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

chore(lms): WIP v2 using LmsState

Browse Source
This commit is contained in:
Steffen Jost 2023-07-20 12:49:45 +00:00
parent 8bcdbd95f0
commit 00d8d684f4
10 changed files with 74 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -60,7 +60,7 @@ TableLmsStatus: Status E‑Learning
TableLmsStatusTooltip mbMonth@(Maybe Int): Zeigt #{maybeToMessage "bis zu " (fmap (flip pluralDEeN "Monat") mbMonth) " nach Abschluss"} den letzten Zustand eines E‑Learnings an:
TableLmsStatusDay: Datum letzte Statusänderung E‑Learning
TableLmsSuccess: Bestanden
TableLmsFailed: Gesperrt
TableLmsLock: Gesperrt
LmsStatusBlocked: Durchgefallen wegen zu vieler Fehlversuche
LmsStatusExpired: Durchgefallen nach Fristablauf
LmsStatusSuccess: E#{nonBreakableDash}Learning bestanden
@ -76,7 +76,7 @@ CsvColumnLmsResetPin: Wird das E-Learning Passwort bei der nächsten Synchronisa
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.)
CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme (UTC)
CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts
CsvColumnLmsLock: User was locked by LMS, usually due to too many attempts
LmsUserlistInsert: Neuer LMS User
LmsUserlistUpdate: LMS User aktualisierung
LmsResultInsert: Neues LMS Ergebnis

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

@ -60,7 +60,7 @@ TableLmsStatus: Status e‑learning
TableLmsStatusTooltip mbMonth: Shows #{maybeToMessage "for up to " (fmap (flip pluralENsN "month") mbMonth) " after closure"} the last e#{nonBreakableDash}learning status change:
TableLmsStatusDay: Date of last e‑learning status change
TableLmsSuccess: Completed
TableLmsFailed: Blocked
TableLmsLock: Locked
LmsStatusBlocked: Failed after too many attempts
LmsStatusExpired: Failed due to expiry
LmsStatusSuccess: Passed
@ -76,7 +76,7 @@ CsvColumnLmsResetPin: Will the e#{nonBreakableDash}learning password be reset up
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)
CsvColumnLmsSuccess: Timestamp of successful completion (UTC)
CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche
CsvColumnLmsLock: Blockiert durch LMS, üblicherweise wegen zu vieler Fehlversuche
LmsUserlistInsert: New LMS user
LmsUserlistUpdate: Update of LMS user
LmsResultInsert: New LMS result

2
models/lms.model
View File

@ -157,7 +157,7 @@ LmsReport
ident LmsIdent
date Day Maybe -- BEWARE: timezone is local as submitted by LMS
result Int -- (0|1|2) 0=too many ties, 1=open, 2=success
lock Int -- (0|1)
lock Bool -- (0|1)
timestamp UTCTime default=now()
UniqueLmsReport qualification ident -- required by DBTable
deriving Generic

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

