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

chore(lms): no longer abort jobs with error

Browse Source
This commit is contained in:
Steffen Jost 2022-09-27 15:26:08 +02:00
parent 116c699a18
commit c3fe47f50d
2 changed files with 70 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -150,51 +150,51 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
-- act :: YesodJobDB UniWorX () -- act :: YesodJobDB UniWorX ()
act = hoist lift $ do act = hoist lift $ do
quali <- getJust qid quali <- getJust qid
now <- liftIO getCurrentTime whenIsJust (qualificationValidDuration quali) $ \renewalMonths -> do
let nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems -- otherwise there is nothing to do: we cannot renew s qualification without a specified validDuration
renewalMonths :: Word = fromMaybe (error ("Cannot renew qualification " <> citext2string (qualificationShorthand quali) <> " without specified validDuration!")) -- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)]
(qualificationValidDuration quali) results <- E.select $ do
-- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)] (quser E.:& luser E.:& lresult) <- E.from $
results <- E.select $ do E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide!
(quser E.:& luser E.:& lresult) <- E.from $ `E.innerJoin` E.table @LmsUser
E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide! `E.on` (\(quser E.:& luser) ->
`E.innerJoin` E.table @LmsUser luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
`E.on` (\(quser E.:& luser) -> E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification)
luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser `E.innerJoin` E.table @LmsResult
E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) `E.on` (\(_ E.:& luser E.:& lresult) ->
`E.innerJoin` E.table @LmsResult luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent
`E.on` (\(_ E.:& luser E.:& lresult) -> E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification)
luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification) E.&&. luser E.^. LmsUserQualification E.==. E.val qid
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.&&. E.isNothing (luser E.^. LmsUserStatus) -- do not process learners already having a result
E.&&. luser E.^. LmsUserQualification E.==. E.val qid E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
E.&&. E.isNothing (luser E.^. LmsUserStatus) -- do not process learners already having a result return (quser, luser, lresult)
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners now <- liftIO getCurrentTime
return (quser, luser, lresult) forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
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.
-- 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
let lmsUserStartedDay = utctDay lmsUserStarted lmsUserStartedDay = utctDay lmsUserStarted
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1) saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1)
&& qualificationUserLastRefresh <= lmsUserStartedDay && qualificationUserLastRefresh <= lmsUserStartedDay
newStatus = LmsSuccess lmsResultSuccess newStatus = LmsSuccess lmsResultSuccess
newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
note <- if saneDate && isLmsSuccess newStatus note <- if saneDate && isLmsSuccess newStatus
then do then do
update quid [ QualificationUserValidUntil =. newValidTo update quid [ QualificationUserValidUntil =. newValidTo
, QualificationUserLastRefresh =. lmsResultSuccess , QualificationUserLastRefresh =. lmsResultSuccess
] ]
update luid [ LmsUserStatus =. Just newStatus update luid [ LmsUserStatus =. Just newStatus
, LmsUserReceived =. Just lmsResultTimestamp , LmsUserReceived =. Just lmsResultTimestamp
] ]
return Nothing return Nothing
else do else do
let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|] let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]
$logErrorS "LmsResult" errmsg $logErrorS "LmsResult" errmsg
return $ Just errmsg return $ Just errmsg
insert_ $ LmsAudit qid lmsUserIdent newStatus note lmsResultTimestamp now -- always log success, since this is only transmitted once insert_ $ LmsAudit qid lmsUserIdent newStatus note lmsResultTimestamp now -- always log success, since this is only transmitted once
delete lrid delete lrid
$logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|] $logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|]
-- processes received input and block qualifications, if applicable -- processes received input and block qualifications, if applicable

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

@ -24,6 +24,8 @@ import Text.Hamlet
-- import qualified Database.Esqueleto.Utils as E -- 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 :: QualificationId -> Day -> UserId -> Handler ()
dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = userMailT jRecipient $ do dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = userMailT jRecipient $ do
(recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- liftHandler . runDB $ (,,) (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- liftHandler . runDB $ (,,)
@ -83,33 +85,37 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
, toMeta "url-text" lmsUrl , toMeta "url-text" lmsUrl
, toMeta "url" lmsLogin , toMeta "url" lmsLogin
] ]
emailRenewal attachment = do emailRenewal attachment
when (Text.null (CI.original userEmail)) $ do | 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!" let msg = "Notify " <> tshow encRecipient <> " failed: no email nor address for user known!"
$logErrorS "LMS" msg $logErrorS "LMS" msg
error $ unpack msg -- if neither email nor postal address is known, we must abort! return False
userMailT jRecipient $ do | otherwise = do
replaceMailHeader "Auto-Submitted" $ Just "auto-generated" userMailT jRecipient $ do
setSubjectI $ MsgMailSubjectQualificationRenewal qname replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
whenIsJust attachment $ \afile -> setSubjectI $ MsgMailSubjectQualificationRenewal qname
addPart (File { fileTitle = Text.unpack fileName whenIsJust attachment $ \afile ->
, fileModified = now addPart (File { fileTitle = Text.unpack fileName
, fileContent = Just $ yield $ LBS.toStrict afile , fileModified = now
} :: PureFile) , fileContent = Just $ yield $ LBS.toStrict afile
editNotifications <- mkEditNotifications jRecipient } :: PureFile)
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet") 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 Right pdf | userPrefersLetter recipient -> -- userPrefersLetter is false if both userEmail and userPostAddress are null
let printSender = Nothing let printSender = Nothing
in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification)) >>= \case in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification)) >>= \case
Left err -> do Left err -> do
let msg = "Notify " <> tshow encRecipient <> ": PDF printing to send letter failed with error " <> cropText err let msg = "Notify " <> tshow encRecipient <> ": PDF printing to send letter failed with error " <> cropText err
$logErrorS "LMS" msg $logErrorS "LMS" msg
error $ unpack msg return False
Right (msg,_) Right (msg,_)
| null msg -> return () | null msg -> return True
| otherwise -> $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg | otherwise -> do
$logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg
return True
Right pdf -> do Right pdf -> do
attch <- case userPinPassword of attch <- case userPinPassword of
@ -127,6 +133,5 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
$logErrorS "LMS" msg $logErrorS "LMS" msg
emailRenewal Nothing emailRenewal Nothing
-- if we reach the end, mark the user as notified. TODO: Maybe defer this until the print job is marked as sent? when notifyOk $ runDB $ update luid [ LmsUserNotified =. Just now]
runDB $ update luid [ LmsUserNotified =. Just now]