chore(lms): export user implemented

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

@@ -1,8 +1,16 @@
 TableLmsIdent: Identifikation
-TableLmsFailed: Gesperrt
+TableLmsPin: E-Lernen Pin
-TableLmsSuccess: Bestanden
+TableLmsResetPin: Pin zurücksetzen?
+TableLmsDelete: Löschen?
+TableLmsStaff: Interner Mitarbeiter?
 TableLmsReceived: Erhalten
+TableLmsSuccess: Bestanden
+TableLmsFailed: Gesperrt
 CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer
+CsvColumnLmsPin: PIN des E-Lernen Zugangs
+CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt?
+CsvColumnLmsDelete: Wird der Identifikator in der E-Lernen 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
 CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts
 LmsUserlistInsert: Neuer LMS User 

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

@@ -1,8 +1,16 @@
 TableLmsIdent: Identifier 
-TableLmsFailed: Blocked
+TableLmsPin: E-learning pin
-TableLmsSuccess: Completed
+TableLmsResetPin: Reset pin?
+TableLmsDelete: Delete?
+TableLmsStaff: Staff?
 TableLmsReceived: Received
-CsvColumnLmsIdent: E-Learing identifier, unique for each qualfication and user
+TableLmsSuccess: Completed
+TableLmsFailed: Blocked
+CsvColumnLmsIdent: E-learning identifier, unique for each qualfication and user
+CsvColumnLmsPin: PIN for E-learning access
+CsvColumnLmsResetPin: Will the E-learning PIN be reset 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)
 CsvColumnLmsSuccess: Timestamp of successful completion
 CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche
 LmsUserlistInsert: New LMS User 

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -124,5 +124,6 @@ MenuCourseEventEdit: Kurstermin bearbeiten
 MenuLanguage: Sprache
 
 MenuLms: Schnittstelle E-Lernen
+MenuLmsUsers: Empfang E-Lernen Benutzer
 MenuLmsUserlist: Melden E-Lernen Benutzer
 MenuLmsResult: Melden Ergebnisse E-Lernen

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -125,5 +125,6 @@ MenuCourseEventEdit: Edit course occurrence
 MenuLanguage: Language
 
 MenuLms: Interface E-Learning
+MenuLmsUsers: Download E-Learning Users
 MenuLmsUserlist: Upload E-Learning Users 
 MenuLmsResult: Upload E-Learning Results

models/lms.model

@@ -90,11 +90,12 @@ QualificationUser
 LmsUser
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
   user              UserId
-  ident             LmsIdent
+  ident             LmsIdent                    -- must be unique accross all LMS courses!
   pin               Text
   resetPin          Bool        default=false   -- should pin be reset?
   success           Bool Maybe                  -- open, success or failure; isJust indicates user will be deleted from LMS 
   -- success        LmsStatus   -- this would also encode Day information?!
+  --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete
   started           UTCTime     default=now()
   received          UTCTime Maybe               -- last acknowledgement by LMS 
   ended             UTCTime Maybe               -- ident was deleted from LMS 

routes

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

src/Foundation/Navigation.hs

@@ -134,6 +134,7 @@ breadcrumb InstanceR        = i18nCrumb MsgMenuInstance        Nothing
 breadcrumb StatusR          = i18nCrumb MsgMenuHealth          Nothing  -- never displayed
 
 breadcrumb (LmsR         _sid _qsh) = i18nCrumb MsgMenuLms             Nothing
+breadcrumb (LmsUsersR     sid  qsh) = i18nCrumb MsgMenuLmsUsers      $ Just $ LmsR sid qsh
 breadcrumb (LmsUserlistR  sid  qsh) = i18nCrumb MsgMenuLmsUserlist   $ Just $ LmsR sid qsh
 breadcrumb (LmsResultR    sid  qsh) = i18nCrumb MsgMenuLmsResult     $ Just $ LmsR sid qsh
 

src/Handler/LMS.hs

