fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Steffen Jost 2022-09-08 18:11:07 +02:00
parent 243d468c98
commit 6159403b27
12 changed files with 107 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
config/settings.yml
View File

@ -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"

3
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -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

3
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -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

10
src/Foundation/Navigation.hs
View File

@ -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 {

13
src/Handler/LMS/Result.hs
View File

@ -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

13
src/Handler/LMS/Userlist.hs
View File

@ -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

20
src/Handler/LMS/Users.hs
View File

@ -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

11
src/Handler/Utils/Csv.hs
View File

@ -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

1
src/Handler/Utils/Form.hs
View File

@ -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)

3
src/Model/Types/Avs.hs
View File

@ -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 --
-------------

38
src/Model/Types/Csv.hs
View File

@ -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

26
src/Settings.hs
View File

@ -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"