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

fix(lms): accept success for no-status learners and print several more debug messages processing reports

Browse Source
This commit is contained in:
Steffen Jost 2023-09-04 15:52:06 +00:00
parent 0b19705e80
commit a7ed659866
2 changed files with 79 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
src/Handler/LMS/Report.hs
View File

@ -201,7 +201,7 @@ mkReportTable sid qsh qid = do
, LmsReportTimestamp =. now
]
-- audit $ Transaction.. (add to Audit.Types)
lift . queueDBJob $ JobLmsReports qid -- TODO: V2
lift . queueDBJob $ JobLmsReports qid
return $ LmsReportR sid qsh
, dbtCsvRenderKey = const $ \case
LmsReportInsertData{..} -> do -- TODO: i18n
@ -277,15 +277,16 @@ postLmsReportUploadR sid qsh = do
FormSuccess file -> do
-- content <- fileSourceByteString file
-- return $ Just (fileName file, content)
nr <- runDBJobs $ do
(nr, qid) <- runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
nr <- runConduit $ fileSource file
.| decodeCsv
.| foldMC (saveReportCsv now qid) 0
queueDBJob $ JobLmsReports qid
return nr
.| foldMC (saveReportCsv now qid) 0
return (nr, qid)
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
redirect $ LmsReportR sid qsh
-- redirect $ LmsReportR sid qsh
getLmsReportR sid qsh <* queueJob' (JobLmsReports qid) -- show uploaded data before processing
FormFailure errs -> do
forM_ errs $ addMessage Error . toHtml
redirect $ LmsReportUploadR sid qsh

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

