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

chore(lms): WIP V2 Report pages done, job and lms-main page to do

Browse Source
This commit is contained in:
Steffen Jost 2023-07-21 15:47:57 +00:00
parent b84577984a
commit 20b3a39bc3
8 changed files with 127 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -49,6 +49,7 @@ TableLmsElearning: E‑Learning
TableLmsPin: E‑Learning Passwort TableLmsPin: E‑Learning Passwort
TableLmsResetPin: E-Learning Passwort zurücksetzen? TableLmsResetPin: E-Learning Passwort zurücksetzen?
TableLmsDatePin: E-Learning Passwort erstellt TableLmsDatePin: E-Learning Passwort erstellt
TableLmsDate: Datum
TableLmsDelete: Löschen? TableLmsDelete: Löschen?
TableLmsStaff: Interner Mitarbeiter? TableLmsStaff: Interner Mitarbeiter?
TableLmsStarted: Begonnen TableLmsStarted: Begonnen
@ -76,15 +77,20 @@ CsvColumnLmsPin: Passwort E#{nonBreakableDash}Learning Zugang
CsvColumnLmsResetPin: Wird das E-Learning Passwort bei der nächsten Synchronisation zurückgesetzt? CsvColumnLmsResetPin: Wird das E-Learning Passwort bei der nächsten Synchronisation zurückgesetzt?
CsvColumnLmsDelete: Wird der Identifikator in der E‑Learning Plattform bei der nächsten Synchronisation gelöscht? CsvColumnLmsDelete: Wird der Identifikator in der E‑Learning Plattform bei der nächsten Synchronisation gelöscht?
CsvColumnLmsStaff: Handelt es sich um einen internen Mitarbeiter? (Aus historischen Gründen, wird momentan ignoriert.) CsvColumnLmsStaff: Handelt es sich um einen internen Mitarbeiter? (Aus historischen Gründen, wird momentan ignoriert.)
CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme (UTC) CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme
CsvColumnLmsDate: Datum des E‑Learning Ereignisses
CsvColumnLmsResetTries: Anzahl der bisher verbrauchten E‑Learning Prüfungsversuche zurücksetzen CsvColumnLmsResetTries: Anzahl der bisher verbrauchten E‑Learning Prüfungsversuche zurücksetzen
CsvColumnLmsLock: E‑Learning Login gesperrt CsvColumnLmsLock: E‑Learning Login gesperrt
CsvColumnLmsResult !ident-ok: LMS Status
LmsUserlistInsert: Neuer LMS User LmsUserlistInsert: Neuer LMS User
LmsUserlistUpdate: LMS User aktualisierung LmsUserlistUpdate: LMS User Aktualisierung
LmsResultInsert: Neues LMS Ergebnis LmsResultInsert: Neues LMS Ergebnis
LmsResultUpdate: LMS Ergebnis aktualisierung LmsResultUpdate: LMS Ergebnis Aktualisierung
LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel LmsReportInsert: Neues LMS Ereignis
LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel LmsReportUpdate: LMS Ereignis Aktualisierung
LmsResultCsvExceptionDuplicatedKey: CSV-Import LmsResult fand uneindeutigen Schlüssel
LmsUserlistCsvExceptionDuplicatedKey: CSV-Import LmsUserlist fand uneindeutigen Schlüssel
LmsReportCsvExceptionDuplicatedKey: CSV-Import LmsReport fand uneindeutigen Schlüssel
LmsDirectUpload: Direkter Upload für automatisierte Systeme LmsDirectUpload: Direkter Upload für automatisierte Systeme
LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde. LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde.
MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden

12
messages/uniworx/categories/qualification/en-eu.msg
View File

