chore(lms): userlist page refactored and improved

messages/uniworx/categories/qualification/de-de-formal.msg

@@ -1,7 +1,9 @@
 TableLmsIdent: Identifikation
 TableLmsFailed: Gesperrt
 TableLmsSuccess: Bestanden
-CsvColumnLmsResultIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer
+TableLmsReceived: Erhalten
-CsvColumnLmsResultSuccess: Zeitstempel der erfolgreichen Teilnahme
+CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer
+CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme
+CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts
 LmsResultInsert: Neues LMS Ergebnis 
 LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel

messages/uniworx/categories/qualification/en-eu.msg

@@ -1,7 +1,9 @@
 TableLmsIdent: Identifier 
 TableLmsFailed: Blocked
 TableLmsSuccess: Completed
-CsvColumnLmsResultIdent: E-Learing identifier, unique for each qualfication and user
+TableLmsReceived: Received
-CsvColumnLmsResultSuccess: Timestamp of successful completion
+CsvColumnLmsIdent: E-Learing identifier, unique for each qualfication and user
+CsvColumnLmsSuccess: Timestamp of successful completion
+CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche
 LmsResultInsert: New LMS result
 LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key

routes

@@ -256,6 +256,7 @@
 
 -- OSIS CSV Export Demo
 /lms/#SchoolId/#QualificationShorthand              LmsR  				GET POST
+--/lms/#SchoolId/#QualificationShorthand/users      LmsUsersR	    GET POST
 /lms/#SchoolId/#QualificationShorthand/userlist     LmsUserlistR	GET POST
 /lms/#SchoolId/#QualificationShorthand/result       LmsResultR    GET POST
  

src/Handler/LMS.hs

@@ -13,6 +13,7 @@ module Handler.LMS
 import Import
 
 import Handler.Utils
+import Handler.Utils.LMS
 
 import qualified Data.Map as Map
 import qualified Data.Csv as Csv
@@ -21,13 +22,13 @@ import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
-import Handler.LMS.Result as Handler.LMS
+import Handler.LMS.Result   as Handler.LMS
+import Handler.LMS.Userlist as Handler.LMS
 
 
-type LmsUserIdent = Text -- Unique random use-once identifier for each individual e-learning course; i.e. users may have several active LmsUserIdents at once!
 
 data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
