From 86fd7423b856eb4aae1af84f43d5f1d5179fd5ad Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 19 Sep 2022 18:57:53 +0200 Subject: [PATCH] refactor(lms): WIP created a nice E.delete that I am no using now --- src/Jobs/Handler/LMS.hs | 92 +++++++++++++++++++++++++++++++---------- 1 file changed, 71 insertions(+), 21 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index ba542ef4c..a90614a53 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -77,11 +77,6 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } } forM_ renewalUsers (queueDBJob . usr_job) - case qualificationAuditDuration quali of - Nothing -> return () -- no automatic removal - (Just auditDuration) -> - let deleteDate = addMonths auditDuration now - in deleteWhere [LmsUserQualification ==. qid, LmsUserEnded !=. Nothing, LmsUserEnded >. Just deleteDate] dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act @@ -113,16 +108,69 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act -- process all received input and renew or block qualifications dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX dispatchJobLmsDequeue qid = JobHandlerAtomic act - -- wenn bestanden: qualification verlängern -- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart) where act = do $logInfoS "lms" $ "Processing e-learning results for qualification " <> tshow qid <> "." quali <- getJust qid -- may throw an error, aborting the job + now <- liftIO getCurrentTime + -- purge LmsUsers + case qualificationAuditDuration quali of + Nothing -> return () -- no automatic removal + (Just auditDuration) -> + let auditCutoff = addDiffDaysRollover (fromMonths $ negate auditDuration) now + delusers <- fmap E.unValue $ E.select $ do + luser <- E.from $ E.table @LmsUser + E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid + E.&&. luser E.^. LmsUserEnded E.<. E.just (E.val auditCutoff) + E.&&. E.isJust (luser E.^. LmsUserEnded) + E.&&. E.notExists (do + audit <- E.from $ E.table @LmsAudit + E.where_ $ audit E.^. LmsAuditQualification E.==. E.val qid + E.&&. audit E.^. LmsAuditIdent E.==. luser E.^. LmsUserIdent + E.&&. audit E.^. LmsAuditProcessed E.>=. E.val auditCutoff + ) + pure (luser E.^. LmsUserIdent) + deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers] + deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers] + deleteWhere [LmsResult ==. qid, LmsResultIdent <-. delusers] + deleteWhere [LmsAudit ==. qid, LmsAuditIdent <-. delusers] + + + + deleteWhere [LmsUserQualification ==. qid, LmsUserEnded !=. Nothing, LmsUserEnded <. Just lmsCutoff] + -- purge LmsAudit + + in E.delete $ do + audit <- E.from $ E.table @LmsAudit + E.where_ $ audit E.^. LmsAuditQualification E.==. E.val qid + E.&&. E.notExists (do + luser <- E.from $ E.table @LmsUser + E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid + E.&&. luser E.^. LmsUserIdent E.==. audit E.^. LmsAuditIdent + ) + E.groupBy $ audit E.^. LmsAuditIdent + E.having $ E.val auditCutoff E.<. E.max_ (audit E.^. LmsAuditProcessed) + + + + in deleteWhere [LmsAuditQualification ==. qid, LmsAuditProcessed >. Just deleteDate] + + + + let auditCutoff = + + nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems + renewalMonths :: Word = fromMaybe (error ("Cannot renew qualification " <> citext2string (qualificationShorthand quali) <> " without specified validDuration!")) + (qualificationValidDuration quali) + + case qualificationRefreshWithin quali of - Nothing -> return () -- no automatic scheduling for this qid (usually job is not scheduled for these qualifications, see above) - (Just _renewalPeriod) -> + Nothing -> return () -- no automatic deletion + (Just auditDuration) -> return () -- TODO + + deleteWhere [LmsUserEnded >. ] {- do now_day <- utctDay <$> liftIO getCurrentTime let _renewalDate = addGregorianDurationClip renewalPeriod now_day @@ -178,9 +226,8 @@ dispatchJobLmsResults qid = JobHandlerAtomic act saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1) && qualificationUserLastRefresh <= lmsUserStartedDay newStatus = LmsSuccess lmsResultSuccess - newValidTo = addMonthsDay renewalMonths qualificationUserValidUntil -- renew from old validUntil onwards - -- addMonthsDay renewalMonths lmsResultSuccess -- renew from completion onwards - if saneDate && isLmsSuccess newStatus + newValidTo = addGregorianMonthsRollover (toIntger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards + note <- if saneDate && isLmsSuccess newStatus then do update quid [ QualificationUserValidUntil =. newValidTo , QualificationUserLastRefresh =. lmsResultSuccess @@ -188,9 +235,13 @@ dispatchJobLmsResults qid = JobHandlerAtomic act update luid [ LmsUserStatus =. Just newStatus , LmsUserReceived =. Just lmsResultTimestamp ] - else - $logErrorS "LmsResult" [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|] - insert_ $ LmsAudit qid lmsUserIdent newStatus lmsResultTimestamp now -- always log success, since this is only transmitted once + return Nothing + else do + let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|] + $logErrorS "LmsResult" errmsg + return $ Just errmsg + + insert_ $ LmsAudit qid lmsUserIdent newStatus note lmsResultTimestamp now -- always log success, since this is only transmitted once delete lrid $logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|] @@ -226,13 +277,12 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act } let lReceived = lmsUserlistTimestamp lulist isBlocked = lmsUserlistFailed lulist - newStatus = LmsBlocked $ utctDay lReceived - oldStatus = lmsUserStatus luser - update luid [ LmsUserStatus =. (oldStatus <> toMaybe isBlocked newStatus) - , LmsUserReceived =. Just lReceived ] + update luid [LmsUserReceived =. Just lReceived] when isBlocked $ do + let newStatus = LmsBlocked $ utctDay lReceived + oldStatus = lmsUserStatus luser + insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus (Just $ "Old Status was " <> tshow oldStatus) lReceived now + update luid [LmsUserStatus =. (oldStatus <> Just newStatus)] updateBy (UniqueQualificationUser qid (lmsUserUser luser)) [QualificationUserBlockedDue =. Just (QualificationBlockedLms (utctDay lReceived))] - insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lReceived now -- always log blocked - delete lulid - + delete lulid $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]