From c3fe47f50d796320da7da3c016451aa91d258277 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 27 Sep 2022 15:26:08 +0200 Subject: [PATCH] chore(lms): no longer abort jobs with error --- src/Jobs/Handler/LMS.hs | 88 +++++++++---------- .../Handler/SendNotification/Qualification.hs | 47 +++++----- 2 files changed, 70 insertions(+), 65 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 9b0a275dd..1f710ae52 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -150,51 +150,51 @@ dispatchJobLmsResults qid = JobHandlerAtomic act -- act :: YesodJobDB UniWorX () act = hoist lift $ do quali <- getJust qid - now <- liftIO getCurrentTime - let nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems - renewalMonths :: Word = fromMaybe (error ("Cannot renew qualification " <> citext2string (qualificationShorthand quali) <> " without specified validDuration!")) - (qualificationValidDuration quali) - -- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)] - results <- E.select $ do - (quser E.:& luser E.:& lresult) <- E.from $ - E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide! - `E.innerJoin` E.table @LmsUser - `E.on` (\(quser E.:& luser) -> - luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser - E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) - `E.innerJoin` E.table @LmsResult - `E.on` (\(_ E.:& luser E.:& lresult) -> - luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent - E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification) - E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid - E.&&. luser E.^. LmsUserQualification E.==. E.val qid - E.&&. E.isNothing (luser E.^. LmsUserStatus) -- do not process learners already having a result - E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners - return (quser, luser, lresult) - forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do - -- three separate DB operations per result is not so nice. All within one transaction though. - let lmsUserStartedDay = utctDay lmsUserStarted - saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1) - && qualificationUserLastRefresh <= lmsUserStartedDay - newStatus = LmsSuccess lmsResultSuccess - newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards - note <- if saneDate && isLmsSuccess newStatus - then do - update quid [ QualificationUserValidUntil =. newValidTo - , QualificationUserLastRefresh =. lmsResultSuccess - ] - update luid [ LmsUserStatus =. Just newStatus - , LmsUserReceived =. Just lmsResultTimestamp - ] - return Nothing - else do - let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|] - $logErrorS "LmsResult" errmsg - return $ Just errmsg + whenIsJust (qualificationValidDuration quali) $ \renewalMonths -> do + -- otherwise there is nothing to do: we cannot renew s qualification without a specified validDuration + -- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)] + results <- E.select $ do + (quser E.:& luser E.:& lresult) <- E.from $ + E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide! + `E.innerJoin` E.table @LmsUser + `E.on` (\(quser E.:& luser) -> + luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser + E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) + `E.innerJoin` E.table @LmsResult + `E.on` (\(_ E.:& luser E.:& lresult) -> + luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent + E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification) + E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid + E.&&. luser E.^. LmsUserQualification E.==. E.val qid + E.&&. E.isNothing (luser E.^. LmsUserStatus) -- do not process learners already having a result + E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners + return (quser, luser, lresult) + now <- liftIO getCurrentTime + forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do + -- three separate DB operations per result is not so nice. All within one transaction though. + let nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems + lmsUserStartedDay = utctDay lmsUserStarted + saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1) + && qualificationUserLastRefresh <= lmsUserStartedDay + newStatus = LmsSuccess lmsResultSuccess + newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards + note <- if saneDate && isLmsSuccess newStatus + then do + update quid [ QualificationUserValidUntil =. newValidTo + , QualificationUserLastRefresh =. lmsResultSuccess + ] + update luid [ LmsUserStatus =. Just newStatus + , LmsUserReceived =. Just lmsResultTimestamp + ] + return Nothing + else do + let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|] + $logErrorS "LmsResult" errmsg + return $ Just errmsg - insert_ $ LmsAudit qid lmsUserIdent newStatus note lmsResultTimestamp now -- always log success, since this is only transmitted once - delete lrid - $logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|] + insert_ $ LmsAudit qid lmsUserIdent newStatus note lmsResultTimestamp now -- always log success, since this is only transmitted once + delete lrid + $logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|] -- processes received input and block qualifications, if applicable diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 35778e8c4..ef7ebfd3b 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -24,6 +24,8 @@ import Text.Hamlet -- import qualified Database.Esqueleto.Utils as E +-- TODO: refactor! Do not call error in Jobs, as this results in locked jobs. Abort graceful! + dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler () dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = userMailT jRecipient $ do (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- liftHandler . runDB $ (,,) @@ -83,33 +85,37 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do , toMeta "url-text" lmsUrl , toMeta "url" lmsLogin ] - 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 afile - } :: PureFile) - editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet") + emailRenewal attachment + | Text.null (CI.original userEmail) = do -- if neither email nor postal address is known, we must abort! + let msg = "Notify " <> tshow encRecipient <> " failed: no email nor address for user known!" + $logErrorS "LMS" msg + return False + | otherwise = do + 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 afile + } :: PureFile) + editNotifications <- mkEditNotifications jRecipient + addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet") + return True - pdfRenewal pdfMeta >>= \case + notifyOk <- 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 + return False Right (msg,_) - | null msg -> return () - | otherwise -> $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg + | null msg -> return True + | otherwise -> do + $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg + return True Right pdf -> do attch <- case userPinPassword of @@ -127,6 +133,5 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do $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] + when notifyOk $ runDB $ update luid [ LmsUserNotified =. Just now] \ No newline at end of file