From 60087d44b026c706b58bb38f2a5948e90e883b70 Mon Sep 17 00:00:00 2001
From: Steffen Jost <jost@tcs.ifi.lmu.de>
Date: Wed, 23 Feb 2022 17:07:43 +0100
Subject: [PATCH] chore(lms): userlist page csv export added

---
 src/Handler/LMS/Result.hs   |  3 +--
 src/Handler/LMS/Userlist.hs | 47 +++++++++++++++++++++++++++++++++++--
 test/Database/Fill.hs       | 13 ++++++----
 3 files changed, 54 insertions(+), 9 deletions(-)

diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs
index 5aca0ab12..dd8a2a5d8 100644
--- a/src/Handler/LMS/Result.hs
+++ b/src/Handler/LMS/Result.hs
@@ -72,7 +72,7 @@ makeLenses_ ''LmsResultTableCsv
 instance Csv.ToRecord   LmsResultTableCsv -- default suffices
 instance Csv.FromRecord LmsResultTableCsv -- default suffices
 
--- csv with headers
+-- csv with headers -- TODO not yet supported
 lmsResultTableCsvHeader :: Csv.Header
 lmsResultTableCsvHeader = Csv.header [ csvResultIdent, csvResultSuccess ]
 
@@ -88,7 +88,6 @@ instance FromNamedRecord LmsResultTableCsv where
         <$> csv Csv..: csvResultIdent
         <*> csv Csv..: csvResultSuccess
 
-
 instance CsvColumnsExplained LmsResultTableCsv where
   csvColumnsExplanations _ = mconcat
     [ single csvResultIdent     MsgCsvColumnLmsIdent
diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs
index 9a621479f..29721e585 100644
--- a/src/Handler/LMS/Userlist.hs
+++ b/src/Handler/LMS/Userlist.hs
@@ -20,12 +20,46 @@ import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
+data LmsUserlistTableCsv = LmsUserlistTableCsv
+  { csvLULident  :: LmsIdent
+  , csvLULfailed :: Bool 
+  }
+  deriving Generic
+makeLenses_ ''LmsUserlistTableCsv
+
+-- csv without headers -- TODO not yet supported
+instance Csv.ToRecord LmsUserlistTableCsv
+instance Csv.FromRecord LmsUserlistTableCsv
+
+-- csv with headers 
+lmsUserlistTableCsvHeader :: Csv.Header
+lmsUserlistTableCsvHeader = Csv.header [ csvUserlistIdent, csvUserlistBlocked ]
+
+instance ToNamedRecord LmsUserlistTableCsv where 
+  toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord
+    [ csvUserlistIdent    Csv..= csvLULident
+    , csvUserlistBlocked  Csv..= csvLULfailed
+    ]
+instance FromNamedRecord LmsUserlistTableCsv where
+  parseNamedRecord (lsfHeaderTranslate -> csv)
+    = LmsUserlistTableCsv
+        <$> csv Csv..: csvUserlistIdent
+        <*> csv Csv..: csvUserlistBlocked
+
+instance CsvColumnsExplained LmsUserlistTableCsv where
+  csvColumnsExplanations _ = mconcat
+    [ single csvUserlistIdent     MsgCsvColumnLmsIdent
+    , single csvUserlistBlocked   MsgCsvColumnLmsFailed
+    ]
+    where
+      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
+      single k v = singletonMap k [whamlet|_{v}|]
 
 
 mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
 mkUserlistTable _sid qsh qid = do
   dbtCsvName <- csvFilenameLmsUserlist qsh
-  let _dbtCsvSheetName = dbtCsvName
+  let dbtCsvSheetName = dbtCsvName
   let
     userlistTable = DBTable{..}
       where
@@ -56,7 +90,16 @@ mkUserlistTable _sid qsh qid = do
         dbtParams = def
         dbtIdent :: Text
         dbtIdent = "lms-userlist"
-        dbtCsvEncode = noCsvEncode
+        dbtCsvEncode = Just DBTCsvEncode {..}
+          where 
+            dbtCsvExportForm    = pure ()
+            dbtCsvNoExportData  = Just id
+            dbtCsvExampleData   = Nothing 
+            dbtCsvHeader        = const $ return lmsUserlistTableCsvHeader
+            dbtCsvDoEncode      = \() -> C.map (doEncode' . view _2)
+            doEncode' = LmsUserlistTableCsv
+              <$> view (_dbrOutput . _entityVal . _lmsUserlistIdent)
+              <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed)
         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 = []
 
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index 5d8bf71c4..0c5e82d16 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -457,11 +457,14 @@ 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_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" Nothing (Just 24) (Just $ 5 * 12) Nothing False
-  void . insert' $ LmsResult qid_r (LmsIdent "hijklmn") (addBDays (-1) $ 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 
+  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_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 
   let
     sdBsc = StudyDegreeKey' 82
     sdMst = StudyDegreeKey' 88