diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 98c63e1ff..9b0a275dd 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -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] diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index ad2f42e24..35778e8c4 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -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] \ No newline at end of file diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index f62bbd73f..e332e7e20 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -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