@ -11,14 +11,14 @@ module Jobs.Handler.LMS
, dispatchJobLmsDequeue
, dispatchJobLmsReports
, dispatchJobLmsResults
, dispatchJobLmsUserlist
, dispatchJobLmsUserlist
) where
import Import
import Jobs.Queue
-- import Jobs.Handler.Intervals.Utils
import Database.Persist.Sql (deleteWhereCount)
import Database.Persist.Sql -- (deleteWhereCount, updateWhereCount)
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E
--import qualified Database.Esqueleto.Legacy as E
@ -65,13 +65,13 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
$logInfoS "LMS" $ "Notifying about exipiring qualification " <> qshort
now <- liftIO getCurrentTime
case qualificationRefreshWithin quali of
Nothing -> return () -- TODO: no renewal period, no reminders currenty
Nothing -> return () -- TODO: no renewal period, no reminders currently
(Just renewalPeriod) -> do
let nowaday = utctDay now
renewalDate = addGregorianDurationClip renewalPeriod nowaday
sendReminders remindPeriod = do
let remindDate = addGregorianDurationClip remindPeriod nowaday
reminders <- E.select $ do -- TODO: refactor to remove some redundancies with later query
sendReminders remindPeriod = do
let remindDate = addGregorianDurationClip remindPeriod nowaday
reminders <- E.select $ do -- TODO: refactor to remove some redundancies with later query
(luser :& quser) <- E.from $ E.table @LmsUser `E.innerJoin` E.table @QualificationUser
`E.on` (\(luser :& quser) -> luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
@ -99,7 +99,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
renewalUsers <- E.select $ do
quser <- E.from $ E.table @QualificationUser
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. quser E.^. QualificationUserScheduleRenewal
E.&&. quser E.^. QualificationUserScheduleRenewal
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
E.&&. (quser `qualificationValid` now)
E.&&. E.notExists (do
@ -127,7 +127,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
act = do
identsInUseVs <- E.select $ do
lui <- E.from $
( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- no filter by Qid, since LmsIdents must be unique across all
( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- no filter by Qid, since LmsIdents must be unique across all
`E.union_`
( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult ) )
`E.union_`
@ -173,9 +173,9 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
let qshort = CI.original $ qualificationShorthand quali
$logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort
now <- liftIO getCurrentTime
let nowaday = utctDay now
let nowaday = utctDay now
-- end users that expired by doing nothing
expiredLearners <- E.select $ do
expiredLearners <- E.select $ do
(quser :& luser) <- E.from $
E.table @QualificationUser
`E.innerJoin` E.table @LmsUser
@ -187,7 +187,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
E.&&. E.isNothing (luser E.^. LmsUserStatus)
E.&&. E.isNothing (luser E.^. LmsUserEnded)
E.&&. E.not_ (validQualification now quser)
pure (luser E.^. LmsUserId)
pure (luser E.^. LmsUserId)
nrExpired <- E.updateCount $ \luser -> do
E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal nowaday]
E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners)
@ -195,13 +195,13 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
$logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
when (quali ^. _qualificationExpiryNotification) $ do
notifyInvalidDrivers <- E.select $ do
quser <- E.from $ E.table @QualificationUser
notifyInvalidDrivers <- E.select $ do
quser <- E.from $ E.table @QualificationUser
E.where_ $ E.not_ (quser `qualificationValid` now) -- currently invalid
E.&&. quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification
E.&&. quser `quserToNotify` now -- recently became invalid or blocked
pure (quser E.^. QualificationUserUser)
pure (quser E.^. QualificationUserUser)
forM_ notifyInvalidDrivers $ \(E.Value uid) ->
queueDBJob JobUserNotification
{ jRecipient = uid
@ -227,7 +227,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
-- )
pure (luser E.^. LmsUserIdent)
let delusers = E.unValue <$> delusersVals
numdel = length delusers
numdel = length delusers
when (numdel > 0) $ do
$logInfoS "LMS" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort
deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers]
@ -241,7 +241,10 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
where
-- act :: YesodJobDB UniWorX ()
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
totalrows <- count [LmsReportQualification ==. qid]
$logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid
let today = utctDay now
-- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only
-- DB query for LmsUserUser, provided a matching LmsReport exists
@ -250,7 +253,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
E.&&. luFltr luser
E.&&. E.exists (do
E.&&. E.exists (do
lreport <- E.from $ E.table @LmsReport
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
@ -270,19 +273,35 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
-- group results by LmsReportDate
grpRepByDay :: [(Entity LmsUser, Entity LmsReport)] -> Map.Map (Maybe Day) ([LmsUserId],[UserId])
grpRepByDay reps = Map.fromListWith (<>) [(lmsReportDate lreport, ([luid],[lmsUserUser luser])) | (Entity luid luser, Entity _ lreport) <- reps]
-- A) notify all newly reported users that lms is available
-- A) reset status for learners that had their tries just resetted as indicated by LmsOpen
E.update $ \luser -> do
E.set luser [ LmsUserStatus E.=. E.nothing
, LmsUserResetTries E.=. E.false ]
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
E.&&. E.isNothing (luser E.^. LmsUserEnded ) -- must still exist at server
E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet
E.&&. luser E.^. LmsUserResetTries
E.&&. E.exists (do
lreport <- E.from $ E.table @LmsReport
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
E.&&. lreport E.^. LmsReportResult E.==. E.val LmsOpen
E.&&. lreport E.^. LmsReportLock E.==. E.true
)
-- B) notify all newly reported users that lms is available
let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting
notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } }
in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner
-- B) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit)
-- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit)
let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed
in lrepQry lrFltrBlock >>= (\toBlock ->
void $ flip Map.traverseWithKey (grpRepByDay toBlock) $ \repDay (lids,uids) -> do
void $ qualificationUserBlocking qid uids False (toMidnight <$> repDay) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log
updateWhere [LmsUserQualification ==. qid, LmsUserId <-. lids] [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. (repDay <|> Just today)]
in lrepQry lrFltrBlock >>= (\toBlock ->
void $ flip Map.traverseWithKey (grpRepByDay toBlock) $ \repDay (lids,uids) -> do
ok_block <- qualificationUserBlocking qid uids False (toMidnight <$> repDay) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log
ok_status <- updateWhereCount [LmsUserQualification ==. qid, LmsUserId <-. lids] [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. (repDay <|> Just today)]
$logInfoS "LMS" $ "Report processing for " <> tshow repDay <> "(" <> tshow (length lids) <> "): " <> tshow ok_block <> " blocked, " <> tshow ok_status <> " status set to blocked for qualification " <> tshow qid -- debug, remove later
)
-- C) renew qualifications for all successfull learners
let lrFltrSuccess luser lreport = luser E.^. LmsUserStatus E.!=. E.justVal LmsSuccess E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed -- LMS WORKAROUND 1: LmsPassed replaces any other status
-- D) renew qualifications for all successfull learners
let lrFltrSuccess luser lreport = (E.isNothing (luser E.^. LmsUserStatus) E.||. luser E.^. LmsUserStatus E.!=. E.justVal LmsSuccess) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed -- LMS WORKAROUND 1: LmsPassed replaces any other status
in lrepQry lrFltrSuccess >>= (\toRenew ->
void $ flip Map.traverseWithKey (grpRepByDay toRenew) $ \repDay (lids,uids) -> do
-- 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
@ -291,65 +310,49 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
ok_unblock <- qualificationUserUnblockByReason qid uids 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|])
-- END LMS WORKAROUND 2
void $ renewValidQualificationUsers qid repTime uids -- only valid qualifications are truly renewed; transcribes to audit log
updateWhere [LmsUserQualification ==. qid, LmsUserId <-. lids] [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. (repDay <|> Just today)]
ok_renew <- renewValidQualificationUsers qid repTime uids -- only valid qualifications are truly renewed; transcribes to audit log
ok_status <- updateWhereCount [LmsUserQualification ==. qid, LmsUserId <-. lids] [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. (repDay <|> Just today)]
$logInfoS "LMS" $ "Report processing for " <> tshow repDay <> "(" <> tshow (length lids) <> "): " <> tshow ok_unblock <> " unblocked, " <> tshow ok_renew <> " renewed, " <> tshow ok_status <> " status set to success for qualification " <> tshow qid -- debug, remove later
)
-- D) 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)
E.update $ \luser -> do
E.set luser [ LmsUserEnded E.=. E.justVal now ]
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
E.&&. E.isNothing (luser E.^. LmsUserEnded )
E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet
E.&&. E.notExists (do
E.&&. E.notExists (do
lreport <- E.from $ E.table @LmsReport
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
)
-- E) reset status for learners that had their tries just resetted as indicated by LmsOpen
E.update $ \luser -> do
E.set luser [ LmsUserStatus E.=. E.nothing
, LmsUserResetTries E.=. E.false ]
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
E.&&. E.isNothing (luser E.^. LmsUserEnded )
E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet
E.&&. luser E.^. LmsUserResetTries
E.&&. E.exists (do
lreport <- E.from $ E.table @LmsReport
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
E.&&. lreport E.^. LmsReportResult E.==. E.val LmsOpen
E.&&. lreport E.^. LmsReportLock E.==. E.true
)
-- F) lock expired learneds: happens during JobLmsDequeue only
-- F) lock expired learners: happens during JobLmsDequeue only
-- G) update lock and received
let updateReceivedLocked lockstatus = E.update $ \luser -> do -- due to the absence of UPDATE..FROM in esqueleto, we call update twice
let updateReceivedLocked lockstatus = E.updateCount $ \luser -> do -- due to the absence of UPDATE..FROM in esqueleto, we call update twice
E.set luser [ LmsUserReceived E.=. E.justVal now
, LmsUserLocked E.=. E.val lockstatus ]
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
E.&&. E.isNothing (luser E.^. LmsUserEnded)
E.&&. E.exists (do
E.&&. E.exists (do
lreport <- E.from $ E.table @LmsReport
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
)
-- TODO: implement tries-reset here:
-- if | LmsUserResetTries && LmsReportStatus = LmsOpen => LmsUserStatus =. Nothing
-- | LmsUserResetTries && LmsUserStatus == Nothing && not LmsReportLock => LmsUserResetTries =. False
-- TODO: check whether this works too:
-- let updateReceivedLocked' lockstatus = E.update $ \luser -> do -- attempt to use 'from'-clause in update as per PostgreSQL
-- NOTE: this code leads to a runtime errror; apparently from-clauses are not allowed in updates yet
-- let updateReceivedLocked lockstatus = E.update $ \luser -> do -- attempt to use 'from'-clause in update as per PostgreSQL
-- E.set luser [ LmsUserReceived E.=. E.justVal now
-- , lmsUserLocked E.=. E.val lockstatus ]
-- , LmsUserLocked E.=. E.val lockstatus ]
-- lreport <- E.from $ E.table @LmsReport
-- E.where_ $ E.isNothing (luser E.^. LmsUserEnded)
-- E.&&. luser E.^. LmsUserQualification E.==. E.val qid
-- E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
-- E.&&. lreport E.^. LmsReportIdent E.==. luser E.^. LmsReportIdent
-- E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
-- E.&&. lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
-- E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
updateReceivedLocked False
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later
updateReceivedLocked True
>>= \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 and log
repProc <- deleteWhereCount [LmsReportQualification ==. qid]
$logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|]
@ -383,7 +386,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
-- three separate DB operations per result is not so nice. All within one transaction though.
let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
-- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway
-- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway
-- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
note <- if saneDate && (lmsUserStatus /= Just LmsSuccess)
then do
@ -395,11 +398,11 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
_ok_renew <- renewValidQualificationUsers qid Nothing [qualificationUserUser] -- only unblocked are renewed
-- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
update luid
update luid
[ LmsUserStatus =. Just LmsSuccess
, LmsUserStatusDay =. Just lmsResultSuccess
, LmsUserReceived =. Just lmsResultTimestamp
]
]
return Nothing
else do
let errmsg = [st|LMS Result: success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent} for #{tshow qid}|]
@ -424,7 +427,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
where
act :: YesodJobDB UniWorX ()
act = whenM (exists [LmsUserlistQualification ==. qid]) $ do -- safeguard against multiple calls, which would close all learners due to first case below
now <- liftIO getCurrentTime
now <- liftIO getCurrentTime
-- result :: [(Entity LmsUser, Entity LmsUserlist)]
results <- E.select $ do
(luser :& lulist) <- E.from $
@ -444,23 +447,23 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
(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
update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications
when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
queueDBJob JobUserNotification
{ jRecipient = lmsUserUser luser
, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False }
}
let isBlocked = lmsUserlistFailed lulist
oldStatus = lmsUserStatus luser
updateStatus = isBlocked && oldStatus /= Just LmsSuccess
when updateStatus $ do
update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lmsMsgDay]
when updateStatus $ do
update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lmsMsgDay]
ok <- qualificationUserBlocking qid [lmsUserUser luser] False Nothing (Right QualificationBlockFailedELearning) True
when (ok /= 1) $ do
when (ok /= 1) $ do
uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser
$logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}]
$logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}]
audit TransactionLmsBlocked
{ transactionQualification = qid
, transactionLmsIdent = lmsUserIdent luser