diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index ace249f67..8fadb1d68 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/print/en-eu.msg b/messages/uniworx/categories/print/en-eu.msg index fe24d8edb..76859efab 100644 --- a/messages/uniworx/categories/print/en-eu.msg +++ b/messages/uniworx/categories/print/en-eu.msg @@ -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 diff --git a/routes b/routes index 578be197f..d1ec9cf1b 100644 --- a/routes +++ b/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 diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 8c9892ba7..dc820de2b 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index c28dd2688..1a80d4049 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -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 [] diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index fa0890783..dfe28ad44 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -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 diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 472b3cc6a..c5d1e888c 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -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 diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index b54155756..4eb168247 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -298,6 +298,7 @@ sendLetter' _ = do -} + ----------------------------- -- Typed Process Utilities -- ----------------------------- diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 0143369a8..07f419054 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -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)