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

refactor(lms): clean lms handling code

Browse Source
This commit is contained in:
Steffen Jost 2023-09-27 15:36:05 +00:00
parent ae4470333e
commit cdb23115ef
4 changed files with 116 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Handler/LMS.hs
View File

@ -741,7 +741,7 @@ postLmsR sid qsh = do
forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing
fromIntegral <$> (if isReset fromIntegral <$> (if isReset
then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False, LmsUserEnded ==. Nothing] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective
++ ([LmsUserStatus ==. Just LmsBlocked] ||. [LmsUserStatus ==. Just LmsExpired])) [LmsUserResetTries =. True] ++ ([LmsUserStatus ==. Just LmsBlocked] ||. [LmsUserStatus ==. Just LmsExpired])) [LmsUserResetTries =. True]
else deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList] else deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
) )
@ -768,7 +768,7 @@ postLmsR sid qsh = do
numExaminees <- runDB $ do numExaminees <- runDB $ do
okUsers <- selectList [ LmsUserQualification ==. qid -- matching qualification okUsers <- selectList [ LmsUserQualification ==. qid -- matching qualification
, LmsUserEnded ==. Nothing -- not yet deleted , LmsUserEnded ==. Nothing -- not yet deleted
, LmsUserStatus ==. Nothing -- not yet decided -- , LmsUserStatus ==. Nothing -- not yet decided
, LmsUserUser <-. Set.toList selectedUsers -- selected , LmsUserUser <-. Set.toList selectedUsers -- selected
] [] ] []
forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do

2
src/Handler/LMS/Learners.hs
View File

@ -204,7 +204,7 @@ getLmsLearnersDirectR sid qsh = do
csvOpts = def { csvFormat = fmtOpts } csvOpts = def { csvFormat = fmtOpts }
csvSheetName <- csvFilenameLmsUser qsh csvSheetName <- csvFilenameLmsUser qsh
let nr = length lms_users let nr = length lms_users
msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
$logInfoS "LMS" msg $logInfoS "LMS" msg
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered

2
src/Handler/Utils/Qualification.hs
View File

@ -263,7 +263,7 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReason
, qualificationUserBlockBlocker = authUsr , qualificationUserBlockBlocker = authUsr
})) toChange })) toChange
E.insertMany_ (snd <$> newBlocks) E.insertMany_ (snd <$> newBlocks)
unless notify $ updateWhere [QualificationUserId <-. (qualificationUserBlockQualificationUser . snd <$> newBlocks)] [QualificationUserLastNotified =. now] unless notify $ updateWhere [QualificationUserId <-. (qualificationUserBlockQualificationUser . snd <$> newBlocks)] [QualificationUserLastNotified =. addUTCTime 1 blockTime]
forM_ newBlocks $ \(uid, qub) -> audit TransactionQualificationUserBlocking forM_ newBlocks $ \(uid, qub) -> audit TransactionQualificationUserBlocking
{ transactionQualification = qid { transactionQualification = qid
, transactionUser = uid , transactionUser = uid

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

@ -196,7 +196,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. luser E.^. LmsUserQualification E.==. E.val qid E.&&. luser E.^. LmsUserQualification E.==. E.val qid
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) pure (luser E.^. LmsUserId)
nrExpired <- E.updateCount $ \luser -> do nrExpired <- E.updateCount $ \luser -> do
@ -205,7 +205,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
E.&&. luser E.^. LmsUserQualification E.==. E.val qid E.&&. luser E.^. LmsUserQualification E.==. E.val qid
$logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
when (quali ^. _qualificationExpiryNotification) $ do when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers
notifyInvalidDrivers <- E.select $ do notifyInvalidDrivers <- E.select $ do
quser <- E.from $ E.table @QualificationUser quser <- E.from $ E.table @QualificationUser
E.where_ $ E.not_ (validQualification now quser) -- currently invalid E.where_ $ E.not_ (validQualification now quser) -- currently invalid
@ -256,6 +256,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
-- 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
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
-- DB query for LmsUserUser, provided a matching LmsReport exists -- DB query for LmsUserUser, provided a matching LmsReport exists
luserQry luFltr repFltr = E.select $ do luserQry luFltr repFltr = E.select $ do
@ -283,6 +284,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
-- 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
, LmsUserStatusDay E.=. E.nothing
, LmsUserResetTries E.=. E.false ] , LmsUserResetTries E.=. E.false ]
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
E.&&. E.isNothing (luser E.^. LmsUserEnded ) -- must still exist at server E.&&. E.isNothing (luser E.^. LmsUserEnded ) -- must still exist at server
@ -299,7 +301,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting 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 } } notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } }
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) -- 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
@ -343,7 +345,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
E.set luser [ LmsUserReceived E.=. E.justVal now E.set luser [ LmsUserReceived E.=. E.justVal now
, LmsUserLocked E.=. E.val lockstatus ] , LmsUserLocked E.=. E.val lockstatus ]
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.isNothing (luser E.^. LmsUserEnded) -- should always be true, but maybe there is a bug?
E.&&. E.exists (do E.&&. E.exists (do
lreport <- E.from $ E.table @LmsReport lreport <- E.from $ E.table @LmsReport
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent