105 lines
3.0 KiB
Haskell
105 lines
3.0 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Utils.Csv
|
|
( typeCsv, extensionCsv
|
|
, decodeCsv
|
|
, encodeCsv
|
|
, respondCsv, respondCsvDB
|
|
, fileSourceCsv
|
|
, CsvParseError(..)
|
|
, ToNamedRecord(..), FromNamedRecord(..)
|
|
, DefaultOrdered(..)
|
|
, ToField(..), FromField(..)
|
|
, CsvRendered(..)
|
|
, toCsvRendered
|
|
) where
|
|
|
|
import Import hiding (Header)
|
|
|
|
import Data.Csv
|
|
import Data.Csv.Conduit
|
|
|
|
import qualified Data.Conduit.List as C
|
|
import qualified Data.Conduit.Combinators as C (sourceLazy)
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Vector as Vector
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
|
|
|
|
deriving instance Typeable CsvParseError
|
|
instance Exception CsvParseError
|
|
|
|
|
|
typeCsv, typeCsv' :: ContentType
|
|
typeCsv = "text/csv"
|
|
typeCsv' = "text/csv; charset=UTF-8; header=present"
|
|
|
|
extensionCsv :: Extension
|
|
extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ]
|
|
|
|
|
|
decodeCsv :: (MonadThrow m, FromNamedRecord csv) => Conduit ByteString m csv
|
|
decodeCsv = transPipe throwExceptT $ fromNamedCsv defaultDecodeOptions
|
|
|
|
encodeCsv :: ( ToNamedRecord csv
|
|
, DefaultOrdered csv
|
|
, Monad m
|
|
)
|
|
=> Conduit csv m ByteString
|
|
-- ^ Encode a stream of records
|
|
--
|
|
-- Currently not streaming
|
|
encodeCsv = fmap encodeDefaultOrderedByName (C.foldMap pure) >>= C.sourceLazy
|
|
|
|
|
|
respondCsv :: ( ToNamedRecord csv
|
|
, DefaultOrdered csv
|
|
)
|
|
=> Source (HandlerT site IO) csv
|
|
-> HandlerT site IO TypedContent
|
|
respondCsv src = respondSource typeCsv' $ src .| encodeCsv .| awaitForever sendChunk
|
|
|
|
respondCsvDB :: ( ToNamedRecord csv
|
|
, DefaultOrdered csv
|
|
, YesodPersistRunner site
|
|
)
|
|
=> Source (YesodDB site) csv
|
|
-> HandlerT site IO TypedContent
|
|
respondCsvDB src = respondSourceDB typeCsv' $ src .| encodeCsv .| awaitForever sendChunk
|
|
|
|
fileSourceCsv :: ( FromNamedRecord csv
|
|
, MonadResource m
|
|
)
|
|
=> FileInfo
|
|
-> Source m csv
|
|
fileSourceCsv = (.| decodeCsv) . fileSource
|
|
|
|
|
|
data CsvRendered = CsvRendered
|
|
{ csvRenderedHeader :: Header
|
|
, csvRenderedData :: [NamedRecord]
|
|
} deriving (Eq, Read, Show, Generic, Typeable)
|
|
|
|
instance ToWidget UniWorX CsvRendered where
|
|
toWidget CsvRendered{..} = liftWidgetT $(widgetFile "widgets/csvRendered")
|
|
where
|
|
csvData = [ [ decodeUtf8 <$> HashMap.lookup columnKey row
|
|
| columnKey <- Vector.toList csvRenderedHeader
|
|
]
|
|
| row <- csvRenderedData
|
|
]
|
|
|
|
headers = decodeUtf8 <$> Vector.toList csvRenderedHeader
|
|
|
|
toCsvRendered :: forall mono.
|
|
( ToNamedRecord (Element mono)
|
|
, DefaultOrdered (Element mono)
|
|
, MonoFoldable mono
|
|
)
|
|
=> mono -> CsvRendered
|
|
toCsvRendered (otoList -> csvs) = CsvRendered{..}
|
|
where
|
|
csvRenderedHeader = headerOrder (error "not forced" :: Element mono)
|
|
csvRenderedData = map toNamedRecord csvs
|