@ -29,8 +29,8 @@ import Jobs.Queue
data LmsReportTableCsv = LmsReportTableCsv
{ csvLRident :: LmsIdent
, csvLRdate :: Maybe LmsDay
, csvLRresult :: Int
, csvLRlock :: Int
, csvLRresult :: LmsState
, csvLRlock :: LmsBool
}
deriving Generic
makeLenses_ ''LmsReportTableCsv
@ -70,20 +70,6 @@ instance CsvColumnsExplained LmsReportTableCsv where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
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 { lmsReportInsertIdent :: LmsIdent, lmsReportInsertDate :: Maybe Day, lmsReportInsertResult :: Int, lmsReportInsertLock :: Int }
| LmsReportUpdateData { lmsReportInsertIdent :: LmsIdent, lmsReportInsertDate :: Maybe Day, lmsReportInsertResult :: Int, lmsReportInsertLock :: Int }
deriving (Eq, Ord, Read, Show, Generic)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece'' 2 1 -- LmsReportInsertData -> insert
, fieldLabelModifier = camelToPathPiece' 2 -- lmsReportInsertIdent -> insert-ident | lmsReportInsertSuccess -> insert-success
, sumEncoding = TaggedObject "action" "data"
} ''LmsReportCsvAction
data LmsReportCsvException
= LmsReportCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
@ -106,27 +92,31 @@ mkReportTable sid qsh qid = do
dbtRowKey = (E.^. LmsReportId)
dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsReportIdent . _getLmsIdent -> ident) -> textCell ident
, sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsReportSuccess -> success) -> dayCell success
, sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsReportTimestamp -> timestamp) -> dateTimeCell timestamp
[ 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 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 csvLmsTimestamp) (i18nCell MsgTableLmsReceived)$ \(view $ _dbrOutput . _entityVal . _lmsReportTimestamp -> t) -> dateTimeCell timestamp
]
dbtSorting = Map.fromList
[ (csvLmsIdent , SortColumn (E.^. LmsReportIdent))
, (csvLmsSuccess , SortColumn (E.^. LmsReportSuccess))
, (csvLmsDate , SortColumn (E.^. LmsReportDate))
, (csvLmsResult , SortColumn (E.^. LmsReportResult))
, (csvLmsLock , SortColumn (E.^. LmsReportLock))
, (csvLmsTimestamp, SortColumn (E.^. LmsReportTimestamp))
]
dbtFilter = Map.fromList
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsReportIdent))
, (csvLmsSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsReportSuccess))
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsReportIdent))
, (csvLmsDate , FilterColumn $ E.mkExactFilter (E.?. LmsReportDate))
]
dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess)
, prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsDate)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def
dbtIdent :: Text
dbtIdent = "lms-Report"
dbtIdent = "lms-report"
dbtCsvEncode = Just DBTCsvEncode
{ dbtCsvExportForm = pure ()
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
@ -135,14 +125,21 @@ mkReportTable sid qsh qid = do
, dbtCsvNoExportData = Just id
, dbtCsvHeader = const $ return lmsReportTableCsvHeader
, dbtCsvExampleData = Just
[ LmsReportTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day }
| (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..]
[ LmsReportTableCsv
{ csvLRident = LmsIdent lid
, csvLRdate = LmsDay $ addDays (-dos) now_day
, csvLRresult = LmsState $ toEnum $ dos `mod` succ (fromEnum (maxBound :: LmsState))
, csvLRlock = LmsBool $ even dos
}
| (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch", "x2!y3-z4"] [1..]
]
}
where
doEncode' = LmsReportTableCsv
<$> view (_dbrOutput . _entityVal . _lmsReportIdent)
<*> view (_dbrOutput . _entityVal . _lmsReportSuccess . _lmsDay)
<*> view (_dbrOutput . _entityVal . _lmsReportDate . _lmsDay)
<*> view (_dbrOutput . _entityVal . _lmsReportResult . enum)
<*> view (_dbrOutput . _entityVal . _lmsReportLock . _lmsBool)
dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
{ dbtCsvRowKey = \LmsReportTableCsv{..} ->
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsReport qid csvLRTident

6
src/Handler/LMS/Userlist.hs
View File

@ -54,7 +54,7 @@ instance FromNamedRecord LmsUserlistTableCsv where
instance CsvColumnsExplained LmsUserlistTableCsv where
csvColumnsExplanations _ = mconcat
[ single csvLmsIdent MsgCsvColumnLmsIdent
, single csvLmsBlocked MsgCsvColumnLmsFailed
, single csvLmsBlocked MsgCsvColumnLmsLock
]
where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
@ -97,7 +97,7 @@ mkUserlistTable sid qsh qid = do
dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent
, sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked
, sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsLock) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked
, sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp
]
dbtSorting = Map.fromList
@ -111,7 +111,7 @@ mkUserlistTable sid qsh qid = do
]
dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed)
, prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsLock)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def

5
src/Handler/Utils/Table/Cells.hs
View File

