fix(notifications): qualification renewals are more robust and not sent multiple times at once
This commit is contained in:
Steffen Jost
parent
77fe8051d2
commit
1cdd52e96c
@ -125,7 +125,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
delusersVals <- E.select $ do
|
||||
luser <- E.from $ E.table @LmsUser
|
||||
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.notExists (do
|
||||
laudit <- E.from $ E.table @LmsAudit
|
||||
@ -135,12 +135,12 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
)
|
||||
pure (luser E.^. LmsUserIdent)
|
||||
let numdel = length delusers
|
||||
delusers = E.unValue <$> delusersVals
|
||||
when (numdel > 0) $ $logInfoS "lms" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort
|
||||
delusers = E.unValue <$> delusersVals
|
||||
deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers]
|
||||
deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
|
||||
deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. 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
|
||||
@ -221,11 +221,12 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
| otherwise -> return () -- users likely not yet started
|
||||
|
||||
(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
|
||||
{ jRecipient = lmsUserUser luser
|
||||
, jNotification = NotificationQualificationRenewal { nQualification = qid }
|
||||
}
|
||||
-- update luid [ LmsUserNotified =. Just now ] -- wird erst beim tatsächlichen senden gesetzt!
|
||||
let lReceived = lmsUserlistTimestamp lulist
|
||||
isBlocked = lmsUserlistFailed lulist
|
||||
update luid [LmsUserReceived =. Just lReceived]
|
||||
|
||||
@ -66,10 +66,12 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient
|
||||
|
||||
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
|
||||
lmsIdent = lmsUserIdent & getLmsIdent
|
||||
pdfMeta = mkMeta
|
||||
pdfMeta = mkMeta
|
||||
[ toMeta "date" letterDate
|
||||
, toMeta "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang
|
||||
, toMeta "login" lmsIdent
|
||||
@ -79,50 +81,52 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
, toMeta "expiry" expiryDate
|
||||
, mbMeta "validduration" (show <$> qualificationValidDuration)
|
||||
, toMeta "url-text" lmsUrl
|
||||
, toMeta "url" (lmsUrl <> "/?login=" <> lmsIdent)
|
||||
, toMeta "url" lmsLogin
|
||||
]
|
||||
pdfRenewal pdfMeta >>= \case
|
||||
Left err -> do
|
||||
let msg = "Notify " <> tshow encRecipient <> " PDF generation failed with error: " <> err
|
||||
$logErrorS "LMS" msg
|
||||
error $ unpack msg
|
||||
|
||||
Right pdf | userPrefersLetter recipient -> do
|
||||
let printSender = Nothing
|
||||
runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification)) >>= \case
|
||||
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
|
||||
emailRenewal attachment = do
|
||||
when (Text.null (CI.original userEmail)) $ do
|
||||
let msg = "Notify " <> tshow encRecipient <> " failed: no email nor address for user known!"
|
||||
$logErrorS "LMS" msg
|
||||
error $ unpack msg -- if neither email nor postal address is known, we must abort!
|
||||
userMailT jRecipient $ do
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectQualificationRenewal qname
|
||||
whenIsJust attachment $ \afile ->
|
||||
addPart (File { fileTitle = Text.unpack fileName
|
||||
, fileModified = now
|
||||
, fileContent = Just $ yield $ LBS.toStrict pdffile
|
||||
, fileContent = Just $ yield $ LBS.toStrict afile
|
||||
} :: PureFile)
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
|
||||
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
|
||||
-- if we reach the end, mark the user as notified
|
||||
-- TODO: defer this until the print job is marked as sent?
|
||||
runDB $
|
||||
update luid [ LmsUserNotified =. Just now]
|
||||
pdfRenewal pdfMeta >>= \case
|
||||
Right pdf | userPrefersLetter recipient -> -- userPrefersLetter is false if both userEmail and userPostAddress are null
|
||||
let printSender = Nothing
|
||||
in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification)) >>= \case
|
||||
Left err -> do
|
||||
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]
|
||||
|
||||
@ -322,19 +322,32 @@ data JobNoQueueSame = JobNoQueueSame | JobNoQueueSameTag
|
||||
|
||||
jobNoQueueSame :: Job -> Maybe JobNoQueueSame
|
||||
jobNoQueueSame = \case
|
||||
JobSendPasswordReset{} -> Just JobNoQueueSame
|
||||
JobTruncateTransactionLog{} -> Just JobNoQueueSame
|
||||
JobPruneInvitations{} -> Just JobNoQueueSame
|
||||
JobDeleteTransactionLogIPs{} -> Just JobNoQueueSame
|
||||
JobSynchroniseLdapUser{} -> Just JobNoQueueSame
|
||||
JobChangeUserDisplayEmail{} -> Just JobNoQueueSame
|
||||
JobPruneSessionFiles{} -> Just JobNoQueueSameTag
|
||||
JobPruneUnreferencedFiles{} -> Just JobNoQueueSameTag
|
||||
JobInjectFiles{} -> Just JobNoQueueSameTag
|
||||
JobSendNotification{jNotification} -> notifyNoQueueSame jNotification
|
||||
JobSendPasswordReset{} -> Just JobNoQueueSame
|
||||
JobTruncateTransactionLog{} -> Just JobNoQueueSame
|
||||
JobPruneInvitations{} -> Just JobNoQueueSame
|
||||
JobDeleteTransactionLogIPs{} -> Just JobNoQueueSame
|
||||
JobSynchroniseLdapUser{} -> Just JobNoQueueSame
|
||||
JobChangeUserDisplayEmail{} -> Just JobNoQueueSame
|
||||
JobPruneSessionFiles{} -> Just JobNoQueueSameTag
|
||||
JobPruneUnreferencedFiles{} -> Just JobNoQueueSameTag
|
||||
JobInjectFiles{} -> Just JobNoQueueSameTag
|
||||
JobPruneFallbackPersonalisedSheetFilesKeys{} -> Just JobNoQueueSameTag
|
||||
JobRechunkFiles{} -> Just JobNoQueueSameTag
|
||||
JobDetectMissingFiles{} -> Just JobNoQueueSameTag
|
||||
_ -> Nothing
|
||||
JobRechunkFiles{} -> Just JobNoQueueSameTag
|
||||
JobDetectMissingFiles{} -> Just JobNoQueueSameTag
|
||||
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 = isn't _JobCtlTest
|
||||
|
||||
Loading…
Reference in New Issue
Block a user