chore(lms): full export (WIP)

src/Handler/LMS.hs

@@ -185,39 +185,55 @@ data LmsTableCsv = LmsTableCsv   -- L..T..C.. -> ltc..
 
 makeLenses_ ''LmsTableCsv
 
-lmsTableCsvHeaderList :: [ByteString]
-lmsTableCsvHeaderList =
-  [ "licensee"
-  , "email"
-  , "valid-until"
-  , "last-renewed"
-  , "first-held"
-  , "e-learn-ident"
-  , "e-learn-status"
-  , "e-learn-started"
-  , "e-learn-pin-created"
-  , "e-learn-last-update"
-  , "e-learn-ended"
+ltcOptions :: Csv.Options
+ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
+  where 
+    renameLtc "ltcDisplayName" = "licensee"
+    renameLtc "ltcLmsDatePin"  = prefixLms "pin-created"
+    renameLtc "ltcLmsReceived" = prefixLms "last-update"
+    renameLtc other = replaceLtc $ camelToPathPiece' 1 other
+    replaceLtc ('l':'m':'s':'-':t) = prefixLms t
+    replaceLtc other = other
+    prefixLms = ("e-learn-" <>)
+
+lmsTableCsvHeaderList :: LmsTableCsv ->  [(ByteString, ByteString)]
+lmsTableCsvHeaderList LmsTableCsv{..} =
+  [ "licensee"              Csv..= ltcDisplayName
+  , "email"                 Csv..= ltcEmail
+  , "valid-until"           Csv..= ltcValidUntil
+  , "last-renewed"          Csv..= ltcLastRefresh
+  , "first-held"            Csv..= ltcFirstHeld
+  , "e-learn-ident"         Csv..= ltcLmsIdent
+  , "e-learn-status"        Csv..= ltcLmsStatus
+  , "e-learn-started"       Csv..= ltcLmsStarted
+  , "e-learn-pin-created"   Csv..= ltcLmsDatePin
+  , "e-learn-last-update"   Csv..= ltcLmsReceived
+  , "e-learn-ended"         Csv..= ltcLmsEnded
   ]
 
 lmsTableCsvHeader :: Csv.Header
-lmsTableCsvHeader = Csv.header lmsTableCsvHeaderList
+lmsTableCsvHeader = Csv.header $ fst <$> lmsTableCsvHeaderList (error "lmsTableCsvHeader: this value should never be evaluated")
+{-
+  where dummy = LmsTableCsv { ltcDisplayName = mempty
+                            , ltcEmail       = mempty
+                            , ltcValidUntil  = mempty
+                            , ltcLastRefresh = mempty
+                            , ltcFirstHeld   = mempty
+                            , ltcLmsIdent    = mempty
+                            , ltcLmsStatus   = mempty
+                            , ltcLmsStarted  = mempty
+                            , ltcLmsDatePin  = mempty
+                            , ltcLmsReceived = mempty
+                            , ltcLmsEnded    = mempty
+                            }
+-}
 
 instance Csv.ToNamedRecord LmsTableCsv where 
-  toNamedRecord LmsTableCsv{..} = Csv.namedRecord $ zipWith lmsTableCsvHeaderList lmsTableFields Csv.namedField
-    where lmsTableFields =
-            [ ltcDisplayName
-            , ltcEmail
-            , ltcValidUntil
-            , ltcLastRefresh
-            , ltcFirstHeld
-            , ltcLmsIdent
-            , ltcLmsStatus
-            , ltcLmsStarted
-            , ltcLmsDatePin
-            , ltcLmsReceived
-            , ltcLmsEnded
-            ]
+  toNamedRecord ltc = Csv.namedRecord $ lmsTableCsvHeaderList ltc
+
+instance CsvColumnsExplained LmsTableCsv 
+  -- where csvColumnsExplanations _ = ??
+
 
 
 type LmsTableExpr = (                   E.SqlExpr (Entity QualificationUser)
@@ -349,8 +365,8 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
     dbtCsvEncode = Just DBTCsvEncode
       { dbtCsvExportForm   = pure ()
       , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
-      , dbtCsvName 
-      , dbtCsvSheetName
+      , dbtCsvName         = "TODO" :: Text
+      , dbtCsvSheetName    = "TODO" :: Text 
       , dbtCsvNoExportData = Just id
       , dbtCsvHeader       = const $ return lmsTableCsvHeader
       , dbtCsvExampleData  = Nothing -- TODO
@@ -362,19 +378,21 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
           -}
       }
       where 
-        doEncode' = LmsTableCsv
-          <$> view (resultUser . _entityVal . _userDisplayName)
-          <*> view (resultUser . _entityVal . _userEmail) 
-          <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
-          <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
-          <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
-          <*> preview (resultLmsUser . _entityVal . _lmsUserIdent)
-          <*> preview (resultLmsUser . _entityVal . _lmsUserStatus)
-          <*> preview (resultLmsUser . _entityVal . _lmsUserStarted)
-          <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin)
-          <*> preview (resultLmsUser . _entityVal . _lmsUserReceived)
-          <*> preview (resultLmsUser . _entityVal . _lmsUserEnded)          
-      
+        doEncode' :: LmsTableData -> LmsTableCsv
+        doEncode' = LmsTableCsv 
+          <$> view    (resultUser     . _entityVal . _userDisplayName)
+          <*> view    (resultUser     . _entityVal . _userEmail) 
+          <*> view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
+          <*> view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)
+          <*> view    (resultQualUser . _entityVal . _qualificationUserFirstHeld)
+          <*> preview (resultLmsUser  . _entityVal . _lmsUserIdent)
+          <*> view    (resultLmsUser  . _entityVal . _lmsUserStatus)
+          <*> preview (resultLmsUser  . _entityVal . _lmsUserStarted)
+          <*> preview (resultLmsUser  . _entityVal . _lmsUserDatePin)
+          <*> view    (resultLmsUser  . _entityVal . _lmsUserReceived)
+          <*> view    (resultLmsUser  . _entityVal . _lmsUserEnded)          
+
+
     dbtCsvDecode = Nothing
     dbtExtraReps = []
     dbtParams = DBParamsForm

src/Model/Types/Lms.hs

@@ -49,6 +49,10 @@ deriveJSON  defaultOptions
   } ''LmsStatus
 derivePersistFieldJSON ''LmsStatus
 
+instance Csv.ToField LmsStatus where
+  toField (LmsBlocked d) = "Failure: " <> Csv.toField d
+  toField (LmsSuccess d) = "Success: " <> Csv.toField d
+
 
 -- | LMS interface requires Bool to be encoded by 0 or 1 only
 newtype LmsBool = LmsBool { lms2bool :: Bool }