refactor(lms): cvs export for qualifcation overview working and clean

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

@@ -13,6 +13,7 @@ TableQualificationValidUntil: Gültig bis
 TableQualificationLastRefresh: Zuletzt erneuert
 TableQualificationFirstHeld: Erstmalig
 TableLmsUser: Ermächtigter
+TableLmsEmail: E-Mail
 TableLmsIdent: Identifikation
 TableLmsElearning: E-Lernen
 TableLmsPin: E-Lernen Pin

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

@@ -13,6 +13,7 @@ TableQualificationValidUntil: Valid until
 TableQualificationLastRefresh: Last renewed
 TableQualificationFirstHeld: First held
 TableLmsUser: Licensee
+TableLmsEmail: Email
 TableLmsIdent: Identifier
 TableLmsPin: E-learning pin
 TableLmsElearning: E-learning

src/Handler/LMS.hs

@@ -26,6 +26,8 @@ import Handler.Utils.LMS
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.Csv as Csv
+import qualified Data.Text as T
+import qualified Data.CaseInsensitive as CI
 import qualified Data.Conduit.List as C
 import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
 import qualified Database.Esqueleto.Legacy as E
@@ -182,9 +184,26 @@ data LmsTableCsv = LmsTableCsv   -- L..T..C.. -> ltc..
   , ltcLmsEnded    :: Maybe UTCTime
   }
   deriving Generic
-
 makeLenses_ ''LmsTableCsv
 
+ltcExample :: LmsTableCsv
+ltcExample = LmsTableCsv 
+    { ltcDisplayName = "Max Mustermann"
+    , ltcEmail       = "m.mustermann@does.not.exist"
+    , ltcValidUntil  = compday
+    , ltcLastRefresh = compday
+    , ltcFirstHeld   = compday
+    , ltcLmsIdent    = Nothing
+    , ltcLmsStatus   = Nothing
+    , ltcLmsStarted  = Nothing
+    , ltcLmsDatePin  = Nothing
+    , ltcLmsReceived = Nothing
+    , ltcLmsEnded    = Nothing
+    }
+  where 
+    compday :: Day 
+    compday = utctDay $compileTime
+
 ltcOptions :: Csv.Options
 ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
   where
@@ -196,44 +215,26 @@ ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
     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 $ 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 ltc = Csv.namedRecord $ lmsTableCsvHeaderList ltc
+  toNamedRecord = Csv.genericToNamedRecord ltcOptions
 
-instance CsvColumnsExplained LmsTableCsv
+instance Csv.DefaultOrdered LmsTableCsv where
-  -- where csvColumnsExplanations _ = ??
+  headerOrder = Csv.genericHeaderOrder ltcOptions  
 