@ -413,6 +413,11 @@ lmsStatusCell extendedInfo (Just toLink) lu = cell $ do
uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser
modal (lmsUserStatusWidget extendedInfo lu) (Left $ SomeRoute $ toLink uuid)
lmsStateCell :: IsDBTable m a => LmsState -> DBCell m a
lmsStateCell LmsFailed = iconBoolCell False
lmsStateCell LmsOpen = iconSpacerCell
lmsStateCell LmsPassed = iconBoolCell True
avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
avsPersonNoCell = numCell . view _userAvsNoPerson

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

@ -38,8 +38,7 @@ deriveJSON defaultOptions
data LmsStatus = LmsExpired
| LmsBlocked
| LmsSuccess
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData)
deriving anyclass (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
@ -90,10 +89,24 @@ instance Csv.ToField LmsBool where
toField (LmsBool True ) = "1"
instance Csv.FromField LmsBool where
parseField i
| i == "0" = pure $ LmsBool False
| i == "1" = pure $ LmsBool True
| otherwise = mempty
parseField "0" = pure $ LmsBool False
parseField "1" = pure $ LmsBool True
parseField _ = mempty
-- | LMS interface communicating user status
data LmsState = LmsFailed | LmsOpen | LmsPassed
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite)
instance Csv.ToField LmsState where
toField LmsFailed = "0"
toField LmsOpen = "1"
toField LmsPassed = "2"
instance Csv.FromField LmsState where
parseField "0" = pure LmsFailed
parseField "1" = pure LmsOpen
parseField "2" = pure LmsPassed
parseField _ = mempty
-- | LMS interface requires day format not compliant with iso8601; also LMS uses LOCAL TIMEZONE
newtype LmsDay = LmsDay { lms2day :: Day }

2
src/Utils/Icon.hs
View File

@ -111,6 +111,7 @@ data Icon
| IconSupervisor
-- | IconWaitingForUser
| IconExpired
| IconLocked
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
deriving anyclass (Universe, Finite, NFData)
@ -199,6 +200,7 @@ iconText = \case
IconSupervisor -> "head-side" -- must be notably different to user
-- IconWaitingForUser -> "user-cog" -- Waiting on a user to do something
IconExpired -> "hourglass-end"
IconLocked -> "lock"
nullaryPathPiece ''Icon $ camelToPathPiece' 1
deriveLift ''Icon

1
src/Utils/Lens.hs
View File

@ -127,6 +127,7 @@ makeClassyFor_ ''LmsUser
-- makeClassyFor_ ''LmsUserStatus
makeClassyFor_ ''LmsUserlist
makeClassyFor_ ''LmsResult
makeClassyFor_ ''LmsReport
makeClassyFor_ ''UserAvs
makeClassyFor_ ''UserAvsCard

15
test/Model/TypesSpec.hs
View File

@ -403,9 +403,18 @@ instance Arbitrary SchoolAuthorshipStatementMode where
instance Arbitrary SheetAuthorshipStatementMode where
arbitrary = genericArbitrary
instance Arbitrary LmsBool where
arbitrary = LmsBool <$> arbitrary
instance Arbitrary LmsStatus where
arbitrary = genericArbitrary
instance Arbitrary LmsState where
arbitrary = genericArbitrary
instance Arbitrary LmsDay where
arbitrary = LmsDay <$> arbitrary
deriving newtype instance Arbitrary LmsIdent
spec :: Spec
@ -521,8 +530,14 @@ spec = do
[ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws, binaryLaws, httpApiDataLaws ]
lawsCheckHspec (Proxy @SheetAuthorshipStatementMode)
[ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws, binaryLaws, httpApiDataLaws ]
lawsCheckHspec (Proxy @LmsBool)
[ eqLaws, ordLaws, showLaws, showReadLaws, csvFieldLaws ]
lawsCheckHspec (Proxy @LmsStatus)
[ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ]
lawsCheckHspec (Proxy @LmsState)
[ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, csvFieldLaws ]
lawsCheckHspec (Proxy @LmsDay)
[ eqLaws, ordLaws, showLaws, showReadLaws, csvFieldLaws ]
describe "TermIdentifier" $ do
it "has compatible encoding/decoding to/from Text" . property $