From 81415e1afb02126a40bb1979ad4c039fd9cccb58 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 23 Oct 2019 17:34:37 +0200 Subject: [PATCH] feat(csv): encoding --- messages/uniworx/de.msg | 11 ++- src/Data/Encoding/Instances.hs | 33 ++++++++ src/Handler/Profile.hs | 2 +- src/Handler/Utils/Csv.hs | 75 ++++++++++++++---- src/Handler/Utils/Form.hs | 69 ++++++++++------- src/Handler/Utils/Table/Pagination.hs | 3 +- src/Import/NoModel.hs | 4 + src/Jobs/Handler/SendCourseCommunication.hs | 3 +- src/Model/Types/Misc.hs | 85 +++++++++++++++++---- templates/i18n/changelog/de.hamlet | 7 ++ test/Database.hs | 4 +- test/Model/TypesSpec.hs | 12 ++- 12 files changed, 242 insertions(+), 66 deletions(-) create mode 100644 src/Data/Encoding/Instances.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index aef920e2b..7733ef300 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1879,7 +1879,10 @@ AcceptApplicationsSecondaryRandom: Zufällig AcceptApplicationsSecondaryTime: Nach Zeitpunkt der Bewerbung CsvOptions: CSV-Optionen -CsvOptionsTip: Diese Einstellungen betreffen nur den CSV-Export; beim Import werden die verwendeten Einstellungen automatisch ermittelt. +CsvOptionsTip: Diese Einstellungen betreffen nur den CSV-Export; beim Import werden die verwendeten Einstellungen automatisch ermittelt. Als Zeichenkodierung wird beim Import stets Unicode erwartet. +CsvFormatOptions: Dateiformat +CsvTimestamp: Zeitstempel +CsvTimestampTip: Soll an den Namen jeder exportierten CSV-Datei ein Zeitstempel vorne angehängt werden? CsvPresetRFC: Standard-Konform (RFC 4180) CsvPresetExcel: Excel-Kompatibel CsvCustom: Benutzerdefiniert @@ -1887,6 +1890,10 @@ CsvDelimiter: Trennzeichen CsvUseCrLf: Zeilenumbrüche CsvQuoting: Quoting CsvQuotingTip: Wann sollen Anführungszeichen (") um Felder platziert werden, um Interpretation von im Feld enthaltenen Zeichen als Trennzeichen zu verhindern? +CsvEncoding: Encoding +CsvEncodingTip: CSV-Dateien können in einer anderen Zeichenkodierung als dem vom System standardmäßig verwendeten UTF-8 exportiert werden. Beachten Sie dass es bei nicht-UTF-8 Zeichenkodierungen wmgl. zu Darstellungsproblemen mit Sonderzeichen kommt. +CsvUTF8: UTF-8 (Unicode) +CsvCP1252: Windows CP-1252 ("ANSI") CsvDelimiterNull: Null-Byte CsvDelimiterTab: Tabulator CsvDelimiterComma: Komma @@ -1979,4 +1986,4 @@ ShortSexFemale: w ShortSexNotApplicable: k.A. ShowSex: Geschlechter anderer Nutzer anzeigen -ShowSexTip: Sollen in Kursteilnehmer-Tabellen u.Ä. die Geschlechter der Nutzer angezeigt werden? \ No newline at end of file +ShowSexTip: Sollen in Kursteilnehmer-Tabellen u.Ä. die Geschlechter der Nutzer angezeigt werden? diff --git a/src/Data/Encoding/Instances.hs b/src/Data/Encoding/Instances.hs new file mode 100644 index 000000000..ee73551fb --- /dev/null +++ b/src/Data/Encoding/Instances.hs @@ -0,0 +1,33 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Encoding.Instances + ( + ) where + +import ClassyPrelude +import Utils.PathPiece +import Data.String (IsString(..)) +import Text.Read + +import Web.PathPieces + +import Data.Encoding + + +instance PathPiece DynEncoding where + toPathPiece = showToPathPiece + fromPathPiece = encodingFromStringExplicit . unpack + +pathPieceJSON ''DynEncoding + + +instance IsString DynEncoding where + fromString = encodingFromString +instance Read DynEncoding where + readPrec = parens $ lexP >>= \case + Ident str -> maybe (fail "Could not parse encoding") return $ encodingFromStringExplicit str + _ -> fail "Ident lexeme expected" + + +instance Ord DynEncoding where + compare = comparing show diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index fbb3093cf..164d575c2 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -822,7 +822,7 @@ postCsvOptionsR = do Entity uid User{userCsvOptions} <- requireAuth ((optionsRes, optionsWgt'), optionsEnctype) <- runFormPost . renderAForm FormStandard $ - csvOptionsForm (fslI MsgCsvOptions & setTooltip MsgCsvOptionsTip) (Just userCsvOptions) + csvOptionsForm (Just userCsvOptions) formResultModal optionsRes CsvOptionsR $ \opts -> do lift . runDB $ update uid [ UserCsvOptions =. opts ] diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index b13e2c0e3..13ea6546c 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -2,11 +2,13 @@ module Handler.Utils.Csv ( decodeCsv, decodeCsvPositional + , timestampCsv , encodeCsv , encodeDefaultOrderedCsv , respondCsv, respondCsvDB , respondDefaultOrderedCsv, respondDefaultOrderedCsvDB , fileSourceCsv + , partIsAttachmentCsv , CsvParseError(..) , ToNamedRecord(..), FromNamedRecord(..) , DefaultOrdered(..) @@ -37,24 +39,42 @@ import qualified Data.Attoparsec.ByteString.Lazy as A import Control.Monad.Except (ExceptT) +import Handler.Utils.DateTime +import Data.Time.Format (iso8601DateFormat) -decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => ConduitT ByteString csv m () + +decodeCsv :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromNamedRecord csv) => ConduitT ByteString csv m () decodeCsv = decodeCsv' fromNamedCsv -decodeCsvPositional :: (MonadThrow m, FromRecord csv, MonadLogger m) => HasHeader -> ConduitT ByteString csv m () +decodeCsvPositional :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromRecord csv) => HasHeader -> ConduitT ByteString csv m () decodeCsvPositional hdr = decodeCsv' (`fromCsv` hdr) -decodeCsv' :: (MonadThrow m, MonadLogger m) => (forall m'. Monad m' => DecodeOptions -> ConduitT ByteString csv (ExceptT CsvParseError m') ()) -> ConduitT ByteString csv m () -decodeCsv' fromCsv' = transPipe throwExceptT $ do - testBuffer <- accumTestBuffer LBS.empty - mapM_ leftover $ LBS.toChunks testBuffer +decodeCsv' :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => (forall m'. Monad m' => DecodeOptions -> ConduitT ByteString csv (ExceptT CsvParseError m') ()) -> ConduitT ByteString csv m () +decodeCsv' fromCsv' = do + encOpts <- maybe def (userCsvOptions . entityVal) <$> lift maybeAuth - let decodeOptions = defaultDecodeOptions - & guessDelimiter testBuffer - $logInfoS "decodeCsv" [st|Guessed Csv.DecodeOptions from buffer of size #{tshow (LBS.length testBuffer)}/#{tshow testBufferSize}: #{tshow decodeOptions}|] - - fromCsv' decodeOptions + let + recode' + | enc == "UTF8" + = id + | otherwise + = \act -> do + inp <- sinkLazy + let inp' = encodeLazyByteString UTF8 $ decodeLazyByteString enc inp + sourceLazy inp' .| act + where enc = encOpts ^. _csvFormat . _csvEncoding + + recode' decodeCsv'' where + decodeCsv'' = transPipe throwExceptT $ do + testBuffer <- accumTestBuffer LBS.empty + mapM_ leftover $ LBS.toChunks testBuffer + + let decodeOptions = defaultDecodeOptions + & guessDelimiter testBuffer + $logInfoS "decodeCsv" [st|Guessed Csv.DecodeOptions from buffer of size #{tshow (LBS.length testBuffer)}/#{tshow testBufferSize}: #{tshow decodeOptions}|] + + fromCsv' decodeOptions testBufferSize = 4096 accumTestBuffer acc | LBS.length acc >= testBufferSize = return acc @@ -115,8 +135,33 @@ encodeCsv :: ( ToNamedRecord csv -- -- Currently not streaming encodeCsv hdr = do - csvOpts <- fmap (maybe def (userCsvOptions . entityVal)) . lift $ liftHandler maybeAuth - fmap (encodeByNameWith (csvOpts ^. _CsvEncodeOptions) hdr) (C.foldMap pure) >>= C.sourceLazy + csvOpts <- maybe def (userCsvOptions . entityVal) <$> lift maybeAuth + let recode' + | enc == "UTF8" + = id + | otherwise + = encodeLazyByteString enc . decodeLazyByteString UTF8 + where enc = csvOpts ^. _csvFormat . _csvEncoding + fmap (encodeByNameWith (csvOpts ^. _csvFormat . _CsvEncodeOptions) hdr) (C.foldMap pure) >>= C.sourceLazy . recode' + +timestampCsv :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => m (FilePath -> FilePath) +timestampCsv = do + csvOpts <- maybe def (userCsvOptions . entityVal) <$> maybeAuth + if + | csvOpts ^. _csvTimestamp -> do + ts <- formatTime' (iso8601DateFormat $ Just "%H%M") =<< liftIO getCurrentTime + return $ (<>) (unpack ts <> "-") + | otherwise -> return id + +partIsAttachmentCsv :: (Textual t, MonadMail m, HandlerSite m ~ UniWorX) + => t + -> StateT Part m () +partIsAttachmentCsv (repack -> fName) = do + ts <- timestampCsv + partIsAttachment . ts $ fName `addExtension` unpack extensionCsv encodeDefaultOrderedCsv :: forall csv m. ( ToNamedRecord csv @@ -157,9 +202,9 @@ respondDefaultOrderedCsvDB :: forall csv. respondDefaultOrderedCsvDB = respondCsvDB $ headerOrder (error "headerOrder" :: csv) fileSourceCsv :: ( FromNamedRecord csv - , MonadResource m - , MonadLogger m , MonadThrow m + , MonadHandler m + , HandlerSite m ~ UniWorX ) => FileInfo -> ConduitT () csv m () diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 9f132d2dd..27c243555 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1201,42 +1201,43 @@ examPassedField :: forall m. examPassedField = hoistField liftHandler $ selectField optionsFinite -data CsvOptions' = CsvOptionsPreset' CsvPreset - | CsvOptionsCustom' +data CsvFormatOptions' = CsvFormatOptionsPreset' CsvPreset + | CsvFormatOptionsCustom' deriving (Eq, Ord, Read, Show, Generic, Typeable) -deriveFinite ''CsvOptions' -instance PathPiece CsvOptions' where +deriveFinite ''CsvFormatOptions' +instance PathPiece CsvFormatOptions' where toPathPiece = \case - CsvOptionsPreset' p -> toPathPiece p - CsvOptionsCustom' -> "custom" + CsvFormatOptionsPreset' p -> toPathPiece p + CsvFormatOptionsCustom' -> "custom" fromPathPiece t = fromPathPiece t - <|> guardOn (t == "custom") CsvOptionsCustom' -instance RenderMessage UniWorX CsvOptions' where + <|> guardOn (t == "custom") CsvFormatOptionsCustom' +instance RenderMessage UniWorX CsvFormatOptions' where renderMessage m ls = \case - CsvOptionsPreset' p -> mr p - CsvOptionsCustom' -> mr MsgCsvCustom + CsvFormatOptionsPreset' p -> mr p + CsvFormatOptionsCustom' -> mr MsgCsvCustom where mr :: forall msg. RenderMessage UniWorX msg => msg -> Text mr = renderMessage m ls -csvOptionsForm :: forall m. - ( MonadHandler m - , HandlerSite m ~ UniWorX - ) - => FieldSettings UniWorX - -> Maybe CsvOptions - -> AForm m CsvOptions -csvOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs $ classifyCsvOptions <$> mPrev +csvFormatOptionsForm :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => FieldSettings UniWorX + -> Maybe CsvFormatOptions + -> AForm m CsvFormatOptions +csvFormatOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs $ classifyCsvFormatOptions <$> mPrev where - csvActs :: Map CsvOptions' (AForm Handler CsvOptions) + csvActs :: Map CsvFormatOptions' (AForm Handler CsvFormatOptions) csvActs = mapF $ \case - CsvOptionsPreset' preset + CsvFormatOptionsPreset' preset -> pure $ csvPreset # preset - CsvOptionsCustom' - -> CsvOptions + CsvFormatOptionsCustom' + -> CsvFormatOptions <$> areq (selectField delimiterOpts) (fslI MsgCsvDelimiter) (csvDelimiter <$> mPrev) <*> areq (selectField lineEndOpts) (fslI MsgCsvUseCrLf) (csvUseCrLf <$> mPrev) <*> areq (selectField quoteOpts) (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (csvQuoting <$> mPrev) + <*> areq (selectField encodingOpts) (fslI MsgCsvEncoding & setTooltip MsgCsvEncodingTip) (csvEncoding <$> mPrev) delimiterOpts :: Handler (OptionList Char) delimiterOpts = do @@ -1274,9 +1275,25 @@ csvOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs $ cla , QuoteAll ] - classifyCsvOptions :: CsvOptions -> CsvOptions' - classifyCsvOptions opts + encodingOpts :: Handler (OptionList DynEncoding) + encodingOpts = optionsPathPiece + [ (MsgCsvUTF8, "UTF8") + , (MsgCsvCP1252, "CP1252") + ] + + classifyCsvFormatOptions :: CsvFormatOptions -> CsvFormatOptions' + classifyCsvFormatOptions opts | Just preset <- opts ^? csvPreset - = CsvOptionsPreset' preset + = CsvFormatOptionsPreset' preset | otherwise - = CsvOptionsCustom' + = CsvFormatOptionsCustom' + +csvOptionsForm :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => Maybe CsvOptions + -> AForm m CsvOptions +csvOptionsForm mPrev = hoistAForm liftHandler $ CsvOptions + <$> csvFormatOptionsForm (fslI MsgCsvFormatOptions & setTooltip MsgCsvOptionsTip) (csvFormat <$> mPrev) + <*> apopt checkBoxField (fslI MsgCsvTimestamp & setTooltip MsgCsvTimestampTip) (csvTimestamp <$> mPrev) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index cf7543204..89a6eeec1 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -985,7 +985,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , Just exportData <- fromDynamic dbCsvExportData -> do hdr <- dbtCsvHeader $ Just exportData let ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName - setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName + dbtCsvName' <- timestampCsv <*> pure dbtCsvName + setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName' sendResponse <=< liftHandler . respondCsvDB hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave DBCsvImport{..} | Just DBTCsvEncode{..} <- dbtCsvEncode diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index ec4e44c34..eeef7957f 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -151,6 +151,7 @@ import Data.Void.Instances as Import () import Crypto.Hash.Instances as Import () import Colonnade.Instances as Import () import Data.Bool.Instances as Import () +import Data.Encoding.Instances as Import () import Control.Lens as Import hiding ( (<.>) @@ -163,6 +164,9 @@ import Data.Set.Lens as Import import Control.Arrow as Import (Kleisli(..)) +import Data.Encoding as Import (DynEncoding, decodeLazyByteString, encodeLazyByteString) +import Data.Encoding.UTF8 as Import (UTF8(UTF8)) + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index 0f05d72a1..e3ad496b2 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -7,6 +7,7 @@ import Import import Handler.Utils import qualified Data.CaseInsensitive as CI +import Handler.Utils.Csv (partIsAttachmentCsv) dispatchJobSendCourseCommunication :: Either UserEmail UserId @@ -32,5 +33,5 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours void $ addPart jMailContent when (jRecipientEmail == Right jSender) $ addPart' $ do - partIsAttachment $ unpack (mr MsgCommAllRecipients) `addExtension` unpack extensionCsv + partIsAttachmentCsv $ mr MsgCommAllRecipients toMailPart (toDefaultOrderedCsvRendered jAllRecipientAddresses, userCsvOptions sender) diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 4dc1c899e..00b5a93e5 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -17,6 +17,8 @@ import Data.Maybe (fromJust) import qualified Data.Text as Text import qualified Data.Text.Lens as Text +import qualified Data.ByteString.Lazy as LBS + import Data.Csv (Quoting(..)) import qualified Data.Csv as Csv @@ -24,6 +26,8 @@ import qualified Data.Aeson as JSON import Database.Persist.Sql (PersistFieldSql(..)) +import Utils.Lens.TH + data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) @@ -68,13 +72,30 @@ nullaryPathPiece ''Quoting $ \q -> if data CsvOptions = CsvOptions - { csvDelimiter :: Char - , csvUseCrLf :: Bool - , csvQuoting :: Csv.Quoting + { csvFormat :: CsvFormatOptions + , csvTimestamp :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) +data CsvFormatOptions + = CsvFormatOptions + { csvDelimiter :: Char + , csvUseCrLf :: Bool + , csvQuoting :: Csv.Quoting + , csvEncoding :: DynEncoding + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +makeLenses_ ''CsvOptions +makeLenses_ ''CsvFormatOptions + instance Default CsvOptions where + def = CsvOptions + { csvFormat = def + , csvTimestamp = False + } + +instance Default CsvFormatOptions where def = csvPreset # CsvPresetRFC data CsvPreset = CsvPresetRFC @@ -83,28 +104,38 @@ data CsvPreset = CsvPresetRFC instance Universe CsvPreset instance Finite CsvPreset -csvPreset :: Prism' CsvOptions CsvPreset +csvPreset :: Prism' CsvFormatOptions CsvPreset csvPreset = prism' fromPreset toPreset where - fromPreset :: CsvPreset -> CsvOptions - fromPreset CsvPresetRFC = CsvOptions { csvDelimiter = ',', csvUseCrLf = True, csvQuoting = QuoteMinimal } - fromPreset CsvPresetExcel = CsvOptions { csvDelimiter = ';', csvUseCrLf = True, csvQuoting = QuoteAll } + fromPreset :: CsvPreset -> CsvFormatOptions + fromPreset CsvPresetRFC = CsvFormatOptions + { csvDelimiter = ',' + , csvUseCrLf = True + , csvQuoting = QuoteMinimal + , csvEncoding = "UTF8" + } + fromPreset CsvPresetExcel = CsvFormatOptions + { csvDelimiter = ';' + , csvUseCrLf = True + , csvQuoting = QuoteAll + , csvEncoding = "CP1252" + } - toPreset :: CsvOptions -> Maybe CsvPreset + toPreset :: CsvFormatOptions -> Maybe CsvPreset toPreset opts = case filter (\p -> fromPreset p == opts) universeF of [p] -> Just p _other -> Nothing -_CsvEncodeOptions :: Iso' CsvOptions Csv.EncodeOptions +_CsvEncodeOptions :: Iso' CsvFormatOptions Csv.EncodeOptions _CsvEncodeOptions = iso toEncode fromEncode where - toEncode CsvOptions{..} = Csv.defaultEncodeOptions + toEncode CsvFormatOptions{..} = Csv.defaultEncodeOptions { Csv.encDelimiter = fromIntegral $ fromEnum csvDelimiter , Csv.encUseCrLf = csvUseCrLf , Csv.encQuoting = csvQuoting , Csv.encIncludeHeader = True } - fromEncode encOpts = CsvOptions + fromEncode encOpts = def { csvDelimiter = toEnum . fromIntegral $ Csv.encDelimiter encOpts , csvUseCrLf = Csv.encUseCrLf encOpts , csvQuoting = Csv.encQuoting encOpts @@ -112,16 +143,31 @@ _CsvEncodeOptions = iso toEncode fromEncode instance ToJSON CsvOptions where toJSON CsvOptions{..} = JSON.object + [ "format" JSON..= csvFormat + , "timestamp" JSON..= csvTimestamp + ] + +instance FromJSON CsvOptions where + parseJSON = JSON.withObject "CsvOptions" $ \o -> do + csvFormat <- o JSON..:? "format" JSON..!= csvFormat def + csvTimestamp <- o JSON..:? "timestamp" JSON..!= csvTimestamp def + return CsvOptions{..} + +instance ToJSON CsvFormatOptions where + toJSON CsvFormatOptions{..} = JSON.object [ "delimiter" JSON..= fromEnum csvDelimiter , "use-cr-lf" JSON..= csvUseCrLf , "quoting" JSON..= csvQuoting + , "encoding" JSON..= csvEncoding ] -instance FromJSON CsvOptions where - parseJSON = JSON.withObject "CsvOptions" $ \o -> do +instance FromJSON CsvFormatOptions where + parseJSON = JSON.withObject "CsvFormatOptions" $ \o -> 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 - return CsvOptions{..} + csvEncoding <- o JSON..:? "encoding" JSON..!= csvEncoding def + return CsvFormatOptions{..} + derivePersistFieldJSON ''CsvOptions nullaryPathPiece ''CsvPreset $ camelToPathPiece' 2 @@ -130,7 +176,16 @@ instance YesodMail site => ToMailPart site (CsvRendered, CsvOptions) where toMailPart (CsvRendered{..}, encOpts) = do _partType .= decodeUtf8 typeCsv' _partEncoding .= QuotedPrintableText - _partContent .= Csv.encodeByNameWith (encOpts ^. _CsvEncodeOptions) csvRenderedHeader csvRenderedData + _partContent .= recode' (Csv.encodeByNameWith (encOpts ^. _csvFormat . _CsvEncodeOptions) csvRenderedHeader csvRenderedData) + where + recode' :: LBS.ByteString -> LBS.ByteString + recode' + | enc == "UTF8" + = id + | otherwise + = encodeLazyByteString enc . decodeLazyByteString UTF8 + where enc = encOpts ^. _csvFormat . _csvEncoding + instance YesodMail site => ToMailPart site CsvRendered where toMailPart = toMailPart . (, def :: CsvOptions) diff --git a/templates/i18n/changelog/de.hamlet b/templates/i18n/changelog/de.hamlet index c31cab31d..e991eb104 100644 --- a/templates/i18n/changelog/de.hamlet +++ b/templates/i18n/changelog/de.hamlet @@ -1,5 +1,12 @@ $newline never
+
+ ^{formatGregorianW 2019 10 23} +
+
    +
  • Option um an die Namen aller heruntergeladenen CSV-Dateien einen Zeitstempel vorne anzuhängen +
  • CSV-Export-Option um den beim import und export verwendeten Zeichensatz einzustellen +
    ^{formatGregorianW 2019 10 14}
    diff --git a/test/Database.hs b/test/Database.hs index a3ca55a07..825886ffe 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -112,7 +112,7 @@ fillDb = do , userNotificationSettings = def , userCreated = now , userLastLdapSynchronisation = Nothing - , userCsvOptions = csvPreset # CsvPresetRFC + , userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC } , userSex = Just SexMale , userShowSex = userDefaultShowSex } @@ -140,7 +140,7 @@ fillDb = do , userNotificationSettings = def , userCreated = now , userLastLdapSynchronisation = Nothing - , userCsvOptions = csvPreset # CsvPresetExcel + , userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel } , userSex = Just SexMale , userShowSex = userDefaultShowSex } diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index f5f7d2efd..df7407558 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -31,7 +31,7 @@ import Web.PathPieces import qualified Data.Csv as Csv import Data.Scientific -import Utils.Lens +import Utils.Lens hiding (elements) import qualified Data.Char as Char @@ -257,11 +257,12 @@ instance Arbitrary Quoting where arbitrary = genericArbitrary shrink = genericShrink -instance Arbitrary CsvOptions where - arbitrary = CsvOptions +instance Arbitrary CsvFormatOptions where + arbitrary = CsvFormatOptions <$> suchThat arbitrary validDelimiter <*> arbitrary <*> arbitrary + <*> elements ["UTF8", "CP1252"] where validDelimiter c = and [ Char.isLatin1 c @@ -269,6 +270,11 @@ instance Arbitrary CsvOptions where , c /= '\r' , c /= '\n' ] + +instance Arbitrary CsvOptions where + arbitrary = CsvOptions + <$> arbitrary + <*> arbitrary shrink = genericShrink instance Arbitrary CsvPreset where