fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(lpr): convenience acknowledgement secured against being outdated by hash

Browse Source
This commit is contained in:
Steffen Jost 2022-09-28 16:03:58 +02:00
parent 9b14a727c0
commit c76fb2229d
9 changed files with 73 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
messages/uniworx/categories/print/de-de-formal.msg
View File

@ -5,7 +5,8 @@ PrintJobId !ident-ok: Id
PrintJobCreated: Gesendet PrintJobCreated: Gesendet
PrintJobAcknowledged: Bestätigt PrintJobAcknowledged: Bestätigt
PrintJobAcknowledge n@Int64: #{n} #{pluralDE n "Druckauftrag" "Druckaufräge"} als gedruckt und versendet 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 PrintRecipient: Empfänger
PrintSender !ident-ok: Sender PrintSender !ident-ok: Sender
PrintCourse: Kurse PrintCourse: Kurse

3
messages/uniworx/categories/print/en-eu.msg
View File

@ -4,7 +4,8 @@ PrintJobFilename: Filename
PrintJobId: Id PrintJobId: Id
PrintJobCreated: Created PrintJobCreated: Created
PrintJobAcknowledged: Acknowledged 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? PrintJobAcknowledgeQuestion n d: Mark #{n} #{pluralENs n "print-job"} issued on #{d} as printed and mailed already?
PrintRecipient: Recipient PrintRecipient: Recipient
PrintSender: Sender PrintSender: Sender

30
routes
View File

@ -64,23 +64,23 @@
/admin/avs AdminAvsR GET POST /admin/avs AdminAvsR GET POST
/admin/ldap AdminLdapR GET POST /admin/ldap AdminLdapR GET POST
/print PrintCenterR GET POST !system-printer /print PrintCenterR GET POST !system-printer
/print/acknowledge/#Day PrintAcknowR GET POST !system-printer /print/acknowledge/#Day/#Int/#Int PrintAcknowR GET POST !system-printer
/print/send PrintSendR GET POST /print/send PrintSendR GET POST
/print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer /print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer
/health HealthR GET !free /health HealthR GET !free
/instance InstanceR GET !free /instance InstanceR GET !free
/info InfoR GET !free /info InfoR GET !free
/info/lecturer InfoLecturerR GET !free /info/lecturer InfoLecturerR GET !free
/info/legal LegalR GET !free /info/legal LegalR GET !free
/info/allocation InfoAllocationR GET !free /info/allocation InfoAllocationR GET !free
/info/glossary GlossaryR GET !free /info/glossary GlossaryR GET !free
/info/faq FaqR GET !free /info/faq FaqR GET !free
/version VersionR GET !free /version VersionR GET !free
/status StatusR GET !free /status StatusR GET !free
/help HelpR GET POST !free /help HelpR GET POST !free
/external-apis ExternalApisR ServantApiExternalApis getServantApi /external-apis ExternalApisR ServantApiExternalApis getServantApi

13
src/CryptoID.hs
View File