@ -49,6 +49,7 @@ TableLmsPin: E‑learning password
TableLmsElearning: E‑learning TableLmsElearning: E‑learning
TableLmsResetPin: Reset E‑learning password? TableLmsResetPin: Reset E‑learning password?
TableLmsDatePin: E‑learning password created TableLmsDatePin: E‑learning password created
TableLmsDate: Date
TableLmsDelete: Delete? TableLmsDelete: Delete?
TableLmsStaff: Staff? TableLmsStaff: Staff?
TableLmsStarted: Started TableLmsStarted: Started
@ -74,17 +75,22 @@ FilterLmsNotificationDue: Notification due
CsvColumnLmsIdent: E#{nonBreakableDash}learning identifier, unique for each qualification and user CsvColumnLmsIdent: E#{nonBreakableDash}learning identifier, unique for each qualification and user
CsvColumnLmsPin: Password e#{nonBreakableDash}learning access CsvColumnLmsPin: Password e#{nonBreakableDash}learning access
CsvColumnLmsResetPin: Will the e#{nonBreakableDash}learning password be reset upon next synchronisation? CsvColumnLmsResetPin: Will the e#{nonBreakableDash}learning password be reset upon next synchronisation?
CsvColumnLmsDelete: Will the identifier be deleted from the E‑learning platfrom upon next synchronisation? CsvColumnLmsDelete: Will the identifier be deleted from the e‑learning platfrom upon next synchronisation?
CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored) CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored)
CsvColumnLmsSuccess: Timestamp of successful completion (UTC) CsvColumnLmsSuccess: Timestamp of successful completion (UTC)
CsvColumnLmsResetTries: Reset number of used up e‑learning exam attempts CsvColumnLmsResetTries: Reset number of used up e‑learning exam attempts
CsvColumnLmsDate: Date of e‑learning event
CsvColumnLmsResult: LMS Status
CsvColumnLmsLock: E‑learning login is not permitted CsvColumnLmsLock: E‑learning login is not permitted
LmsUserlistInsert: New LMS user LmsUserlistInsert: New LMS user
LmsUserlistUpdate: Update of LMS user LmsUserlistUpdate: Update of LMS user
LmsResultInsert: New LMS result LmsResultInsert: New LMS result
LmsResultUpdate: Update of LMS result LmsResultUpdate: Update of LMS result
LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key LmsReportInsert: New LMS event
LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key LmsReportUpdate: Update of LMS event
LmsResultCsvExceptionDuplicatedKey: CSV import LmsResult with ambiguous key
LmsUserlistCsvExceptionDuplicatedKey: CSV import LmsUserlist with ambiguous key
LmsReportCsvExceptionDuplicatedKey: CSV Import LmsReport with ambiguous key
LmsDirectUpload: Direct upload for automated systems LmsDirectUpload: Direct upload for automated systems
LmsErrorNoRefreshElearning: Error: E‑learning will not be started automatically due to refresh-within time period not being set. LmsErrorNoRefreshElearning: Error: E‑learning will not be started automatically due to refresh-within time period not being set.
MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly

8
models/lms.model
View File

@ -113,7 +113,7 @@ LmsUser
user UserId OnDeleteCascade OnUpdateCascade user UserId OnDeleteCascade OnUpdateCascade
ident LmsIdent -- must be unique accross all LMS courses! ident LmsIdent -- must be unique accross all LMS courses!
pin Text pin Text
resetPin Bool default=false -- should pin be reset? resetPin Bool default=false -- should pin be reset?
datePin UTCTime default=now() -- time pin was created datePin UTCTime default=now() -- time pin was created
status LmsStatus Maybe -- open, success or failure; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS status LmsStatus Maybe -- open, success or failure; 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
@ -122,7 +122,9 @@ LmsUser
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
ended UTCTime Maybe -- ident was deleted from LMS ended UTCTime Maybe -- ident was deleted from LMS
-- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this? resetTries Bool default=false -- V2 should e-learning exam tries be reset?
locked Bool default=false -- V2 last returned lock status
-- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this? No.
UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS! UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS!
UniqueLmsQualificationUser qualification user -- each user may be enrolled at most once per course UniqueLmsQualificationUser qualification user -- each user may be enrolled at most once per course
deriving Generic deriving Generic
@ -156,7 +158,7 @@ LmsReport
qualification QualificationId OnDeleteCascade OnUpdateCascade qualification QualificationId OnDeleteCascade OnUpdateCascade
ident LmsIdent ident LmsIdent
date Day Maybe -- BEWARE: timezone is local as submitted by LMS date Day Maybe -- BEWARE: timezone is local as submitted by LMS
result Int -- (0|1|2) 0=too many ties, 1=open, 2=success result LmsState -- (0|1|2) 0=too many ties, 1=open, 2=success
lock Bool -- (0|1) lock Bool -- (0|1)
timestamp UTCTime default=now() timestamp UTCTime default=now()
UniqueLmsReport qualification ident -- required by DBTable UniqueLmsReport qualification ident -- required by DBTable

