chore(lpr): convenience acknowledgement secured against being outdated by hash
This commit is contained in:
Steffen Jost
parent
9b14a727c0
commit
c76fb2229d
@ -5,7 +5,8 @@ PrintJobId !ident-ok: Id
|
||||
PrintJobCreated: Gesendet
|
||||
PrintJobAcknowledged: Bestätigt
|
||||
PrintJobAcknowledge n@Int64: #{n} #{pluralDE n "Druckauftrag" "Druckaufräge"} als gedruckt und versendet bestätigt
|
||||
PrintJobAcknowledgeQuestion n@Int64 d@Text: #{n} #{pluralDE n "Druckauftrag" "Druckaufräge"} vom #{d} als gedruckt und versendet bestätigen?
|
||||
PrintJobAcknowledgeFailed: Keine Druckaufträge bestätigt aufgrund zwischenzeitlicher Änderungen. Bitte die Seite im Browser aktualisieren!
|
||||
PrintJobAcknowledgeQuestion n@Int d@Text: #{n} #{pluralDE n "Druckauftrag" "Druckaufräge"} vom #{d} als gedruckt und versendet bestätigen?
|
||||
PrintRecipient: Empfänger
|
||||
PrintSender !ident-ok: Sender
|
||||
PrintCourse: Kurse
|
||||
|
||||
@ -4,7 +4,8 @@ PrintJobFilename: Filename
|
||||
PrintJobId: Id
|
||||
PrintJobCreated: Created
|
||||
PrintJobAcknowledged: Acknowledged
|
||||
PrintJobAcknowledge n@Int64: #{n} #{pluralENs n "print-job"} marked as printed and mailed
|
||||
PrintJobAcknowledge n: #{n} #{pluralENs n "print-job"} marked as printed and mailed
|
||||
PrintJobAcknowledgeFailed: No print-jobs acknowledged, due to intermediate changes. Please reload this page!
|
||||
PrintJobAcknowledgeQuestion n d: Mark #{n} #{pluralENs n "print-job"} issued on #{d} as printed and mailed already?
|
||||
PrintRecipient: Recipient
|
||||
PrintSender: Sender
|
||||
|
||||
30
routes
30
routes
@ -64,23 +64,23 @@
|
||||
/admin/avs AdminAvsR GET POST
|
||||
/admin/ldap AdminLdapR GET POST
|
||||
|
||||
/print PrintCenterR GET POST !system-printer
|
||||
/print/acknowledge/#Day PrintAcknowR GET POST !system-printer
|
||||
/print/send PrintSendR GET POST
|
||||
/print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer
|
||||
/print PrintCenterR GET POST !system-printer
|
||||
/print/acknowledge/#Day/#Int/#Int PrintAcknowR GET POST !system-printer
|
||||
/print/send PrintSendR GET POST
|
||||
/print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer
|
||||
|
||||
/health HealthR GET !free
|
||||
/instance InstanceR GET !free
|
||||
/info InfoR GET !free
|
||||
/info/lecturer InfoLecturerR GET !free
|
||||
/info/legal LegalR GET !free
|
||||
/info/allocation InfoAllocationR GET !free
|
||||
/info/glossary GlossaryR GET !free
|
||||
/info/faq FaqR GET !free
|
||||
/version VersionR GET !free
|
||||
/status StatusR GET !free
|
||||
/health HealthR GET !free
|
||||
/instance InstanceR GET !free
|
||||
/info InfoR GET !free
|
||||
/info/lecturer InfoLecturerR GET !free
|
||||
/info/legal LegalR GET !free
|
||||
/info/allocation InfoAllocationR GET !free
|
||||
/info/glossary GlossaryR GET !free
|
||||
/info/faq FaqR GET !free
|
||||
/version VersionR GET !free
|
||||
/status StatusR GET !free
|
||||
|
||||
/help HelpR GET POST !free
|
||||
/help HelpR GET POST !free
|
||||
|
||||
/external-apis ExternalApisR ServantApiExternalApis getServantApi
|
||||
|
||||
|
||||
@ -105,19 +105,6 @@ instance {-# OVERLAPS #-} PathPiece (E.CryptoID "PrintJob" (CI FilePath)) where
|
||||
piece' <- (stripPrefix `on` map CI.mk) "uwl" piece
|
||||
return . CryptoID . CI.mk $ map CI.original piece'
|
||||
toPathPiece = Text.pack . ("uwl" <>) . CI.foldedCase . ciphertext
|
||||
|
||||
-- TODO: DELETE THIS AGAIN, NO LONGER NEEDD:
|
||||
-- this is a hack needed for a hiddenField; better use JSON instance?!
|
||||
instance PathPiece [E.CryptoID "PrintJob" UUID] where
|
||||
toPathPiece = Text.intercalate ";;;" . toPathMultiPiece
|
||||
fromPathPiece = fromPathMultiPiece . Text.splitOn ";;;"
|
||||
|
||||
{-
|
||||
instance PathPiece [E.CryptoID "PrintJob" (CI FilePath)] where
|
||||
toPathPiece = Text.decodeUtf8Lenient . encode
|
||||
fromPathPiece = decode . Text.encodeUtf8
|
||||
-}
|
||||
|
||||
instance {-# OVERLAPS #-} ToJSON (E.CryptoID "PrintJob" (CI FilePath)) where
|
||||
toJSON = String . toPathPiece
|
||||
instance {-# OVERLAPS #-} ToJSONKey (E.CryptoID "PrintJob" (CI FilePath)) where
|
||||
|
||||
@ -30,6 +30,8 @@ import Handler.Utils.Memcached
|
||||
import Handler.Utils.ExamOffice.Course
|
||||
import Utils.Sheet
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
@ -109,10 +111,10 @@ breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
|
||||
breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR
|
||||
breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR
|
||||
|
||||
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing
|
||||
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
|
||||
breadcrumb (PrintDownloadR _) = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR
|
||||
breadcrumb (PrintAcknowR _) = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
|
||||
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing
|
||||
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
|
||||
breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR
|
||||
breadcrumb PrintAcknowR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
|
||||
|
||||
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
|
||||
breadcrumb (SchoolR ssh sRoute) = case sRoute of
|
||||
@ -2518,17 +2520,19 @@ pageActions PrintCenterR = do
|
||||
pj <- Ex.from $ Ex.table @PrintJob
|
||||
let pjDay = E.day $ pj Ex.^. PrintJobCreated
|
||||
Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
|
||||
Ex.groupBy pjDay
|
||||
Ex.orderBy [ Ex.asc pjDay ]
|
||||
pure (pjDay, Ex.countRows)
|
||||
-- TODO: add hash of prinjobs to route to avoid an outdated acknowledgement!
|
||||
let toDayAck (Ex.unValue -> d, Ex.unValue -> n::Int) = do
|
||||
pure (pjDay, pj Ex.^. PrintJobId)
|
||||
|
||||
let dayMap = Map.fromListWith (<>) (openDays <&> (\(Ex.unValue -> pjDay, Ex.unValue -> pjId) -> (pjDay, Set.singleton pjId)))
|
||||
toDayAck (d, pjIds) = do
|
||||
dtxt <- formatTime SelFormatDate d
|
||||
let msg = "#" <> tshow n <> ", " <> dtxt
|
||||
let n = Set.size pjIds
|
||||
h = hash pjIds
|
||||
msg = "#" <> tshow n <> ", " <> dtxt
|
||||
return NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = SomeMessage msg
|
||||
, navRoute = PrintAcknowR d
|
||||
, navRoute = PrintAcknowR d n h
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = True }
|
||||
, navQuick' = mempty
|
||||
@ -2546,8 +2550,8 @@ pageActions PrintCenterR = do
|
||||
, navForceActive = False
|
||||
}
|
||||
}
|
||||
dayLinks <- mapM toDayAck openDays
|
||||
return $ manualSend : take 8 dayLinks
|
||||
dayLinks <- mapM toDayAck $ Map.toAscList dayMap
|
||||
return $ manualSend : take 9 dayLinks
|
||||
|
||||
pageActions _ = return []
|
||||
|
||||
|
||||
@ -353,50 +353,45 @@ getPrintDownloadR cupj = do
|
||||
-}
|
||||
|
||||
|
||||
getPrintAcknowR, postPrintAcknowR :: Day -> Handler Html
|
||||
getPrintAcknowR, postPrintAcknowR :: Day -> Int -> Int -> Handler Html
|
||||
getPrintAcknowR = postPrintAcknowR
|
||||
postPrintAcknowR ackDay = do
|
||||
dayJobs <- runDB $ Ex.select $ do
|
||||
pj <- Ex.from $ Ex.table @PrintJob
|
||||
let pjDay = E.day $ pj Ex.^. PrintJobCreated
|
||||
Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
|
||||
E.&&. (pjDay Ex.==. Ex.val ackDay)
|
||||
return $ pj Ex.^. PrintJobId
|
||||
let encPJ :: PrintJobId -> Handler CryptoUUIDPrintJob
|
||||
encPJ = encrypt
|
||||
pjHash = hash (Ex.unValue <$> dayJobs)
|
||||
_encJobs <- mapM (encPJ . Ex.unValue) dayJobs
|
||||
let hiddenPJs = areq hiddenField "ack-pjs" $ Just pjHash
|
||||
--_mkAckForm :: Form ([PrintJobId], ButtonConfirm)
|
||||
--_mkAckForm = withButtonForm' [BtnConfirm] hiddenPJs
|
||||
((ackRes, ackWgt), ackEnctype) <- runFormPost . identifyForm FIDPrintAcknowledge . withButtonForm' [BtnConfirm] $ renderAForm FormStandard hiddenPJs
|
||||
postPrintAcknowR ackDay numAck chksm = do
|
||||
((ackRes, ackWgt), ackEnctype) <- runFormPost (identifyForm FIDPrintAcknowledge buttonForm :: Form ButtonConfirm)
|
||||
let ackForm = wrapForm ackWgt def
|
||||
{ formAction = Just $ SomeRoute $ PrintAcknowR ackDay
|
||||
{ formAction = Just $ SomeRoute $ PrintAcknowR ackDay numAck chksm
|
||||
, formEncoding = ackEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
formResult ackRes $ \(_pjIds, BtnConfirm) -> do
|
||||
now <- liftIO getCurrentTime
|
||||
num <- runDB $
|
||||
E.updateCount $ \pj -> do
|
||||
E.set pj [ PrintJobAcknowledged E.=. E.just (E.val now) ]
|
||||
E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged)
|
||||
E.&&. E.val ackDay E.==. E.day (pj E.^. PrintJobCreated)
|
||||
-- Ex.updateCount $ do
|
||||
-- pj <- Ex.from $ Ex.table @PrintJob
|
||||
-- Ex.set pj [ PrintJobAcknowledged Ex.=. Ex.just (Ex.val now) ]
|
||||
-- Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
|
||||
-- Ex.&&. Ex.val ackDay Ex.==. E.day (pj Ex.^. PrintJobCreated)
|
||||
addMessageI Success $ MsgPrintJobAcknowledge num
|
||||
formResult ackRes $ \BtnConfirm -> do
|
||||
numNew <- runDB $ do
|
||||
pjs <- Ex.select $ do
|
||||
pj <- Ex.from $ Ex.table @PrintJob
|
||||
let pjDay = E.day $ pj Ex.^. PrintJobCreated
|
||||
Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
|
||||
Ex.&&. (pjDay Ex.==. Ex.val ackDay)
|
||||
return $ pj Ex.^. PrintJobId
|
||||
let changed = numAck /= length pjs || chksm /= hash (Set.fromList (Ex.unValue <$> pjs))
|
||||
if changed
|
||||
then return (-1)
|
||||
else do
|
||||
now <- liftIO getCurrentTime
|
||||
E.updateCount $ \pj -> do
|
||||
let pjDay = E.day $ pj E.^. PrintJobCreated
|
||||
E.set pj [ PrintJobAcknowledged E.=. E.just (E.val now) ]
|
||||
E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged)
|
||||
E.&&. (pjDay E.==. E.val ackDay)
|
||||
-- Ex.updateCount $ do
|
||||
-- pj <- Ex.from $ Ex.table @PrintJob
|
||||
-- let pjDay = E.day $ pj Ex.^. PrintJobCreated
|
||||
-- Ex.set pj [ PrintJobAcknowledged Ex.=. Ex.just (Ex.val now) ]
|
||||
-- Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
|
||||
-- Ex.&&. (pjDay Ex.==. Ex.val ackDay)
|
||||
if numNew > 0
|
||||
then addMessageI Success $ MsgPrintJobAcknowledge numNew
|
||||
else addMessageI Error MsgPrintJobAcknowledgeFailed
|
||||
redirect PrintCenterR
|
||||
ackNum' <- runDB $ Ex.select $ do
|
||||
pj <- Ex.from $ Ex.table @PrintJob
|
||||
Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
|
||||
Ex.&&. Ex.val ackDay Ex.==. E.day (pj Ex.^. PrintJobCreated)
|
||||
pure Ex.countRows
|
||||
let ackNum = headDef 0 $ Ex.unValue <$> ackNum'
|
||||
ackDayText <- formatTime SelFormatDate ackDay
|
||||
siteLayoutMsg
|
||||
(MsgPrintJobAcknowledgeQuestion ackNum ackDayText)
|
||||
(MsgPrintJobAcknowledgeQuestion numAck ackDayText)
|
||||
ackForm
|
||||
|
||||
|
||||
@ -211,7 +211,7 @@ mkLmsTable (Entity qid quali) = do
|
||||
, single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent))
|
||||
-- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB
|
||||
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
|
||||
, single ("renewal-due" , FilterColumn $ \(view (to queryQualUser) -> quser) criterion ->
|
||||
, single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
|
||||
if | Just renewal <- mbRenewal
|
||||
, Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
|
||||
|
||||
@ -298,6 +298,7 @@ sendLetter' _ = do
|
||||
-}
|
||||
|
||||
|
||||
|
||||
-----------------------------
|
||||
-- Typed Process Utilities --
|
||||
-----------------------------
|
||||
|
||||
@ -522,11 +522,12 @@ fillDb = do
|
||||
void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now
|
||||
void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now
|
||||
void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now
|
||||
lujost <- insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing Nothing Nothing
|
||||
lujost <- insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5))
|
||||
luvaupel <- insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) Nothing Nothing
|
||||
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing Nothing
|
||||
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) now (Just now) (Just $ n_day' (-1)) Nothing
|
||||
lutina <- insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) now (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing
|
||||
void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) (Just $ n_day' (-2)) (Just $ n_day' (-1))
|
||||
void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) Nothing Nothing
|
||||
void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing now Nothing Nothing Nothing
|
||||
|
||||
void . insert $ PrintJob "TestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing
|
||||
void . insert $ PrintJob "TestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing (Just qid_f) (Just lujost)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user