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

fix(lms): report log did not match qualification

Browse Source
This commit is contained in:
Steffen Jost 2023-11-08 15:56:35 +00:00
parent 8500e72dee
commit 390ff317ea
1 changed files with 21 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -164,7 +164,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse) maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse)
-- runMaybeT $ do -- runMaybeT $ do
-- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse -- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse
-- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid -- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
case inserted of case inserted of
Nothing -> do Nothing -> do
@ -187,7 +187,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
quali <- getJust qid -- may throw an error, aborting the job quali <- getJust qid -- may throw an error, aborting the job
let qshort = CI.original $ qualificationShorthand quali let qshort = CI.original $ qualificationShorthand quali
$logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort $logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
-- end users that expired by doing nothing -- end users that expired by doing nothing
expiredUsers <- E.select $ do expiredUsers <- E.select $ do
(quser :& luser) <- E.from $ (quser :& luser) <- E.from $
@ -201,7 +201,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
-- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- E.&&. E.isNothing (luser E.^. LmsUserStatus)
-- E.&&. E.isNothing (luser E.^. LmsUserEnded) -- E.&&. E.isNothing (luser E.^. LmsUserEnded)
E.&&. E.not_ (validQualification now quser) E.&&. E.not_ (validQualification now quser)
pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser) pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser)
nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ] let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ]
-- let expiredLearners = catMaybes (E.unValue . fst <$> expiredUsers) -- let expiredLearners = catMaybes (E.unValue . fst <$> expiredUsers)
@ -214,7 +214,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers
notifyInvalidDrivers <- E.select $ do notifyInvalidDrivers <- E.select $ do
(quser :& qblock) <- E.from $ (quser :& qblock) <- E.from $
E.table @QualificationUser E.table @QualificationUser
`E.leftJoin` E.table @QualificationUserBlock `E.leftJoin` E.table @QualificationUserBlock
`E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId `E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId
@ -267,7 +267,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise) act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise)
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
-- DEBUG 2rows; remove later -- DEBUG 2rows; remove later
totalrows <- count [LmsReportQualification ==. qid] totalrows <- count [LmsReportQualification ==. qid]
$logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid $logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid
when (totalrows > 0) $ do when (totalrows > 0) $ do
let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only
@ -293,7 +293,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
E.&&. lrFltr luser lreport E.&&. lrFltr luser lreport
return (luser, lreport) return (luser, lreport)
-- A) reset status for learners that had their tries just resetted as indicated by LmsOpen -- A) reset status for learners that had their tries just resetted as indicated by LmsOpen
E.update $ \luser -> do E.update $ \luser -> do
E.set luser [ LmsUserStatus E.=. E.nothing E.set luser [ LmsUserStatus E.=. E.nothing
@ -316,13 +316,13 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner
-- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry
let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed
procBlock (Entity luid luser, Entity _ lreport) = do procBlock (Entity luid luser, Entity _ lreport) = do
let repDay = lmsReportDate lreport <|> Just now let repDay = lmsReportDate lreport <|> Just now
ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right $ QualificationBlockFailedELearningBy $ lmsUserIdent luser) True -- only valid qualifications are blocked; transcribes to audit log ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right $ QualificationBlockFailedELearningBy $ lmsUserIdent luser) True -- only valid qualifications are blocked; transcribes to audit log
update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay] update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay]
return $ Sum ok_block return $ Sum ok_block
in lrepQry lrFltrBlock in lrepQry lrFltrBlock
>>= foldMapM procBlock >>= foldMapM procBlock
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later
-- D) renew qualifications for all successfull learners -- D) renew qualifications for all successfull learners
let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed
@ -330,14 +330,14 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
let repDay = lmsReportDate lreport <|> Just now let repDay = lmsReportDate lreport <|> Just now
reason = Just $ Right $ QualificationRenewELearningBy $ lmsUserIdent luser reason = Just $ Right $ QualificationRenewELearningBy $ lmsUserIdent luser
-- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning -- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
-- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
-- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log -- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
-- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|]) -- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|])
-- END LMS WORKAROUND 2 -- END LMS WORKAROUND 2
ok_renew <- renewValidQualificationUsers qid reason repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log ok_renew <- renewValidQualificationUsers qid reason repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log
update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay] update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay]
return $ Sum ok_renew return $ Sum ok_renew
in lrepQry lrFltrSuccess in lrepQry lrFltrSuccess
>>= foldMapM procRenew >>= foldMapM procRenew
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later
-- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) -- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
@ -380,8 +380,8 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later
updateReceivedLocked True updateReceivedLocked True
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later
-- G) Truncate LmsReport for qid, after updating log -- G) Truncate LmsReport for qid, after updating log
E.insertSelect $ do E.insertSelect $ do
lreport <- E.from $ E.table @LmsReport lreport <- E.from $ E.table @LmsReport
let samelog = E.subSelect $ do let samelog = E.subSelect $ do
lrl <- E.from $ E.table @LmsReportLog lrl <- E.from $ E.table @LmsReportLog
@ -389,22 +389,23 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
E.&&. lrl E.^. LmsReportLogIdent E.==. lreport E.^. LmsReportIdent E.&&. lrl E.^. LmsReportLogIdent E.==. lreport E.^. LmsReportIdent
E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp] E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp]
return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult
E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock
E.&&. E.not_ (lrl E.^. LmsReportLogMissing) E.&&. E.not_ (lrl E.^. LmsReportLogMissing)
E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid
E.&&. E.not_ (E.isTrue samelog) E.&&. E.not_ (E.isTrue samelog)
return (LmsReportLog return (LmsReportLog
E.<# (lreport E.^. LmsReportQualification) E.<# (lreport E.^. LmsReportQualification)
E.<&> (lreport E.^. LmsReportIdent ) E.<&> (lreport E.^. LmsReportIdent )
E.<&> E.nothing E.<&> (lreport E.^. LmsReportDate )
E.<&> (lreport E.^. LmsReportResult ) E.<&> (lreport E.^. LmsReportResult )
E.<&> (lreport E.^. LmsReportLock ) E.<&> (lreport E.^. LmsReportLock )
E.<&> (lreport E.^. LmsReportTimestamp ) E.<&> (lreport E.^. LmsReportTimestamp )
E.<&> E.false) E.<&> E.false)
E.insertSelect $ do E.insertSelect $ do
lrl <- E.from $ E.table @LmsReportLog lrl <- E.from $ E.table @LmsReportLog
E.where_ $ E.not_ (lrl E.^. LmsReportLogMissing) E.where_ $ E.not_ (lrl E.^. LmsReportLogMissing)
E.&&. E.notExists (do E.&&. lrl E.^. LmsReportLogQualification E.==. E.val qid
E.&&. E.notExists (do
lreport <- E.from $ E.table @LmsReport lreport <- E.from $ E.table @LmsReport
E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid
E.&&. lreport E.^. LmsReportIdent E.==. lrl E.^. LmsReportLogIdent E.&&. lreport E.^. LmsReportIdent E.==. lrl E.^. LmsReportLogIdent
@ -418,7 +419,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
return (LmsReportLog return (LmsReportLog
E.<# (lrl E.^. LmsReportLogQualification) E.<# (lrl E.^. LmsReportLogQualification)
E.<&> (lrl E.^. LmsReportLogIdent ) E.<&> (lrl E.^. LmsReportLogIdent )
E.<&> (lrl E.^. LmsReportLogDate ) E.<&> E.nothing
E.<&> (lrl E.^. LmsReportLogResult ) E.<&> (lrl E.^. LmsReportLogResult )
E.<&> (lrl E.^. LmsReportLogLock ) E.<&> (lrl E.^. LmsReportLogLock )
E.<&> E.val now E.<&> E.val now
@ -514,7 +515,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
| otherwise -> return () -- users likely not yet started | otherwise -> return () -- users likely not yet started
(Entity luid luser, Just (Entity _lulid lulist)) -> do (Entity luid luser, Just (Entity _lulid lulist)) -> do
let lReceived = lmsUserlistTimestamp lulist let lReceived = lmsUserlistTimestamp lulist
update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications
when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available