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

fix(lms): send e-learning failed qualification only once

Browse Source
This commit is contained in:
Steffen Jost 2023-03-28 14:57:31 +00:00
parent 9cc1d93f1c
commit c62a42d5c2
2 changed files with 31 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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

12
src/Model/Types/Lms.hs
View File

@ -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