diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 4f8b887dc..d081fdc97 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 659773060..2987413ae 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -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 diff --git a/models/lms.model b/models/lms.model index 24a2f3a48..a77e63df0 100644 --- a/models/lms.model +++ b/models/lms.model @@ -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 \ No newline at end of file diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index fe7046e82..aabcb1367 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -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 diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index cb8618b6d..6304c5be7 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -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 diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 6e12bef8d..1389b8305 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -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 diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index dcb87ad27..ecdc25d37 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -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 } diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 260e0e03b..b90fcdf9b 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 9bab8bda5..861d98fd4 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -127,6 +127,7 @@ makeClassyFor_ ''LmsUser -- makeClassyFor_ ''LmsUserStatus makeClassyFor_ ''LmsUserlist makeClassyFor_ ''LmsResult +makeClassyFor_ ''LmsReport makeClassyFor_ ''UserAvs makeClassyFor_ ''UserAvsCard diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index f5eba0d6a..fe9eb7325 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -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 $