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

refactor(apc): speed up apc id acceptance by delayed processing

Browse Source
This commit is contained in:
Steffen Jost 2023-08-31 15:34:40 +00:00
parent f7ad290053
commit 6052af4d90
9 changed files with 50 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/categories/admin/de-de-formal.msg
View File

@ -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

1
messages/uniworx/categories/admin/en-eu.msg
View File

@ -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'

12
models/print.model
View File

@ -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

5
src/Handler/Admin.hs
View File

@ -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)

13
src/Handler/LMS/Report.hs
View File

@ -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

41
src/Handler/PrintCenter.hs
View File

@ -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

1
src/Jobs.hs
View File

@ -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

4
src/Jobs/Types.hs
View File

@ -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

4
templates/admin-problems.hamlet
View File

@ -45,6 +45,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dt .deflist__dt>^{flagError noStalePrintJobs}
<dd .deflist__dd>^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffPrintDays) PrintCenterR}
<dt .deflist__dt>^{flagError noBadAPCids}
<dd .deflist__dd>_{MsgProblemsNoBadAPCIds}
$maybe reroute <- rerouteMail
<dt .deflist__dt>^{flagWarning False}
<dd .deflist__dd>_{MsgMailRerouteTo reroute}