@ -105,19 +105,6 @@ instance {-# OVERLAPS #-} PathPiece (E.CryptoID "PrintJob" (CI FilePath)) where
piece' <- (stripPrefix `on` map CI.mk) "uwl" piece piece' <- (stripPrefix `on` map CI.mk) "uwl" piece
return . CryptoID . CI.mk $ map CI.original piece' return . CryptoID . CI.mk $ map CI.original piece'
toPathPiece = Text.pack . ("uwl" <>) . CI.foldedCase . ciphertext 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 instance {-# OVERLAPS #-} ToJSON (E.CryptoID "PrintJob" (CI FilePath)) where
toJSON = String . toPathPiece toJSON = String . toPathPiece
instance {-# OVERLAPS #-} ToJSONKey (E.CryptoID "PrintJob" (CI FilePath)) where instance {-# OVERLAPS #-} ToJSONKey (E.CryptoID "PrintJob" (CI FilePath)) where

28
src/Foundation/Navigation.hs
View File

@ -30,6 +30,8 @@ import Handler.Utils.Memcached
import Handler.Utils.ExamOffice.Course import Handler.Utils.ExamOffice.Course
import Utils.Sheet import Utils.Sheet
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils 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 AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR
breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
breadcrumb (PrintDownloadR _) = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR
breadcrumb (PrintAcknowR _) = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR breadcrumb PrintAcknowR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
breadcrumb (SchoolR ssh sRoute) = case sRoute of breadcrumb (SchoolR ssh sRoute) = case sRoute of
@ -2518,17 +2520,19 @@ pageActions PrintCenterR = do
pj <- Ex.from $ Ex.table @PrintJob pj <- Ex.from $ Ex.table @PrintJob
let pjDay = E.day $ pj Ex.^. PrintJobCreated let pjDay = E.day $ pj Ex.^. PrintJobCreated
Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged) Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
Ex.groupBy pjDay
Ex.orderBy [ Ex.asc pjDay ] Ex.orderBy [ Ex.asc pjDay ]
pure (pjDay, Ex.countRows) pure (pjDay, pj Ex.^. PrintJobId)
-- TODO: add hash of prinjobs to route to avoid an outdated acknowledgement!
let toDayAck (Ex.unValue -> d, Ex.unValue -> n::Int) = do let dayMap = Map.fromListWith (<>) (openDays <&> (\(Ex.unValue -> pjDay, Ex.unValue -> pjId) -> (pjDay, Set.singleton pjId)))
toDayAck (d, pjIds) = do
dtxt <- formatTime SelFormatDate d dtxt <- formatTime SelFormatDate d
let msg = "#" <> tshow n <> ", " <> dtxt let n = Set.size pjIds
h = hash pjIds
msg = "#" <> tshow n <> ", " <> dtxt
return NavPageActionPrimary return NavPageActionPrimary
{ navLink = NavLink { navLink = NavLink
{ navLabel = SomeMessage msg { navLabel = SomeMessage msg
, navRoute = PrintAcknowR d , navRoute = PrintAcknowR d n h
, navAccess' = NavAccessTrue , navAccess' = NavAccessTrue
, navType = NavTypeLink { navModal = True } , navType = NavTypeLink { navModal = True }
, navQuick' = mempty , navQuick' = mempty
@ -2546,8 +2550,8 @@ pageActions PrintCenterR = do
, navForceActive = False , navForceActive = False
} }
} }
dayLinks <- mapM toDayAck openDays dayLinks <- mapM toDayAck $ Map.toAscList dayMap
return $ manualSend : take 8 dayLinks return $ manualSend : take 9 dayLinks
pageActions _ = return [] pageActions _ = return []

69
src/Handler/PrintCenter.hs
View File

@ -353,50 +353,45 @@ getPrintDownloadR cupj = do
-} -}
getPrintAcknowR, postPrintAcknowR :: Day -> Handler Html getPrintAcknowR, postPrintAcknowR :: Day -> Int -> Int -> Handler Html
getPrintAcknowR = postPrintAcknowR getPrintAcknowR = postPrintAcknowR
postPrintAcknowR ackDay = do postPrintAcknowR ackDay numAck chksm = do
dayJobs <- runDB $ Ex.select $ do ((ackRes, ackWgt), ackEnctype) <- runFormPost (identifyForm FIDPrintAcknowledge buttonForm :: Form ButtonConfirm)
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
let ackForm = wrapForm ackWgt def let ackForm = wrapForm ackWgt def
{ formAction = Just $ SomeRoute $ PrintAcknowR ackDay { formAction = Just $ SomeRoute $ PrintAcknowR ackDay numAck chksm
, formEncoding = ackEnctype , formEncoding = ackEnctype
, formSubmit = FormNoSubmit , formSubmit = FormNoSubmit
} }
formResult ackRes $ \(_pjIds, BtnConfirm) -> do formResult ackRes $ \BtnConfirm -> do
now <- liftIO getCurrentTime numNew <- runDB $ do
num <- runDB $ pjs <- Ex.select $ do
E.updateCount $ \pj -> do pj <- Ex.from $ Ex.table @PrintJob
E.set pj [ PrintJobAcknowledged E.=. E.just (E.val now) ] let pjDay = E.day $ pj Ex.^. PrintJobCreated
E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged) Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
E.&&. E.val ackDay E.==. E.day (pj E.^. PrintJobCreated) Ex.&&. (pjDay Ex.==. Ex.val ackDay)
-- Ex.updateCount $ do return $ pj Ex.^. PrintJobId
-- pj <- Ex.from $ Ex.table @PrintJob let changed = numAck /= length pjs || chksm /= hash (Set.fromList (Ex.unValue <$> pjs))
-- Ex.set pj [ PrintJobAcknowledged Ex.=. Ex.just (Ex.val now) ] if changed
-- Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged) then return (-1)
-- Ex.&&. Ex.val ackDay Ex.==. E.day (pj Ex.^. PrintJobCreated) else do
addMessageI Success $ MsgPrintJobAcknowledge num 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 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 ackDayText <- formatTime SelFormatDate ackDay
siteLayoutMsg siteLayoutMsg
(MsgPrintJobAcknowledgeQuestion ackNum ackDayText) (MsgPrintJobAcknowledgeQuestion numAck ackDayText)
ackForm ackForm

2
src/Handler/Qualification.hs
View File

@ -211,7 +211,7 @@ mkLmsTable (Entity qid quali) = do
, single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) , 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 ("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 ("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 if | Just renewal <- mbRenewal
, Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday

1
src/Utils/Print.hs
View File

@ -298,6 +298,7 @@ sendLetter' _ = do
-} -}
----------------------------- -----------------------------
-- Typed Process Utilities -- -- Typed Process Utilities --
----------------------------- -----------------------------

7
test/Database/Fill.hs
View File

@ -522,11 +522,12 @@ fillDb = do
void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now
void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now
void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False 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 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 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 "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) 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)