From 2d62acea5eddb52ffbf2bfdde68fdfaeb2193bee Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 3 Jul 2023 16:45:16 +0000 Subject: [PATCH] refactor(lms): fix #75 by splitting lmsStatus --- models/lms.model | 3 +- src/Handler/LMS.hs | 10 ++++-- src/Handler/PrintCenter.hs | 2 +- src/Handler/Qualification.hs | 4 +-- src/Handler/Utils/LMS.hs | 11 +++--- src/Jobs/Handler/LMS.hs | 20 +++++------ src/Model/Migration/Definitions.hs | 15 ++++++-- src/Model/Types/Lms.hs | 58 +++++++----------------------- src/Model/Types/Security.hs | 6 ++-- test/Database/Fill.hs | 16 ++++----- 10 files changed, 65 insertions(+), 80 deletions(-) diff --git a/models/lms.model b/models/lms.model index b25ba00f8..ccc8d91ee 100644 --- a/models/lms.model +++ b/models/lms.model @@ -117,6 +117,7 @@ LmsUser 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 + statusDay Day Maybe -- date of status change; should be isJust iff isJust status; modelling as a separate table too bothersome, unlike qualification block started UTCTime default=now() received UTCTime Maybe -- last acknowledgement by LMS notified UTCTime Maybe -- last notified by FRADrive @@ -130,7 +131,7 @@ LmsUser -- lmsUser LmsUserId OnDeleteCascade OnUpdateCascade -- result LmsStatus -- data LmsStatus = LmsBlocked | LmsExpired | LmsSuccess -- day Day --- UniqueLmsUserStatus lmsUser +-- UniqueLmsUserStatus lmsUser -- enforcing uniqueness prohibits history -- deriving Generic -- LmsUserlist stores LMS upload for later processing only diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index a07d24e9d..db38ebded 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -213,6 +213,7 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. , ltcBlockFrom :: Maybe UTCTime , ltcLmsIdent :: LmsIdent , ltcLmsStatus :: Maybe LmsStatus + , ltcLmsStatusDay :: Maybe Day , ltcLmsStarted :: UTCTime , ltcLmsDatePin :: UTCTime , ltcLmsReceived :: Maybe UTCTime @@ -228,13 +229,14 @@ ltcExample = LmsTableCsv , ltcEmail = "m.mustermann@example.com" , ltcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" , ltcCompanyNumbers = CsvSemicolonList [27,69] - , ltcValidUntil = compDay + , ltcValidUntil = succ compDay , ltcLastRefresh = compDay - , ltcFirstHeld = compDay + , ltcFirstHeld = pred $ pred compDay , ltcBlockStatus = Nothing , ltcBlockFrom = Nothing , ltcLmsIdent = LmsIdent "abcdefgh" - , ltcLmsStatus = Nothing + , ltcLmsStatus = Just LmsSuccess + , ltcLmsStatusDay = Just $ pred compDay , ltcLmsStarted = compTime , ltcLmsDatePin = compTime , ltcLmsReceived = Nothing @@ -277,6 +279,7 @@ instance CsvColumnsExplained LmsTableCsv where , ('ltcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom) , ('ltcLmsIdent , SomeMessage MsgTableLmsIdent) , ('ltcLmsStatus , SomeMessage MsgTableLmsStatus) + , ('ltcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) , ('ltcLmsStarted , SomeMessage MsgTableLmsStarted) , ('ltcLmsDatePin , SomeMessage MsgTableLmsDatePin) , ('ltcLmsReceived , SomeMessage MsgTableLmsReceived) @@ -520,6 +523,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do <*> preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom) <*> view (resultLmsUser . _entityVal . _lmsUserIdent) <*> view (resultLmsUser . _entityVal . _lmsUserStatus) + <*> view (resultLmsUser . _entityVal . _lmsUserStatusDay) <*> view (resultLmsUser . _entityVal . _lmsUserStarted) <*> view (resultLmsUser . _entityVal . _lmsUserDatePin) <*> view (resultLmsUser . _entityVal . _lmsUserReceived) diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 90889c63d..da0a8ecdb 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -400,7 +400,7 @@ postPrintAckR ackDay numAck chksm = do now <- liftIO getCurrentTime E.updateCount $ \pj -> do let pjDay = E.day $ pj E.^. PrintJobCreated - E.set pj [ PrintJobAcknowledged E.=. E.just (E.val now) ] + E.set pj [ PrintJobAcknowledged E.=. E.justVal now ] E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged) E.&&. (pjDay E.==. E.val ackDay) -- Ex.updateCount $ do diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 0615c8fb8..095a2b027 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -489,8 +489,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $ preview (resultLmsUser . _entityVal . _lmsUserStarted) getStatusPlusDay = - (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case - Just ls -> return $ Just $ lmsStatusDay ls + (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case + lsd@(Just _) -> return lsd Nothing -> utctDay <<$>> preview (resultLmsUser . _entityVal . _lmsUserStarted) dbtCsvDecode = Nothing diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 4eeb608fe..e832af3dc 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -114,12 +114,13 @@ lmsDeletionDate = do -- | Decide whether LMS platform should delete an identifier lmsUserToDeleteExpr :: Day -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) lmsUserToDeleteExpr cutoff lmslist = E.isNothing (lmslist E.^. LmsUserEnded) - E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserStatus) - E.&&. E.explicitUnsafeCoerceSqlExprValue "timestamp" ((lmslist E.^. LmsUserStatus) E.#>>. "{day}") E.<=. E.val cutoff + E.&&. E.isJust (lmslist E.^. LmsUserStatus) + E.&&. E.isJust (lmslist E.^. LmsUserStatusDay) + E.&&. lmslist E.^. LmsUserStatusDay E.<=. E.justVal cutoff -- | Is everything since cutoff day or before? lmsUserToDelete :: Day -> LmsUser -> Bool -lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatus= Just lstat} = lmsStatusDay lstat < cutoff +lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatusDay= Just lstat} = lstat < cutoff lmsUserToDelete _ _ = False _lmsUserToDelete :: Day -> Getter LmsUser Bool @@ -194,9 +195,9 @@ lmsStatusIcon LmsExpired{} = IconExpired lmsStatusIcon _other = IconNotOK lmsUserStatusWidget :: Bool -> LmsUser -> Widget -lmsUserStatusWidget _ LmsUser{lmsUserStatus=Just lStat} = +lmsUserStatusWidget _ LmsUser{lmsUserStatus=Just lStat, lmsUserStatusDay=Just aday} = [whamlet|$newline never - ^{formatTimeW SelFormatDate (lmsStatusDay lStat)} + ^{formatTimeW SelFormatDate aday} \ ^{icon (lmsStatusIcon lStat)} |] -- previously: IconWaitingForUser for lmsUserStatus==Nothing diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 56273ca8b..d9953f15c 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -141,6 +141,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act , lmsUserResetPin = False , lmsUserDatePin = now , lmsUserStatus = Nothing + , lmsUserStatusDay = Nothing , lmsUserStarted = now , lmsUserReceived = Nothing , lmsUserNotified = Nothing @@ -183,7 +184,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.&&. E.not_ (validQualification now quser) pure (luser E.^. LmsUserId) nrExpired <- E.updateCount $ \luser -> do - E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)] + E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal nowaday] E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners) E.&&. luser E.^. LmsUserQualification E.==. E.val qid $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort @@ -211,7 +212,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act 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.&&. luser E.^. LmsUserEnded E.<. E.justVal auditCutoff E.&&. E.isJust (luser E.^. LmsUserEnded) -- E.&&. E.notExists (do -- laudit <- E.from $ E.table @LmsAudit @@ -257,10 +258,9 @@ dispatchJobLmsResults qid = JobHandlerAtomic act -- three separate DB operations per result is not so nice. All within one transaction though. let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay) - -- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway - newStatus = Just $ LmsSuccess lmsResultSuccess + -- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway -- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards - note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus + note <- if saneDate && (lmsUserStatus /= Just LmsSuccess) then do -- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning @@ -271,8 +271,9 @@ dispatchJobLmsResults qid = JobHandlerAtomic act -- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings update luid - [ LmsUserStatus =. newStatus - , LmsUserReceived =. Just lmsResultTimestamp + [ LmsUserStatus =. Just LmsSuccess + , LmsUserStatusDay =. Just lmsResultSuccess + , LmsUserReceived =. Just lmsResultTimestamp ] return Nothing else do @@ -328,10 +329,9 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act let isBlocked = lmsUserlistFailed lulist oldStatus = lmsUserStatus luser - newStatus = bool Nothing (Just $ LmsBlocked lmsMsgDay) isBlocked - updateStatus = replaceLmsStatus oldStatus newStatus + updateStatus = isBlocked && oldStatus /= Just LmsSuccess when updateStatus $ do - update luid [LmsUserStatus =. newStatus] + update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lmsMsgDay] ok <- qualificationUserBlocking qid [lmsUserUser luser] False (Right QualificationBlockFailedELearning) True when (ok /= 1) $ do uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index ee107a190..2ff047457 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -93,6 +93,7 @@ data ManualMigration | Migration20210318CrontabSubmissionRatedNotification | Migration20210608SeparateTermActive | Migration20230524QualificationUserBlock + | Migration20230703LmsUserStatus deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving anyclass (Universe, Finite) @@ -868,9 +869,9 @@ customMigrations = mapF $ \case , "from" timestamp with time zone NOT NULL , "reason" character varying NOT NULL , "blocker" bigint - , CONSTRAINT qualification_user_block_qualification_user_fkey FOREIGN KEY ("qualification_user") REFERENCES "qualification_user"(id) ON DELETE CASCADE + , CONSTRAINT qualification_user_block_qualification_user_fkey FOREIGN KEY ("qualification_user") REFERENCES "qualification_user"(id) ON DELETE CASCADE ON UPDATE CASCADE , CONSTRAINT qualification_user_block_blocker_fkey FOREIGN KEY ("blocker") REFERENCES "user"(id) - ) + ); |] let getBlocks = [queryQQ|SELECT "id", "blocked_due" FROM "qualification_user" WHERE "blocked_due" IS NOT NULL|] @@ -883,6 +884,16 @@ customMigrations = mapF $ \case ALTER TABLE "qualification_user" DROP COLUMN "blocked_due"; |] + Migration20230703LmsUserStatus -> + unlessM (columnExists "lms_user" "status_day") $ do + [executeQQ| + ALTER TABLE "lms_user" ADD COLUMN "status_day" date; + UPDATE "lms_user" + SET "status_day" = CAST("status"->>'day' AS date) + , "status" = "status"->'lms-status' + ; + |] + tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists table = do diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 8d7d3a804..f8d728b3c 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -34,57 +34,25 @@ deriveJSON defaultOptions -- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS? -- ...also see similar type QualificationBlocked -data LmsStatus = LmsBlocked { lmsStatusDay :: Day } - | LmsExpired { lmsStatusDay :: Day } - | LmsSuccess { lmsStatusDay :: Day } - deriving (Eq, Read, Show, Generic, NFData) - -instance Ord LmsStatus where - compare a b - | daycmp <- compare (lmsStatusDay a) (lmsStatusDay b) - , daycmp /= EQ = daycmp - compare LmsSuccess{} LmsBlocked{} = GT - compare LmsSuccess{} LmsExpired{} = GT - compare LmsBlocked{} LmsSuccess{} = LT - compare LmsExpired{} LmsSuccess{} = LT - compare LmsBlocked{} LmsExpired{} = GT - compare LmsExpired{} LmsBlocked{} = LT - compare _ _ = EQ - -isLmsSuccess :: LmsStatus -> Bool -isLmsSuccess LmsSuccess{} = True -isLmsSuccess _other = False - -isLmsExpired :: LmsStatus -> Bool -isLmsExpired LmsExpired{} = True -isLmsExpired _other = False - --- | What to do if LMS sends multiple responses and whether an oldStatus should be overwritten -replaceLmsStatus :: Maybe LmsStatus -> Maybe LmsStatus -> Bool -replaceLmsStatus _ Nothing = False -replaceLmsStatus Nothing _ = True -replaceLmsStatus (Just LmsSuccess{}) _ = False -replaceLmsStatus (Just LmsExpired{}) (Just newStat) = not $ isLmsExpired newStat -replaceLmsStatus (Just LmsBlocked{}) (Just newStat) = isLmsSuccess newStat - -makeLenses_ ''LmsStatus - --- 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 = min a b -- earliest date, otherwise LmsBlocked before LmsSuccess +data LmsStatus = LmsExpired + | LmsBlocked + | LmsSuccess + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData) + deriving anyclass (Universe, Finite) deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor, since the object is tagged with lms already - , fieldLabelModifier = camelToPathPiece' 2 -- just day suffices for the day field - , omitNothingFields = True - , sumEncoding = TaggedObject "lms-status" "lms-result" + { constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor + , fieldLabelModifier = camelToPathPiece' 1 + , sumEncoding = UntaggedValue } ''LmsStatus derivePersistFieldJSON ''LmsStatus +nullaryPathPiece ''LmsStatus $ camelToPathPiece' 1 + instance Csv.ToField LmsStatus where - toField (LmsBlocked d) = "Failure: " <> Csv.toField d - toField (LmsExpired d) = "Expired: " <> Csv.toField d - toField (LmsSuccess d) = "Success: " <> Csv.toField d + toField = Csv.toField . toPathPiece + + -- | Default Block/Unblock reasons data QualificationBlockStandardReason diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index dbea81892..cb73195b2 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -63,9 +63,9 @@ instance Hashable AuthenticationMode instance NFData AuthenticationMode deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , sumEncoding = UntaggedValue + { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 + , sumEncoding = UntaggedValue } ''AuthenticationMode derivePersistFieldJSON ''AuthenticationMode diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index d668e63ad..03c7ee385 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -731,12 +731,12 @@ fillDb = do void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now - void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) - void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing - void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing - void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-22)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing - void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing - void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing now Nothing Nothing Nothing + void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) + void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing + void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just LmsBlocked) (Just $ utctDay now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing + void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just LmsSuccess) (Just $ n_day (-22)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing + void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just LmsBlocked) (Just $ n_day (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing + void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing Nothing now Nothing Nothing Nothing void . insert $ PrintJob "TestJob1" "AckTestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing void . insert $ PrintJob "TestJob2" "AckTestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing (Just qid_f) (Just $ LmsIdent "ijk") @@ -1100,7 +1100,7 @@ fillDb = do , exceptEnd = TimeOfDay 16 20 0 } , ExceptOccur - { exceptDay = succ $ succ $ secondDay + { exceptDay = succ $ succ secondDay , exceptStart = TimeOfDay 10 12 0 , exceptEnd = TimeOfDay 12 13 0 } @@ -1112,7 +1112,7 @@ fillDb = do , tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , tutorialLastChanged = now , tutorialTutorControlled = True - , tutorialFirstDay = Just $ succ $ succ $ firstDay + , tutorialFirstDay = Just $ succ $ succ firstDay } when (odd tyear) $ void . insert' $ Exam