feat(lms): configurable csv settings for lms direct import and export routes

config/settings.yml

@@ -125,6 +125,13 @@ ldap:
 
 ldap-re-test-failover: 60
 
+lms:
+  upload-headedness:    "_env:LMSUPLOADHEADEDNESS:true"
+  upload-delimiter:     "_env:LMSUPLOADDELIMITER:,"
+  download-headedness:  "_env:LMSDOWNLOADHEADEDNESS:true"
+  download-delimiter:   "_env:LMSDOWNLOADDELIMITER:,"
+  download-cr-lf:       "_env:LMSDOWNLOADCRLF:true"
+
 avs:
   host:    "_env:AVSHOST:skytest.fra.fraport.de"
   port:    "_env:AVSPORT:443"

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

@@ -130,7 +130,8 @@ MenuLmsUsers: Export E-Lernen Benutzer
 MenuLmsUserlist: Melden E-Lernen Benutzer
 MenuLmsResult: Melden Ergebnisse E-Lernen
 MenuLmsUpload: Hochladen
-MenuLmsDirect: Direkter Upload
+MenuLmsDirectUpload: Direkter Upload
+MenuLmsDirectDownload: Direkter Download
 MenuLmsFake: Testnutzer generieren
 
 MenuAvs: Schnittstelle AVS

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

@@ -131,7 +131,8 @@ MenuLmsUsers: Download E-Learning Users
 MenuLmsUserlist: Upload E-Learning Users
 MenuLmsResult: Upload E-Learning Results
 MenuLmsUpload: Upload
-MenuLmsDirect: Direct Upload
+MenuLmsDirectUpload: Direct Upload
+MenuLmsDirectDownload: Direct Download
 MenuLmsFake: Generate test users
 
 MenuAvs: AVS Interface

src/Foundation/Navigation.hs

