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

fix(lms): negating unsigned word auditDuration bug squashed

Browse Source
This commit is contained in:
Steffen Jost 2022-09-30 15:39:56 +02:00
parent 32ca2a3280
commit 7b152b67ed
2 changed files with 20 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
models/lms.model
View File

@ -4,8 +4,8 @@ Qualification
shorthand (CI Text)
name (CI Text)
description StoredMarkup Maybe -- user-defined large Html, ought to contain full description
validDuration Word Maybe -- qualification is valid indefinitely or for a specified number of months, use with addMonthsDay
auditDuration Word Maybe -- number of months to keep audit log and LmsUserIdents; or indefinitely (dangerous, since LmsIdents may run out)
validDuration Int Maybe -- > 0, qualification is valid indefinitely or for a specified number of months, use with addMonthsDay
auditDuration Int Maybe -- > 0, number of months to keep audit log and LmsUserIdents; or indefinitely (dangerous, since LmsIdents may run out)
refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip
elearningStart Bool -- automatically schedule e-refresher
-- elearningOnly Bool -- successful E-learing automatically increases validity. NO!

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

@ -122,6 +122,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
Nothing -> return () -- no automatic removal
(Just auditDuration) -> do
let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now
$logInfoS "lms" $ "Audit Cuttoff at " <> tshow auditCutoff <> " for Audit Duration " <> tshow auditDuration
delusersVals <- E.select $ do
luser <- E.from $ E.table @LmsUser
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
@ -134,13 +135,15 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
E.&&. laudit E.^. LmsAuditProcessed E.>=. E.val auditCutoff
)
pure (luser E.^. LmsUserIdent)
let numdel = length delusers
delusers = E.unValue <$> delusersVals
deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers]
deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers]
deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers]
when (numdel > 0) $ $logInfoS "lms" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort
let delusers = E.unValue <$> delusersVals
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]
deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers]
deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers]
-- processes received results and lengthen qualifications, if applicable
@ -207,20 +210,20 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
-- result :: [(Entity LmsUser, Entity LmsUserlist)]
results <- E.select $ do
(luser E.:& lulist) <- E.from $
E.table @LmsUser `E.fullOuterJoin` E.table @LmsUserlist
`E.on` (\(luser E.:& lulist) -> luser E.?. LmsUserIdent E.==. lulist E.?. LmsUserlistIdent
E.&&. luser E.?. LmsUserQualification E.==. lulist E.?. LmsUserlistQualification)
E.where_ $ luser E.?. LmsUserQualification E.?=. E.val qid
E.&&. E.isNothing (E.joinV (luser E.?. LmsUserEnded)) -- do not process closed learners
E.table @LmsUser `E.leftJoin` E.table @LmsUserlist
`E.on` (\(luser E.:& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent
E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification)
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
return (luser, lulist)
forM_ results $ \case
(Just (Entity luid luser), Nothing)
forM_ results $ \case
(Entity luid luser, Nothing)
| isJust $ lmsUserReceived luser -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
, isNothing $ lmsUserEnded luser ->
update luid [LmsUserEnded =. Just now]
| otherwise -> return () -- users likely not yet started
(Just (Entity luid luser), Just (Entity lulid lulist)) -> do
(Entity luid luser, Just (Entity lulid lulist)) -> do
when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
queueDBJob JobSendNotification
{ jRecipient = lmsUserUser luser
@ -237,6 +240,4 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]
updateBy (UniqueQualificationUser qid (lmsUserUser luser)) [QualificationUserBlockedDue =. Just (QualificationBlockedLms (utctDay lReceived))]
delete lulid
(_,_) -> return () -- TODO CONTINUE HERE
-- PROBLEM: Orphans funktioniert so nicht wegen E.where_ Filter! Separate Query!
$logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]