-  { csvLmsUserIdent :: LmsUserIdent
+  { csvLmsUserIdent :: LmsIdent
   , csvLmsUserPin   :: Text
   , csvLmsUserReset, cvsLmsUserRemove, cvsLmsUserIntern :: Int
   }
@@ -122,52 +123,3 @@ postLmsR sid qsh = do
     $(widgetFile "lms")
 
 
-
-
-mkUserlistTable :: QualificationId -> DB (Any, Widget)
-mkUserlistTable qid = do
-  let
-    userlistTable = DBTable{..}
-      where
-        dbtSQLQuery lmslist = do
-          E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid
-          return lmslist
-        dbtRowKey = (E.^. LmsUserlistId)
-        dbtProj   = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
-        dbtColonnade = dbColonnade $ mconcat
-          [ sortable (Just "ident")  (i18nCell MsgTableLmsIdent)  $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ getLmsIdent lmsUserlistIdent
-          , sortable (Just "failed") (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> isBadCell lmsUserlistFailed
-          ]
-        dbtSorting = Map.fromList
-          [ ("ident" , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent)
-          , ("failed", SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed)
-          ]
-        dbtFilter = mempty          -- TODO !!! continue here !!!
-        dbtFilterUI = const mempty  -- TODO !!! continue here !!! Manual filtering useful to deal with user complaints!
-        dbtStyle = def
-        dbtParams = def
-        dbtIdent :: Text
-        dbtIdent = "lms-userlist"
-        dbtCsvEncode = noCsvEncode
-        dbtCsvDecode = Nothing      -- TODO !!! continue here !!! CSV Import is the purpose of this page! Just save to DB, create Job to deal with it later!
-        dbtExtraReps = []
-
-    userlistDBTableValidator = def
-      & defaultSorting [SortAscBy "ident"]
-
-  dbTable userlistDBTableValidator userlistTable
-
-
-getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsUserlistR = postLmsUserlistR 
-postLmsUserlistR sid qsh = do
-  lmsTable <- runDB $ do
-    qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
-    view _2 <$> mkUserlistTable qid
-  siteLayoutMsg MsgMenuLmsUserlist $ do
-    setTitleI MsgMenuLmsUserlist
-    $(widgetFile "lms-userlist")
-
-
--- See Module Handler.LMS.Result for
--- getLmsResultR :: QualificationId -> Handler Html

src/Handler/LMS/Result.hs

@@ -1,12 +1,8 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
 {-# OPTIONS -Wno-unused-top-binds #-}      -- TODO: remove me, for debugging only
-{-# OPTIONS -Wno-unused-imports #-}        -- TODO: remove me, for debugging only
-{-# OPTIONS -Wno-redundant-constraints #-} -- TODO: remove me, for debugging only
-
 
 module Handler.LMS.Result
-  ( makeLmsFilename
+  ( getLmsResultR, postLmsResultR 
-  , getLmsResultR, postLmsResultR 
   )
   where
 
@@ -14,36 +10,15 @@ import Import
 
 import Handler.Utils
 import Handler.Utils.Csv
+import Handler.Utils.LMS
 
 import qualified Data.Map as Map
 import qualified Data.Csv as Csv
 import qualified Data.Conduit.List as C
-import qualified Data.CaseInsensitive as CI
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
-import qualified Data.Text.Lens as Text
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
-csvLmsUserFilename :: MonadHandler m => QualificationShorthand -> m Text
-csvLmsUserFilename = makeLmsFilename "user"
-
-csvLmsUserlistFilename :: MonadHandler m => QualificationShorthand -> m Text
-csvLmsUserlistFilename = makeLmsFilename "userliste"
-
-csvLmsResultFilename :: MonadHandler m => QualificationShorthand -> m Text
-csvLmsResultFilename = makeLmsFilename "ergebnisse"
-
--- | Create filenames as specified by the LMS interface agreed with Know How AG
-makeLmsFilename :: MonadHandler m => Text -> QualificationShorthand ->  m Text
-makeLmsFilename ftag (citext2lower -> qsh) = do
-  ymth <- getYMTH
-  return $ "fradrive_" <> qsh <> "_" <> ftag <> "_" <> ymth <> ".csv"
-
--- | Return current datetime in YYYYMMDDHH format
-getYMTH :: MonadHandler m => m Text
-getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
 
 
 type LmsResultTableExpr = (             E.SqlExpr (Entity Qualification)
@@ -99,25 +74,25 @@ instance Csv.FromRecord LmsResultTableCsv -- default suffices
 
 -- csv with headers
 lmsResultTableCsvHeader :: Csv.Header
-lmsResultTableCsvHeader = Csv.header [ "identification", "day-success" ]
+lmsResultTableCsvHeader = Csv.header [ csvResultIdent, csvResultSuccess ]
 
 instance ToNamedRecord LmsResultTableCsv where
   toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord
-    [ "identification" Csv..= csvLRTident
+    [ csvResultIdent    Csv..= csvLRTident
-    , "day-success"    Csv..= csvLRTsuccess
+    , csvResultSuccess  Csv..= csvLRTsuccess
     ]
 
 instance FromNamedRecord LmsResultTableCsv where
   parseNamedRecord (lsfHeaderTranslate -> csv)
     = LmsResultTableCsv
-        <$> csv Csv..: "identification"
+        <$> csv Csv..: csvResultIdent
-        <*> csv Csv..: "day-success"
+        <*> csv Csv..: csvResultSuccess
 
 
 instance CsvColumnsExplained LmsResultTableCsv where
   csvColumnsExplanations _ = mconcat
-    [ single "identification"     MsgCsvColumnLmsResultIdent
+    [ single csvResultIdent     MsgCsvColumnLmsIdent
-    , single "timestamp-success"  MsgCsvColumnLmsResultSuccess
+    , single csvResultSuccess   MsgCsvColumnLmsSuccess
     ]
     where
       single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
@@ -148,7 +123,7 @@ embedRenderMessage ''UniWorX ''LmsResultCsvException id
 
 mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
 mkResultTable sid qsh qid = do  
-  dbtCsvName <- csvLmsResultFilename qsh
+  dbtCsvName <- csvFilenameLmsResult qsh
   let dbtCsvSheetName = dbtCsvName
   let
     resultDBTable = DBTable{..}
@@ -168,26 +143,26 @@ mkResultTable sid qsh qid = do
         dbtRowKey = queryLmsResult >>> (E.^. LmsResultId)
         dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
         dbtColonnade = dbColonnade $ mconcat
-          [ sortable (Just "ident")  (i18nCell MsgTableLmsIdent)   $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
+          [ sortable (Just csvResultIdent)   (i18nCell MsgTableLmsIdent)   $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
-          , sortable (Just "sucess") (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success
+          , sortable (Just csvResultSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success
           ] -- TODO: add more columns for manual debugging view !!!
         dbtSorting = Map.fromList
-          [ ("ident"  , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent))
+          [ (csvResultIdent  , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent))
-       -- , ("success", SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess))
+       -- , (csvResultSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess))
-          , ("success", SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess))
+          , (csvResultSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess))
           ]
         dbtFilter = Map.fromList
-          [ ("ident"      , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent))
+          [ (csvResultIdent  , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent))
-          , ("success"    , FilterColumn . E.mkExactFilter                 $ views (to queryLmsResult) (E.^. LmsResultSuccess))
+          , (csvResultSuccess, FilterColumn . E.mkExactFilter                 $ views (to queryLmsResult) (E.^. LmsResultSuccess))
           ]
         dbtFilterUI = \mPrev -> mconcat 
-          [ prismAForm (singletonFilter "ident"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)     (fslI MsgTableLmsIdent)
+          [ prismAForm (singletonFilter csvResultIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)     (fslI MsgTableLmsIdent)
-          , prismAForm (singletonFilter "success" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsIdent)
+          , prismAForm (singletonFilter csvResultSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsSuccess)
           ]
         dbtStyle = def
         dbtParams = def
         dbtIdent :: Text
-        dbtIdent = "lms-userlist"        
+        dbtIdent = "lms-result"        
         dbtCsvEncode = Just DBTCsvEncode
           { dbtCsvExportForm   = pure ()
           , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)

src/Handler/LMS/Userlist.hs

@@ -0,0 +1,77 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
+{-# OPTIONS -Wno-unused-top-binds #-}      -- TODO: remove me, for debugging only
+{-# OPTIONS -Wno-unused-imports #-}        -- TODO: remove me, for debugging only
+
+module Handler.LMS.Userlist
+  ( getLmsUserlistR, postLmsUserlistR 
+  )
+  where
+
+import Import
+
+import Handler.Utils
+import Handler.Utils.Csv
+import Handler.Utils.LMS
+
+import qualified Data.Map as Map
+import qualified Data.Csv as Csv
+import qualified Data.Conduit.List as C
+import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils.TH
+
+
+
+mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
+mkUserlistTable _sid qsh qid = do
+  dbtCsvName <- csvFilenameLmsUserlist qsh
+  let _dbtCsvSheetName = dbtCsvName
+  let
+    userlistTable = DBTable{..}
+      where
+        dbtSQLQuery lmslist = do
+          E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid
+          return lmslist
+        dbtRowKey = (E.^. LmsUserlistId)
+        dbtProj   = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
+        dbtColonnade = dbColonnade $ mconcat
+          [ sortable (Just csvUserlistIdent)   (i18nCell MsgTableLmsIdent)    $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell    $ lmsUserlistIdent & getLmsIdent
+          , sortable (Just csvUserlistBlocked) (i18nCell MsgTableLmsFailed)   $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> isBadCell     lmsUserlistFailed
+          , sortable (Just "timestamp")        (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell  lmsUserlistTimestamp
+          ]
+        dbtSorting = Map.fromList
+          [ (csvUserlistIdent  , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent)
+          , (csvUserlistBlocked, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed)
+          , ("timestamp"       , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp)
+          ]
+        dbtFilter = Map.fromList
+          [ (csvUserlistIdent  , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent ))
+          , (csvUserlistBlocked, FilterColumn $ E.mkExactFilter                 (E.^. LmsUserlistFailed))
+          ]
+        dbtFilterUI =  \mPrev -> mconcat 
+          [ prismAForm (singletonFilter csvUserlistIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)     (fslI MsgTableLmsIdent)
+          , prismAForm (singletonFilter csvUserlistBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed)
+          ]
+        dbtStyle = def
+        dbtParams = def
+        dbtIdent :: Text
+        dbtIdent = "lms-userlist"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing      -- TODO !!! continue here !!! CSV Import is the purpose of this page! Just save to DB, create Job to deal with it later!
+        dbtExtraReps = []
+
+    userlistDBTableValidator = def
+      & defaultSorting [SortAscBy "ident"]
+
+  dbTable userlistDBTableValidator userlistTable
+
+
+getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
+getLmsUserlistR = postLmsUserlistR 
+postLmsUserlistR sid qsh = do
+  lmsTable <- runDB $ do
+    qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
+    view _2 <$> mkUserlistTable sid qsh qid
+  siteLayoutMsg MsgMenuLmsUserlist $ do
+    setTitleI MsgMenuLmsUserlist
+    $(widgetFile "lms-userlist")

src/Handler/Utils/LMS.hs

@@ -0,0 +1,46 @@
+module Handler.Utils.LMS
+  ( csvUserlistIdent, csvUserlistBlocked
+  , csvResultIdent, csvResultSuccess
+  , csvFilenameLmsUser 
+  , csvFilenameLmsUserlist
+  , csvFilenameLmsResult
+  ) where
+
+-- general utils for LMS Interface Handlers
+
+import Import 
+import Handler.Utils
+
+-- Column names 
+csvUserlistIdent   :: IsString a => a
+csvUserlistIdent   = fromString "Benutzerkennung"
+csvUserlistBlocked :: IsString a => a
+csvUserlistBlocked = fromString "Sperrung"
+
+csvResultIdent   :: IsString a => a
+csvResultIdent   = fromString "Benutzerkennung"
+csvResultSuccess :: IsString a => a
+csvResultSuccess = fromString "Datum"
+
+
+-- | Filename for User transmission, contains current datestamp as agreed in LMS interface
+csvFilenameLmsUser :: MonadHandler m => QualificationShorthand -> m Text
+csvFilenameLmsUser = makeLmsFilename "user"
+
+-- | Filename for Userlist transmission, contains current datestamp as agreed in LMS interface
+csvFilenameLmsUserlist :: MonadHandler m => QualificationShorthand -> m Text
+csvFilenameLmsUserlist = makeLmsFilename "userliste"
+
+-- | Filename for Result transmission, contains current datestamp as agreed in LMS interface
+csvFilenameLmsResult :: MonadHandler m => QualificationShorthand -> m Text
+csvFilenameLmsResult = makeLmsFilename "ergebnisse"
+
+-- | Create filenames as specified by the LMS interface agreed with Know How AG
+makeLmsFilename :: MonadHandler m => Text -> QualificationShorthand ->  m Text
+makeLmsFilename ftag (citext2lower -> qsh) = do
+  ymth <- getYMTH
+  return $ "fradrive_" <> qsh <> "_" <> ftag <> "_" <> ymth <> ".csv"
+
+-- | Return current datetime in YYYYMMDDHH format
+getYMTH :: MonadHandler m => m Text
+getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime

src/Utils.hs

@@ -274,6 +274,9 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs
 stripAll :: Text -> Text
 stripAll = Text.filter (not . isSpace)
 
+citext2lower :: CI Text -> Text 
+citext2lower = Text.toLower . CI.original
+
 -- | Convert text as it is to Html, may prevent ambiguous types
 -- This function definition is mainly for documentation purposes
 text2Html :: Text -> Html
@@ -295,9 +298,6 @@ text2widget t = [whamlet|#{t}|]
 citext2widget :: CI Text -> WidgetFor site ()
 citext2widget t = [whamlet|#{CI.original t}|]
 
-citext2lower :: CI Text -> Text 
-citext2lower = Text.toLower . CI.original
-
 str2widget :: String -> WidgetFor site ()
 str2widget s = [whamlet|#{s}|]
 

test/Database/Fill.hs

@@ -457,10 +457,10 @@ fillDb = do
   for_ [jost] $ \uid ->
     void . insert' $ UserSchool uid avn False
 
-  qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein"  Nothing (Just 24) (Just $ 5 * 12) Nothing True 
+  _qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein"  Nothing (Just 24) (Just $ 5 * 12) Nothing True 
   qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" Nothing (Just 24) (Just $ 5 * 12) Nothing False
-  void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (addBDays (-1) $ utctDay now) now 
+  void . insert' $ LmsResult qid_r (LmsIdent "hijklmn") (addBDays (-1) $ utctDay now) now 
-  void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (addBDays (-2) $ utctDay now) now 
+  void . insert' $ LmsResult qid_r (LmsIdent "opqgrs" ) (addBDays (-2) $ utctDay now) now 
   void . insert' $ LmsResult qid_r (LmsIdent "pqgrst" ) (addBDays (-3) $ utctDay now) now 
   let
     sdBsc = StudyDegreeKey' 82