chore(lms): allow full timestamps in LmsReport
This commit is contained in:
parent
16b6b33c37
commit
726b05bbe1
@ -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()
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ]
|
||||
|
||||
@ -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 }
|
||||
|
||||
Loading…
Reference in New Issue
Block a user