fraport/fradrive-old
Archived
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 -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -125,7 +125,7 @@ LmsUser
datePin UTCTime default=now() -- time pin was created 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 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 --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() started UTCTime default=now()
received UTCTime Maybe -- last acknowledgement by LMS received UTCTime Maybe -- last acknowledgement by LMS
notified UTCTime Maybe -- last notified by FRADrive 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 -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -197,7 +197,7 @@ data Transaction
| TransactionLmsBlocked | TransactionLmsBlocked
{ transactionQualification :: QualificationId { transactionQualification :: QualificationId
, transactionLmsIdent :: LmsIdent , transactionLmsIdent :: LmsIdent
, transactionLmsDay :: Day , transactionLmsDay :: UTCTime
, transactionLmsUser :: UserId , transactionLmsUser :: UserId
, transactionNote :: Maybe Text , transactionNote :: Maybe Text
, transactionReceived :: UTCTime -- when was the csv file received? , transactionReceived :: UTCTime -- when was the csv file received?
@ -205,7 +205,7 @@ data Transaction
| TransactionLmsSuccess | TransactionLmsSuccess
{ transactionQualification :: QualificationId { transactionQualification :: QualificationId
, transactionLmsIdent :: LmsIdent , transactionLmsIdent :: LmsIdent
, transactionLmsDay :: Day , transactionLmsDay :: UTCTime
, transactionLmsUser :: UserId , transactionLmsUser :: UserId
, transactionNote :: Maybe Text , transactionNote :: Maybe Text
, transactionReceived :: UTCTime -- when was the csv file received? , 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 , ltcBlockFrom :: Maybe UTCTime
, ltcLmsIdent :: LmsIdent , ltcLmsIdent :: LmsIdent
, ltcLmsStatus :: Maybe LmsStatus , ltcLmsStatus :: Maybe LmsStatus
, ltcLmsStatusDay :: Maybe Day , ltcLmsStatusDay :: Maybe UTCTime
, ltcLmsStarted :: UTCTime , ltcLmsStarted :: UTCTime
, ltcLmsDatePin :: UTCTime , ltcLmsDatePin :: UTCTime
, ltcLmsReceived :: Maybe UTCTime , ltcLmsReceived :: Maybe UTCTime
@ -249,7 +249,7 @@ ltcExample = LmsTableCsv
, ltcBlockFrom = Nothing , ltcBlockFrom = Nothing
, ltcLmsIdent = LmsIdent "abcdefgh" , ltcLmsIdent = LmsIdent "abcdefgh"
, ltcLmsStatus = Just LmsSuccess , ltcLmsStatus = Just LmsSuccess
, ltcLmsStatusDay = Just $ pred compDay , ltcLmsStatusDay = Just compTime
, ltcLmsStarted = compTime , ltcLmsStarted = compTime
, ltcLmsDatePin = compTime , ltcLmsDatePin = compTime
, ltcLmsReceived = Nothing , 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 -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -34,7 +34,7 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
makeLenses_ ''LmsUserTableCsv makeLenses_ ''LmsUserTableCsv
-- | Mundane conversion needed for direct download without dbTable only -- | Mundane conversion needed for direct download without dbTable only
lmsUser2csv :: Day -> LmsUser -> LmsUserTableCsv lmsUser2csv :: UTCTime -> LmsUser -> LmsUserTableCsv
lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv
{ csvLUTident = lmsUserIdent { csvLUTident = lmsUserIdent
, csvLUTpin = lmsUserPin , 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 -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -33,7 +33,7 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
makeLenses_ ''LmsUserTableCsv makeLenses_ ''LmsUserTableCsv
-- | Mundane conversion needed for direct download without dbTable only -- | Mundane conversion needed for direct download without dbTable only
lmsUser2csv :: Day -> LmsUser -> LmsUserTableCsv lmsUser2csv :: UTCTime -> LmsUser -> LmsUserTableCsv
lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv
{ csvLUTident = lmsUserIdent { csvLUTident = lmsUserIdent
, csvLUTpin = lmsUserPin , csvLUTpin = lmsUserPin

6
src/Handler/Qualification.hs
View File

@ -160,7 +160,7 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
, qtcBlockFrom :: Maybe UTCTime , qtcBlockFrom :: Maybe UTCTime
, qtcScheduleRenewal:: Bool , qtcScheduleRenewal:: Bool
, qtcLmsStatusTxt :: Maybe Text , qtcLmsStatusTxt :: Maybe Text
, qtcLmsStatusDay :: Maybe Day , qtcLmsStatusDay :: Maybe UTCTime
} }
deriving Generic deriving Generic
makeLenses_ ''QualificationTableCsv makeLenses_ ''QualificationTableCsv
@ -177,7 +177,7 @@ qtcExample = QualificationTableCsv
, qtcBlockFrom = Nothing , qtcBlockFrom = Nothing
, qtcScheduleRenewal= True , qtcScheduleRenewal= True
, qtcLmsStatusTxt = Just "Success" , qtcLmsStatusTxt = Just "Success"
, qtcLmsStatusDay = Just compDay , qtcLmsStatusDay = Just compTime
} }
where where
compTime :: UTCTime compTime :: UTCTime
@ -491,7 +491,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
getStatusPlusDay = getStatusPlusDay =
(join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case
lsd@(Just _) -> return lsd lsd@(Just _) -> return lsd
Nothing -> utctDay <<$>> preview (resultLmsUser . _entityVal . _lmsUserStarted) Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted)
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
dbtExtraReps = [] 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 -- 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 getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
-- --
lmsDeletionDate :: Handler Day lmsDeletionDate :: Handler UTCTime
lmsDeletionDate = do lmsDeletionDate = do
LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf 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 -- | 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) lmsUserToDeleteExpr cutoff lmslist = E.isNothing (lmslist E.^. LmsUserEnded)
E.&&. E.isJust (lmslist E.^. LmsUserStatus) E.&&. E.isJust (lmslist E.^. LmsUserStatus)
E.&&. E.isJust (lmslist E.^. LmsUserStatusDay) E.&&. E.isJust (lmslist E.^. LmsUserStatusDay)
E.&&. lmslist E.^. LmsUserStatusDay E.<=. E.justVal cutoff E.&&. lmslist E.^. LmsUserStatusDay E.<=. E.justVal cutoff
-- | Is everything since cutoff day or before? -- | Is everything since cutoff day or before?
lmsUserToDelete :: Day -> LmsUser -> Bool lmsUserToDelete :: UTCTime -> LmsUser -> Bool
lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatusDay= Just lstat} = lstat < cutoff lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatusDay=Just lstat} = lstat < cutoff
lmsUserToDelete _ _ = False lmsUserToDelete _ _ = False
_lmsUserToDelete :: Day -> Getter LmsUser Bool _lmsUserToDelete :: UTCTime -> Getter LmsUser Bool
_lmsUserToDelete cutoff = to $ lmsUserToDelete cutoff _lmsUserToDelete cutoff = to $ lmsUserToDelete cutoff
lmsUserToResetTriesExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) 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} -> LmsUser{lmsUserStatus=Just lStat, lmsUserStatusDay=mbDay} ->
[whamlet|$newline never [whamlet|$newline never
$maybe aday <- mbDay $maybe aday <- mbDay
^{formatTimeW SelFormatDate aday} ^{formatTimeW SelFormatDateTime aday}
$nothing $nothing
--.--.---- --.--.----
\ ^{iconFixed (lmsStatusIcon lStat)} \ ^{iconFixed (lmsStatusIcon lStat)}
@ -271,7 +271,7 @@ lmsUserStatusWidget adminInfo luser = case luser of
LmsUser{lmsUserNotified=Just d} -> LmsUser{lmsUserNotified=Just d} ->
[whamlet|$newline never [whamlet|$newline never
^{formatTimeW SelFormatDate d} ^{formatTimeW SelFormatDateTime d}
\ ^{iconFixed IconNotificationSent} \ ^{iconFixed IconNotificationSent}
$if adminInfo $if adminInfo
\ ^{lockIcon} \ ^{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; LmsUser{lmsUserStarted=dstart} | adminInfo -> -- E-Learning started, but not yet notified; only intended for Admins;
[whamlet|$newline never [whamlet|$newline never
^{formatTimeW SelFormatDate dstart} ^{formatTimeW SelFormatDateTime dstart}
\ ^{iconFixed IconPlanned} \ ^{iconFixed IconPlanned}
$if adminInfo $if adminInfo
\ ^{resetIcon} \ ^{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 quali <- getJust qid -- may throw an error, aborting the job
let qshort = CI.original $ qualificationShorthand quali let qshort = CI.original $ qualificationShorthand quali
$logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort $logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let nowaday = utctDay now
-- end users that expired by doing nothing -- end users that expired by doing nothing
expiredLearners <- E.select $ do expiredLearners <- E.select $ do
(quser :& luser) <- E.from $ (quser :& luser) <- E.from $
@ -201,7 +200,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
E.&&. E.not_ (validQualification now quser) E.&&. E.not_ (validQualification now quser)
pure (luser E.^. LmsUserId) pure (luser E.^. LmsUserId)
nrExpired <- E.updateCount $ \luser -> do 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.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners)
E.&&. luser E.^. LmsUserQualification E.==. E.val qid E.&&. luser E.^. LmsUserQualification E.==. E.val qid
$logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
@ -257,8 +256,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
-- DEBUG 2rows; remove later -- DEBUG 2rows; remove later
totalrows <- count [LmsReportQualification ==. qid] totalrows <- count [LmsReportQualification ==. qid]
$logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid $logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid
let today = utctDay now let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only
-- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only
-- DB query for LmsUserUser, provided a matching LmsReport exists -- DB query for LmsUserUser, provided a matching LmsReport exists
luserQry luFltr repFltr = E.select $ do luserQry luFltr repFltr = E.select $ do
luser <- E.from $ E.table @LmsUser 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) -- 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 let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed
procBlock (Entity luid luser, Entity _ lreport) = do 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 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] update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay]
return $ Sum ok_block return $ Sum ok_block
@ -314,7 +312,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
-- D) renew qualifications for all successfull learners -- 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 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 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 -- 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 -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
-- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log -- 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 update luid
[ LmsUserStatus =. Just LmsSuccess [ LmsUserStatus =. Just LmsSuccess
, LmsUserStatusDay =. Just lmsResultSuccess , LmsUserStatusDay =. Just (toMidnight lmsResultSuccess)
, LmsUserReceived =. Just lmsResultTimestamp , LmsUserReceived =. Just lmsResultTimestamp
] ]
return Nothing return Nothing
@ -424,7 +422,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
audit TransactionLmsSuccess -- always log success, since this is only transmitted once audit TransactionLmsSuccess -- always log success, since this is only transmitted once
{ transactionQualification = qid { transactionQualification = qid
, transactionLmsIdent = lmsUserIdent , transactionLmsIdent = lmsUserIdent
, transactionLmsDay = lmsResultSuccess , transactionLmsDay = toMidnight lmsResultSuccess
, transactionLmsUser = lmsUserUser , transactionLmsUser = lmsUserUser
, transactionNote = note , transactionNote = note
, transactionReceived = lmsResultTimestamp , transactionReceived = lmsResultTimestamp
@ -457,8 +455,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
| otherwise -> return () -- users likely not yet started | otherwise -> return () -- users likely not yet started
(Entity luid luser, Just (Entity _lulid lulist)) -> do (Entity luid luser, Just (Entity _lulid lulist)) -> do
let lReceived = lmsUserlistTimestamp lulist let lReceived = lmsUserlistTimestamp lulist
lmsMsgDay = utctDay lReceived
update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications
when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
@ -471,7 +468,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
oldStatus = lmsUserStatus luser oldStatus = lmsUserStatus luser
updateStatus = isBlocked && oldStatus /= Just LmsSuccess updateStatus = isBlocked && oldStatus /= Just LmsSuccess
when updateStatus $ do 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 ok <- qualificationUserBlocking qid [lmsUserUser luser] False Nothing (Right QualificationBlockFailedELearning) True
when (ok /= 1) $ do when (ok /= 1) $ do
uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser
@ -479,7 +476,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
audit TransactionLmsBlocked audit TransactionLmsBlocked
{ transactionQualification = qid { transactionQualification = qid
, transactionLmsIdent = lmsUserIdent luser , transactionLmsIdent = lmsUserIdent luser
, transactionLmsDay = lmsMsgDay , transactionLmsDay = lReceived
, transactionLmsUser = lmsUserUser luser , transactionLmsUser = lmsUserUser luser
, transactionNote = Just $ "Old status was " <> tshow oldStatus , transactionNote = Just $ "Old status was " <> tshow oldStatus
, transactionReceived = lReceived , 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 "abcdefg") True now
void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False 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 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 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 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 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 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' $ 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 void . insert $ PrintJob "TestJob1" "AckTestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing