From 7b152b67edfc20f9d2a5dd3573c2bd52e710ff41 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 30 Sep 2022 15:39:56 +0200 Subject: [PATCH] fix(lms): negating unsigned word auditDuration bug squashed --- models/lms.model | 4 ++-- src/Jobs/Handler/LMS.hs | 35 ++++++++++++++++++----------------- 2 files changed, 20 insertions(+), 19 deletions(-) diff --git a/models/lms.model b/models/lms.model index 02bda1bb4..4c4469a1c 100644 --- a/models/lms.model +++ b/models/lms.model @@ -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! diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index f2c483fd9..61b9b1477 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -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|]