fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(lms): full timestamps in LmsStatus too

Browse Source
This commit is contained in:
Steffen Jost 2023-09-19 18:11:06 +02:00 committed by Steffen Jost
parent 726b05bbe1
commit 2bdb85faa1
9 changed files with 38 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
models/lms.model
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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

6
src/Audit/Types.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,,Steffen Jost <s.jost@fraport.de>
--
-- 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?

4
src/Handler/LMS.hs
View File

@ -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

4
src/Handler/LMS/Learners.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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

4
src/Handler/LMS/Users.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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

6
src/Handler/Qualification.hs
View File

@ -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 = []

20
src/Handler/Utils/LMS.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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}

23
src/Jobs/Handler/LMS.hs
View File

@ -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

8
test/Database/Fill.hs
View File

@ -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