+instance CsvColumnsExplained LmsTableCsv where
+  csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
+    [ ('ltcDisplayName, MsgTableLmsUser)
+    , ('ltcEmail      , MsgTableLmsEmail)
+    , ('ltcValidUntil , MsgTableQualificationValidUntil)
+    , ('ltcLastRefresh, MsgTableQualificationLastRefresh)
+    , ('ltcFirstHeld  , MsgTableQualificationFirstHeld)
+    , ('ltcLmsIdent   , MsgTableLmsIdent)
+    , ('ltcLmsStatus  , MsgTableLmsStatus)
+    , ('ltcLmsStarted , MsgTableLmsStarted)
+    , ('ltcLmsDatePin , MsgTableLmsDatePin)
+    , ('ltcLmsReceived, MsgTableLmsReceived)
+    , ('ltcLmsEnded   , MsgTableLmsEnded)
+    ]
 
 
 type LmsTableExpr = (                   E.SqlExpr (Entity QualificationUser)
@@ -309,19 +310,22 @@ mkLmsTable :: forall h p cols act act'.
               , Ord act, PathPiece act, RenderMessage UniWorX act
               , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool                                        LmsTableData))) cols
               )
-           => Entity Qualification
+           => Entity Qualification           
            -> Map act (AForm Handler act')
            -> (LmsTableExpr -> E.SqlExpr (E.Value Bool))
            -> cols
            -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))
            -> DB (FormResult (act', Set UserId), Widget)
 mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
-  now <- liftIO getCurrentTime
+  now <- liftIO getCurrentTime  
   -- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here
-  let
+  let    
     currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali)
     nowaday = utctDay now
     mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
+    csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
+    dbtIdent :: Text
+    dbtIdent = "qualification"    
     dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q)
     dbtRowKey = queryUser >>> (E.^. UserId)
     dbtProj = dbtProjFilteredPostId
@@ -359,55 +363,30 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
       , if isNothing mbRenewal then mempty
         else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
       ]
-    dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
+    dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }    
-    dbtIdent :: Text
-    dbtIdent = "qualification"
     dbtCsvEncode = Just DBTCsvEncode
       { dbtCsvExportForm   = pure ()
       , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
-      , dbtCsvName         = "TODO" :: Text
+      , dbtCsvName         = csvName
-      , dbtCsvSheetName    = "TODO" :: Text
+      , dbtCsvSheetName    = csvName
       , dbtCsvNoExportData = Just id
-      , dbtCsvHeader       = const $ return lmsTableCsvHeader
+      , dbtCsvHeader       = const $ return $ Csv.headerOrder ltcExample
-      , dbtCsvExampleData  = Nothing -- TODO
+      , dbtCsvExampleData  = Just [ltcExample]
-        {-
-            Just
-          [ LmsTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day }
-          | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..]
-          ]
-          -}
       }
       where
         doEncode' :: LmsTableData -> LmsTableCsv
-        doEncode' ltd = LmsTableCsv {
-            ltcDisplayName = ltd ^.  (resultUser     . _entityVal . _userDisplayName)
-          , ltcEmail       = ltd ^.  (resultUser     . _entityVal . _userEmail)
-          , ltcValidUntil  = ltd ^.  (resultQualUser . _entityVal . _qualificationUserValidUntil)
-          , ltcLastRefresh = ltd ^.  (resultQualUser . _entityVal . _qualificationUserLastRefresh)
-          , ltcFirstHeld   = ltd ^.  (resultQualUser . _entityVal . _qualificationUserFirstHeld)
-          , ltcLmsIdent    = ltd ^?  (resultLmsUser  . _entityVal . _lmsUserIdent)
-          , ltcLmsStatus   = join $ ltd ^?  (resultLmsUser  . _entityVal . _lmsUserStatus)
-          , ltcLmsStarted  = ltd ^?  (resultLmsUser  . _entityVal . _lmsUserStarted)
-          , ltcLmsDatePin  = ltd ^?  (resultLmsUser  . _entityVal . _lmsUserDatePin)
-          , ltcLmsReceived = join $ ltd ^? (resultLmsUser . _entityVal . _lmsUserReceived)
-          , ltcLmsEnded    = join $ ltd ^? (_dbrOutput . _3 . _Just . _entityVal . _lmsUserEnded)
-          }
-
-        {-
         doEncode' = LmsTableCsv
-          <$> view    (resultUser     . _entityVal . _userDisplayName)
+          <$>  view    (resultUser     . _entityVal . _userDisplayName)
-          <*> view    (resultUser     . _entityVal . _userEmail)
+          <*>  view    (resultUser     . _entityVal . _userEmail)
-          <*> view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
+          <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
-          <*> view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)
+          <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)
-          <*> view    (resultQualUser . _entityVal . _qualificationUserFirstHeld)
+          <*>  view    (resultQualUser . _entityVal . _qualificationUserFirstHeld)
-          <*> preview (resultLmsUser  . _entityVal . _lmsUserIdent)
+          <*>  preview (resultLmsUser  . _entityVal . _lmsUserIdent)
-          <*> view    (resultLmsUser  . _entityVal . _lmsUserStatus)
+          <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserStatus))
-          <*> preview (resultLmsUser  . _entityVal . _lmsUserStarted)
+          <*>  preview (resultLmsUser  . _entityVal . _lmsUserStarted)
-          <*> preview (resultLmsUser  . _entityVal . _lmsUserDatePin)
+          <*>  preview (resultLmsUser  . _entityVal . _lmsUserDatePin)
-          <*> view    (resultLmsUser  . _entityVal . _lmsUserReceived)
+          <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserReceived))
-          <*> view    (resultLmsUser  . _entityVal . _lmsUserEnded)
+          <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserEnded))
-        -}
-
     dbtCsvDecode = Nothing
     dbtExtraReps = []
     dbtParams = DBParamsForm
@@ -444,7 +423,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
 getLmsR,  postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
 getLmsR = postLmsR
 postLmsR sid qsh = do
-  currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
+  currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler  
   ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
     qent <- getBy404 $ SchoolQualificationShort sid qsh
     let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)