@@ -1,3 +1,4 @@
+{-# 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
@@ -5,6 +6,7 @@
 
 module Handler.LMS
   ( getLmsR        , postLmsR
+  , getLmsUsersR   , postLmsUsersR
   , getLmsUserlistR, postLmsUserlistR
   , getLmsResultR  , postLmsResultR
   )
@@ -13,6 +15,7 @@ module Handler.LMS
 import Import
 
 import Handler.Utils
+import Handler.Utils.Csv
 import Handler.Utils.LMS
 
 import qualified Data.Map as Map
@@ -22,11 +25,11 @@ 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.Users    as Handler.LMS
 import Handler.LMS.Userlist as Handler.LMS
+import Handler.LMS.Result   as Handler.LMS
 
-
+{-
-
 data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
   { csvLmsUserIdent :: LmsIdent
   , csvLmsUserPin   :: Text
@@ -60,7 +63,7 @@ getLmsR = postLmsR
 postLmsR sid qsh = do
   _qid <- runDB . getKeyBy404 $ UniqueSchoolShort sid qsh
   -- TODO !!! filter table by qid !!!
-  {-
+  
   dbtCsvName <- csvLmsUserFilename
   let dbtIdent     = "lmsUsers" :: Text
       dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
@@ -116,10 +119,222 @@ postLmsR sid qsh = do
         -- }
       psValidator = def
       lmsTable = dbTable psValidator DBTable{..}
-      -}
+  
   let lmsTable = [whamlet|TODO|]  -- TODO: remove me, just for debugging
   siteLayoutMsg MsgMenuLms $ do
     setTitleI MsgMenuLms
     $(widgetFile "lms")
+-}
+
+--- old above, new below
+
+type LmsResultTableExpr = (             E.SqlExpr (Entity Qualification)
+                          `E.InnerJoin` E.SqlExpr (Entity LmsResult)
+                          ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
+                            `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
+
+queryQualification :: LmsResultTableExpr -> E.SqlExpr (Entity Qualification)
+queryQualification = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
+
+queryLmsResult :: LmsResultTableExpr -> E.SqlExpr (Entity LmsResult)
+queryLmsResult = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
+
+queryLmsUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
+queryLmsUser = $(sqlLOJproj 3 2)
+
+queryUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity User))
+queryUser = $(sqlLOJproj 3 3)
+
+type LmsResultTableData = DBRow (Entity Qualification, Entity LmsResult, Maybe (Entity LmsUser), Maybe (Entity User))
+
+instance HasEntity LmsResultTableData LmsResult where
+  hasEntity = _dbrOutput . _2
+
+{- MaybeHasUser only!
+instance HasUser LmsResultTableData where
+  hasUser = _dbrOutput . _4 . _entityVal
+-}
+
+resultQualification :: Lens' LmsResultTableData (Entity Qualification)
+resultQualification = _dbrOutput . _1
+
+resultLmsResult :: Lens' LmsResultTableData (Entity LmsResult)
+resultLmsResult = _dbrOutput . _2
+
+resultLmsUser :: Traversal' LmsResultTableData (Entity LmsUser)
+resultLmsUser = _dbrOutput . _3 . _Just
+
+resultUser :: Traversal' LmsResultTableData (Entity User)
+resultUser = _dbrOutput . _4 . _Just
+
+-- required for import only
+data LmsResultTableCsv = LmsResultTableCsv
+  { csvLRTident   :: LmsIdent
+  , csvLRTsuccess :: Day
+  }
+  deriving Generic
+makeLenses_ ''LmsResultTableCsv
+
+-- csv without headers
+instance Csv.ToRecord   LmsResultTableCsv -- default suffices
+instance Csv.FromRecord LmsResultTableCsv -- default suffices
+
+-- csv with headers -- TODO not yet supported
+lmsResultTableCsvHeader :: Csv.Header
+lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ]
+
+instance ToNamedRecord LmsResultTableCsv where
+  toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord
+    [ csvLmsIdent    Csv..= csvLRTident
+    , csvLmsSuccess  Csv..= csvLRTsuccess
+    ]
+
+instance FromNamedRecord LmsResultTableCsv where
+  parseNamedRecord (lsfHeaderTranslate -> csv)
+    = LmsResultTableCsv
+        <$> csv Csv..: csvLmsIdent
+        <*> csv Csv..: csvLmsSuccess
+
+instance CsvColumnsExplained LmsResultTableCsv where
+  csvColumnsExplanations _ = mconcat
+    [ single csvLmsIdent     MsgCsvColumnLmsIdent
+    , single csvLmsSuccess   MsgCsvColumnLmsSuccess
+    ]
+    where
+      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
+      single k v = singletonMap k [whamlet|_{v}|]
+
+data LmsResultCsvActionClass = LmsResultInsert 
+  deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded)
+embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id
+
+-- By coincidence the action type is identical to LmsResultTableCsv
+data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece'' 2 1   -- LmsResultInsertData -> insert
+  , fieldLabelModifier = camelToPathPiece' 2          -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success
+  , sumEncoding = TaggedObject "action" "data"
+  } ''LmsResultCsvAction
+
+data LmsResultCsvException 
+  = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
+  deriving (Show, Generic, Typeable)
+
+instance Exception LmsResultCsvException
+embedRenderMessage ''UniWorX ''LmsResultCsvException id 
 
 
+
+mkLmsTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
+mkLmsTable sid qsh qid = do  
+  dbtCsvName <- csvFilenameLmsResult qsh
+  let dbtCsvSheetName = dbtCsvName
+  let
+    resultDBTable = DBTable{..}
+      where
+
+        dbtSQLQuery = runReaderT $ do
+          qualification <- asks queryQualification
+          lmsResult     <- asks queryLmsResult
+          lmsUser       <- asks queryLmsUser
+          user          <- asks queryUser
+          lift $ do
+            E.on $ qualification E.^. QualificationId E.==. lmsResult E.^. LmsResultQualification
+            E.on $ lmsUser E.?. LmsUserIdent E.==. E.just (lmsResult E.^. LmsResultIdent)
+            E.on $ lmsUser E.?. LmsUserUser  E.==. user E.?. UserId
+            E.where_ $ qualification E.^. QualificationId E.==. E.val qid
+          return (qualification, lmsResult, lmsUser, user)
+        dbtRowKey = queryLmsResult >>> (E.^. LmsResultId)
+        dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
+        dbtColonnade = dbColonnade $ mconcat
+          [ sortable (Just csvLmsIdent)   (i18nCell MsgTableLmsIdent)   $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
+          , sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success
+          ] -- TODO: add more columns for manual debugging view !!!
+        dbtSorting = Map.fromList
+          [ (csvLmsIdent  , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent))
+       -- , (csvLmsSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess))
+          , (csvLmsSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess))
+          ]
+        dbtFilter = Map.fromList
+          [ (csvLmsIdent  , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent))
+          , (csvLmsSuccess, FilterColumn . E.mkExactFilter                 $ views (to queryLmsResult) (E.^. LmsResultSuccess))
+          ]
+        dbtFilterUI = \mPrev -> mconcat 
+          [ prismAForm (singletonFilter csvLmsIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)     (fslI MsgTableLmsIdent)
+          , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsSuccess)
+          ]
+        dbtStyle = def
+        dbtParams = def
+        dbtIdent :: Text
+        dbtIdent = "lms-result"        
+        dbtCsvEncode = Just DBTCsvEncode
+          { dbtCsvExportForm   = pure ()
+          , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
+          , dbtCsvName 
+          , dbtCsvSheetName
+          , dbtCsvNoExportData = Just id
+          , dbtCsvHeader       = const $ return lmsResultTableCsvHeader
+          , dbtCsvExampleData  = Nothing
+          }
+          where 
+            doEncode' = LmsResultTableCsv
+              <$> view (resultLmsResult . _entityVal . _lmsResultIdent)
+              <*> view (resultLmsResult . _entityVal . _lmsResultSuccess)
+
+        dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
+          { dbtCsvRowKey = \LmsResultTableCsv{..} -> 
+              fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident csvLRTsuccess
+          , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
+              DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do                 
+                yield $ LmsResultInsertData
+                        { lmsResultInsertIdent      = csvLRTident   dbCsvNew
+                        , lmsResultInsertSuccess    = csvLRTsuccess dbCsvNew                        
+                        }                              
+              DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code
+              DBCsvDiffMissing{}  -> return () -- no deletion
+              DBCsvDiffExisting{} -> return () -- no merge                      TODO!!! ADD MERGE DUE TO Uniqueness!
+          , dbtCsvClassifyAction      = \LmsResultInsertData{} -> LmsResultInsert
+          , dbtCsvCoarsenActionClass  = \LmsResultInsert -> DBCsvActionNew   -- there is only one action: insert into table
+          , dbtCsvValidateActions     = return ()  -- no validation, since this is an automatic upload, i.e. no user to review error
+          , dbtCsvExecuteActions      = do
+            C.mapM_ $ \LmsResultInsertData{..} -> do 
+                now <- liftIO getCurrentTime
+                void $ upsert 
+                  LmsResult
+                    { lmsResultQualification  = qid 
+                    , lmsResultIdent          = lmsResultInsertIdent
+                    , lmsResultSuccess        = lmsResultInsertSuccess
+                    , lmsResultTimestamp      = now -- lmsResultInsertTimestamp -- does it matter which one to choose?
+                    }
+                  [ LmsResultSuccess          =. lmsResultInsertSuccess
+                  , LmsResultTimestamp        =. now
+                  ]
+                -- queueDBJob?? -- todo
+                -- audit 
+            return $ LmsResultR sid qsh 
+          , dbtCsvRenderKey           = \_ LmsResultInsertData{..} -> do -- TODO: i18n
+              [whamlet|
+                $newline never
+                Ident #{getLmsIdent lmsResultInsertIdent} #
+                had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
+              |]
+          , dbtCsvRenderActionClass   = toWidget <=< ap getMessageRender . pure
+          , dbtCsvRenderException     = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
+          }                    
+        dbtExtraReps = []
+
+    resultDBTableValidator = def
+      & defaultSorting [SortAscBy csvLmsIdent]
+  dbTable resultDBTableValidator resultDBTable
+
+getLmsR,  postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
+getLmsR = postLmsR
+postLmsR sid qsh = do
+  lmsTable <- runDB $ do 
+    qid <- getKeyBy404 $ UniqueSchoolShort sid qsh 
+    view _2 <$> mkLmsTable sid qsh qid 
+  siteLayoutMsg MsgMenuLmsResult $ do
+    setTitleI MsgMenuLmsResult
+    $(widgetFile "lms")

src/Handler/LMS/Result.hs

@@ -27,29 +27,29 @@ data LmsResultTableCsv = LmsResultTableCsv
 makeLenses_ ''LmsResultTableCsv
 
 -- csv without headers -- TODO not yet supported
-instance Csv.ToRecord   LmsResultTableCsv -- default suffices
+--instance Csv.ToRecord   LmsResultTableCsv -- default suffices
-instance Csv.FromRecord LmsResultTableCsv -- default suffices
+--instance Csv.FromRecord LmsResultTableCsv -- default suffices
 
 -- csv with headers 
 lmsResultTableCsvHeader :: Csv.Header
-lmsResultTableCsvHeader = Csv.header [ csvResultIdent, csvResultSuccess ]
+lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ]
 
 instance ToNamedRecord LmsResultTableCsv where
   toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord
-    [ csvResultIdent    Csv..= csvLRTident
+    [ csvLmsIdent   Csv..= csvLRTident
-    , csvResultSuccess  Csv..= csvLRTsuccess
+    , csvLmsSuccess Csv..= csvLRTsuccess
     ]
 
 instance FromNamedRecord LmsResultTableCsv where
   parseNamedRecord (lsfHeaderTranslate -> csv)
     = LmsResultTableCsv
-        <$> csv Csv..: csvResultIdent
+        <$> csv Csv..: csvLmsIdent
-        <*> csv Csv..: csvResultSuccess
+        <*> csv Csv..: csvLmsSuccess
 
 instance CsvColumnsExplained LmsResultTableCsv where
   csvColumnsExplanations _ = mconcat
-    [ single csvResultIdent     MsgCsvColumnLmsIdent
+    [ single csvLmsIdent   MsgCsvColumnLmsIdent
-    , single csvResultSuccess   MsgCsvColumnLmsSuccess
+    , single csvLmsSuccess MsgCsvColumnLmsSuccess
     ]
     where
       single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
@@ -91,22 +91,22 @@ mkResultTable sid qsh qid = do
         dbtRowKey = (E.^. LmsResultId)
         dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
         dbtColonnade = dbColonnade $ mconcat
-          [ sortable (Just csvResultIdent)   (i18nCell MsgTableLmsIdent)    $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
+          [ sortable (Just csvLmsIdent)     (i18nCell MsgTableLmsIdent)    $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
-          , sortable (Just csvResultSuccess) (i18nCell MsgTableLmsSuccess)  $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess            -> success) -> dayCell success
+          , sortable (Just csvLmsSuccess)   (i18nCell MsgTableLmsSuccess)  $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess            -> success) -> dayCell success
-          , sortable (Just csvLmsTimestamp)  (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp        -> timestamp) -> dateTimeCell timestamp
+          , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp        -> timestamp) -> dateTimeCell timestamp
           ] 
         dbtSorting = Map.fromList
-          [ (csvResultIdent  , SortColumn (E.^. LmsResultIdent))
+          [ (csvLmsIdent    , SortColumn (E.^. LmsResultIdent))
-          , (csvResultSuccess, SortColumn (E.^. LmsResultSuccess))
+          , (csvLmsSuccess  , SortColumn (E.^. LmsResultSuccess))
-          , (csvLmsTimestamp , SortColumn (E.^. LmsResultTimestamp))
+          , (csvLmsTimestamp, SortColumn (E.^. LmsResultTimestamp))
           ]
         dbtFilter = Map.fromList
-          [ (csvResultIdent  , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent))
+          [ (csvLmsIdent  , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent))
-          , (csvResultSuccess, FilterColumn $ E.mkExactFilter                 (E.^. LmsResultSuccess))
+          , (csvLmsSuccess, FilterColumn $ E.mkExactFilter                 (E.^. LmsResultSuccess))
           ]
         dbtFilterUI = \mPrev -> mconcat 
-          [ prismAForm (singletonFilter csvResultIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
+          [ prismAForm (singletonFilter csvLmsIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
-          , prismAForm (singletonFilter csvResultSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField)  (fslI MsgTableLmsSuccess)
+          , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField)  (fslI MsgTableLmsSuccess)
           ]
         dbtStyle = def
         dbtParams = def
@@ -183,7 +183,7 @@ mkResultTable sid qsh qid = do
         dbtExtraReps = []
 
     resultDBTableValidator = def
-      & defaultSorting [SortAscBy csvResultIdent]
+      & defaultSorting [SortAscBy csvLmsIdent]
   dbTable resultDBTableValidator resultDBTable
 
 getLmsResultR,  postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html

src/Handler/LMS/User.hs

@@ -1,235 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
-{-# OPTIONS -Wno-unused-top-binds #-}      -- TODO: remove me, for debugging only
-
-module Handler.LMS.User
-  ( getLmsUserR, postLmsUserR 
-  )
-  where
-
--- TODO: needs complete refactoring! Old RESULT templates follows
-
-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
-
-
-
-type LmsResultTableExpr = (             E.SqlExpr (Entity Qualification)
-                          `E.InnerJoin` E.SqlExpr (Entity LmsResult)
-                          ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
-                            `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
-
-queryQualification :: LmsResultTableExpr -> E.SqlExpr (Entity Qualification)
-queryQualification = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
-
-queryLmsResult :: LmsResultTableExpr -> E.SqlExpr (Entity LmsResult)
-queryLmsResult = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
-
-queryLmsUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
-queryLmsUser = $(sqlLOJproj 3 2)
-
-queryUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity User))
-queryUser = $(sqlLOJproj 3 3)
-
-type LmsResultTableData = DBRow (Entity Qualification, Entity LmsResult, Maybe (Entity LmsUser), Maybe (Entity User))
-
-instance HasEntity LmsResultTableData LmsResult where
-  hasEntity = _dbrOutput . _2
-
-{- MaybeHasUser only!
-instance HasUser LmsResultTableData where
-  hasUser = _dbrOutput . _4 . _entityVal
--}
-
-resultQualification :: Lens' LmsResultTableData (Entity Qualification)
-resultQualification = _dbrOutput . _1
-
-resultLmsResult :: Lens' LmsResultTableData (Entity LmsResult)
-resultLmsResult = _dbrOutput . _2
-
-resultLmsUser :: Traversal' LmsResultTableData (Entity LmsUser)
-resultLmsUser = _dbrOutput . _3 . _Just
-
-resultUser :: Traversal' LmsResultTableData (Entity User)
-resultUser = _dbrOutput . _4 . _Just
-
--- required for import only
-data LmsResultTableCsv = LmsResultTableCsv
-  { csvLRTident   :: LmsIdent
-  , csvLRTsuccess :: Day
-  }
-  deriving Generic
-makeLenses_ ''LmsResultTableCsv
-
--- csv without headers
-instance Csv.ToRecord   LmsResultTableCsv -- default suffices
-instance Csv.FromRecord LmsResultTableCsv -- default suffices
-
--- csv with headers -- TODO not yet supported
-lmsResultTableCsvHeader :: Csv.Header
-lmsResultTableCsvHeader = Csv.header [ csvResultIdent, csvResultSuccess ]
-
-instance ToNamedRecord LmsResultTableCsv where
-  toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord
-    [ csvResultIdent    Csv..= csvLRTident
-    , csvResultSuccess  Csv..= csvLRTsuccess
-    ]
-
-instance FromNamedRecord LmsResultTableCsv where
-  parseNamedRecord (lsfHeaderTranslate -> csv)
-    = LmsResultTableCsv
-        <$> csv Csv..: csvResultIdent
-        <*> csv Csv..: csvResultSuccess
-
-instance CsvColumnsExplained LmsResultTableCsv where
-  csvColumnsExplanations _ = mconcat
-    [ single csvResultIdent     MsgCsvColumnLmsIdent
-    , single csvResultSuccess   MsgCsvColumnLmsSuccess
-    ]
-    where
-      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
-      single k v = singletonMap k [whamlet|_{v}|]
-
-data LmsResultCsvActionClass = LmsResultInsert 
-  deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded)
-embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id
-
--- By coincidence the action type is identical to LmsResultTableCsv
-data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece'' 2 1   -- LmsResultInsertData -> insert
-  , fieldLabelModifier = camelToPathPiece' 2          -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success
-  , sumEncoding = TaggedObject "action" "data"
-  } ''LmsResultCsvAction
-
-data LmsResultCsvException 
-  = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
-  deriving (Show, Generic, Typeable)
-
-instance Exception LmsResultCsvException
-embedRenderMessage ''UniWorX ''LmsResultCsvException id 
-
-
-
-mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
-mkResultTable sid qsh qid = do  
-  dbtCsvName <- csvFilenameLmsResult qsh
-  let dbtCsvSheetName = dbtCsvName
-  let
-    resultDBTable = DBTable{..}
-      where
-
-        dbtSQLQuery = runReaderT $ do
-          qualification <- asks queryQualification
-          lmsResult     <- asks queryLmsResult
-          lmsUser       <- asks queryLmsUser
-          user          <- asks queryUser
-          lift $ do
-            E.on $ qualification E.^. QualificationId E.==. lmsResult E.^. LmsResultQualification
-            E.on $ lmsUser E.?. LmsUserIdent E.==. E.just (lmsResult E.^. LmsResultIdent)
-            E.on $ lmsUser E.?. LmsUserUser  E.==. user E.?. UserId
-            E.where_ $ qualification E.^. QualificationId E.==. E.val qid
-          return (qualification, lmsResult, lmsUser, user)
-        dbtRowKey = queryLmsResult >>> (E.^. LmsResultId)
-        dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
-        dbtColonnade = dbColonnade $ mconcat
-          [ sortable (Just csvResultIdent)   (i18nCell MsgTableLmsIdent)   $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
-          , sortable (Just csvResultSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success
-          ] -- TODO: add more columns for manual debugging view !!!
-        dbtSorting = Map.fromList
-          [ (csvResultIdent  , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent))
-       -- , (csvResultSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess))
-          , (csvResultSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess))
-          ]
-        dbtFilter = Map.fromList
-          [ (csvResultIdent  , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent))
-          , (csvResultSuccess, FilterColumn . E.mkExactFilter                 $ views (to queryLmsResult) (E.^. LmsResultSuccess))
-          ]
-        dbtFilterUI = \mPrev -> mconcat 
-          [ prismAForm (singletonFilter csvResultIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)     (fslI MsgTableLmsIdent)
-          , prismAForm (singletonFilter csvResultSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsSuccess)
-          ]
-        dbtStyle = def
-        dbtParams = def
-        dbtIdent :: Text
-        dbtIdent = "lms-result"        
-        dbtCsvEncode = Just DBTCsvEncode
-          { dbtCsvExportForm   = pure ()
-          , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
-          , dbtCsvName 
-          , dbtCsvSheetName
-          , dbtCsvNoExportData = Just id
-          , dbtCsvHeader       = const $ return lmsResultTableCsvHeader
-          , dbtCsvExampleData  = Nothing
-          }
-          where 
-            doEncode' = LmsResultTableCsv
-              <$> view (resultLmsResult . _entityVal . _lmsResultIdent)
-              <*> view (resultLmsResult . _entityVal . _lmsResultSuccess)
-
-        dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
-          { dbtCsvRowKey = \LmsResultTableCsv{..} -> 
-              fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident csvLRTsuccess
-          , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
-              DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do                 
-                yield $ LmsResultInsertData
-                        { lmsResultInsertIdent      = csvLRTident   dbCsvNew
-                        , lmsResultInsertSuccess    = csvLRTsuccess dbCsvNew                        
-                        }                              
-              DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code
-              DBCsvDiffMissing{}  -> return () -- no deletion
-              DBCsvDiffExisting{} -> return () -- no merge                      TODO!!! ADD MERGE DUE TO Uniqueness!
-          , dbtCsvClassifyAction      = \LmsResultInsertData{} -> LmsResultInsert
-          , dbtCsvCoarsenActionClass  = \LmsResultInsert -> DBCsvActionNew   -- there is only one action: insert into table
-          , dbtCsvValidateActions     = return ()  -- no validation, since this is an automatic upload, i.e. no user to review error
-          , dbtCsvExecuteActions      = do
-            C.mapM_ $ \LmsResultInsertData{..} -> do 
-                now <- liftIO getCurrentTime
-                void $ upsert 
-                  LmsResult
-                    { lmsResultQualification  = qid 
-                    , lmsResultIdent          = lmsResultInsertIdent
-                    , lmsResultSuccess        = lmsResultInsertSuccess
-                    , lmsResultTimestamp      = now -- lmsResultInsertTimestamp -- does it matter which one to choose?
-                    }
-                  [ LmsResultSuccess          =. lmsResultInsertSuccess
-                  , LmsResultTimestamp        =. now
-                  ]
-                -- queueDBJob?? -- todo
-                -- audit 
-            return $ LmsResultR sid qsh 
-          , dbtCsvRenderKey           = \_ LmsResultInsertData{..} -> do -- TODO: i18n
-              [whamlet|
-                $newline never
-                Ident #{getLmsIdent lmsResultInsertIdent} #
-                had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
-              |]
-          , dbtCsvRenderActionClass   = toWidget <=< ap getMessageRender . pure
-          , dbtCsvRenderException     = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
-          }                    
-        dbtExtraReps = []
-
-    resultDBTableValidator = def
-      & defaultSorting [SortAscBy csvResultIdent]
-  dbTable resultDBTableValidator resultDBTable
-
-getLmsUserR,  postLmsUserR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsUserR = postLmsUserR
-postLmsUserR sid qsh = do
-  lmsTable <- runDB $ do 
-    qid <- getKeyBy404 $ UniqueSchoolShort sid qsh 
-    view _2 <$> mkResultTable sid qsh qid 
-  siteLayoutMsg MsgMenuLmsResult $ do
-    setTitleI MsgMenuLmsResult
-    $(widgetFile "lms-result")

