feat(csv): encoding
This commit is contained in:
parent
38aa292807
commit
81415e1afb
@ -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?
|
||||
ShowSexTip: Sollen in Kursteilnehmer-Tabellen u.Ä. die Geschlechter der Nutzer angezeigt werden?
|
||||
|
||||
33
src/Data/Encoding/Instances.hs
Normal file
33
src/Data/Encoding/Instances.hs
Normal file
@ -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
|
||||
@ -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 ]
|
||||
|
||||
@ -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 ()
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -1,5 +1,12 @@
|
||||
$newline never
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>
|
||||
^{formatGregorianW 2019 10 23}
|
||||
<dd .deflist__dd>
|
||||
<ul>
|
||||
<li>Option um an die Namen aller heruntergeladenen CSV-Dateien einen Zeitstempel vorne anzuhängen
|
||||
<li>CSV-Export-Option um den beim import und export verwendeten Zeichensatz einzustellen
|
||||
|
||||
<dt .deflist__dt>
|
||||
^{formatGregorianW 2019 10 14}
|
||||
<dd .deflist__dd>
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user