102
src/Handler/LMS/Report.hs
View File

@ -70,6 +70,20 @@ instance CsvColumnsExplained LmsReportTableCsv where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
single k v = singletonMap k [whamlet|_{v}|] single k v = singletonMap k [whamlet|_{v}|]
data LmsReportCsvActionClass = LmsReportInsert | LmsReportUpdate
deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded)
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 }
deriving (Eq, Ord, Read, Show, Generic)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece'' 2 1 -- LmsReportInsertData -> insert
, fieldLabelModifier = camelToPathPiece' 2 -- lmsReportCsvIdent -> csv-ident
, sumEncoding = TaggedObject "action" "data"
} ''LmsReportCsvAction
data LmsReportCsvException data LmsReportCsvException
= LmsReportCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! = LmsReportCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
@ -95,8 +109,8 @@ mkReportTable sid qsh qid = do
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsReportIdent . _getLmsIdent -> ident) -> textCell ident [ 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 dayCell d
, sortable (Just csvLmsResult) (i18nCell MsgTableLmsStatus) $ \(view $ _dbrOutput . _entityVal . _lmsReportResult -> s) -> lmsStateCell s , sortable (Just csvLmsResult) (i18nCell MsgTableLmsStatus) $ \(view $ _dbrOutput . _entityVal . _lmsReportResult -> s) -> lmsStateCell s
, sortable (Just csvLmsLock) (i18nCell MsgTableLmsLock) $ \(view $ _dbrOutput . _entityVal . _lmsReportLock . _lmsBool -> b) -> ifIconCell b IconLocked , sortable (Just csvLmsLock) (i18nCell MsgTableLmsLock) $ \(view $ _dbrOutput . _entityVal . _lmsReportLock -> b) -> ifIconCell b IconLocked
, sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived)$ \(view $ _dbrOutput . _entityVal . _lmsReportTimestamp -> t) -> dateTimeCell timestamp , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived)$ \(view $ _dbrOutput . _entityVal . _lmsReportTimestamp -> t) -> dateTimeCell t
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ (csvLmsIdent , SortColumn (E.^. LmsReportIdent)) [ (csvLmsIdent , SortColumn (E.^. LmsReportIdent))
@ -128,7 +142,7 @@ mkReportTable sid qsh qid = do
[ LmsReportTableCsv [ LmsReportTableCsv
{ csvLRident = LmsIdent lid { csvLRident = LmsIdent lid
, csvLRdate = LmsDay $ addDays (-dos) now_day , csvLRdate = LmsDay $ addDays (-dos) now_day
, csvLRresult = LmsState $ toEnum $ dos `mod` succ (fromEnum (maxBound :: LmsState)) , csvLRresult = toEnum $ dos `mod` succ (fromEnum (maxBound :: LmsState))
, csvLRlock = LmsBool $ even dos , csvLRlock = LmsBool $ even dos
} }
| (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch", "x2!y3-z4"] [1..] | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch", "x2!y3-z4"] [1..]
@ -136,26 +150,30 @@ mkReportTable sid qsh qid = do
} }
where where
doEncode' = LmsReportTableCsv doEncode' = LmsReportTableCsv
<$> view (_dbrOutput . _entityVal . _lmsReportIdent) <$> view (_dbrOutput . _entityVal . _lmsReportIdent)
<*> view (_dbrOutput . _entityVal . _lmsReportDate . _lmsDay) <*> preview (_dbrOutput . _entityVal . _lmsReportDate . _Just . _lmsDay)
<*> view (_dbrOutput . _entityVal . _lmsReportResult . enum) <*> view (_dbrOutput . _entityVal . _lmsReportResult)
<*> view (_dbrOutput . _entityVal . _lmsReportLock . _lmsBool) <*> view (_dbrOutput . _entityVal . _lmsReportLock . _lmsBool)
dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
{ dbtCsvRowKey = \LmsReportTableCsv{..} -> { dbtCsvRowKey = \LmsReportTableCsv{..} ->
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsReport qid csvLRTident fmap E.Value . MaybeT . getKeyBy $ UniqueLmsReport qid csvLRident
, dbtCsvComputeActions = \case -- purpose is to show a diff to the user first , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew = LmsReportTableCsv{..}} -> do
yield $ LmsReportInsertData yield $ LmsReportInsertData
{ lmsReportInsertIdent = csvLRTident dbCsvNew { lmsReportCsvIdent = csvLRident
, lmsReportInsertSuccess = csvLRTsuccess dbCsvNew & lms2day , lmsReportCsvDate = csvLRdate <&> lms2day
} , lmsReportCsvResult = csvLRresult
, lmsReportCsvLock = csvLRlock
}
DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsReport was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code 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 DBCsvDiffExisting{dbCsvNew = LmsReportTableCsv{..}, dbCsvOld} -> do
let successDay = lms2day csvLRTsuccess let resultDay = csvLRdate <&> lms2day
when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsReportSuccess) $ when (resultDay > dbCsvOld ^. _dbrOutput . _entityVal . _lmsReportDate) $
yield $ LmsReportUpdateData yield $ LmsReportUpdateData
{ lmsReportInsertIdent = csvLRTident { lmsReportCsvIdent = csvLRident
, lmsReportInsertSuccess = successDay , lmsReportCsvDate = resultDay
, lmsReportCsvResult = csvLRresult
, lmsReportCsvLock = csvLRlock
} }
DBCsvDiffMissing{} -> return () -- no deletion DBCsvDiffMissing{} -> return () -- no deletion
, dbtCsvClassifyAction = \case , dbtCsvClassifyAction = \case
@ -171,37 +189,49 @@ mkReportTable sid qsh qid = do
void $ upsert void $ upsert
LmsReport LmsReport
{ lmsReportQualification = qid { lmsReportQualification = qid
, lmsReportIdent = lmsReportInsertIdent actionData , lmsReportIdent = lmsReportCsvIdent actionData
, lmsReportSuccess = lmsReportInsertSuccess actionData , lmsReportDate = lmsReportCsvDate actionData
, lmsReportTimestamp = now -- lmsReportInsertTimestamp -- does it matter which one to choose? , lmsReportResult = lmsReportCsvResult actionData
, lmsReportLock = lmsReportCsvLock actionData
, lmsReportTimestamp = now
} }
[ LmsReportSuccess =. lmsReportInsertSuccess actionData [ LmsReportDate =. lmsReportCsvDate actionData
, LmsReportResult =. lmsReportCsvResult actionData
, LmsReportLock =. lmsReportCsvLock actionData
, LmsReportTimestamp =. now , LmsReportTimestamp =. now
] ]
-- audit $ Transaction.. (add to Audit.Types) -- audit $ Transaction.. (add to Audit.Types)
lift . queueDBJob $ JobLmsReports qid lift . queueDBJob $ JobLmsReports qid -- TODO: V2
return $ LmsReportR sid qsh return $ LmsReportR sid qsh
, dbtCsvRenderKey = const $ \case , dbtCsvRenderKey = const $ \case
LmsReportInsertData{..} -> do -- TODO: i18n LmsReportInsertData{..} -> do -- TODO: i18n
[whamlet| [whamlet|
$newline never $newline never
Insert: Ident #{getLmsIdent lmsReportInsertIdent} # Insert: Ident #{getLmsIdent lmsReportCsvIdent} #
had success on ^{formatTimeW SelFormatDate lmsReportInsertSuccess} has status #{show lmsReportCsvResult} #
$if lmsReportCsvLock
and is locked #
$maybe d <- lmsReportCsvDate
on ^{formatTimeW SelFormatDate d}
|] |]
LmsReportUpdateData{..} -> do -- TODO: i18n LmsReportUpdateData{..} -> do -- TODO: i18n
[whamlet| [whamlet|
$newline never $newline never
Update: Ident #{getLmsIdent lmsReportInsertIdent} # Update: Ident #{getLmsIdent lmsReportCsvIdent} #
had success on ^{formatTimeW SelFormatDate lmsReportInsertSuccess} has status #{show lmsReportCsvResult} #
$if lmsReportCsvLock
and is locked #
$maybe d <- lmsReportCsvDate
on ^{formatTimeW SelFormatDate d}
|] |]
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
, dbtCsvRenderException = ap getMessageRender . pure :: LmsReportCsvException -> DB Text , dbtCsvRenderException = ap getMessageRender . pure :: LmsReportCsvException -> DB Text
} }
dbtExtraReps = [] dbtExtraReps = []
ReportDBTableValidator = def reportDBTableValidator = def
& defaultSorting [SortAscBy csvLmsIdent] & defaultSorting [SortAscBy csvLmsIdent]
dbTable ReportDBTableValidator ReportDBTable dbTable reportDBTableValidator reportDBTable
getLmsReportR, postLmsReportR :: SchoolId -> QualificationShorthand -> Handler Html getLmsReportR, postLmsReportR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsReportR = postLmsReportR getLmsReportR = postLmsReportR
@ -212,7 +242,7 @@ postLmsReportR sid qsh = do
view _2 <$> mkReportTable sid qsh qid view _2 <$> mkReportTable sid qsh qid
siteLayoutMsg MsgMenuLmsReport $ do siteLayoutMsg MsgMenuLmsReport $ do
setTitleI MsgMenuLmsReport setTitleI MsgMenuLmsReport
$(widgetFile "lms-Report") $(widgetFile "lms-report")
-- Direct File Upload/Download -- Direct File Upload/Download
@ -223,11 +253,15 @@ saveReportCsv qid i LmsReportTableCsv{..} = do
void $ upsert void $ upsert
LmsReport LmsReport
{ lmsReportQualification = qid { lmsReportQualification = qid
, lmsReportIdent = csvLRTident , lmsReportIdent = csvLRident
, lmsReportSuccess = csvLRTsuccess & lms2day , lmsReportDate = csvLRdate <&> lms2day
, lmsReportResult = csvLRresult
, lmsReportLock = csvLRlock
, lmsReportTimestamp = now , lmsReportTimestamp = now
} }
[ LmsReportSuccess =. (csvLRTsuccess & lms2day) [ LmsReportDate =. (csvLRdate <&> lms2day)
, LmsReportResult =. csvLRresult
, LmsReportLock =. csvLRlock
, LmsReportTimestamp =. now , LmsReportTimestamp =. now
] ]
return $ succ i return $ succ i
@ -238,8 +272,8 @@ makeReportUploadForm = renderAForm FormStandard $ fileAFormReq "Report CSV"
getLmsReportUploadR, postLmsReportUploadR :: SchoolId -> QualificationShorthand -> Handler Html getLmsReportUploadR, postLmsReportUploadR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsReportUploadR = postLmsReportUploadR getLmsReportUploadR = postLmsReportUploadR
postLmsReportUploadR sid qsh = do postLmsReportUploadR sid qsh = do
((Report,widget), enctype) <- runFormPost makeReportUploadForm ((report,widget), enctype) <- runFormPost makeReportUploadForm
case Report of case report of
FormSuccess file -> do FormSuccess file -> do
-- content <- fileSourceByteString file -- content <- fileSourceByteString file
-- return $ Just (fileName file, content) -- return $ Just (fileName file, content)

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

