diff --git a/models/lms.model b/models/lms.model index c5f2f33f0..02bda1bb4 100644 --- a/models/lms.model +++ b/models/lms.model @@ -1,11 +1,11 @@ Qualification - -- INVARIANT: 2*refreshWithin < validDuration + -- INVARIANT: 2*refreshWithin < validDuration school SchoolId --TODO: Ansprechpartner der Schule in Briefe erwähnen 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 month to keep audit log; or indefinitely + auditDuration Word Maybe -- 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! @@ -18,9 +18,9 @@ Qualification -- TODOs: -- - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen? -- Falls ja, so sollte bei automatischem refresher vorher der Kunde durch FRADrive befragt werden?! --- A: Der Inhaber per Email informieren! +-- A: Der Inhaber per Email informieren! -- A: Es kann gleich eine LMS Pin generiert und verschickt werden! --- - Aufteilung Qualification "R" in zwei Teile: "R e-learning" und "R praxis" okay? +-- - Aufteilung Qualification "R" in zwei Teile: "R e-learning" und "R praxis" okay? -- Besonderheiten: -- - LmsIdent muss für alle Qualificationen einzigartig sein! @@ -33,7 +33,7 @@ Qualification QualificationPrecondition qualification QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions - required [QualificationId] -- OR : alternatives, any one will suffice + required [QualificationId] -- OR : alternatives, any one will suffice continuous Bool -- expiring precondition removes qualification deriving Generic @@ -53,17 +53,17 @@ QualificationUser firstHeld Day -- first time the qualification was earned, should never change blockedDue QualificationBlocked Maybe -- isJust means that the qualification is currently revoked -- temporärer Entzug vorsehen - -- Begründungsfeld vorsehen + -- Begründungsfeld vorsehen UniqueQualificationUser qualification user deriving Generic -- LMS Interface Tables, need regular processing by background jobs, per QualificationId: - -- - -- 1. Daily Job: Add to LmsUser daily all qualification holders with - -- QualificationUserValidUntil >= now + -- + -- 1. Daily Job: Add to LmsUser daily all qualification holders with + -- QualificationUserValidUntil >= now -- /\ QualificationUserValudUntil <= now + QualificationRefreshWithin (time to schedule refresher) - -- /\ not already enlisted - -- + -- /\ not already enlisted + -- -- 2. REST GET User.csv: -- - where LmsUserReceived == Nothing \/ (LmsUserResetPin /\ LmsUserEnded == Nothing) -- - delete-flag: isJust LmsUserStatus @@ -77,60 +77,61 @@ QualificationUser -- - For all LmsUser: -- + if contained: -- set LmsUserReceived to Just now() - -- if LmsUserlistFailed: set LmsUserStatus to Just Day + -- if LmsUserlistFailed: set LmsUserStatus to Just LmsBlocked now -- + not contained, by LmsUserReceived is set: set LmsUserEnded to Just now() -- - move row to LmsAudit -- -- 6. When received: Daily Job LmsResult: - -- - set LmsUserReceived to Just now() - -- - set LmsUserStatus to Just Day -- always + -- - set LmsUserReceived to Just now() -- always + -- - set LmsUserStatus to Just LmsSuccess now -- conditional + -- - and renew QualificationValidTo -- - move row to LmsAudit -- -- 7. Daily Job: dequeue LMS Users - -- - renew qualification, if passed -- - remove from LmsUser after audit Period has passed LmsUser qualification QualificationId OnDeleteCascade OnUpdateCascade - user UserId OnDeleteCascade OnUpdateCascade - ident LmsIdent -- must be unique accross all LMS courses! + user UserId OnDeleteCascade OnUpdateCascade + ident LmsIdent -- must be unique accross all LMS courses! 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; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS + resetPin Bool default=false -- should pin be reset? + datePin UTCTime default=now() -- time pin was created + 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 - notified UTCTime Maybe -- last notified by FRADrive - ended UTCTime Maybe -- ident was deleted from LMS + started UTCTime default=now() + received UTCTime Maybe -- last acknowledgement by LMS + notified UTCTime Maybe -- last notified by FRADrive + ended UTCTime Maybe -- ident was deleted from LMS -- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this? - UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS! - UniqueLmsQualificationUser qualification user -- each user may be enrolled at most once per course + UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS! + UniqueLmsQualificationUser qualification user -- each user may be enrolled at most once per course deriving Generic --- LmsUserlist stores LMS upload for later processing only +-- LmsUserlist stores LMS upload for later processing only LmsUserlist - qualification QualificationId OnDeleteCascade OnUpdateCascade - ident LmsIdent + qualification QualificationId OnDeleteCascade OnUpdateCascade + ident LmsIdent failed Bool - timestamp UTCTime default=now() + timestamp UTCTime default=now() UniqueLmsUserlist qualification ident deriving Generic --- LmsResult stores LMS upload for later processing only +-- LmsResult stores LMS upload for later processing only LmsResult qualification QualificationId OnDeleteCascade OnUpdateCascade - ident LmsIdent + ident LmsIdent success Day - timestamp UTCTime default=now() + timestamp UTCTime default=now() UniqueLmsResult qualification ident -- required by DBTable deriving Generic -- Logs all processed rows from LmsUserlist and LmsResult -LmsAudit +LmsAudit qualification QualificationId OnDeleteCascade OnUpdateCascade ident LmsIdent - notificationType LmsStatus -- LmsBlocked Day | LmsSuccess Day + notificationType LmsStatus -- LmsBlocked Day | LmsSuccess Day + note Text Maybe received UTCTime -- timestamp from LmsUserlist/LmsResult - processed UTCTime default=now() + processed UTCTime default=now() deriving Generic diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 43ddac453..8d5abf085 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -274,8 +274,8 @@ postLmsResultDirectR sid qsh = do return (badRequest400, "Exception: " <> tshow e) Right nr -> do let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead - $logWarnS "LMS" msg -- TODO: change to Info Level in the future - queueDBJob $ JobLmsResults qid + $logInfoS "LMS" msg + when (nr > 0) $ queueDBJob $ JobLmsResults qid return (ok200, msg) [] -> do let msg = "Result upload file missing." diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index ab904ba52..0987aa442 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -270,8 +270,8 @@ postLmsUserlistDirectR sid qsh = do return (badRequest400, "Exception: " <> tshow e) Right nr -> do let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead - $logWarnS "LMS" msg -- TODO: change to Info Level in the future - queueDBJob $ JobLmsUserlist qid + $logInfoS "LMS" msg + when (nr > 0) $ queueDBJob $ JobLmsUserlist qid return (ok200, msg) [] -> do let msg = "Userlist upload file missing." diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 024bfbf14..fb82e3d6d 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -12,10 +12,10 @@ module Handler.Utils.DateTime , getTimeLocale, getDateTimeFormat , getDateTimeFormatter , validDateTimeFormats, dateTimeFormatOptions - , addLocalDays, addDiffDays - , addMonths, addMonthsDay + , addLocalDays + , addDiffDaysClip, addDiffDaysRollOver , addOneWeek, addWeeks - , fromMonths + , fromDays, fromMonths , weeksToAdd , setYear, getYear , firstDayOfWeekOnAfter @@ -265,18 +265,17 @@ addLocalDays n utct = localTimeToUTCTZ appTZ newLocal -- CalendarDiffDays -- ---------------------- -fromMonths :: Word -> CalendarDiffDays -fromMonths m = scaleCalendarDiffDays (toInteger m) calendarMonth --- fromMonths m = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent +fromMonths :: Integral a => a -> CalendarDiffDays +fromMonths (toInteger -> m) = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent -addDiffDays :: CalendarDiffDays -> UTCTime -> UTCTime -addDiffDays = over _utctDay . addGregorianDurationClip +fromDays :: Integral a => a -> CalendarDiffDays +fromDays (toInteger -> d) = CalendarDiffDays { cdMonths = 0, cdDays = d } -addMonths :: Word -> UTCTime -> UTCTime -addMonths = addDiffDays . fromMonths +addDiffDaysClip :: CalendarDiffDays -> UTCTime -> UTCTime +addDiffDaysClip = over _utctDay . addGregorianDurationClip -addMonthsDay :: Word -> Day -> Day -addMonthsDay = addGregorianMonthsClip . toInteger +addDiffDaysRollOver :: CalendarDiffDays -> UTCTime -> UTCTime +addDiffDaysRollOver = over _utctDay . addGregorianDurationRollOver weeksToAdd :: UTCTime -> UTCTime -> Integer -- ^ Number of weeks needed to add so that first diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index a90614a53..98c63e1ff 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -21,7 +21,7 @@ import qualified Database.Esqueleto.Utils as E import Handler.Utils.DateTime import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries) --- import qualified Data.CaseInsensitive as CI +import qualified Data.CaseInsensitive as CI dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX @@ -47,9 +47,10 @@ dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX dispatchJobLmsEnqueue qid = JobHandlerAtomic act where -- act :: YesodJobDB UniWorX () - act = do - $logInfoS "lms" $ "Notifying about exipiring qualification " <> tshow qid <> "." + act = do quali <- getJust qid -- may throw an error, aborting the job + let qshort = CI.original $ qualificationShorthand quali + $logInfoS "lms" $ "Notifying about exipiring qualification " <> qshort now <- liftIO getCurrentTime case qualificationRefreshWithin quali of Nothing -> return () -- no automatic scheduling for this qid @@ -101,95 +102,45 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act startLmsUser = E.insertUniqueEntity =<< (mkLmsUser <$> randomLMSIdent <*> randomLMSpw) inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser case inserted of - Nothing -> $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uid " <> tshow uid <> " and qid " <> tshow qid <> "!" + Nothing -> do + uuid :: CryptoUUIDUser <- encrypt uid + $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> "!" (Just _) -> return () -- lmsUser started, but not yet notified --- process all received input and renew or block qualifications +-- purge LmsIdent adter QualificationAuditDuration expired dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX -dispatchJobLmsDequeue qid = JobHandlerAtomic act - -- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart) +dispatchJobLmsDequeue qid = JobHandlerAtomic act where - act = do - $logInfoS "lms" $ "Processing e-learning results for qualification " <> tshow qid <> "." + act = do quali <- getJust qid -- may throw an error, aborting the job + let qshort = CI.original $ qualificationShorthand quali + $logInfoS "lms" $ "Processing e-learning results for qualification " <> qshort 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 + (Just auditDuration) -> do + let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now + delusersVals <- 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 + laudit <- E.from $ E.table @LmsAudit + E.where_ $ laudit E.^. LmsAuditQualification E.==. E.val qid + E.&&. laudit E.^. LmsAuditIdent E.==. luser E.^. LmsUserIdent + E.&&. laudit E.^. LmsAuditProcessed E.>=. E.val auditCutoff ) pure (luser E.^. LmsUserIdent) + let numdel = length delusers + delusers = E.unValue <$> delusersVals + when (numdel > 0) $ $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 [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 deletion - (Just auditDuration) -> - return () -- TODO - - deleteWhere [LmsUserEnded >. ] - {- do - now_day <- utctDay <$> liftIO getCurrentTime - let _renewalDate = addGregorianDurationClip renewalPeriod now_day - - -- CONTINUE HERE: TODO - -- delete users after audit period has expired!!! - - _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 - ) - 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.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success -- result already known - pure (quser, luser) - -} + deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers] + deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] -- processes received results and lengthen qualifications, if applicable @@ -226,7 +177,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1) && qualificationUserLastRefresh <= lmsUserStartedDay newStatus = LmsSuccess lmsResultSuccess - newValidTo = addGregorianMonthsRollover (toIntger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards + newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards note <- if saneDate && isLmsSuccess newStatus then do update quid [ QualificationUserValidUntil =. newValidTo diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index f5e08f55c..ad2f42e24 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -59,7 +59,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do let entRecipient = Entity jRecipient recipient qname = CI.original qualificationName - $logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname + $logInfoS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname now <- liftIO getCurrentTime letterDate <- formatTimeUser SelFormatDate now $ Just entRecipient diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 5cd94d86b..3bc7b2a64 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -31,17 +31,23 @@ deriveJSON defaultOptions -- ...also see similar type QualificationBlocked data LmsStatus = LmsBlocked { lmsStatusDay :: Day } | LmsSuccess { lmsStatusDay :: Day } - deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData) + deriving (Eq, Read, Show, Generic, Typeable, NFData) + +instance Ord LmsStatus where + compare a b + | daycmp <- compare (lmsStatusDay a) (lmsStatusDay b) + , daycmp /= EQ = daycmp + compare LmsSuccess{} LmsBlocked{} = GT + compare LmsBlocked{} LmsSuccess{} = LT + compare _ _ = EQ isLmsSuccess :: LmsStatus -> Bool 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! +-- Entscheidung 16.09.22: Es gewinnt was zuerst gemeldet wurde. Das verhindert, dass eine Qualifikation doppelt verlängert wird! Siehe Model.TypesSpec instance Semigroup LmsStatus where - a <> b | a >= b = a - | otherwise = b + a <> b = min a b -- earliest date, otherwise LmsBlocked before LmsSuccess deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor, since the object is tagged with lms already diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 8e8096c97..4830ffca3 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -620,10 +620,8 @@ spec = do showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorMissing `shouldBe` "[1.0 - D]" showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorExcused `shouldBe` "{1.0 - D}" describe "Semigroup LmsStatus" $ do - it "LmsSuccess supersedes LmsBlocked" . property $ - \p1 p2 -> (isLmsSuccess p1 || isLmsSuccess p2) == isLmsSuccess (p1 <> p2) - it "lmsStatusDay merges to latest" . property $ - \p1 p2 -> (isLmsSuccess p1 == isLmsSuccess p2) ==> lmsStatusDay (p1 <> p2) == max (lmsStatusDay p1) (lmsStatusDay p2) + it "lmsStatusDay merges to earliest" . property $ + \p1 p2 -> lmsStatusDay (p1 <> p2) == min (lmsStatusDay p1) (lmsStatusDay p2) termExample :: (TermIdentifier, Text) -> Expectation