From 20af976357f67176d523a44cd42f889f58dc60ec Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 16 Sep 2022 17:01:02 +0200 Subject: [PATCH] refactor(lms): lms results and blocked processing reworked --- models/lms.model | 4 +- src/Handler/Utils/DateTime.hs | 6 ++- src/Jobs/Handler/LMS.hs | 92 +++++++++++++++++++---------------- src/Model/Types/Lms.hs | 1 + src/Utils.hs | 4 ++ 5 files changed, 63 insertions(+), 44 deletions(-) diff --git a/models/lms.model b/models/lms.model index 528ea939b..c5f2f33f0 100644 --- a/models/lms.model +++ b/models/lms.model @@ -4,7 +4,7 @@ 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 + validDuration Word Maybe -- qualification is valid indefinitely or for a specified number of months, use with addMonthsDay auditDuration Word Maybe -- number of month to keep audit log; or indefinitely 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 @@ -97,7 +97,7 @@ LmsUser pin Text resetPin Bool default=false -- should pin be reset? datePin UTCTime default=now() -- time pin was created - status LmsStatus Maybe -- open, success or failure; isJust indicates user will be deleted from LMS + status LmsStatus Maybe -- open, success or failure; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete started UTCTime default=now() received UTCTime Maybe -- last acknowledgement by LMS diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 550175e02..ca9778c3b 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -12,7 +12,8 @@ module Handler.Utils.DateTime , getTimeLocale, getDateTimeFormat , getDateTimeFormatter , validDateTimeFormats, dateTimeFormatOptions - , addLocalDays, addDiffDays, addMonths + , addLocalDays, addDiffDays + , addMonths, addMonthsDay , addOneWeek, addWeeks , fromMonths , weeksToAdd @@ -271,6 +272,9 @@ addDiffDays = over _utctDay . addGregorianDurationClip addMonths :: Word -> UTCTime -> UTCTime addMonths = addDiffDays . fromMonths +addMonthsDay :: Word -> Day -> Day +addMonthsDay = addGregorianMonthsClip . toInteger + weeksToAdd :: UTCTime -> UTCTime -> Integer -- ^ Number of weeks needed to add so that first -- time occurs later than second time diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 01b46cd90..f5daef5f6 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -18,9 +18,11 @@ import qualified Database.Esqueleto.Experimental as E -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant import qualified Database.Esqueleto.Utils as E -import Handler.Utils.DateTime (fromMonths, addMonths) +import Handler.Utils.DateTime import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries) +-- import qualified Data.CaseInsensitive as CI + dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue @@ -119,15 +121,16 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act quali <- getJust qid -- may throw an error, aborting the job case qualificationRefreshWithin quali of Nothing -> return () -- no automatic scheduling for this qid (usually job is not scheduled for these qualifications, see above) - (Just renewalPeriod) -> do + (Just _renewalPeriod) -> + return () -- TODO + {- do now_day <- utctDay <$> liftIO getCurrentTime - let renewalDate = addGregorianDurationClip renewalPeriod now_day + let _renewalDate = addGregorianDurationClip renewalPeriod now_day - -- CONTINUE HERE: TODO - -- select users that need renewal due to success + -- CONTINUE HERE: TODO -- delete users after audit period has expired!!! - renewalUsers <- E.select $ do + _renewalUsers <- E.select $ do (quser E.:& luser) <- E.from $ E.table @QualificationUser `E.innerJoin` E.table @LmsUser `E.on` (\(quser E.:& luser) -> quser E.^. QualificationUserUser E.==. luser E.^. LmsUserUser E.&&. quser E.^. QualificationUserQualification E.==. luser E.^. LmsUserQualification @@ -135,56 +138,61 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.where_ $ E.val qid E.==. quser E.^. QualificationUserQualification E.&&. E.val qid E.==. luser E.^. LmsUserQualification E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day -- still valid - E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate -- due to renewal + -- E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate -- due to renewal E.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success -- result already known pure (quser, luser) - let usr_job (quser, luser) = - let vold = quser ^. _entityVal . _qualificationUserValidUntil - pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualifications that have infinite validity?! - vnew = addGregorianDurationClip pmonth vold - lmsstatus = luser ^. _entityVal . _lmsUserStatus - in case lmsstatus of - Just (LmsSuccess refreshDay) -> update (quser ^. _entityKey) [QualificationUserValidUntil =. vnew, QualificationUserLastRefresh =. refreshDay] - _ -> return () - forM_ renewalUsers usr_job + -} --- just processes received input, but does not affect any exisitng qualifications yet +-- processes received results and lengthen qualifications, if applicable dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX dispatchJobLmsResults qid = JobHandlerAtomic act where -- act :: YesodJobDB UniWorX () act = hoist lift $ do now <- liftIO getCurrentTime - -- result :: [(Entity LmsUser, Entity LmsResult)] + quali <- getJust qid + let renewalMonths :: Word = fromMaybe (error ("Cannot renew qualification " <> citext2string (qualificationShorthand quali) <> " without specified validDuration!")) + (qualificationValidDuration quali) + -- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)] results <- E.select $ do - (luser E.:& lresult) <- E.from $ - E.table @LmsUser `E.innerJoin` E.table @LmsResult - `E.on` (\(luser E.:& lresult) -> luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent - E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification) - E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid - E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners - return (luser, lresult) - forM_ results $ \(Entity luid luser, Entity lrid lresult) -> do + (quser E.:& luser E.:& lresult) <- E.from $ + E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide! + `E.innerJoin` E.table @LmsUser + `E.on` (\(quser E.:& luser) -> + luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser + E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) + `E.innerJoin` E.table @LmsResult + `E.on` (\(_ E.:& luser E.:& lresult) -> + luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent + E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification) + E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid + E.&&. luser E.^. LmsUserQualification E.==. E.val qid + E.&&. E.isNothing (luser E.^. LmsUserStatus) -- do not process learners already having a result + E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners + return (quser, luser, lresult) + forM_ results $ \(Entity quid QualificationUser{}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do -- three separate DB operations per result is not so nice. All within one transaction though. - let lreceived = lmsResultTimestamp lresult - newStatus = lmsResultSuccess lresult & LmsSuccess - oldStatus = lmsUserStatus luser - saneDate = lmsResultSuccess lresult `inBetween` (utctDay $ lmsUserStarted luser, utctDay now) - -- always log success, since this is only transmitted once - if saneDate - then - update luid [ LmsUserStatus =. (oldStatus <> Just newStatus) - , LmsUserReceived =. Just lreceived + let saneDate = lmsResultSuccess `inBetween` (utctDay lmsUserStarted, utctDay now) + newStatus = LmsSuccess lmsResultSuccess + newValidTo = -- addMonthsDay renewalMonths qualificationUserValidUntil -- renew from old validUntil onwards + addMonthsDay renewalMonths lmsResultSuccess -- renew from completion onwards + if saneDate && isLmsSuccess newStatus + then do + update quid [ QualificationUserValidUntil =. newValidTo + , QualificationUserLastRefresh =. lmsResultSuccess ] + update luid [ LmsUserStatus =. Just newStatus + , LmsUserReceived =. Just lmsResultTimestamp + ] else - $logErrorS "LmsResult" [st|LMS success with insane date #{tshow (lmsResultSuccess lresult)} received|] - insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lreceived now - delete lrid - $logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|] + $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 + delete lrid + $logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|] --- just processes received input, but does not affect any exisitng qualifications yet +-- processes received input and block qualifications, if applicable dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX dispatchJobLmsUserlist qid = JobHandlerAtomic act where @@ -219,7 +227,9 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act oldStatus = lmsUserStatus luser update luid [ LmsUserStatus =. (oldStatus <> toMaybe isBlocked newStatus) , LmsUserReceived =. Just lReceived ] - when isBlocked . insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lReceived now -- always log blocked + when isBlocked $ do + updateBy (UniqueQualificationUser qid (lmsUserUser luser)) [QualificationUserBlockedDue =. Just (QualificationBlockedLms (utctDay lReceived))] + insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lReceived now -- always log blocked delete lulid $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|] diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 898395262..5cd94d86b 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -38,6 +38,7 @@ isLmsSuccess LmsSuccess{} = True isLmsSuccess _other = False -- Entscheidung 08.04.22: LmsSuccess gewinnt immer über LmsBlocked oder umgekehrt; siehe Model.TypesSpec +-- Entscheidung 16.09.22: Es gewinnt was zuerst gemeldet wurde. Das verhindert, dass eine Qualifikation doppelt verlängert wird! instance Semigroup LmsStatus where a <> b | a >= b = a | otherwise = b diff --git a/src/Utils.hs b/src/Utils.hs index c9043998e..f2c1be58c 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -283,6 +283,10 @@ stripCI = CI.mk . Text.strip citext2lower :: CI Text -> Text citext2lower = Text.toLower . CI.original +-- avoids unnecessary imports +citext2string :: CI Text -> String +citext2string = Text.unpack . CI.original + -- | Convert text as it is to Html, may prevent ambiguous types -- This function definition is mainly for documentation purposes text2Html :: Text -> Html