@ -146,6 +146,8 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
, lmsUserReceived = Nothing , lmsUserReceived = Nothing
, lmsUserNotified = Nothing , lmsUserNotified = Nothing
, lmsUserEnded = Nothing , lmsUserEnded = Nothing
, lmsUserResetTries = False
, lmsUserLocked = True -- initially display locked, since it is not yet available until the first feedback
} }
-- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser)) -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
startLmsUser = do startLmsUser = do

22
src/Model/Types/Lms.hs
View File

@ -24,7 +24,7 @@ import Utils.Lens.TH
newtype LmsIdent = LmsIdent { getLmsIdent :: Text } newtype LmsIdent = LmsIdent { getLmsIdent :: Text }
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable) deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable)
instance E.SqlString LmsIdent instance E.SqlString LmsIdent
makeLenses_ ''LmsIdent makeLenses_ ''LmsIdent
deriveJSON defaultOptions deriveJSON defaultOptions
@ -35,16 +35,16 @@ deriveJSON defaultOptions
-- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS? -- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS?
-- ...also see similar type QualificationBlocked -- ...also see similar type QualificationBlocked
data LmsStatus = LmsExpired data LmsStatus = LmsExpired
| LmsBlocked | LmsBlocked
| LmsSuccess | LmsSuccess
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite)
-- embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) -- neccessarily moved to Handler.Utils.Lms -- embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) -- neccessarily moved to Handler.Utils.Lms
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor { constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor
, fieldLabelModifier = camelToPathPiece' 1 , fieldLabelModifier = camelToPathPiece' 1
, sumEncoding = UntaggedValue , sumEncoding = UntaggedValue
} ''LmsStatus } ''LmsStatus
derivePersistFieldJSON ''LmsStatus derivePersistFieldJSON ''LmsStatus
@ -53,7 +53,6 @@ nullaryPathPiece ''LmsStatus $ camelToPathPiece' 1
instance Csv.ToField LmsStatus where instance Csv.ToField LmsStatus where
toField = Csv.toField . toPathPiece toField = Csv.toField . toPathPiece
-- | Default Block/Unblock reasons -- | Default Block/Unblock reasons
@ -93,7 +92,7 @@ instance Csv.FromField LmsBool where
parseField "1" = pure $ LmsBool True parseField "1" = pure $ LmsBool True
parseField _ = mempty parseField _ = mempty
-- | LMS interface communicating user status -- | Only to be used in LMS interface communicating user status
data LmsState = LmsFailed | LmsOpen | LmsPassed data LmsState = LmsFailed | LmsOpen | LmsPassed
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite)
@ -108,6 +107,15 @@ instance Csv.FromField LmsState where
parseField "2" = pure LmsPassed parseField "2" = pure LmsPassed
parseField _ = mempty parseField _ = mempty
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor
, fieldLabelModifier = camelToPathPiece' 1
, sumEncoding = UntaggedValue
} ''LmsState
derivePersistFieldJSON ''LmsState
nullaryPathPiece ''LmsState $ camelToPathPiece' 1
-- | LMS interface requires day format not compliant with iso8601; also LMS uses LOCAL TIMEZONE -- | LMS interface requires day format not compliant with iso8601; also LMS uses LOCAL TIMEZONE
newtype LmsDay = LmsDay { lms2day :: Day } newtype LmsDay = LmsDay { lms2day :: Day }
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)

11
templates/lms-report.hamlet Normal file
View File

@ -0,0 +1,11 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<p>
^{lmsTable}
<p>
<a href=@{directUploadLink}>
_{MsgLmsDirectUpload}

12
test/Database/Fill.hs
View File

@ -731,12 +731,12 @@ fillDb = do
void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now
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)) 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 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 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 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 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 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
void . insert $ PrintJob "TestJob2" "AckTestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing (Just qid_f) (Just $ LmsIdent "ijk") void . insert $ PrintJob "TestJob2" "AckTestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing (Just qid_f) (Just $ LmsIdent "ijk")