src/Handler/LMS/Userlist.hs

@@ -1,6 +1,4 @@
 {-# 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 
@@ -28,28 +26,28 @@ data LmsUserlistTableCsv = LmsUserlistTableCsv
 makeLenses_ ''LmsUserlistTableCsv
 
 -- csv without headers -- TODO not yet supported
-instance Csv.ToRecord   LmsUserlistTableCsv
+--instance Csv.ToRecord   LmsUserlistTableCsv
-instance Csv.FromRecord LmsUserlistTableCsv
+--instance Csv.FromRecord LmsUserlistTableCsv
 
 -- csv with headers 
 lmsUserlistTableCsvHeader :: Csv.Header
-lmsUserlistTableCsvHeader = Csv.header [ csvUserlistIdent, csvUserlistBlocked ]
+lmsUserlistTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsBlocked ]
 
 instance ToNamedRecord LmsUserlistTableCsv where 
   toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord
-    [ csvUserlistIdent    Csv..= csvLULident
+    [ csvLmsIdent   Csv..= csvLULident
-    , csvUserlistBlocked  Csv..= csvLULfailed
+    , csvLmsBlocked Csv..= csvLULfailed
     ]
 instance FromNamedRecord LmsUserlistTableCsv where
   parseNamedRecord (lsfHeaderTranslate -> csv)
     = LmsUserlistTableCsv
-        <$> csv Csv..: csvUserlistIdent
+        <$> csv Csv..: csvLmsIdent
-        <*> csv Csv..: csvUserlistBlocked
+        <*> csv Csv..: csvLmsBlocked
 
 instance CsvColumnsExplained LmsUserlistTableCsv where
   csvColumnsExplanations _ = mconcat
-    [ single csvUserlistIdent     MsgCsvColumnLmsIdent
+    [ single csvLmsIdent   MsgCsvColumnLmsIdent
-    , single csvUserlistBlocked   MsgCsvColumnLmsFailed
+    , single csvLmsBlocked MsgCsvColumnLmsFailed
     ]
     where
       single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
@@ -91,22 +89,22 @@ mkUserlistTable sid qsh qid = do
         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 csvLmsIdent)     (i18nCell MsgTableLmsIdent)    $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell    $ lmsUserlistIdent & getLmsIdent
-          , sortable (Just csvUserlistBlocked) (i18nCell MsgTableLmsFailed)   $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> isBadCell     lmsUserlistFailed
+          , sortable (Just csvLmsBlocked)   (i18nCell MsgTableLmsFailed)   $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell    lmsUserlistFailed IconBlocked
-          , sortable (Just csvLmsTimestamp)    (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell  lmsUserlistTimestamp
+          , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell  lmsUserlistTimestamp
           ]
         dbtSorting = Map.fromList
-          [ (csvUserlistIdent  , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent)
+          [ (csvLmsIdent    , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent)
-          , (csvUserlistBlocked, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed)
+          , (csvLmsBlocked  , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed)
-          , (csvLmsTimestamp   , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp)
+          , (csvLmsTimestamp, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp)
           ]
         dbtFilter = Map.fromList
-          [ (csvUserlistIdent  , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent ))
+          [ (csvLmsIdent  , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent ))
-          , (csvUserlistBlocked, FilterColumn $ E.mkExactFilter                 (E.^. LmsUserlistFailed))
+          , (csvLmsBlocked, FilterColumn $ E.mkExactFilter                 (E.^. LmsUserlistFailed))
           ]
         dbtFilterUI =  \mPrev -> mconcat 
-          [ prismAForm (singletonFilter csvUserlistIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)     (fslI MsgTableLmsIdent)
+          [ prismAForm (singletonFilter csvLmsIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)     (fslI MsgTableLmsIdent)
-          , prismAForm (singletonFilter csvUserlistBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed)
+          , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed)
           ]
         dbtStyle = def
         dbtParams = def
@@ -186,7 +184,7 @@ mkUserlistTable sid qsh qid = do
         dbtExtraReps = []
 
     userlistDBTableValidator = def
-      & defaultSorting [SortAscBy csvUserlistIdent]
+      & defaultSorting [SortAscBy csvLmsIdent]
 
   dbTable userlistDBTableValidator userlistTable
 

src/Handler/LMS/Users.hs

@@ -0,0 +1,136 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
+{-# OPTIONS -Wno-unused-top-binds #-}      -- TODO: remove me, for debugging only
+
+module Handler.LMS.Users
+  ( getLmsUsersR, postLmsUsersR 
+  )
+  where
+
+-- TODO: needs complete refactoring! Old RESULT templates follows
+
+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
+
+data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
+  { csvLUTident :: LmsIdent
+  , csvLUTpin   :: Text
+  , csvLUTresetPin, csvLUTdelete, csvLUTstaff :: LmsBool
+  }
+  deriving Generic
+makeLenses_ ''LmsUserTableCsv 
+
+
+-- csv without headers -- TODO not yet supported
+-- instance Csv.ToRecord   LmsUserTableCsv
+-- instance Csv.FromRecord LmsUserTableCsv
+
+-- csv with headers 
+lmsUserTableCsvHeader :: Csv.Header
+lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff ]
+
+instance ToNamedRecord LmsUserTableCsv where 
+  toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord
+    [ csvLmsIdent     Csv..= csvLUTident
+    , csvLmsPin       Csv..= csvLUTpin 
+    , csvLmsResetPin  Csv..= csvLUTresetPin
+    , csvLmsDelete    Csv..= csvLUTdelete
+    , csvLmsStaff     Csv..= csvLUTstaff
+    ]
+instance FromNamedRecord LmsUserTableCsv where
+  parseNamedRecord (lsfHeaderTranslate -> csv)
+    = LmsUserTableCsv
+        <$> csv Csv..: csvLmsIdent
+        <*> csv Csv..: csvLmsPin
+        <*> csv Csv..: csvLmsResetPin
+        <*> csv Csv..: csvLmsDelete
+        <*> csv Csv..: csvLmsStaff
+
+instance CsvColumnsExplained LmsUserTableCsv where
+  csvColumnsExplanations _ = mconcat
+    [ single csvLmsIdent    MsgCsvColumnLmsIdent
+    , single csvLmsPin      MsgCsvColumnLmsPin
+    , single csvLmsResetPin MsgCsvColumnLmsResetPin
+    , single csvLmsDelete   MsgCsvColumnLmsDelete
+    , single csvLmsStaff    MsgCsvColumnLmsStaff
+    ]
+    where
+      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
+      single k v = singletonMap k [whamlet|_{v}|]
+
+
+
+mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
+mkUserTable _sid qsh qid = do  
+  dbtCsvName <- csvFilenameLmsUser qsh
+  let dbtCsvSheetName = dbtCsvName
+  let
+    userDBTable = DBTable{..}
+      where
+        dbtSQLQuery lmsuser = do
+          E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid 
+          return lmsuser
+        dbtRowKey = (E.^. LmsUserId)
+        dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
+        dbtColonnade = dbColonnade $ mconcat
+          [ sortable (Just csvLmsIdent)     (i18nCell MsgTableLmsIdent)    $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident
+          , sortable (Just csvLmsPin)       (i18nCell MsgTableLmsPin)      $ \(view $ _dbrOutput . _entityVal . _lmsUserPin                  -> pin  ) -> textCell pin 
+          , sortable (Just csvLmsResetPin)  (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin             -> reset) -> ifIconCell reset IconReset
+          , sortable (Just csvLmsDelete)    (i18nCell MsgTableLmsDelete)   $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete             -> del  ) -> ifIconCell del   IconRemoveUser
+          , sortable (Just csvLmsStaff)     (i18nCell MsgTableLmsStaff)    $ const mempty
+          ]
+        dbtSorting = Map.fromList
+          [ (csvLmsIdent    , SortColumn $ \lmslist -> lmslist E.^. LmsUserIdent)
+          , (csvLmsResetPin , SortColumn $ \lmslist -> lmslist E.^. LmsUserResetPin)
+          ]
+        dbtFilter = Map.fromList
+          [ (csvLmsIdent    , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent ))
+          , (csvLmsResetPin , FilterColumn $ E.mkExactFilter                 (E.^. LmsUserResetPin))
+          ]
+        dbtFilterUI = \mPrev -> mconcat 
+          [ prismAForm (singletonFilter csvLmsIdent    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)     (fslI MsgTableLmsIdent)
+          , prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsResetPin)
+          ]
+        dbtStyle = def
+        dbtParams = def
+        dbtIdent :: Text
+        dbtIdent = "lms-user"        
+        dbtCsvEncode = Just DBTCsvEncode {..}
+          where 
+            dbtCsvExportForm   = pure ()
+            dbtCsvNoExportData = Just id
+            dbtCsvExampleData  = Nothing
+            dbtCsvHeader       = const $ return lmsUserTableCsvHeader
+            dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
+            doEncode' = LmsUserTableCsv
+              <$> view (_dbrOutput . _entityVal . _lmsUserIdent)
+              <*> view (_dbrOutput . _entityVal . _lmsUserPin)
+              <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool)
+              <*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool)
+              -- <*> const $ LmsBool False
+              <*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool)
+
+        dbtCsvDecode = Nothing
+        dbtExtraReps = []
+
+    userDBTableValidator = def
+      & defaultSorting [SortAscBy csvLmsIdent]
+  dbTable userDBTableValidator userDBTable
+
+getLmsUsersR,  postLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html
+getLmsUsersR = postLmsUsersR
+postLmsUsersR sid qsh = do
+  lmsTable <- runDB $ do 
+    qid <- getKeyBy404 $ UniqueSchoolShort sid qsh 
+    view _2 <$> mkUserTable sid qsh qid 
+  siteLayoutMsg MsgMenuLmsUsers $ do
+    setTitleI MsgMenuLmsUsers
+    $(widgetFile "lms-user")

