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

fix(notifications): qualification renewals are more robust and not sent multiple times at once

Browse Source
This commit is contained in:
Steffen Jost 2022-09-21 13:25:45 +02:00
parent 77fe8051d2
commit 1cdd52e96c
3 changed files with 77 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/Jobs/Handler/LMS.hs
View File

@ -125,7 +125,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
delusersVals <- E.select $ do delusersVals <- E.select $ do
luser <- E.from $ E.table @LmsUser luser <- E.from $ E.table @LmsUser
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
E.&&. luser E.^. LmsUserEnded E.<. E.just (E.val auditCutoff) E.&&. luser E.^. LmsUserEnded E.<. E.just (E.val auditCutoff)
E.&&. E.isJust (luser E.^. LmsUserEnded) E.&&. E.isJust (luser E.^. LmsUserEnded)
E.&&. E.notExists (do E.&&. E.notExists (do
laudit <- E.from $ E.table @LmsAudit laudit <- E.from $ E.table @LmsAudit
@ -136,11 +136,11 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
pure (luser E.^. LmsUserIdent) pure (luser E.^. LmsUserIdent)
let numdel = length delusers let numdel = length delusers
delusers = E.unValue <$> delusersVals delusers = E.unValue <$> delusersVals
when (numdel > 0) $ $logInfoS "lms" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort
deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers] deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers]
deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers] deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers] deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers]
deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers]
when (numdel > 0) $ $logInfoS "lms" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort
-- processes received results and lengthen qualifications, if applicable -- processes received results and lengthen qualifications, if applicable
@ -221,11 +221,12 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
| otherwise -> return () -- users likely not yet started | otherwise -> return () -- users likely not yet started
(Entity luid luser, Just (Entity lulid lulist)) -> do (Entity luid luser, Just (Entity lulid lulist)) -> do
when (isNothing $ lmsUserNotified luser) $ -- notify users that lms is available when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
queueDBJob JobSendNotification queueDBJob JobSendNotification
{ jRecipient = lmsUserUser luser { jRecipient = lmsUserUser luser
, jNotification = NotificationQualificationRenewal { nQualification = qid } , jNotification = NotificationQualificationRenewal { nQualification = qid }
} }
-- update luid [ LmsUserNotified =. Just now ] -- wird erst beim tatsächlichen senden gesetzt!
let lReceived = lmsUserlistTimestamp lulist let lReceived = lmsUserlistTimestamp lulist
isBlocked = lmsUserlistFailed lulist isBlocked = lmsUserlistFailed lulist
update luid [LmsUserReceived =. Just lReceived] update luid [LmsUserReceived =. Just lReceived]

90
src/Jobs/Handler/SendNotification/Qualification.hs
View File

@ -66,10 +66,12 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient
let printJobName = "RenewalPin" let printJobName = "RenewalPin"
lmsUrl = "https://drive.fraport.de" fileName = printJobName <> "_" <> abbrvName recipient <> ".pdf"
lmsIdent = lmsUserIdent & getLmsIdent
lmsUrl = "https://drive.fraport.de"
lmsLogin = lmsUrl <> "/?login=" <> lmsIdent
prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address
lmsIdent = lmsUserIdent & getLmsIdent pdfMeta = mkMeta
pdfMeta = mkMeta
[ toMeta "date" letterDate [ toMeta "date" letterDate
, toMeta "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang , toMeta "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang
, toMeta "login" lmsIdent , toMeta "login" lmsIdent
@ -79,50 +81,52 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
, toMeta "expiry" expiryDate , toMeta "expiry" expiryDate
, mbMeta "validduration" (show <$> qualificationValidDuration) , mbMeta "validduration" (show <$> qualificationValidDuration)
, toMeta "url-text" lmsUrl , toMeta "url-text" lmsUrl
, toMeta "url" (lmsUrl <> "/?login=" <> lmsIdent) , toMeta "url" lmsLogin
] ]
pdfRenewal pdfMeta >>= \case emailRenewal attachment = do
Left err -> do when (Text.null (CI.original userEmail)) $ do
let msg = "Notify " <> tshow encRecipient <> " PDF generation failed with error: " <> err let msg = "Notify " <> tshow encRecipient <> " failed: no email nor address for user known!"
$logErrorS "LMS" msg $logErrorS "LMS" msg
error $ unpack msg error $ unpack msg -- if neither email nor postal address is known, we must abort!
userMailT jRecipient $ do
Right pdf | userPrefersLetter recipient -> do replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
let printSender = Nothing setSubjectI $ MsgMailSubjectQualificationRenewal qname
runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification)) >>= \case whenIsJust attachment $ \afile ->
Left err -> do
let msg = "Notify " <> tshow encRecipient <> " PDF printing to send letter failed with error: " <> err
$logErrorS "LMS" msg
error $ unpack msg
Right (msg,_)
| null msg -> return ()
| otherwise -> $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg
Right pdf -> userMailT jRecipient $ do
-- userPrefersLetter is false if both userEmail and userPostAddress are null
when (Text.null (CI.original userEmail)) $ $logErrorS "LMS" ("Notify " <> tshow encRecipient <> " failed: no email nor address for user known!")
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectQualificationRenewal qname
let fileName = printJobName <> "_" <> abbrvName recipient <> ".pdf"
encryptPDF (fromMaybe "tomatenmarmelade" userPinPassword) pdf >>= \case -- TODO
Left err -> do
let msg = "Notify " <> tshow encRecipient <> " PDF encryption failed with error: " <> err
$logErrorS "LMS" msg
Right pdffile -> do
addPart (File { fileTitle = Text.unpack fileName addPart (File { fileTitle = Text.unpack fileName
, fileModified = now , fileModified = now
, fileContent = Just $ yield $ LBS.toStrict pdffile , fileContent = Just $ yield $ LBS.toStrict afile
} :: PureFile) } :: PureFile)
editNotifications <- mkEditNotifications jRecipient
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
editNotifications <- mkEditNotifications jRecipient pdfRenewal pdfMeta >>= \case
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet") Right pdf | userPrefersLetter recipient -> -- userPrefersLetter is false if both userEmail and userPostAddress are null
-- if we reach the end, mark the user as notified let printSender = Nothing
-- TODO: defer this until the print job is marked as sent? in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification)) >>= \case
runDB $ Left err -> do
update luid [ LmsUserNotified =. Just now] let msg = "Notify " <> tshow encRecipient <> ": PDF printing to send letter failed with error " <> cropText err
$logErrorS "LMS" msg
error $ unpack msg
Right (msg,_)
| null msg -> return ()
| otherwise -> $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg
Right pdf -> do
attch <- case userPinPassword of
Nothing -> return $ Just pdf -- attach unencrypted, since there is no password set
Just passwd -> encryptPDF passwd pdf >>= \case
Right encPdf -> return $ Just encPdf -- attach encrypted
Left err -> do -- send email without attachment, so that the user is at least notified about the expiry
let msg = "Notify " <> tshow encRecipient <> " PDF encryption failed with error: " <> cropText err
$logErrorS "LMS" msg
return Nothing
emailRenewal attch
Left err -> do
let msg = "Notify " <> tshow encRecipient <> " PDF generation failed with error: " <> cropText err
$logErrorS "LMS" msg
emailRenewal Nothing
-- if we reach the end, mark the user as notified. TODO: Maybe defer this until the print job is marked as sent?
runDB $ update luid [ LmsUserNotified =. Just now]

