From 2bdb85faa18529b8f381a1f54b17a4bda52adaf5 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 19 Sep 2023 18:11:06 +0200 Subject: [PATCH] chore(lms): full timestamps in LmsStatus too --- models/lms.model | 4 ++-- src/Audit/Types.hs | 6 +++--- src/Handler/LMS.hs | 4 ++-- src/Handler/LMS/Learners.hs | 4 ++-- src/Handler/LMS/Users.hs | 4 ++-- src/Handler/Qualification.hs | 6 +++--- src/Handler/Utils/LMS.hs | 20 ++++++++++---------- src/Jobs/Handler/LMS.hs | 23 ++++++++++------------- test/Database/Fill.hs | 8 ++++---- 9 files changed, 38 insertions(+), 41 deletions(-) diff --git a/models/lms.model b/models/lms.model index ea097a33c..616940762 100644 --- a/models/lms.model +++ b/models/lms.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -125,7 +125,7 @@ LmsUser datePin UTCTime default=now() -- time pin was created status LmsStatus Maybe -- Nothing=open, LmsSuccess, LmsBlocked or LmsExpired; 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 + statusDay UTCTime Maybe -- last 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 diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 39824393b..8360410a8 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -197,7 +197,7 @@ data Transaction | TransactionLmsBlocked { transactionQualification :: QualificationId , transactionLmsIdent :: LmsIdent - , transactionLmsDay :: Day + , transactionLmsDay :: UTCTime , transactionLmsUser :: UserId , transactionNote :: Maybe Text , transactionReceived :: UTCTime -- when was the csv file received? @@ -205,7 +205,7 @@ data Transaction | TransactionLmsSuccess { transactionQualification :: QualificationId , transactionLmsIdent :: LmsIdent - , transactionLmsDay :: Day + , transactionLmsDay :: UTCTime , transactionLmsUser :: UserId , transactionNote :: Maybe Text , transactionReceived :: UTCTime -- when was the csv file received? diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index dff707d1a..d85b32ec4 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -226,7 +226,7 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. , ltcBlockFrom :: Maybe UTCTime , ltcLmsIdent :: LmsIdent , ltcLmsStatus :: Maybe LmsStatus - , ltcLmsStatusDay :: Maybe Day + , ltcLmsStatusDay :: Maybe UTCTime , ltcLmsStarted :: UTCTime , ltcLmsDatePin :: UTCTime , ltcLmsReceived :: Maybe UTCTime @@ -249,7 +249,7 @@ ltcExample = LmsTableCsv , ltcBlockFrom = Nothing , ltcLmsIdent = LmsIdent "abcdefgh" , ltcLmsStatus = Just LmsSuccess - , ltcLmsStatusDay = Just $ pred compDay + , ltcLmsStatusDay = Just compTime , ltcLmsStarted = compTime , ltcLmsDatePin = compTime , ltcLmsReceived = Nothing diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 49645838d..19b5d0ca7 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Steffen Jost +-- SPDX-FileCopyrightText: 2023 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -34,7 +34,7 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only makeLenses_ ''LmsUserTableCsv -- | Mundane conversion needed for direct download without dbTable only -lmsUser2csv :: Day -> LmsUser -> LmsUserTableCsv +lmsUser2csv :: UTCTime -> LmsUser -> LmsUserTableCsv lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv { csvLUTident = lmsUserIdent , csvLUTpin = lmsUserPin diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 66a928727..389ad16f6 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -33,7 +33,7 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only makeLenses_ ''LmsUserTableCsv -- | Mundane conversion needed for direct download without dbTable only -lmsUser2csv :: Day -> LmsUser -> LmsUserTableCsv +lmsUser2csv :: UTCTime -> LmsUser -> LmsUserTableCsv lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv { csvLUTident = lmsUserIdent , csvLUTpin = lmsUserPin diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 62e0ff3bc..7abf93a93 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -160,7 +160,7 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. , qtcBlockFrom :: Maybe UTCTime , qtcScheduleRenewal:: Bool , qtcLmsStatusTxt :: Maybe Text - , qtcLmsStatusDay :: Maybe Day + , qtcLmsStatusDay :: Maybe UTCTime } deriving Generic makeLenses_ ''QualificationTableCsv @@ -177,7 +177,7 @@ qtcExample = QualificationTableCsv , qtcBlockFrom = Nothing , qtcScheduleRenewal= True , qtcLmsStatusTxt = Just "Success" - , qtcLmsStatusDay = Just compDay + , qtcLmsStatusDay = Just compTime } where compTime :: UTCTime @@ -491,7 +491,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do getStatusPlusDay = (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case lsd@(Just _) -> return lsd - Nothing -> utctDay <<$>> preview (resultLmsUser . _entityVal . _lmsUserStarted) + Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted) dbtCsvDecode = Nothing dbtExtraReps = [] diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 64328a8d3..59ef0f8c9 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -131,24 +131,24 @@ getYMTH :: MonadHandler m => m Text getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime -- -lmsDeletionDate :: Handler Day +lmsDeletionDate :: Handler UTCTime lmsDeletionDate = do LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf - addDays (fromIntegral $ negate lmsDeletionDays) . utctDay <$> liftIO getCurrentTime + addLocalDays (fromIntegral $ negate lmsDeletionDays) <$> liftIO getCurrentTime -- | Decide whether LMS platform should delete an identifier -lmsUserToDeleteExpr :: Day -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) +lmsUserToDeleteExpr :: UTCTime -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) lmsUserToDeleteExpr cutoff lmslist = E.isNothing (lmslist E.^. LmsUserEnded) 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, lmsUserStatusDay= Just lstat} = lstat < cutoff +lmsUserToDelete :: UTCTime -> LmsUser -> Bool +lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatusDay=Just lstat} = lstat < cutoff lmsUserToDelete _ _ = False -_lmsUserToDelete :: Day -> Getter LmsUser Bool +_lmsUserToDelete :: UTCTime -> Getter LmsUser Bool _lmsUserToDelete cutoff = to $ lmsUserToDelete cutoff lmsUserToResetTriesExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) @@ -260,7 +260,7 @@ lmsUserStatusWidget adminInfo luser = case luser of LmsUser{lmsUserStatus=Just lStat, lmsUserStatusDay=mbDay} -> [whamlet|$newline never $maybe aday <- mbDay - ^{formatTimeW SelFormatDate aday} + ^{formatTimeW SelFormatDateTime aday} $nothing --.--.---- \ ^{iconFixed (lmsStatusIcon lStat)} @@ -271,7 +271,7 @@ lmsUserStatusWidget adminInfo luser = case luser of LmsUser{lmsUserNotified=Just d} -> [whamlet|$newline never - ^{formatTimeW SelFormatDate d} + ^{formatTimeW SelFormatDateTime d} \ ^{iconFixed IconNotificationSent} $if adminInfo \ ^{lockIcon} @@ -280,7 +280,7 @@ lmsUserStatusWidget adminInfo luser = case luser of LmsUser{lmsUserStarted=dstart} | adminInfo -> -- E-Learning started, but not yet notified; only intended for Admins; [whamlet|$newline never - ^{formatTimeW SelFormatDate dstart} + ^{formatTimeW SelFormatDateTime dstart} \ ^{iconFixed IconPlanned} $if adminInfo \ ^{resetIcon} diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index e28919036..d309cce6a 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -184,8 +184,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act 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 - let nowaday = utctDay now + now <- liftIO getCurrentTime -- end users that expired by doing nothing expiredLearners <- E.select $ do (quser :& luser) <- E.from $ @@ -201,7 +200,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, LmsUserStatusDay E.=. E.justVal nowaday] + E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal now] 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 @@ -257,8 +256,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act -- DEBUG 2rows; remove later totalrows <- count [LmsReportQualification ==. qid] $logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid - let today = utctDay now - -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only + let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only -- DB query for LmsUserUser, provided a matching LmsReport exists luserQry luFltr repFltr = E.select $ do luser <- E.from $ E.table @LmsUser @@ -304,7 +302,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit) let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed procBlock (Entity luid luser, Entity _ lreport) = do - let repDay = fmap utctDay (lmsReportDate lreport) <|> Just today + let repDay = lmsReportDate lreport <|> Just now ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay] return $ Sum ok_block @@ -314,7 +312,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act -- D) renew qualifications for all successfull learners let lrFltrSuccess luser lreport = (E.isNothing (luser E.^. LmsUserStatus) E.||. luser E.^. LmsUserStatus E.!=. E.justVal LmsSuccess) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed -- LMS WORKAROUND 1: LmsPassed replaces any other status procRenew (Entity luid luser, Entity _ lreport) = do - let repDay = fmap utctDay (lmsReportDate lreport) <|> Just today + let repDay = lmsReportDate lreport <|> Just now -- LMS WORKAROUND 2: [supposedly fixed now] 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 -- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log @@ -412,7 +410,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act update luid [ LmsUserStatus =. Just LmsSuccess - , LmsUserStatusDay =. Just lmsResultSuccess + , LmsUserStatusDay =. Just (toMidnight lmsResultSuccess) , LmsUserReceived =. Just lmsResultTimestamp ] return Nothing @@ -424,7 +422,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act audit TransactionLmsSuccess -- always log success, since this is only transmitted once { transactionQualification = qid , transactionLmsIdent = lmsUserIdent - , transactionLmsDay = lmsResultSuccess + , transactionLmsDay = toMidnight lmsResultSuccess , transactionLmsUser = lmsUserUser , transactionNote = note , transactionReceived = lmsResultTimestamp @@ -457,8 +455,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act | otherwise -> return () -- users likely not yet started (Entity luid luser, Just (Entity _lulid lulist)) -> do - let lReceived = lmsUserlistTimestamp lulist - lmsMsgDay = utctDay lReceived + let lReceived = lmsUserlistTimestamp lulist update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available @@ -471,7 +468,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act oldStatus = lmsUserStatus luser updateStatus = isBlocked && oldStatus /= Just LmsSuccess when updateStatus $ do - update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lmsMsgDay] + update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lReceived] ok <- qualificationUserBlocking qid [lmsUserUser luser] False Nothing (Right QualificationBlockFailedELearning) True when (ok /= 1) $ do uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser @@ -479,7 +476,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act audit TransactionLmsBlocked { transactionQualification = qid , transactionLmsIdent = lmsUserIdent luser - , transactionLmsDay = lmsMsgDay + , transactionLmsDay = lReceived , transactionLmsUser = lmsUserUser luser , transactionNote = Just $ "Old status was " <> tshow oldStatus , transactionReceived = lReceived diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 1920ea43f..55beaff95 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -734,10 +734,10 @@ fillDb = do 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 Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False - 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 True False - 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 False True - 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 True True - 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 True True + 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 True False + void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True + 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 True True + 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 True True void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing Nothing now Nothing Nothing Nothing False False void . insert $ PrintJob "TestJob1" "AckTestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing