chore(lms): no longer abort jobs with error
This commit is contained in:
Steffen Jost
parent
116c699a18
commit
c3fe47f50d
@ -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
|
||||
|
||||
@ -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]
|
||||
|
||||
Reference in New Issue
Block a user