37
src/Jobs/Types.hs
View File

@ -322,19 +322,32 @@ data JobNoQueueSame = JobNoQueueSame | JobNoQueueSameTag
jobNoQueueSame :: Job -> Maybe JobNoQueueSame jobNoQueueSame :: Job -> Maybe JobNoQueueSame
jobNoQueueSame = \case jobNoQueueSame = \case
JobSendPasswordReset{} -> Just JobNoQueueSame JobSendNotification{jNotification} -> notifyNoQueueSame jNotification
JobTruncateTransactionLog{} -> Just JobNoQueueSame JobSendPasswordReset{} -> Just JobNoQueueSame
JobPruneInvitations{} -> Just JobNoQueueSame JobTruncateTransactionLog{} -> Just JobNoQueueSame
JobDeleteTransactionLogIPs{} -> Just JobNoQueueSame JobPruneInvitations{} -> Just JobNoQueueSame
JobSynchroniseLdapUser{} -> Just JobNoQueueSame JobDeleteTransactionLogIPs{} -> Just JobNoQueueSame
JobChangeUserDisplayEmail{} -> Just JobNoQueueSame JobSynchroniseLdapUser{} -> Just JobNoQueueSame
JobPruneSessionFiles{} -> Just JobNoQueueSameTag JobChangeUserDisplayEmail{} -> Just JobNoQueueSame
JobPruneUnreferencedFiles{} -> Just JobNoQueueSameTag JobPruneSessionFiles{} -> Just JobNoQueueSameTag
JobInjectFiles{} -> Just JobNoQueueSameTag JobPruneUnreferencedFiles{} -> Just JobNoQueueSameTag
JobInjectFiles{} -> Just JobNoQueueSameTag
JobPruneFallbackPersonalisedSheetFilesKeys{} -> Just JobNoQueueSameTag JobPruneFallbackPersonalisedSheetFilesKeys{} -> Just JobNoQueueSameTag
JobRechunkFiles{} -> Just JobNoQueueSameTag JobRechunkFiles{} -> Just JobNoQueueSameTag
JobDetectMissingFiles{} -> Just JobNoQueueSameTag JobDetectMissingFiles{} -> Just JobNoQueueSameTag
_ -> Nothing JobLmsQualificationsEnqueue -> Just JobNoQueueSame
JobLmsEnqueue {} -> Just JobNoQueueSame
JobLmsEnqueueUser {} -> Just JobNoQueueSame
JobLmsQualificationsDequeue -> Just JobNoQueueSame
JobLmsDequeue {} -> Just JobNoQueueSame
JobLmsUserlist {} -> Just JobNoQueueSame
JobLmsResults {} -> Just JobNoQueueSame
_ -> Nothing
notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame
notifyNoQueueSame = \case
NotificationQualificationRenewal{} -> Just JobNoQueueSame -- send one at once; safe, since the job is rescheduled if sending was not acknowledged
_ -> Nothing
jobMovable :: JobCtl -> Bool jobMovable :: JobCtl -> Bool
jobMovable = isn't _JobCtlTest jobMovable = isn't _JobCtlTest