diff --git a/config/settings.yml b/config/settings.yml index 1da144da9..f9c501645 100644 --- a/config/settings.yml +++ b/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" diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 1c8948184..569028694 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index b0e1779d1..ee8b49b0b 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 419c3de01..33fbaf5f8 100644 --- a/src/Foundation/Navigation.hs +++ b/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 MsgMenuLmsDirect $ LmsUserlistDirectR sid qsh + [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh + , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh ] } , NavPageActionPrimary { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh , navChildren = - [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh - , defNavLink MsgMenuLmsDirect $ LmsResultDirectR sid qsh + [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh + , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh ] } , NavPageActionSecondary { diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 6e7fbc6b2..92c6c4550 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -29,9 +29,9 @@ data LmsResultTableCsv = LmsResultTableCsv deriving Generic makeLenses_ ''LmsResultTableCsv --- csv without headers -- TODO not yet supported ---instance Csv.ToRecord LmsResultTableCsv -- default suffices ---instance Csv.FromRecord LmsResultTableCsv -- default suffices +-- csv without headers +instance Csv.ToRecord 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 diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 2a1a4cf1f..3ef15737e 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -28,9 +28,9 @@ data LmsUserlistTableCsv = LmsUserlistTableCsv deriving Generic makeLenses_ ''LmsUserlistTableCsv --- csv without headers -- TODO not yet supported ---instance Csv.ToRecord LmsUserlistTableCsv ---instance Csv.FromRecord LmsUserlistTableCsv +-- csv without headers +instance Csv.ToRecord 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 diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 57954e912..772f7910a 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -39,9 +39,9 @@ lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv , csvLUTstaff = False & LmsBool } --- csv without headers -- TODO not yet supported --- instance Csv.ToRecord LmsUserTableCsv --- instance Csv.FromRecord LmsUserTableCsv +-- csv without headers +instance Csv.ToRecord 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 - csvRenderedHeader = lmsUserTableCsvHeader + LmsConf{..} <- getsYesod $ view _appLmsConf + 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 \ No newline at end of file diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 813527281..b9581486f 100644 --- a/src/Handler/Utils/Csv.hs +++ b/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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index bb5903487..2c00f2317 100644 --- a/src/Handler/Utils/Form.hs +++ b/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) diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index aca992367..a259654b8 100644 --- a/src/Model/Types/Avs.hs +++ b/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 -- ------------- diff --git a/src/Model/Types/Csv.hs b/src/Model/Types/Csv.hs index ca7ec802b..e6053b6ac 100644 --- a/src/Model/Types/Csv.hs +++ b/src/Model/Types/Csv.hs @@ -60,10 +60,11 @@ data CsvOptions data CsvFormatOptions = CsvFormatOptions - { csvDelimiter :: Char - , csvUseCrLf :: Bool - , csvQuoting :: Csv.Quoting - , csvEncoding :: DynEncoding + { csvDelimiter :: Char + , csvUseCrLf :: Bool + , csvQuoting :: Csv.Quoting + , 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 = ',' - , csvUseCrLf = True - , csvQuoting = QuoteMinimal - , csvEncoding = "UTF8" + { csvDelimiter = ',' + , csvUseCrLf = True + , csvIncludeHeader = True + , csvQuoting = QuoteMinimal + , csvEncoding = "UTF8" } fromPreset CsvPresetExcel = CsvFormatOptions - { csvDelimiter = ';' - , csvUseCrLf = True - , csvQuoting = QuoteAll - , csvEncoding = "CP1252" + { csvDelimiter = ';' + , csvUseCrLf = True + , csvIncludeHeader = True + , 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 - csvQuoting <- o JSON..:? "quoting" JSON..!= csvQuoting def - csvEncoding <- o JSON..:? "encoding" JSON..!= csvEncoding def + csvUseCrLf <- o JSON..:? "use-cr-lf" JSON..!= csvUseCrLf def + csvQuoting <- o JSON..:? "quoting" JSON..!= csvQuoting def + csvEncoding <- o JSON..:? "encoding" JSON..!= csvEncoding def + csvIncludeHeader <- o JSON..:? "include-header" JSON..!= csvIncludeHeader def return CsvFormatOptions{..} FormatXlsx -> return CsvXlsxFormatOptions diff --git a/src/Settings.hs b/src/Settings.hs index 33c2f40ca..6f8b502da 100644 --- a/src/Settings.hs +++ b/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"