src/Handler/Utils/LMS.hs

@@ -1,10 +1,18 @@
+{-# OPTIONS -Wno-redundant-constraints #-} -- needed for Getter
+
 module Handler.Utils.LMS
-  ( csvLmsTimestamp
+  ( csvLmsIdent
-  , csvUserlistIdent, csvUserlistBlocked
+  , csvLmsTimestamp
-  , csvResultIdent, csvResultSuccess
+  , csvLmsBlocked
+  , csvLmsSuccess
+  , csvLmsPin     
+  , csvLmsResetPin
+  , csvLmsDelete  
+  , csvLmsStaff   
   , csvFilenameLmsUser 
   , csvFilenameLmsUserlist
-  , csvFilenameLmsResult
+  , csvFilenameLmsResult  
+  , lmsUserToDelete, _lmsUserToDelete
   ) where
 
 -- general utils for LMS Interface Handlers
@@ -12,19 +20,33 @@ module Handler.Utils.LMS
 import Import 
 import Handler.Utils
 
--- Column names 
+-- generic Column names 
+csvLmsIdent   :: IsString a => a
+csvLmsIdent = fromString "user" -- "Benutzerkennung"
+
 csvLmsTimestamp   :: IsString a => a
-csvLmsTimestamp = fromString "Zeitstempel"
+csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel"
 
-csvUserlistIdent   :: IsString a => a
+-- for User Table
-csvUserlistIdent   = fromString "Benutzerkennung"
+csvLmsPin :: IsString a => a
-csvUserlistBlocked :: IsString a => a
+csvLmsPin      = fromString "pin" -- "PIN"
-csvUserlistBlocked = fromString "Sperrung"
 
-csvResultIdent   :: IsString a => a
+csvLmsResetPin :: IsString a => a
-csvResultIdent   = fromString "Benutzerkennung"
+csvLmsResetPin = fromString "reset_pin" -- "PIN zurücksetzen"
-csvResultSuccess :: IsString a => a
+
-csvResultSuccess = fromString "Datum"
+csvLmsDelete :: IsString a => a
+csvLmsDelete   = fromString "delete" -- "Account löschen"
+
+csvLmsStaff :: IsString a => a
+csvLmsStaff    = fromString "staff" -- "Mitarbeiter"
+
+-- for Userlist Table
+csvLmsBlocked :: IsString a => a
+csvLmsBlocked = fromString "blocked" -- "Sperrung"
+
+-- for Result Table
+csvLmsSuccess :: IsString a => a
+csvLmsSuccess = fromString "success" -- "Datum"
 
 
 -- | Filename for User transmission, contains current datestamp as agreed in LMS interface
@@ -47,4 +69,11 @@ makeLmsFilename ftag (citext2lower -> qsh) = do
 
 -- | Return current datetime in YYYYMMDDHH format
 getYMTH :: MonadHandler m => m Text
-getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
+getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
+
+-- | Deceide whether LMS platform should delete an identifier
+lmsUserToDelete :: LmsUser -> Bool 
+lmsUserToDelete LmsUser{lmsUserEnded, lmsUserSuccess} = isNothing lmsUserEnded && isJust lmsUserSuccess
+
+_lmsUserToDelete :: Getter LmsUser Bool 
+_lmsUserToDelete = to lmsUserToDelete

src/Handler/Utils/Table/Cells.hs

@@ -80,6 +80,10 @@ guardAuthCell mkParams = over cellContents $ \act -> do
 iconCell :: IsDBTable m a => Icon -> DBCell m a
 iconCell = cell . toWidget . icon
 
+ifIconCell :: IsDBTable m a => Bool -> Icon -> DBCell m a
+ifIconCell True  = iconCell
+ifIconCell False = const iconSpacerCell
+
 addIconFixedWidth :: IsDBTable m a => DBCell m a -> DBCell m a
 addIconFixedWidth = addCellClass ("icon-fixed-width" :: Text)
 

src/Utils/Icon.hs

@@ -100,6 +100,9 @@ data Icon
   | IconSubmissionUserDuplicate
   | IconNoAllocationUser
   | IconSubmissionNoUsers
+  | IconRemoveUser
+  | IconReset
+  | IconBlocked
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
   deriving anyclass (Universe, Finite, NFData)
 
@@ -143,6 +146,7 @@ iconText = \case
     IconApplyTrue               -> "file-alt"
     IconApplyFalse              -> "trash"
     IconNoCorrectors            -> "user-slash"
+    IconRemoveUser              -> "user-slash"
     IconApplicationVeto         -> "times"
     IconApplicationFiles        -> "file-alt"
     IconTooltipDefault          -> "question-circle"
@@ -183,6 +187,8 @@ iconText = \case
     IconSubmissionUserDuplicate -> "copy"
     IconNoAllocationUser        -> "user-slash"
     IconSubmissionNoUsers       -> "user-slash"
+    IconReset                   -> "undo" -- From fontawesome v6 onwards: "arrow-rotate-left"
+    IconBlocked                 -> "ban"
 
 nullaryPathPiece ''Icon $ camelToPathPiece' 1
 deriveLift ''Icon

templates/lms-user.hamlet

@@ -0,0 +1,2 @@
+LMS User
+^{lmsTable}

templates/lms.hamlet

@@ -1,5 +1,10 @@
 LMS Overview
 
+<ul>
+  <li> <a href=@{LmsUsersR    sid qsh}>Export Users
+  <li> <a href=@{LmsUserlistR sid qsh}>Import Userlist
+  <li> <a href=@{LmsResultR   sid qsh}>Import Result
+
 !!!THIS PAGE IS NOT YET FUNCTIONAL!!!
 
 ^{lmsTable}

test/Database/Fill.hs

@@ -457,14 +457,17 @@ 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
+  _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_f (LmsIdent "opqgrs" ) (addBDays (-2) $ utctDay now) now 
   void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (addBDays (-3) $ utctDay now) 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 "ijk"    ) False now 
+  void . insert' $ LmsUser qid_f jost     (LmsIdent "ijk"    ) "123" False Nothing now Nothing Nothing
+  void . insert' $ LmsUser qid_f svaupel  (LmsIdent "abcdefg") "abc" False (Just True)  now (Just now) Nothing
+  void . insert' $ LmsUser qid_f gkleen   (LmsIdent "hijklmn") "@#!" True  (Just False) now (Just now) Nothing
   let
     sdBsc = StudyDegreeKey' 82
     sdMst = StudyDegreeKey' 88