chore(lms): WIP v2 using LmsState

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

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

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

src/Handler/LMS/Report.hs

@@ -29,8 +29,8 @@ import Jobs.Queue
 data LmsReportTableCsv = LmsReportTableCsv
   { csvLRident  :: LmsIdent
   , csvLRdate   :: Maybe LmsDay
-  , csvLRresult :: Int
+  , csvLRresult :: LmsState
-  , csvLRlock   :: Int
+  , 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 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 csvLmsDate)      (i18nCell MsgTableLmsDate)    $ \(view $ _dbrOutput . _entityVal . _lmsReportDate                 -> d)     -> cellMaybe dayCell d
-          , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsReportTimestamp        -> timestamp) -> dateTimeCell timestamp
+          , 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))
+          [ (csvLmsIdent    , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsReportIdent))
-          , (csvLmsSuccess, FilterColumn $ E.mkExactFilter                 (E.^. LmsReportSuccess))
+          , (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 }
+            [ LmsReportTableCsv
-            | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..]
+              { 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

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

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
 

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 (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite)  
-  deriving anyclass (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
+  parseField "0" = pure $ LmsBool False
-    | i == "0"  = pure $ LmsBool False
+  parseField "1" = pure $ LmsBool True 
-    | i == "1"  = pure $ LmsBool True 
+  parseField  _  = mempty
-    | otherwise = 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 }

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

src/Utils/Lens.hs

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

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 $