diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +module Main (main, Foo (..)) where + +import Prelude () +import Prelude.Compat + +import Data.Csv (DefaultOrdered, FromRecord, ToNamedRecord, ToRecord) +import Data.Maybe (fromMaybe) +import GHC.Generics (Generic) +import Network.Wai (Application) +import Servant +import Servant.CSV.Cassava +import System.Environment (getArgs, lookupEnv) +import Text.Read (readMaybe) + +import qualified Network.Wai.Handler.Warp as Warp + +data Foo = Foo + { fooName :: String + , fooNum :: Int + } + deriving (Eq, Show, Generic) + +instance DefaultOrdered Foo +instance FromRecord Foo +instance ToNamedRecord Foo +instance ToRecord Foo + +type API = "post" :> ReqBody '[CSV] [Foo] :> Post '[CSV] [Foo] + :<|> "csv" :> Get '[CSV] [Foo] + :<|> "tsv" :> Get '[CSV' 'NoHeader TabSeparatedOpts] [Foo] + +api :: Proxy API +api = Proxy + +server :: Server API +server = pure :<|> pure [Foo "Csv!" 42] :<|> pure [Foo "Tsv!" 7] + +app :: Application +app = serve api server + +main :: IO () +main = do + args <- getArgs + case args of + ("run":_) -> do + port <- fromMaybe 8000 . (>>= readMaybe) <$> lookupEnv "PORT" + Warp.run port app + _ -> putStrLn "To run, pass run argument" diff --git a/servant-cassava.cabal b/servant-cassava.cabal --- a/servant-cassava.cabal +++ b/servant-cassava.cabal @@ -1,5 +1,5 @@ name: servant-cassava -version: 0.9 +version: 0.10 synopsis: Servant CSV content-type for cassava description: Servant CSV content-type for cassava. homepage: http://haskell-servant.readthedocs.org/ @@ -8,10 +8,15 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2015-2016 Servant Contributors -category: Web +category: Web, Servant, CSV build-type: Simple cabal-version: >=1.10 bug-reports: http://github.com/haskell-servant/servant-cassava/issues +tested-with: + GHC==7.8.4, + GHC==7.10.3, + GHC==8.0.2, + GHC==8.2.1 source-repository head type: git @@ -19,13 +24,32 @@ library exposed-modules: Servant.CSV.Cassava - build-depends: base >=4.6 && <5 + build-depends: base >=4.7 && <5 , base-compat >=0.9.1 && <0.10 , bytestring - , cassava >0.4 && <0.5 - , servant >=0.7 && <0.12 + , cassava >=0.4.3 && <0.6 + , servant >=0.7 && <0.13 , http-media , vector hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + +test-suite example + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + example + ghc-options: -Wall + build-depends: + base + , base-compat + , bytestring + , http-media + , servant + , cassava + , servant-cassava + , servant-server >=0.4.4.5 && <0.13 + , wai >=3.0.3.0 && <3.3 + , warp >=3.0.13.1 && <3.3 + default-language: Haskell2010 diff --git a/src/Servant/CSV/Cassava.hs b/src/Servant/CSV/Cassava.hs --- a/src/Servant/CSV/Cassava.hs +++ b/src/Servant/CSV/Cassava.hs @@ -56,13 +56,16 @@ lowerSHasHeader SHasHeader = HasHeader lowerSHasHeader SNoHeader = NoHeader --- | Default options, instances providing 'defaultDecodeOptions' and 'defaultEncodeOptions'. +-- | Default options, instances providing 'defaultDecodeOptions' and 'defaultEncodeOptions', and content type @text/csv;charset=utf-8@ data DefaultOpts deriving (Typeable, Generic) --- | @text/csv;charset=utf-8@ -instance Accept (CSV' hasHeader opt) where - contentType _ = "text" M.// "csv" M./: ("charset", "utf-8") +-- | Options that work for tab delimited data, with content type @text/tab-separated-values;charset=utf-8@ +data TabSeparatedOpts deriving (Typeable, Generic) +-- | Content type can be determined to coincide with encode opts. +instance EncodeOpts opt => Accept (CSV' hasHeader opt) where + contentType _ = csvContentType (Proxy :: Proxy opt) + -- * Encoding -- ** Instances @@ -114,11 +117,24 @@ where opts = encodeOpts (Proxy :: Proxy opt) --- ** Encode Options +-- ** Encode/Decode Options class EncodeOpts opt where encodeOpts :: Proxy opt -> EncodeOptions + decodeOpts :: Proxy opt -> DecodeOptions + decodeOpts p = DecodeOptions + { decDelimiter = encDelimiter e + } + where + e = encodeOpts p + + csvContentType :: Proxy opt -> M.MediaType + csvContentType p = case encDelimiter (encodeOpts p) of + -- ord '\t' = 9 + 9 -> "text" M.// "tab-separated-values" M./: ("charset", "utf-8") + _ -> "text" M.// "csv" M./: ("charset", "utf-8") + encodeOpts' :: forall opt hasHeader. (EncodeOpts opt, SHasHeaderI hasHeader) => Proxy opt -> Proxy hasHeader -> EncodeOptions @@ -128,43 +144,41 @@ instance EncodeOpts DefaultOpts where encodeOpts _ = defaultEncodeOptions + decodeOpts _ = defaultDecodeOptions +instance EncodeOpts TabSeparatedOpts where + -- ord '\t' = 9 + encodeOpts _ = defaultEncodeOptions { encDelimiter = 9 } + decodeOpts _ = defaultDecodeOptions { decDelimiter = 9 } + + -- * Decoding -- ** Instances -- | Decode with 'decodeByNameWith'. -instance ( FromNamedRecord a, DecodeOpts opt +instance ( FromNamedRecord a, EncodeOpts opt ) => MimeUnrender (CSV' 'HasHeader opt) (Header, [a]) where mimeUnrender _ bs = fmap toList <$> decodeByNameWith (decodeOpts p) bs where p = Proxy :: Proxy opt -- | Decode with 'decodeWith'. -instance ( FromRecord a, DecodeOpts opt, SHasHeaderI hasHeader +instance ( FromRecord a, EncodeOpts opt, SHasHeaderI hasHeader ) => MimeUnrender (CSV' hasHeader opt) [a] where mimeUnrender _ = fmap toList . decodeWith (decodeOpts p) (lowerSHasHeader sh) where p = Proxy :: Proxy opt sh = shasheader :: SHasHeader hasHeader -instance ( FromNamedRecord a, DecodeOpts opt +instance ( FromNamedRecord a, EncodeOpts opt ) => MimeUnrender (CSV' 'HasHeader opt) (Header, Vector a) where mimeUnrender _ = decodeByNameWith (decodeOpts p) where p = Proxy :: Proxy opt -- | Decode with 'decodeWith'. -instance ( FromRecord a, DecodeOpts opt, SHasHeaderI hasHeader +instance ( FromRecord a, EncodeOpts opt, SHasHeaderI hasHeader ) => MimeUnrender (CSV' hasHeader opt) (Vector a) where mimeUnrender _ = decodeWith (decodeOpts p) (lowerSHasHeader sh) where p = Proxy :: Proxy opt sh = shasheader :: SHasHeader hasHeader - - --- ** Decode Options - -class DecodeOpts a where - decodeOpts :: Proxy a -> DecodeOptions - -instance DecodeOpts DefaultOpts where - decodeOpts _ = defaultDecodeOptions