diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 1368ba81b..36e668a08 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -222,14 +222,14 @@ dispatchJobLmsResults qid = JobHandlerAtomic act let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay) && qualificationUserLastRefresh <= utctDay lmsUserStarted - newStatus = LmsSuccess lmsResultSuccess + newStatus = Just $ LmsSuccess lmsResultSuccess -- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards - note <- if saneDate && isLmsSuccess newStatus + note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus then do - _ok <- renewValidQualificationUsers qid [qualificationUserUser] -- blocked is unaffected + _ok <- renewValidQualificationUsers qid [qualificationUserUser] -- blocked remains unaffected -- when (ok==1) $ update luid -- we end lms regardless of wether a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings update luid - [ LmsUserStatus =. Just newStatus + [ LmsUserStatus =. newStatus , LmsUserReceived =. Just lmsResultTimestamp ] -- WORKAROUND LMS-Bug [supposedly fixed now]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning @@ -277,32 +277,35 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act | otherwise -> return () -- users likely not yet started (Entity luid luser, Just (Entity lulid lulist)) -> do + let lReceived = lmsUserlistTimestamp lulist + lmsMsgDay = utctDay lReceived + update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications + -- $logInfoS "LmsUserlist" $ tshow lulist + when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available queueDBJob JobSendNotification { jRecipient = lmsUserUser luser , jNotification = NotificationQualificationRenewal { nQualification = qid } } - let lReceived = lmsUserlistTimestamp lulist - isBlocked = lmsUserlistFailed lulist - update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotfied is only updated upon sending notifications - $logInfoS "LmsUserlist" $ tshow lulist - when isBlocked $ do - let blockedDay = utctDay lReceived - newStatus = LmsBlocked blockedDay - oldStatus = lmsUserStatus luser + + let isBlocked = lmsUserlistFailed lulist + oldStatus = lmsUserStatus luser + newStatus = bool Nothing (Just $ LmsBlocked lmsMsgDay) isBlocked + updateStatus = replaceLmsStatus oldStatus newStatus + when updateStatus $ do audit TransactionLmsBlocked { transactionQualification = qid , transactionLmsIdent = lmsUserIdent luser - , transactionLmsDay = blockedDay + , transactionLmsDay = lmsMsgDay , transactionLmsUser = Just $ lmsUserUser luser , transactionNote = Just $ "Old status was " <> tshow oldStatus , transactionReceived = lReceived } - update luid [LmsUserStatus =. (oldStatus <> Just newStatus)] - void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning blockedDay + update luid [LmsUserStatus =. newStatus] + void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning lmsMsgDay queueDBJob JobSendNotification { jRecipient = lmsUserUser luser - , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = blockedDay } + , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = lmsMsgDay } } delete lulid diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 3563d252c..a9421a496 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -55,6 +55,18 @@ isLmsSuccess :: LmsStatus -> Bool isLmsSuccess LmsSuccess{} = True isLmsSuccess _other = False +isLmsExpired :: LmsStatus -> Bool +isLmsExpired LmsExpired{} = True +isLmsExpired _other = False + +-- | What to do if LMS sends multiple responses and whether an oldStatus should be overwritten +replaceLmsStatus :: Maybe LmsStatus -> Maybe LmsStatus -> Bool +replaceLmsStatus _ Nothing = False +replaceLmsStatus Nothing _ = True +replaceLmsStatus (Just LmsSuccess{}) _ = False +replaceLmsStatus (Just LmsExpired{}) (Just newStat) = not $ isLmsExpired newStat +replaceLmsStatus (Just LmsBlocked{}) (Just newStat) = isLmsSuccess newStat + makeLenses_ ''LmsStatus -- Entscheidung 16.09.22: Es gewinnt was zuerst gemeldet wurde. Das verhindert, dass eine Qualifikation doppelt verlängert wird! Siehe Model.TypesSpec