From 726b05bbe1766aa30c4e6391d7e79789bf4ee7bb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 19 Sep 2023 16:42:20 +0200 Subject: [PATCH] chore(lms): allow full timestamps in LmsReport --- models/lms.model | 2 +- src/Handler/LMS/Report.hs | 36 ++++++++++++++++++------------------ src/Jobs/Handler/LMS.hs | 38 +++++++++++++++++++------------------- src/Model/Types/Lms.hs | 27 +++++++++++++++++++++++++++ 4 files changed, 65 insertions(+), 38 deletions(-) diff --git a/models/lms.model b/models/lms.model index efd7549a2..ea097a33c 100644 --- a/models/lms.model +++ b/models/lms.model @@ -165,7 +165,7 @@ LmsResult LmsReport qualification QualificationId OnDeleteCascade OnUpdateCascade ident LmsIdent - date Day Maybe -- BEWARE: timezone is local as submitted by LMS + date UTCTime Maybe -- BEWARE: timezone is local as submitted by LMS result LmsState -- (0|1|2) 0=LmsFailed[too many tries], 1=LmsOpen, 2=LmsPassed[success] lock Bool -- (0|1) timestamp UTCTime default=now() diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index eb3964e40..c95f13a1f 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -28,7 +28,7 @@ import Jobs.Queue data LmsReportTableCsv = LmsReportTableCsv { csvLRident :: LmsIdent - , csvLRdate :: Maybe LmsDay + , csvLRdate :: Maybe LmsTimestamp , csvLRresult :: LmsState , csvLRlock :: LmsBool } @@ -75,8 +75,8 @@ data LmsReportCsvActionClass = LmsReportInsert | LmsReportUpdate embedRenderMessage ''UniWorX ''LmsReportCsvActionClass id -- By coincidence the action type is identical to LmsReportTableCsv -data LmsReportCsvAction = LmsReportInsertData { lmsReportCsvIdent :: LmsIdent, lmsReportCsvDate :: Maybe Day, lmsReportCsvResult :: LmsState, lmsReportCsvLock :: Bool } - | LmsReportUpdateData { lmsReportCsvIdent :: LmsIdent, lmsReportCsvDate :: Maybe Day, lmsReportCsvResult :: LmsState, lmsReportCsvLock :: Bool } +data LmsReportCsvAction = LmsReportInsertData { lmsReportCsvIdent :: LmsIdent, lmsReportCsvDate :: Maybe UTCTime, lmsReportCsvResult :: LmsState, lmsReportCsvLock :: Bool } + | LmsReportUpdateData { lmsReportCsvIdent :: LmsIdent, lmsReportCsvDate :: Maybe UTCTime, lmsReportCsvResult :: LmsState, lmsReportCsvLock :: Bool } deriving (Eq, Ord, Read, Show, Generic) deriveJSON defaultOptions @@ -94,7 +94,7 @@ embedRenderMessage ''UniWorX ''LmsReportCsvException id mkReportTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkReportTable sid qsh qid = do - now_day <- utctDay <$> liftIO getCurrentTime + now <- liftIO getCurrentTime dbtCsvName <- csvFilenameLmsReport qsh let dbtCsvSheetName = dbtCsvName let @@ -107,7 +107,7 @@ mkReportTable sid qsh qid = do dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsReportIdent . _getLmsIdent -> ident) -> textCell ident - , sortable (Just csvLmsDate) (i18nCell MsgTableLmsDate) $ \(view $ _dbrOutput . _entityVal . _lmsReportDate -> d) -> cellMaybe dayCell d + , sortable (Just csvLmsDate) (i18nCell MsgTableLmsDate) $ \(view $ _dbrOutput . _entityVal . _lmsReportDate -> d) -> cellMaybe dateTimeCell d , sortable (Just csvLmsResult) (i18nCell MsgTableLmsStatus) $ \(view $ _dbrOutput . _entityVal . _lmsReportResult -> s) -> lmsStateCell s , sortable (Just csvLmsLock) (i18nCell MsgTableLmsLock) $ \(view $ _dbrOutput . _entityVal . _lmsReportLock -> b) -> ifIconCell b IconLocked , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived)$ \(view $ _dbrOutput . _entityVal . _lmsReportTimestamp -> t) -> dateTimeCell t @@ -141,7 +141,7 @@ mkReportTable sid qsh qid = do , dbtCsvExampleData = Just [ LmsReportTableCsv { csvLRident = LmsIdent lid - , csvLRdate = Just $ LmsDay $ addDays (fromIntegral $ -dos) now_day + , csvLRdate = Just $ LmsTimestamp $ addLocalDays (fromIntegral $ -dos) now , csvLRresult = toEnum $ dos `mod` succ (fromEnum (maxBound :: LmsState)) , csvLRlock = LmsBool $ even dos } @@ -151,7 +151,7 @@ mkReportTable sid qsh qid = do where doEncode' = LmsReportTableCsv <$> view (_dbrOutput . _entityVal . _lmsReportIdent) - <*> preview (_dbrOutput . _entityVal . _lmsReportDate . _Just . _lmsDay) + <*> preview (_dbrOutput . _entityVal . _lmsReportDate . _Just . _lmsTimestamp) <*> view (_dbrOutput . _entityVal . _lmsReportResult) <*> view (_dbrOutput . _entityVal . _lmsReportLock . _lmsBool) dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later @@ -161,17 +161,17 @@ mkReportTable sid qsh qid = do DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew = LmsReportTableCsv{..}} -> do yield $ LmsReportInsertData { lmsReportCsvIdent = csvLRident - , lmsReportCsvDate = csvLRdate <&> lms2day + , lmsReportCsvDate = csvLRdate <&> lms2timestamp , lmsReportCsvResult = csvLRresult , lmsReportCsvLock = csvLRlock & lms2bool } DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsReport was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code DBCsvDiffExisting{dbCsvNew = LmsReportTableCsv{..}, dbCsvOld} -> do - let resultDay = csvLRdate <&> lms2day - when (resultDay > dbCsvOld ^. _dbrOutput . _entityVal . _lmsReportDate) $ + let resultTime = csvLRdate <&> lms2timestamp + when (resultTime > dbCsvOld ^. _dbrOutput . _entityVal . _lmsReportDate) $ yield $ LmsReportUpdateData { lmsReportCsvIdent = csvLRident - , lmsReportCsvDate = resultDay + , lmsReportCsvDate = resultTime , lmsReportCsvResult = csvLRresult , lmsReportCsvLock = csvLRlock & lms2bool } @@ -185,7 +185,7 @@ mkReportTable sid qsh qid = do , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error , dbtCsvExecuteActions = do C.mapM_ $ \actionData -> do - now <- liftIO getCurrentTime + eanow <- liftIO getCurrentTime void $ upsert LmsReport { lmsReportQualification = qid @@ -193,12 +193,12 @@ mkReportTable sid qsh qid = do , lmsReportDate = lmsReportCsvDate actionData , lmsReportResult = lmsReportCsvResult actionData , lmsReportLock = lmsReportCsvLock actionData - , lmsReportTimestamp = now + , lmsReportTimestamp = eanow } [ LmsReportDate =. lmsReportCsvDate actionData , LmsReportResult =. lmsReportCsvResult actionData , LmsReportLock =. lmsReportCsvLock actionData - , LmsReportTimestamp =. now + , LmsReportTimestamp =. eanow ] -- audit $ Transaction.. (add to Audit.Types) lift . queueDBJob $ JobLmsReports qid @@ -212,7 +212,7 @@ mkReportTable sid qsh qid = do $if lmsReportCsvLock and is locked # $maybe d <- lmsReportCsvDate - on ^{formatTimeW SelFormatDate d} + on ^{formatTimeW SelFormatDateTime d} |] LmsReportUpdateData{..} -> do -- TODO: i18n [whamlet| @@ -222,7 +222,7 @@ mkReportTable sid qsh qid = do $if lmsReportCsvLock and is locked # $maybe d <- lmsReportCsvDate - on ^{formatTimeW SelFormatDate d} + on ^{formatTimeW SelFormatDateTime d} |] , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure , dbtCsvRenderException = ap getMessageRender . pure :: LmsReportCsvException -> DB Text @@ -253,12 +253,12 @@ saveReportCsv now qid i LmsReportTableCsv{..} = do LmsReport { lmsReportQualification = qid , lmsReportIdent = csvLRident - , lmsReportDate = csvLRdate <&> lms2day + , lmsReportDate = csvLRdate <&> lms2timestamp , lmsReportResult = csvLRresult , lmsReportLock = csvLRlock & lms2bool , lmsReportTimestamp = now } - [ LmsReportDate =. (csvLRdate <&> lms2day) + [ LmsReportDate =. (csvLRdate <&> lms2timestamp) , LmsReportResult =. csvLRresult , LmsReportLock =. (csvLRlock & lms2bool) , LmsReportTimestamp =. now diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index bf95b8603..e28919036 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -26,7 +26,7 @@ import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E import qualified Data.Set as Set -import qualified Data.Map as Map +-- import qualified Data.Map as Map import qualified Data.Time.Zones as TZ import Handler.Utils.DateTime @@ -281,10 +281,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. lreport E.^. LmsReportQualification E.==. E.val qid E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners E.&&. lrFltr luser lreport - return (luser, lreport) - -- group results by LmsReportDate - grpRepByDay :: [(Entity LmsUser, Entity LmsReport)] -> Map.Map (Maybe Day) ([LmsUserId],[UserId]) - grpRepByDay reps = Map.fromListWith (<>) [(lmsReportDate lreport, ([luid],[lmsUserUser luser])) | (Entity luid luser, Entity _ lreport) <- reps] + return (luser, lreport) -- A) reset status for learners that had their tries just resetted as indicated by LmsOpen E.update $ \luser -> do E.set luser [ LmsUserStatus E.=. E.nothing @@ -306,26 +303,29 @@ dispatchJobLmsReports qid = JobHandlerAtomic act in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner -- 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 - in lrepQry lrFltrBlock >>= (\toBlock -> - void $ flip Map.traverseWithKey (grpRepByDay toBlock) $ \repDay (lids,uids) -> do - ok_block <- qualificationUserBlocking qid uids False (toMidnight <$> repDay) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log - ok_status <- updateWhereCount [LmsUserQualification ==. qid, LmsUserId <-. lids] [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. (repDay <|> Just today)] - $logInfoS "LMS" $ "Report processing for " <> tshow repDay <> "(" <> tshow (length lids) <> "): " <> tshow ok_block <> " blocked, " <> tshow ok_status <> " status set to blocked for qualification " <> tshow qid -- debug, remove later - ) + procBlock (Entity luid luser, Entity _ lreport) = do + let repDay = fmap utctDay (lmsReportDate lreport) <|> Just today + 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 + in lrepQry lrFltrBlock + >>= foldMapM procBlock + >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later -- 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 - in lrepQry lrFltrSuccess >>= (\toRenew -> - void $ flip Map.traverseWithKey (grpRepByDay toRenew) $ \repDay (lids,uids) -> do - let repTime = toMidnight <$> repDay + procRenew (Entity luid luser, Entity _ lreport) = do + let repDay = fmap utctDay (lmsReportDate lreport) <|> Just today -- 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 uids repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log + -- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log -- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|]) -- END LMS WORKAROUND 2 - ok_renew <- renewValidQualificationUsers qid repTime uids -- only valid qualifications are truly renewed; transcribes to audit log - ok_status <- updateWhereCount [LmsUserQualification ==. qid, LmsUserId <-. lids] [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. (repDay <|> Just today)] - $logInfoS "LMS" $ "Report processing for " <> tshow repDay <> "(" <> tshow (length lids) <> "): " <> tshow ok_renew <> " renewed, " <> tshow ok_status <> " status set to success for qualification " <> tshow qid -- debug, remove later - ) + ok_renew <- renewValidQualificationUsers qid (lmsReportDate lreport) [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log + update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay] + return $ Sum ok_renew + in lrepQry lrFltrSuccess + >>= foldMapM procRenew + >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later -- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) E.update $ \luser -> do E.set luser [ LmsUserEnded E.=. E.justVal now ] diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index ae8ae2e3c..951b001d3 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -138,3 +138,30 @@ instance Csv.FromField LmsDay where d <- Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s <|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future return $ LmsDay d + +-- | LMS interface requires day format not compliant with iso8601; also LMS uses LOCAL TIMEZONE +newtype LmsTimestamp = LmsTimestamp { lms2timestamp :: UTCTime } + deriving (Eq, Ord, Read, Show, Generic) + +_lmsTimestamp :: Iso' UTCTime LmsTimestamp +_lmsTimestamp = iso LmsTimestamp lms2timestamp + +-- | Format for day for LMS interface +lmsTimestampFormat :: String +lmsTimestampFormat = "%d-%m-%Y %T" -- fixed in LMS interface desctiption, due defaultTimeLocale, should not use named entities like weekdays or month names + +instance Csv.ToField LmsTimestamp where + toField (LmsTimestamp d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsTimestampFormat d -- TimeLocale should not matter since format string does not use names; getTimeLocale requires MonadHandler + +instance Csv.FromField LmsTimestamp where +-- parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField +-- where parseLmsDay = Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat + parseField i = do + s <- Csv.parseField i + d <- Time.parseTimeM True Time.defaultTimeLocale lmsTimestampFormat s + <|> (toMidnight <$> Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s) + <|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future + return $ LmsTimestamp d + where + toMidnight :: Day -> UTCTime + toMidnight d = UTCTime { utctDay = d, utctDayTime = toEnum 0 }