@@ -2464,21 +2464,21 @@ pageActions (LmsR sid qsh) = return
   [ NavPageActionPrimary 
     { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh
     , navChildren = 
-        [ defNavLink MsgMenuLmsDirect $ LmsUsersDirectR sid qsh 
+        [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh 
         ]
     }
   , NavPageActionPrimary 
     { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh
     , navChildren = 
-        [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh        
+        [ defNavLink MsgMenuLmsUpload       $ LmsUserlistUploadR sid qsh        
-        , defNavLink MsgMenuLmsDirect $ LmsUserlistDirectR sid qsh        
+        , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh        
         ]
     }
   , NavPageActionPrimary 
     { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh
     , navChildren = 
-        [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh        
+        [ defNavLink MsgMenuLmsUpload       $ LmsResultUploadR sid qsh        
-        , defNavLink MsgMenuLmsDirect $ LmsResultDirectR sid qsh        
+        , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh        
         ]
     }
   , NavPageActionSecondary { 

src/Handler/LMS/Result.hs

@@ -29,9 +29,9 @@ data LmsResultTableCsv = LmsResultTableCsv
   deriving Generic
 makeLenses_ ''LmsResultTableCsv
 
--- csv without headers -- TODO not yet supported
+-- csv without headers
---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
@@ -262,10 +262,15 @@ postLmsResultDirectR sid qsh = do
   (_params, files) <- runRequestBody 
   (status, msg) <- case files of
     [(fhead,file)] -> do
+      LmsConf{..} <- getsYesod $ view _appLmsConf
+      let fmtOpts = def { csvDelimiter     = lmsUploadDelimiter
+                        , csvIncludeHeader = lmsUploadHeadedness
+                        }
+          csvOpts = def { csvFormat = fmtOpts }
       runDBJobs $ do 
         qid <- getKeyBy404 $ SchoolQualificationShort sid qsh 
         enr <- try $ runConduit $ fileSource file
-                .| decodeCsv
+                .| decodeCsvWith csvOpts
                 .| foldMC (saveResultCsv qid) 0
         case enr of 
           Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error

src/Handler/LMS/Userlist.hs

@@ -28,9 +28,9 @@ data LmsUserlistTableCsv = LmsUserlistTableCsv
   deriving Generic
 makeLenses_ ''LmsUserlistTableCsv
 
--- csv without headers -- TODO not yet supported
+-- csv without headers 
---instance Csv.ToRecord   LmsUserlistTableCsv
+instance Csv.ToRecord   LmsUserlistTableCsv
---instance Csv.FromRecord LmsUserlistTableCsv
+instance Csv.FromRecord LmsUserlistTableCsv
 
 -- csv with headers 
 instance DefaultOrdered LmsUserlistTableCsv where 
@@ -258,10 +258,15 @@ postLmsUserlistDirectR sid qsh = do
   (_params, files) <- runRequestBody 
   (status, msg) <- case files of
     [(fhead,file)] -> do
+      LmsConf{..} <- getsYesod $ view _appLmsConf
+      let fmtOpts = def { csvDelimiter     = lmsUploadDelimiter
+                        , csvIncludeHeader = lmsUploadHeadedness
+                        }
+          csvOpts = def { csvFormat = fmtOpts }
       runDBJobs $ do 
         qid <- getKeyBy404 $ SchoolQualificationShort sid qsh 
         enr <- try $ runConduit $ fileSource file
-                .| decodeCsv
+                .| decodeCsvWith csvOpts
                 .| foldMC (saveUserlistCsv qid) 0
         case enr of 
           Left (e :: SomeException) -> do

src/Handler/LMS/Users.hs

@@ -39,9 +39,9 @@ lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv
   , csvLUTstaff     = False              & LmsBool
   }
 
--- csv without headers -- TODO not yet supported
+-- csv without headers 
--- instance Csv.ToRecord   LmsUserTableCsv
+instance Csv.ToRecord   LmsUserTableCsv
--- instance Csv.FromRecord LmsUserTableCsv
+instance Csv.FromRecord LmsUserTableCsv
 
 -- csv with headers 
 lmsUserTableCsvHeader :: Csv.Header
@@ -165,11 +165,19 @@ getLmsUsersDirectR sid qsh = do
           , csvLUTstaff    = LmsBool False
           }
       -} 
-  let csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users      
+  LmsConf{..} <- getsYesod $ view _appLmsConf
-      csvRenderedHeader = lmsUserTableCsvHeader      
+  let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users      
+      --csvRenderedHeader = lmsUserTableCsvHeader      
+      --cvsRendered = CsvRendered {..}
+      csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv . entityVal <$> lms_users
+      fmtOpts = def { csvDelimiter      = lmsDownloadDelimiter
+                    , csvUseCrLf        = lmsDownloadCrLf
+                    , csvIncludeHeader  = lmsDownloadHeadedness
+                    }
+      csvOpts = def { csvFormat = fmtOpts }
   csvSheetName <- csvFilenameLmsUser qsh  
   addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
-  csvRenderedToTypedContent csvSheetName CsvRendered{..}  
+  csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
       
 -- direct Download see:
 -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

src/Handler/Utils/Csv.hs

@@ -1,7 +1,7 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Handler.Utils.Csv
-  ( decodeCsv, decodeCsvPositional
+  ( decodeCsv, decodeCsvPositional, decodeCsvWith
   , encodeCsv, encodeCsvWith, encodeCsvRendered, encodeCsvRenderedWith
   , csvRenderedToTypedContent, csvRenderedToTypedContentWith
   , expectedCsvFormat, expectedCsvContentType
@@ -87,6 +87,15 @@ decodeCsv = decodeCsv' $ \opts -> fromNamedCsvStreamError opts (review _haltingC
 decodeCsvPositional :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromRecord csv) => HasHeader -> ConduitT ByteString csv m ()
 decodeCsvPositional hdr = decodeCsv' $ \opts -> fromCsvStreamError opts hdr (review _haltingCsvParseError) .| throwIncrementalErrors
 
+decodeCsvWith :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromNamedRecord csv, FromRecord csv) => CsvOptions -> ConduitT ByteString csv m ()
+decodeCsvWith opts 
+  | csvIncludeHeader fmtOpts
+    = decodeCsv' $ \_ -> fromNamedCsvStreamError decOpts (review _haltingCsvParseError) .| throwIncrementalErrors
+  | otherwise
+    = decodeCsv' $ \_ -> fromCsvStreamError decOpts NoHeader (review _haltingCsvParseError) .| throwIncrementalErrors
+  where 
+    fmtOpts = csvFormat opts
+    decOpts = DecodeOptions { decDelimiter = fromIntegral $ Char.ord $ csvDelimiter fmtOpts }
 
 decodeCsv' :: forall csv m.
               ( MonadHandler m, HandlerSite m ~ UniWorX

src/Handler/Utils/Form.hs

@@ -2067,6 +2067,7 @@ csvFormatOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs
              <*> apreq (selectField lineEndOpts)   (fslI MsgCsvUseCrLf) (preview _csvUseCrLf =<< mPrev)
              <*> apreq (selectField quoteOpts)     (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (preview _csvQuoting =<< mPrev)
              <*> apreq (selectField encodingOpts)  (fslI MsgCsvEncoding & setTooltip MsgCsvEncodingTip) (preview _csvEncoding =<< mPrev)
+             <*> pure True
       FormatXlsx -> pure CsvXlsxFormatOptions
 
     delimiterOpts :: Handler (OptionList Char)

src/Model/Types/Avs.hs

@@ -61,6 +61,7 @@ data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld
   deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable)
 
 instance ToJSON AvsLicence where
+    -- toJSON al = Number $ fromEnum AvsLicence -- would do, but...
     toJSON AvsNoLicence       = Number 0
     toJSON AvsLicenceVorfeld  = Number 1
     toJSON AvsLicenceRollfeld = Number 2
@@ -229,6 +230,8 @@ deriveJSON defaultOptions
   , rejectUnknownFields = False
   } ''AvsResponsePerson
 
+
+
 -------------
 -- Queries --
 -------------

src/Model/Types/Csv.hs

@@ -60,10 +60,11 @@ data CsvOptions
 
 data CsvFormatOptions
   = CsvFormatOptions
-    { csvDelimiter :: Char
+    { csvDelimiter     :: Char
-    , csvUseCrLf   :: Bool
+    , csvUseCrLf       :: Bool
-    , csvQuoting   :: Csv.Quoting
+    , csvQuoting       :: Csv.Quoting
-    , csvEncoding  :: DynEncoding
+    , csvEncoding      :: DynEncoding
+    , csvIncludeHeader :: Bool
     }
   | CsvXlsxFormatOptions
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
@@ -94,16 +95,18 @@ csvPreset = prism' fromPreset toPreset
   where
     fromPreset :: CsvPreset -> CsvFormatOptions
     fromPreset CsvPresetRFC   = CsvFormatOptions
-      { csvDelimiter = ','
+      { csvDelimiter     = ','
-      , csvUseCrLf   = True
+      , csvUseCrLf       = True
-      , csvQuoting   = QuoteMinimal
+      , csvIncludeHeader = True
-      , csvEncoding  = "UTF8"
+      , csvQuoting       = QuoteMinimal
+      , csvEncoding      = "UTF8"
       }
     fromPreset CsvPresetExcel = CsvFormatOptions
-      { csvDelimiter = ';'
+      { csvDelimiter     = ';'
-      , csvUseCrLf   = True
+      , csvUseCrLf       = True
-      , csvQuoting   = QuoteAll
+      , csvIncludeHeader = True
-      , csvEncoding  = "CP1252"
+      , csvQuoting       = QuoteAll
+      , csvEncoding      = "CP1252"
       }
     fromPreset CsvPresetXlsx = CsvXlsxFormatOptions
 
@@ -119,7 +122,7 @@ _CsvEncodeOptions = prism' fromEncode toEncode
       { Csv.encDelimiter     = fromIntegral $ fromEnum csvDelimiter
       , Csv.encUseCrLf       = csvUseCrLf
       , Csv.encQuoting       = csvQuoting
-      , Csv.encIncludeHeader = True
+      , Csv.encIncludeHeader = csvIncludeHeader
       }
     toEncode CsvXlsxFormatOptions{} = Nothing
     fromEncode encOpts = def
@@ -180,13 +183,14 @@ instance ToJSON CsvFormatOptions where
 instance FromJSON CsvFormatOptions where
   parseJSON = JSON.withObject "CsvFormatOptions" $ \o -> do
     formatTag <- o JSON..:? "format" JSON..!= FormatCsv
-    
+
     case formatTag of
       FormatCsv -> do
         csvDelimiter <- fmap (fmap toEnum) (o JSON..:? "delimiter") JSON..!= csvDelimiter def
-        csvUseCrLf   <- o JSON..:? "use-cr-lf" JSON..!= csvUseCrLf  def
+        csvUseCrLf       <- o JSON..:? "use-cr-lf"       JSON..!= csvUseCrLf       def
-        csvQuoting   <- o JSON..:? "quoting"   JSON..!= csvQuoting  def
+        csvQuoting       <- o JSON..:? "quoting"         JSON..!= csvQuoting       def
-        csvEncoding  <- o JSON..:? "encoding"  JSON..!= csvEncoding def
+        csvEncoding      <- o JSON..:? "encoding"        JSON..!= csvEncoding      def
+        csvIncludeHeader <- o JSON..:? "include-header"  JSON..!= csvIncludeHeader def
         return CsvFormatOptions{..}
       FormatXlsx -> return CsvXlsxFormatOptions
 

src/Settings.hs

@@ -93,6 +93,8 @@ data AppSettings = AppSettings
     -- ^ Configuration settings for accessing the database.
     , appAutoDbMigrate          :: Bool
     , appLdapConf               :: Maybe (PointedList LdapConf)
+    -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System)
+    , appLmsConf                :: LmsConf
     -- ^ Configuration settings for accessing the LDAP-directory
     , appAvsConf                :: Maybe AvsConf
     -- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System)
@@ -301,6 +303,14 @@ data LdapConf = LdapConf
   , ldapPool :: ResourcePoolConf
   } deriving (Show)
 
+data LmsConf = LmsConf
+  { lmsUploadDelimiter    :: Char
+  , lmsUploadHeadedness   :: Bool
+  , lmsDownloadDelimiter  :: Char
+  , lmsDownloadHeadedness :: Bool
+  , lmsDownloadCrLf       :: Bool
+  } deriving (Show)
+
 data AvsConf = AvsConf
   { avsHost :: String
   , avsPort :: Int
@@ -311,7 +321,7 @@ data AvsConf = AvsConf
 data LprConf = LprConf
   { lprHost :: String
   , lprPort :: Int
-  , lprQueue:: String  
+  , lprQueue:: String
   } deriving (Show)
 
 data SmtpConf = SmtpConf
@@ -480,6 +490,17 @@ deriveFromJSON
     }
   ''HaskellNet.AuthType
 
+instance FromJSON LmsConf where
+  parseJSON = withObject "LmsConf" $ \o -> do
+    lmsUploadDelimiter    <- o .: "upload-delimiter"
+    lmsUploadHeadedness   <- o .: "upload-headedness"
+    lmsDownloadDelimiter  <- o .: "download-delimiter"
+    lmsDownloadHeadedness <- o .: "download-headedness"
+    lmsDownloadCrLf       <- o .: "download-cr-lf"
+    return LmsConf{..}
+
+makeLenses_ ''LmsConf
+
 instance FromJSON AvsConf where
   parseJSON = withObject "AvsConf" $ \o -> do
     avsHost <- o .: "host"
@@ -492,7 +513,7 @@ instance FromJSON LprConf where
   parseJSON = withObject "LprConf" $ \o -> do
     lprHost  <- o .: "host"
     lprPort  <- o .: "port"
-    lprQueue <- o .: "queue"    
+    lprQueue <- o .: "queue"
     return LprConf{..}
 
 instance FromJSON SmtpConf where
@@ -576,6 +597,7 @@ instance FromJSON AppSettings where
               Ldap.Tls host _ -> not $ null host
               Ldap.Plain host -> not $ null host
         appLdapConf               <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
+        appLmsConf                <- o .: "lms"
         appAvsConf                <- assertM (not . null . avsPass)  <$> o .:? "avs"
         appLprConf                <- o .: "lpr"
         appSmtpConf               <- assertM (not . null . smtpHost) <$> o .:? "smtp"