git.iko.soy/servant
on master help sign in
Merge pull request #11 from anchor/content-types

Content types

commit33279c525d2b0f59c4c08cb0efd099ebf043bb9d authorJulian Arni <jkarni@gmail.com> dateWed 25 Feb 2015, 13:25 (12 years ago) parentfa0ef86da0e1ca
4 files changed+109−74
compare with master
unifiedsplit
servant-client.cabal+3 src/Servant/Client.hs+19−15 src/Servant/Common/Req.hs+42−34 test/Servant/ClientSpec.hs+45−25
servant-client.cabal+3
@@ -45,6 +45,7 @@ library
4545 , exceptions
4646 , http-client
4747 , http-client-tls
48+ , http-media
4849 , http-types
4950 , network-uri >= 2.6
5051 , safe
@@ -70,11 +71,13 @@ test-suite spec
7071 , deepseq
7172 , either
7273 , hspec == 2.*
74+ , http-media
7375 , http-types
7476 , network >= 2.6
7577 , QuickCheck >= 2.7
7678 , servant >= 0.2.1
7779 , servant-client
7880 , servant-server >= 0.2.1
81+ , text
7982 , wai
8083 , warp
src/Servant/Client.hs+19−15
@@ -1,3 +1,4 @@
1+{-# LANGUAGE DataKinds #-}
12{-# LANGUAGE InstanceSigs #-}
23{-# LANGUAGE TypeFamilies #-}
34{-# LANGUAGE TypeOperators #-}
@@ -22,8 +23,10 @@ import Data.Proxy
2223import Data.String.Conversions
2324import Data.Text (unpack)
2425import GHC.TypeLits
26+import Network.HTTP.Media
2527import qualified Network.HTTP.Types as H
2628import Servant.API
29+import Servant.API.ContentTypes
2730import Servant.Common.BaseUrl
2831import Servant.Common.Req
2932import Servant.Common.Text
@@ -115,10 +118,10 @@ instance HasClient Delete where
115118-- side querying function that is created when calling 'client'
116119-- will just require an argument that specifies the scheme, host
117120-- and port to send the request to.
118−instance FromJSON result => HasClient (Get result) where
119− type Client (Get result) = BaseUrl -> EitherT String IO result
121+instance (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
122+ type Client (Get (ct ': cts) result) = BaseUrl -> EitherT String IO result
120123 clientWithRoute Proxy req host =
121− performRequestJSON H.methodGet req 200 host
124+ performRequestCT (Proxy :: Proxy ct) H.methodGet req 200 host
122125
123126-- | If you use a 'Header' in one of your endpoints in your API,
124127-- the corresponding querying function will automatically take
@@ -161,21 +164,21 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
161164-- side querying function that is created when calling 'client'
162165-- will just require an argument that specifies the scheme, host
163166-- and port to send the request to.
164−instance FromJSON a => HasClient (Post a) where
165− type Client (Post a) = BaseUrl -> EitherT String IO a
167+instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
168+ type Client (Post (ct ': cts) a) = BaseUrl -> EitherT String IO a
166169
167170 clientWithRoute Proxy req uri =
168− performRequestJSON H.methodPost req 201 uri
171+ performRequestCT (Proxy :: Proxy ct) H.methodPost req 201 uri
169172
170173-- | If you have a 'Put' endpoint in your API, the client
171174-- side querying function that is created when calling 'client'
172175-- will just require an argument that specifies the scheme, host
173176-- and port to send the request to.
174−instance FromJSON a => HasClient (Put a) where
175− type Client (Put a) = BaseUrl -> EitherT String IO a
177+instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
178+ type Client (Put (ct ': cts) a) = BaseUrl -> EitherT String IO a
176179
177180 clientWithRoute Proxy req host =
178− performRequestJSON H.methodPut req 200 host
181+ performRequestCT (Proxy :: Proxy ct) H.methodPut req 200 host
179182
180183-- | If you use a 'QueryParam' in one of your endpoints in your API,
181184-- the corresponding querying function will automatically take
@@ -411,7 +414,7 @@ instance (KnownSymbol sym, HasClient sublayout)
411414-- | Pick a 'Method' and specify where the server you want to query is. You get
412415-- back the status code and the response body as a 'ByteString'.
413416instance HasClient Raw where
414− type Client Raw = H.Method -> BaseUrl -> EitherT String IO (Int, ByteString)
417+ type Client Raw = H.Method -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType)
415418
416419 clientWithRoute :: Proxy Raw -> Req -> Client Raw
417420 clientWithRoute Proxy req httpMethod host =
@@ -435,15 +438,16 @@ instance HasClient Raw where
435438-- > addBook :: Book -> BaseUrl -> EitherT String IO Book
436439-- > addBook = client myApi
437440-- > -- then you can just use "addBook" to query that endpoint
438−instance (ToJSON a, HasClient sublayout)
439− => HasClient (ReqBody a :> sublayout) where
441+instance (MimeRender ct a, HasClient sublayout)
442+ => HasClient (ReqBody (ct ': cts) a :> sublayout) where
440443
441− type Client (ReqBody a :> sublayout) =
444+ type Client (ReqBody (ct ': cts) a :> sublayout) =
442445 a -> Client sublayout
443446
444447 clientWithRoute Proxy req body =
445− clientWithRoute (Proxy :: Proxy sublayout) $
446− setRQBody (encode body) req
448+ clientWithRoute (Proxy :: Proxy sublayout) $ do
449+ let ctProxy = Proxy :: Proxy ct
450+ setRQBody (toByteString ctProxy body) (contentType ctProxy) req
447451
448452-- | Make the querying function append @path@ to the request path.
449453instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
src/Servant/Common/Req.hs+42−34
@@ -9,19 +9,18 @@ import Control.Monad
99import Control.Monad.Catch (MonadThrow)
1010import Control.Monad.IO.Class
1111import Control.Monad.Trans.Either
12−import Data.Aeson
13−import Data.Aeson.Parser
14−import Data.Aeson.Types
15−import Data.Attoparsec.ByteString
16−import Data.ByteString.Lazy hiding (pack)
12+import Data.ByteString.Lazy hiding (pack, filter, map, null)
1713import Data.String
1814import Data.String.Conversions
19−import Data.Text
15+import Data.Proxy
16+import Data.Text (Text)
2017import Data.Text.Encoding
21−import Network.HTTP.Client
18+import Network.HTTP.Client hiding (Proxy)
2219import Network.HTTP.Client.TLS
20+import Network.HTTP.Media
2321import Network.HTTP.Types
2422import Network.URI
23+import Servant.API.ContentTypes
2524import Servant.Common.BaseUrl
2625import Servant.Common.Text
2726import System.IO.Unsafe
@@ -29,14 +28,15 @@ import System.IO.Unsafe
2928import qualified Network.HTTP.Client as Client
3029
3130data Req = Req
32− { reqPath :: String
33− , qs :: QueryText
34− , reqBody :: ByteString
35− , headers :: [(String, Text)]
31+ { reqPath :: String
32+ , qs :: QueryText
33+ , reqBody :: Maybe (ByteString, MediaType)
34+ , reqAccept :: [MediaType]
35+ , headers :: [(String, Text)]
3636 }
3737
3838defReq :: Req
39−defReq = Req "" [] "" []
39+defReq = Req "" [] Nothing [] []
4040
4141appendToPath :: String -> Req -> Req
4242appendToPath p req =
@@ -62,12 +62,12 @@ addHeader name val req = req { headers = headers req
6262 ++ [(name, toText val)]
6363 }
6464
65−setRQBody :: ByteString -> Req -> Req
66−setRQBody b req = req { reqBody = b }
65+setRQBody :: ByteString -> MediaType -> Req -> Req
66+setRQBody b t req = req { reqBody = Just (b, t) }
6767
6868reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
6969reqToRequest req (BaseUrl reqScheme reqHost reqPort) =
70− fmap (setheaders . setrqb . setQS ) $ parseUrl url
70+ fmap (setheaders . setAccept . setrqb . setQS ) $ parseUrl url
7171
7272 where url = show $ nullURI { uriScheme = case reqScheme of
7373 Http -> "http:"
@@ -80,10 +80,17 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort) =
8080 , uriPath = reqPath req
8181 }
8282
83− setrqb r = r { requestBody = RequestBodyLBS (reqBody req) }
83+ setrqb r = case reqBody req of
84+ Nothing -> r
85+ Just (b,t) -> r { requestBody = RequestBodyLBS b
86+ , requestHeaders = requestHeaders r
87+ ++ [(hContentType, cs . show $ t)] }
8488 setQS = setQueryString $ queryTextToQuery (qs req)
85− setheaders r = r { requestHeaders = Prelude.map toProperHeader (headers req) }
86−
89+ setheaders r = r { requestHeaders = requestHeaders r
90+ <> fmap toProperHeader (headers req) }
91+ setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)
92+ <> [("Accept", renderHeader $ reqAccept req)
93+ | not . null . reqAccept $ req] }
8794 toProperHeader (name, val) =
8895 (fromString name, encodeUtf8 val)
8996
@@ -104,7 +111,7 @@ displayHttpRequest :: Method -> String
104111displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
105112
106113
107−performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString)
114+performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType)
108115performRequest reqMethod req isWantedStatus reqHost = do
109116 partialRequest <- liftIO $ reqToRequest req reqHost
110117
@@ -123,20 +130,28 @@ performRequest reqMethod req isWantedStatus reqHost = do
123130 let status = Client.responseStatus response
124131 unless (isWantedStatus (statusCode status)) $
125132 left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
126− return $ (statusCode status, Client.responseBody response)
133+ ct <- case lookup "Content-Type" $ Client.responseHeaders response of
134+ Nothing -> pure $ "application"//"octet-stream"
135+ Just t -> case parseAccept t of
136+ Nothing -> left $ "invalid Content-Type header: " <> cs t
137+ Just t' -> pure t'
138+ return (statusCode status, Client.responseBody response, ct)
127139 where
128140 showStatus (Status code message) =
129141 show code ++ " - " ++ cs message
130142
131−
132−performRequestJSON :: FromJSON result =>
133− Method -> Req -> Int -> BaseUrl -> EitherT String IO result
134−performRequestJSON reqMethod req wantedStatus reqHost = do
135− (_status, respBody) <- performRequest reqMethod req (== wantedStatus) reqHost
143+performRequestCT :: MimeUnrender ct result =>
144+ Proxy ct -> Method -> Req -> Int -> BaseUrl -> EitherT String IO result
145+performRequestCT ct reqMethod req wantedStatus reqHost = do
146+ let acceptCT = contentType ct
147+ (_status, respBody, respCT) <-
148+ performRequest reqMethod (req { reqAccept = [acceptCT] }) (== wantedStatus) reqHost
149+ unless (matches respCT (acceptCT)) $
150+ left $ "requested Content-Type " <> show acceptCT <> ", but got " <> show respCT
136151 either
137− (\ message -> left (displayHttpRequest reqMethod ++ " returned invalid json: " ++ message))
152+ (left . ((displayHttpRequest reqMethod ++ " returned invalid response of type" ++ show respCT) ++))
138153 return
139− (decodeLenient respBody)
154+ (fromByteString ct respBody)
140155
141156
142157catchStatusCodeException :: IO a -> IO (Either Status a)
@@ -145,10 +160,3 @@ catchStatusCodeException action =
145160 case e of
146161 Client.StatusCodeException status _ _ -> return $ Left status
147162 exc -> throwIO exc
148−
149−-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just
150−-- objects and arrays.
151−decodeLenient :: FromJSON a => ByteString -> Either String a
152−decodeLenient input = do
153− v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)
154− parseEither parseJSON v
test/Servant/ClientSpec.hs+45−25
@@ -3,6 +3,7 @@
33{-# LANGUAGE ViewPatterns #-}
44{-# LANGUAGE DeriveGeneric #-}
55{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE RecordWildCards #-}
67{-# LANGUAGE OverloadedStrings #-}
78{-# OPTIONS_GHC -fcontext-stack=25 #-}
89module Servant.ClientSpec where
@@ -14,9 +15,11 @@ import Data.Aeson
1415import Data.ByteString.Lazy (ByteString)
1516import Data.Char
1617import Data.Foldable (forM_)
18+import Data.Monoid
1719import Data.Proxy
18−import Data.Typeable
20+import qualified Data.Text as T
1921import GHC.Generics
22+import Network.HTTP.Media
2023import Network.HTTP.Types
2124import Network.Socket
2225import Network.Wai
@@ -26,6 +29,7 @@ import Test.Hspec.QuickCheck
2629import Test.QuickCheck
2730
2831import Servant.API
32+import Servant.API.ContentTypes
2933import Servant.Client
3034import Servant.Server
3135
@@ -40,28 +44,43 @@ data Person = Person {
4044instance ToJSON Person
4145instance FromJSON Person
4246
47+instance ToFormUrlEncoded Person where
48+ toFormUrlEncoded Person{..} =
49+ [("name", T.pack name), ("age", T.pack (show age))]
50+
51+lookupEither :: (Show a, Eq a) => a -> [(a,b)] -> Either String b
52+lookupEither x xs = do
53+ maybe (Left $ "could not find key " <> show x) return $ lookup x xs
54+
55+instance FromFormUrlEncoded Person where
56+ fromFormUrlEncoded xs = do
57+ n <- lookupEither "name" xs
58+ a <- lookupEither "age" xs
59+ return $ Person (T.unpack n) (read $ T.unpack a)
60+
61+
4362alice :: Person
4463alice = Person "Alice" 42
4564
4665type Api =
47− "get" :> Get Person
66+ "get" :> Get '[JSON] Person
4867 :<|> "delete" :> Delete
49− :<|> "capture" :> Capture "name" String :> Get Person
50− :<|> "body" :> ReqBody Person :> Post Person
51− :<|> "param" :> QueryParam "name" String :> Get Person
52− :<|> "params" :> QueryParams "names" String :> Get [Person]
53− :<|> "flag" :> QueryFlag "flag" :> Get Bool
54− :<|> "matrixparam" :> MatrixParam "name" String :> Get Person
55− :<|> "matrixparams" :> MatrixParams "name" String :> Get [Person]
56− :<|> "matrixflag" :> MatrixFlag "flag" :> Get Bool
68+ :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
69+ :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
70+ :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
71+ :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
72+ :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
73+ :<|> "matrixparam" :> MatrixParam "name" String :> Get '[JSON] Person
74+ :<|> "matrixparams" :> MatrixParams "name" String :> Get '[JSON] [Person]
75+ :<|> "matrixflag" :> MatrixFlag "flag" :> Get '[JSON] Bool
5776 :<|> "rawSuccess" :> Raw
5877 :<|> "rawFailure" :> Raw
5978 :<|> "multiple" :>
6079 Capture "first" String :>
6180 QueryParam "second" Int :>
6281 QueryFlag "third" :>
63− ReqBody [(String, [Rational])] :>
64− Get (String, Maybe Int, Bool, [(String, [Rational])])
82+ ReqBody '[JSON] [(String, [Rational])] :>
83+ Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
6584api :: Proxy Api
6685api = Proxy
6786
@@ -101,8 +120,8 @@ getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool
101120getMatrixParam :: Maybe String -> BaseUrl -> EitherT String IO Person
102121getMatrixParams :: [String] -> BaseUrl -> EitherT String IO [Person]
103122getMatrixFlag :: Bool -> BaseUrl -> EitherT String IO Bool
104−getRawSuccess :: Method -> BaseUrl -> EitherT String IO (Int, ByteString)
105−getRawFailure :: Method -> BaseUrl -> EitherT String IO (Int, ByteString)
123+getRawSuccess :: Method -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType)
124+getRawFailure :: Method -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType)
106125getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
107126 -> BaseUrl
108127 -> EitherT String IO (String, Maybe Int, Bool, [(String, [Rational])])
@@ -151,6 +170,7 @@ spec = do
151170 it (show flag) $ withServer $ \ host -> do
152171 runEitherT (getQueryFlag flag host) `shouldReturn` Right flag
153172
173+{-
154174 it "Servant.API.MatrixParam" $ withServer $ \ host -> do
155175 runEitherT (getMatrixParam (Just "alice") host) `shouldReturn` Right alice
156176 Left result <- runEitherT (getMatrixParam (Just "bob") host)
@@ -165,12 +185,13 @@ spec = do
165185 forM_ [False, True] $ \ flag ->
166186 it (show flag) $ withServer $ \ host -> do
167187 runEitherT (getMatrixFlag flag host) `shouldReturn` Right flag
188+-}
168189
169190 it "Servant.API.Raw on success" $ withServer $ \ host -> do
170− runEitherT (getRawSuccess methodGet host) `shouldReturn` Right (200, "rawSuccess")
191+ runEitherT (getRawSuccess methodGet host) `shouldReturn` Right (200, "rawSuccess", "application"//"octet-stream")
171192
172193 it "Servant.API.Raw on failure" $ withServer $ \ host -> do
173− runEitherT (getRawFailure methodGet host) `shouldReturn` Right (400, "rawFailure")
194+ runEitherT (getRawFailure methodGet host) `shouldReturn` Right (400, "rawFailure", "application"//"octet-stream")
174195
175196 modifyMaxSuccess (const 20) $ do
176197 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
@@ -183,9 +204,9 @@ spec = do
183204
184205
185206 context "client correctly handles error status codes" $ do
186− let test :: WrappedApi -> Spec
187− test (WrappedApi api) =
188− it (show (typeOf api)) $
207+ let test :: (WrappedApi, String) -> Spec
208+ test (WrappedApi api, desc) =
209+ it desc $
189210 withWaiDaemon (return (serve api (left (500, "error message")))) $
190211 \ host -> do
191212 let getResponse :: BaseUrl -> EitherT String IO ()
@@ -193,16 +214,15 @@ spec = do
193214 Left result <- runEitherT (getResponse host)
194215 result `shouldContain` "error message"
195216 mapM_ test $
196− (WrappedApi (Proxy :: Proxy Delete)) :
197− (WrappedApi (Proxy :: Proxy (Get ()))) :
198− (WrappedApi (Proxy :: Proxy (Post ()))) :
199− (WrappedApi (Proxy :: Proxy (Put ()))) :
217+ (WrappedApi (Proxy :: Proxy Delete), "Delete") :
218+ (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Delete") :
219+ (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Delete") :
220+ (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Delete") :
200221 []
201222
202223data WrappedApi where
203224 WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a,
204− HasClient api, Client api ~ (BaseUrl -> EitherT String IO ()),
205− Typeable api) =>
225+ HasClient api, Client api ~ (BaseUrl -> EitherT String IO ())) =>
206226 Proxy api -> WrappedApi
207227
208228