86 lines
2.5 KiB
Haskell
86 lines
2.5 KiB
Haskell
{-# OPTIONS -fno-warn-orphans #-}
|
|
|
|
module Utils.Csv
|
|
( typeCsv, typeCsv', extensionCsv
|
|
, pathPieceCsv
|
|
, (.:??)
|
|
, CsvRendered(..)
|
|
, toCsvRendered
|
|
, toDefaultOrderedCsvRendered
|
|
) where
|
|
|
|
import ClassyPrelude hiding (lookup)
|
|
import Settings.Mime
|
|
|
|
import Data.Csv hiding (Name)
|
|
import Data.Csv.Conduit (CsvParseError)
|
|
import qualified Data.Csv.Incremental as Incremental
|
|
|
|
import Language.Haskell.TH (Name)
|
|
import Language.Haskell.TH.Lib
|
|
|
|
import Yesod.Core.Content
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
deriving instance Typeable CsvParseError
|
|
instance Exception CsvParseError
|
|
|
|
|
|
typeCsv, typeCsv' :: ContentType
|
|
typeCsv = simpleContentType typeCsv'
|
|
typeCsv' = "text/csv; charset=UTF-8; header=present"
|
|
|
|
extensionCsv :: Extension
|
|
extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ]
|
|
|
|
|
|
pathPieceCsv :: Name -> DecsQ
|
|
pathPieceCsv (conT -> t) =
|
|
[d|
|
|
instance ToField $(t) where
|
|
toField = toField . toPathPiece
|
|
instance FromField $(t) where
|
|
parseField = maybe (fail "Could not unmarshal from PathPiece") return . fromPathPiece <=< parseField
|
|
|]
|
|
|
|
|
|
(.:??) :: FromField (Maybe a) => NamedRecord -> ByteString -> Parser (Maybe a)
|
|
m .:?? name = lookup m name <|> return Nothing
|
|
|
|
|
|
data CsvRendered = CsvRendered
|
|
{ csvRenderedHeader :: Header
|
|
, csvRenderedData :: [NamedRecord]
|
|
} deriving (Eq, Read, Show, Generic, Typeable)
|
|
|
|
instance ToContent CsvRendered where
|
|
toContent CsvRendered{..} = toContent . Incremental.encodeByName csvRenderedHeader $ foldr ((<>) . Incremental.encodeNamedRecord) mempty csvRenderedData
|
|
|
|
instance ToTypedContent CsvRendered where
|
|
toTypedContent = TypedContent
|
|
<$> getContentType . Identity
|
|
<*> toContent
|
|
|
|
instance HasContentType CsvRendered where
|
|
getContentType _ = typeCsv'
|
|
|
|
toCsvRendered :: forall mono.
|
|
( ToNamedRecord (Element mono)
|
|
, MonoFoldable mono
|
|
)
|
|
=> Header
|
|
-> mono -> CsvRendered
|
|
toCsvRendered csvRenderedHeader (otoList -> csvs) = CsvRendered{..}
|
|
where
|
|
csvRenderedData = map toNamedRecord csvs
|
|
|
|
toDefaultOrderedCsvRendered :: forall mono.
|
|
( ToNamedRecord (Element mono)
|
|
, DefaultOrdered (Element mono)
|
|
, MonoFoldable mono
|
|
)
|
|
=> mono -> CsvRendered
|
|
toDefaultOrderedCsvRendered = toCsvRendered $ headerOrder (error "headerOrder" :: Element mono)
|