diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 5b905fbf1..4ff70a3ee 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -109,6 +109,7 @@ ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS ProblemsHeadingUsers: Allgemein ProblemsUsersAreReachable: Für alle Benutzer ist eine E-Mail oder postalische Adresse bekannt ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge der vergangenen #{show n} Tage wurden von der Druckerei bestätigt +ProblemsNoBadAPCIds: Alle kürzlich empfangenen Druckauftragsbestätigungen waren gültig ProblemsUnreachableHeading: Unerreichbare Benutzer ProblemsUnreachableBody: Benutzer ohne E-Mail oder Postadresse, welche z.B. bei ablaufenden Berechtigungen nicht benachrichtigt werden können: ProblemsRWithoutFHeading: Fahrer mit R ohne F diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index f320c1a3d..a3ad418e9 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -109,6 +109,7 @@ ProblemsDriversHaveAvsIds: All driving licence holder could be matched with thei ProblemsHeadingUsers: Miscellaneous ProblemsUsersAreReachable: Either Email or postal address is known for all users ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{show n} days were acknowledged as printed by the airport printing center +ProblemsNoBadAPCIds: All recently received print job ids from Airport Print Center were legit ProblemsUnreachableHeading: Unreachable Users ProblemsUnreachableBody: Users without Email nor postal address, who thus cannot be notified about expiring qualifications: ProblemsRWithoutFHeading: Drivers having 'R' but not 'F' diff --git a/models/print.model b/models/print.model index 69adcc7ba..ee3f1ea7c 100644 --- a/models/print.model +++ b/models/print.model @@ -16,4 +16,16 @@ PrintJob lmsUser LmsIdent Maybe OnDeleteCascade OnUpdateCascade -- allows tracking if recipient has been notified; must be unique -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible! -- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used + deriving Generic + +PrintAcknowledge -- just to store acknowledging requests to be evaluated by a background job later on + apcIdent Text + timestamp UTCTime default=now() + processed Bool + deriving Generic + +PrintAckIdAlias + needle Text + replacement Text + priority Int deriving Generic \ No newline at end of file diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 97cc51c45..86d4cc6e3 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -45,11 +45,12 @@ getAdminProblemsR = do cutOffPrintDays = 7 cutOffPrintJob = addLocalDays (-cutOffPrintDays) now - (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs) <- runDB $ (,,,) + (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids) <- runDB $ (,,,,) <$> areAllUsersReachable <*> allDriversHaveAvsId now <*> allRDriversHaveFs now - <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <=. cutOffPrintJob]) + <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <=. cutOffPrintJob]) + <*> (not <$> exists [PrintAcknowledgeProcessed ==. False] ) diffLics <- try retrieveDifferingLicences >>= \case -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index 9422fe119..9d968780d 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -247,9 +247,8 @@ postLmsReportR sid qsh = do -- Direct File Upload/Download -saveReportCsv :: QualificationId -> Int -> LmsReportTableCsv -> JobDB Int -saveReportCsv qid i LmsReportTableCsv{..} = do - now <- liftIO getCurrentTime +saveReportCsv :: UTCTime -> QualificationId -> Int -> LmsReportTableCsv -> JobDB Int +saveReportCsv now qid i LmsReportTableCsv{..} = do void $ upsert LmsReport { lmsReportQualification = qid @@ -272,6 +271,7 @@ makeReportUploadForm = renderAForm FormStandard $ fileAFormReq "Report CSV" getLmsReportUploadR, postLmsReportUploadR :: SchoolId -> QualificationShorthand -> Handler Html getLmsReportUploadR = postLmsReportUploadR postLmsReportUploadR sid qsh = do + now <- liftIO getCurrentTime ((report,widget), enctype) <- runFormPost makeReportUploadForm case report of FormSuccess file -> do @@ -281,7 +281,7 @@ postLmsReportUploadR sid qsh = do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh nr <- runConduit $ fileSource file .| decodeCsv - .| foldMC (saveReportCsv qid) 0 + .| foldMC (saveReportCsv now qid) 0 queueDBJob $ JobLmsReports qid return nr addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") @@ -305,12 +305,13 @@ postLmsReportDirectR sid qsh = do (_params, files) <- runRequestBody (status, msg) <- case files of [(fhead,file)] -> do + now <- liftIO getCurrentTime lmsDecoder <- getLmsCsvDecoder runDBJobs $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh enr <- try $ runConduit $ fileSource file .| lmsDecoder - .| foldMC (saveReportCsv qid) 0 + .| foldMC (saveReportCsv now qid) 0 case enr of Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error $logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e @@ -328,5 +329,5 @@ postLmsReportDirectR sid qsh = do let msg = "Report upload received multiple files; all ignored." $logWarnS "LMS" msg return (badRequest400, msg) - sendResponseStatus status msg + sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 4cbd41d95..593810bc9 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -27,13 +27,16 @@ import Database.Esqueleto.Utils.TH import Utils.Print -- import Data.Aeson (encode) -import qualified Data.Text as Text +-- import qualified Data.Text as Text -- import qualified Data.Set as Set import Handler.Utils -- import Handler.Utils.Csv -- import qualified Data.Csv as Csv +import Jobs.Queue + + -- avoids repetition of local definitions single :: (k,a) -> Map k a single = uncurry Map.singleton @@ -434,40 +437,30 @@ postPrintAckR ackDay numAck chksm = do -- | length v >= 1 = v Csv..! 0 -- | otherwise = pure "ERROR" +saveApcident :: UTCTime -> Natural -> Text -> JobDB Natural +saveApcident t i apci = insert_ (PrintAcknowledge apci t False) >> return (succ i) + postPrintAckDirectR :: Handler Html -postPrintAckDirectR = do +postPrintAckDirectR = do + now <- liftIO getCurrentTime (_params, files) <- runRequestBody (status, msg) <- case files of - [(fhead,file)] -> do - runDB $ do + [(_fhead,file)] -> do + runDBJobs $ do enr <- try $ runConduit $ fileSource file -- .| decodeCsvPositional Csv.NoHeader -- decode by separator position .| decodeUtf8C -- no CSV, just convert each line to a single text .| linesUnboundedC - .| sinkList + .| foldMC (saveApcident now) 0 case enr of Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error $logWarnS "APC" $ "Result upload failed parsing: " <> tshow e return (badRequest400, "Error: " <> tshow e) - Right (fmap Text.strip -> reqIds) -> do -- inside conduit? - let nrReq = length reqIds - now <- liftIO getCurrentTime - nrOk <- updateWhereCount - [PrintJobAcknowledged ==. Nothing, PrintJobApcIdent <-. reqIds] - [PrintJobAcknowledged =. Just now] - if | nrReq <= 0 -> do - let msg = "Error: No print job was acknowledged as printed, but " <> tshow nrReq <> " were requested to be, for file " <> fhead - $logErrorS "APC" msg - return (badRequest400, msg) - | nrReq == fromIntegral nrOk -> do - let msg = "Success: " <> tshow nrOk <> " print jobs were acknowledged as printed, for file " <> fhead - $logInfoS "APC" msg - return (ok200, msg) - | otherwise -> do - forM_ reqIds $ \t -> $logInfoS "APC" $ "Received APC Identifier: \"" <> t <> "\"" - let msg = "Warning: Only " <> tshow nrOk <> " print jobs out of " <> tshow nrReq <> " were acknowledged as printed, for file " <> fhead - $logWarnS "APC" msg - return (ok200, msg) + Right nr -> do + let msg = "Success: received " <> tshow nr <> " APC identifiers to be processed later." + $logInfoS "LMS" msg + when (nr > 0) $ queueDBJob JobPrintAck + return (ok200, msg) [] -> do let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging." $logWarnS "APC" msg diff --git a/src/Jobs.hs b/src/Jobs.hs index 0d5993ce7..f48922abb 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -81,6 +81,7 @@ import Jobs.Handler.PersonalisedSheetFiles import Jobs.Handler.PruneOldSentMails import Jobs.Handler.StudyFeatures import Jobs.Handler.LMS +import Jobs.Handler.Print import Jobs.HealthReport diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index c6bdd8ee1..a0717099a 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -131,6 +131,8 @@ data Job | JobLmsUserlist { jQualification :: QualificationId } -- Deprecated, remove together with routes | JobLmsResults { jQualification :: QualificationId } -- Deprecated, remove together with routes | JobLmsReports { jQualification :: QualificationId } + | JobPrintAck + | JobPrintAckAgain deriving (Eq, Ord, Show, Read, Generic) data Notification @@ -363,6 +365,8 @@ jobNoQueueSame = \case JobLmsUserlist {} -> Just JobNoQueueSame JobLmsResults {} -> Just JobNoQueueSame JobLmsReports {} -> Just JobNoQueueSame + JobPrintAck {} -> Just JobNoQueueSame + JobPrintAckAgain {} -> Just JobNoQueueSame _ -> Nothing notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet index 631b41e92..8387a3daa 100644 --- a/templates/admin-problems.hamlet +++ b/templates/admin-problems.hamlet @@ -45,6 +45,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
^{flagError noStalePrintJobs}
^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffPrintDays) PrintCenterR} +
^{flagError noBadAPCids} +
_{MsgProblemsNoBadAPCIds} + + $maybe reroute <- rerouteMail
^{flagWarning False}
_{MsgMailRerouteTo reroute} \ No newline at end of file