From 7a1eac4e8662c41f279f447c7a44f3a8974c7581 Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Tue, 17 Feb 2015 10:05:39 +1100 Subject: [PATCH 01/10] Correctly set the content type for ReqBody --- servant-client.cabal | 1 + src/Servant/Client.hs | 3 ++- src/Servant/Common/Req.hs | 18 ++++++++++++------ 3 files changed, 15 insertions(+), 7 deletions(-) diff --git a/servant-client.cabal b/servant-client.cabal index 2b17dc21..b27e5bc2 100644 --- a/servant-client.cabal +++ b/servant-client.cabal @@ -45,6 +45,7 @@ library , exceptions , http-client , http-client-tls + , http-media , http-types , network-uri >= 2.6 , safe diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs index 6a0f4f6b..69a8d71d 100644 --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -22,6 +22,7 @@ import Data.Proxy import Data.String.Conversions import Data.Text (unpack) import GHC.TypeLits +import Network.HTTP.Media import qualified Network.HTTP.Types as H import Servant.API import Servant.Common.BaseUrl @@ -443,7 +444,7 @@ instance (ToJSON a, HasClient sublayout) clientWithRoute Proxy req body = clientWithRoute (Proxy :: Proxy sublayout) $ - setRQBody (encode body) req + setRQBody (encode body) ("application" // "json" /: ("charset", "utf-8")) req -- | Make the querying function append @path@ to the request path. instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index da85c02a..0e8cf1c6 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -14,12 +14,14 @@ import Data.Aeson.Parser import Data.Aeson.Types import Data.Attoparsec.ByteString import Data.ByteString.Lazy hiding (pack) +import qualified Data.ByteString.Char8 as BS import Data.String import Data.String.Conversions import Data.Text import Data.Text.Encoding import Network.HTTP.Client import Network.HTTP.Client.TLS +import Network.HTTP.Media import Network.HTTP.Types import Network.URI import Servant.Common.BaseUrl @@ -31,12 +33,12 @@ import qualified Network.HTTP.Client as Client data Req = Req { reqPath :: String , qs :: QueryText - , reqBody :: ByteString + , reqBody :: Maybe (ByteString, MediaType) , headers :: [(String, Text)] } defReq :: Req -defReq = Req "" [] "" [] +defReq = Req "" [] Nothing [] appendToPath :: String -> Req -> Req appendToPath p req = @@ -62,8 +64,8 @@ addHeader name val req = req { headers = headers req ++ [(name, toText val)] } -setRQBody :: ByteString -> Req -> Req -setRQBody b req = req { reqBody = b } +setRQBody :: ByteString -> MediaType -> Req -> Req +setRQBody b t req = req { reqBody = Just (b, t) } reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request reqToRequest req (BaseUrl reqScheme reqHost reqPort) = @@ -80,9 +82,13 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort) = , uriPath = reqPath req } - setrqb r = r { requestBody = RequestBodyLBS (reqBody req) } + setrqb r = case (reqBody req) of + Nothing -> r + Just (b,t) -> r { requestBody = RequestBodyLBS b + , requestHeaders = [(hContentType, BS.pack . show $ t)] } setQS = setQueryString $ queryTextToQuery (qs req) - setheaders r = r { requestHeaders = Prelude.map toProperHeader (headers req) } + setheaders r = r { requestHeaders = requestHeaders r + ++ Prelude.map toProperHeader (headers req) } toProperHeader (name, val) = (fromString name, encodeUtf8 val) From db2c5a42b2852f0e627e7dea0e27e2b96bed3354 Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Tue, 17 Feb 2015 10:32:15 +1100 Subject: [PATCH 02/10] Expose content type in response. --- servant-client.cabal | 1 + src/Servant/Client.hs | 2 +- src/Servant/Common/Req.hs | 14 +++++++++----- test/Servant/ClientSpec.hs | 9 +++++---- 4 files changed, 16 insertions(+), 10 deletions(-) diff --git a/servant-client.cabal b/servant-client.cabal index b27e5bc2..a5576cbc 100644 --- a/servant-client.cabal +++ b/servant-client.cabal @@ -71,6 +71,7 @@ test-suite spec , deepseq , either , hspec == 2.* + , http-media , http-types , network >= 2.6 , QuickCheck >= 2.7 diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs index 69a8d71d..88bdc249 100644 --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -412,7 +412,7 @@ instance (KnownSymbol sym, HasClient sublayout) -- | Pick a 'Method' and specify where the server you want to query is. You get -- back the status code and the response body as a 'ByteString'. instance HasClient Raw where - type Client Raw = H.Method -> BaseUrl -> EitherT String IO (Int, ByteString) + type Client Raw = H.Method -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType) clientWithRoute :: Proxy Raw -> Req -> Client Raw clientWithRoute Proxy req httpMethod host = diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index 0e8cf1c6..13b12285 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -14,7 +14,6 @@ import Data.Aeson.Parser import Data.Aeson.Types import Data.Attoparsec.ByteString import Data.ByteString.Lazy hiding (pack) -import qualified Data.ByteString.Char8 as BS import Data.String import Data.String.Conversions import Data.Text @@ -85,7 +84,7 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort) = setrqb r = case (reqBody req) of Nothing -> r Just (b,t) -> r { requestBody = RequestBodyLBS b - , requestHeaders = [(hContentType, BS.pack . show $ t)] } + , requestHeaders = [(hContentType, cs . show $ t)] } setQS = setQueryString $ queryTextToQuery (qs req) setheaders r = r { requestHeaders = requestHeaders r ++ Prelude.map toProperHeader (headers req) } @@ -110,7 +109,7 @@ displayHttpRequest :: Method -> String displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" -performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString) +performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType) performRequest reqMethod req isWantedStatus reqHost = do partialRequest <- liftIO $ reqToRequest req reqHost @@ -129,7 +128,12 @@ performRequest reqMethod req isWantedStatus reqHost = do let status = Client.responseStatus response unless (isWantedStatus (statusCode status)) $ left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status) - return $ (statusCode status, Client.responseBody response) + ct <- case lookup "Content-Type" $ Client.responseHeaders response of + Nothing -> pure $ "application"//"octet-stream" + Just t -> case parseAccept t of + Nothing -> left $ "invalid Content-Type header: " <> cs t + Just t' -> pure t' + return $ (statusCode status, Client.responseBody response, ct) where showStatus (Status code message) = show code ++ " - " ++ cs message @@ -138,7 +142,7 @@ performRequest reqMethod req isWantedStatus reqHost = do performRequestJSON :: FromJSON result => Method -> Req -> Int -> BaseUrl -> EitherT String IO result performRequestJSON reqMethod req wantedStatus reqHost = do - (_status, respBody) <- performRequest reqMethod req (== wantedStatus) reqHost + (_status, respBody, _) <- performRequest reqMethod req (== wantedStatus) reqHost either (\ message -> left (displayHttpRequest reqMethod ++ " returned invalid json: " ++ message)) return diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs index 429a2fe4..70919bdf 100644 --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -17,6 +17,7 @@ import Data.Foldable (forM_) import Data.Proxy import Data.Typeable import GHC.Generics +import Network.HTTP.Media import Network.HTTP.Types import Network.Socket import Network.Wai @@ -101,8 +102,8 @@ getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool getMatrixParam :: Maybe String -> BaseUrl -> EitherT String IO Person getMatrixParams :: [String] -> BaseUrl -> EitherT String IO [Person] getMatrixFlag :: Bool -> BaseUrl -> EitherT String IO Bool -getRawSuccess :: Method -> BaseUrl -> EitherT String IO (Int, ByteString) -getRawFailure :: Method -> BaseUrl -> EitherT String IO (Int, ByteString) +getRawSuccess :: Method -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType) +getRawFailure :: Method -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType) getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> BaseUrl -> EitherT String IO (String, Maybe Int, Bool, [(String, [Rational])]) @@ -167,10 +168,10 @@ spec = do runEitherT (getMatrixFlag flag host) `shouldReturn` Right flag it "Servant.API.Raw on success" $ withServer $ \ host -> do - runEitherT (getRawSuccess methodGet host) `shouldReturn` Right (200, "rawSuccess") + runEitherT (getRawSuccess methodGet host) `shouldReturn` Right (200, "rawSuccess", "application"//"octet-stream") it "Servant.API.Raw on failure" $ withServer $ \ host -> do - runEitherT (getRawFailure methodGet host) `shouldReturn` Right (400, "rawFailure") + runEitherT (getRawFailure methodGet host) `shouldReturn` Right (400, "rawFailure", "application"//"octet-stream") modifyMaxSuccess (const 20) $ do it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ From e6e67b275bd0a32f966d93f25566b6a437aa9163 Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Tue, 17 Feb 2015 10:55:35 +1100 Subject: [PATCH 03/10] Check for correct content-type in result. --- src/Servant/Common/Req.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index 13b12285..aa2bfdcd 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -142,7 +142,9 @@ performRequest reqMethod req isWantedStatus reqHost = do performRequestJSON :: FromJSON result => Method -> Req -> Int -> BaseUrl -> EitherT String IO result performRequestJSON reqMethod req wantedStatus reqHost = do - (_status, respBody, _) <- performRequest reqMethod req (== wantedStatus) reqHost + (_status, respBody, contentType) <- performRequest reqMethod req (== wantedStatus) reqHost + unless (matches contentType ("application"//"json")) $ + left $ "requested Content-Type application/json, but got " <> show contentType either (\ message -> left (displayHttpRequest reqMethod ++ " returned invalid json: " ++ message)) return From c444ec8374f6f279d35306fa12880d26b49b23ec Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Tue, 17 Feb 2015 11:51:59 +1100 Subject: [PATCH 04/10] Send the correct Accept header --- src/Servant/Common/Req.hs | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index aa2bfdcd..3832b86d 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -13,10 +13,12 @@ import Data.Aeson import Data.Aeson.Parser import Data.Aeson.Types import Data.Attoparsec.ByteString -import Data.ByteString.Lazy hiding (pack) +import Data.ByteString.Lazy hiding (pack, filter, map) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC import Data.String import Data.String.Conversions -import Data.Text +import Data.Text (Text) import Data.Text.Encoding import Network.HTTP.Client import Network.HTTP.Client.TLS @@ -30,14 +32,15 @@ import System.IO.Unsafe import qualified Network.HTTP.Client as Client data Req = Req - { reqPath :: String - , qs :: QueryText - , reqBody :: Maybe (ByteString, MediaType) - , headers :: [(String, Text)] + { reqPath :: String + , qs :: QueryText + , reqBody :: Maybe (ByteString, MediaType) + , reqAccept :: [MediaType] + , headers :: [(String, Text)] } defReq :: Req -defReq = Req "" [] Nothing [] +defReq = Req "" [] Nothing [] [] appendToPath :: String -> Req -> Req appendToPath p req = @@ -68,7 +71,7 @@ setRQBody b t req = req { reqBody = Just (b, t) } reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request reqToRequest req (BaseUrl reqScheme reqHost reqPort) = - fmap (setheaders . setrqb . setQS ) $ parseUrl url + fmap (setheaders . setAccept . setrqb . setQS ) $ parseUrl url where url = show $ nullURI { uriScheme = case reqScheme of Http -> "http:" @@ -84,11 +87,15 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort) = setrqb r = case (reqBody req) of Nothing -> r Just (b,t) -> r { requestBody = RequestBodyLBS b - , requestHeaders = [(hContentType, cs . show $ t)] } + , requestHeaders = requestHeaders r + ++ [(hContentType, cs . show $ t)] } setQS = setQueryString $ queryTextToQuery (qs req) setheaders r = r { requestHeaders = requestHeaders r ++ Prelude.map toProperHeader (headers req) } - + setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r) + ++ [("Accept", BS.intercalate ", " (map renderAccept $ reqAccept req))] } + renderAccept :: MediaType -> BS.ByteString + renderAccept m = BSC.pack (show m) toProperHeader (name, val) = (fromString name, encodeUtf8 val) @@ -142,7 +149,8 @@ performRequest reqMethod req isWantedStatus reqHost = do performRequestJSON :: FromJSON result => Method -> Req -> Int -> BaseUrl -> EitherT String IO result performRequestJSON reqMethod req wantedStatus reqHost = do - (_status, respBody, contentType) <- performRequest reqMethod req (== wantedStatus) reqHost + (_status, respBody, contentType) <- + performRequest reqMethod (req { reqAccept = ["application"//"json"] }) (== wantedStatus) reqHost unless (matches contentType ("application"//"json")) $ left $ "requested Content-Type application/json, but got " <> show contentType either From 098b5036251408e571b843e4264edfdb7f91bab2 Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Tue, 17 Feb 2015 11:56:15 +1100 Subject: [PATCH 05/10] Don't send an Accept header if the list of accepted types is empty --- src/Servant/Common/Req.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index 3832b86d..09ea2b03 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -13,7 +13,7 @@ import Data.Aeson import Data.Aeson.Parser import Data.Aeson.Types import Data.Attoparsec.ByteString -import Data.ByteString.Lazy hiding (pack, filter, map) +import Data.ByteString.Lazy hiding (pack, filter, map, null) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import Data.String @@ -93,7 +93,8 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort) = setheaders r = r { requestHeaders = requestHeaders r ++ Prelude.map toProperHeader (headers req) } setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r) - ++ [("Accept", BS.intercalate ", " (map renderAccept $ reqAccept req))] } + ++ [("Accept", BS.intercalate ", " (map renderAccept $ reqAccept req)) + | not . null . reqAccept $ req] } renderAccept :: MediaType -> BS.ByteString renderAccept m = BSC.pack (show m) toProperHeader (name, val) = From a23204e134eae0e9759e866a04b624c497aa7d6e Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Tue, 17 Feb 2015 12:23:03 +1100 Subject: [PATCH 06/10] Use renderHeader to render the Accept header --- src/Servant/Common/Req.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index 09ea2b03..d6243f6c 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -93,10 +93,8 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort) = setheaders r = r { requestHeaders = requestHeaders r ++ Prelude.map toProperHeader (headers req) } setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r) - ++ [("Accept", BS.intercalate ", " (map renderAccept $ reqAccept req)) + ++ [("Accept", renderHeader $ reqAccept req) | not . null . reqAccept $ req] } - renderAccept :: MediaType -> BS.ByteString - renderAccept m = BSC.pack (show m) toProperHeader (name, val) = (fromString name, encodeUtf8 val) From 6c99dfcb6ce1e62eae1361b4e889c2dcc1612b29 Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Tue, 17 Feb 2015 13:50:50 +1100 Subject: [PATCH 07/10] Cleanup --- src/Servant/Common/Req.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index d6243f6c..746ff066 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -14,8 +14,6 @@ import Data.Aeson.Parser import Data.Aeson.Types import Data.Attoparsec.ByteString import Data.ByteString.Lazy hiding (pack, filter, map, null) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC import Data.String import Data.String.Conversions import Data.Text (Text) @@ -84,16 +82,16 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort) = , uriPath = reqPath req } - setrqb r = case (reqBody req) of + setrqb r = case reqBody req of Nothing -> r Just (b,t) -> r { requestBody = RequestBodyLBS b , requestHeaders = requestHeaders r ++ [(hContentType, cs . show $ t)] } setQS = setQueryString $ queryTextToQuery (qs req) setheaders r = r { requestHeaders = requestHeaders r - ++ Prelude.map toProperHeader (headers req) } + <> fmap toProperHeader (headers req) } setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r) - ++ [("Accept", renderHeader $ reqAccept req) + <> [("Accept", renderHeader $ reqAccept req) | not . null . reqAccept $ req] } toProperHeader (name, val) = (fromString name, encodeUtf8 val) @@ -139,7 +137,7 @@ performRequest reqMethod req isWantedStatus reqHost = do Just t -> case parseAccept t of Nothing -> left $ "invalid Content-Type header: " <> cs t Just t' -> pure t' - return $ (statusCode status, Client.responseBody response, ct) + return (statusCode status, Client.responseBody response, ct) where showStatus (Status code message) = show code ++ " - " ++ cs message From 48030a6a1ba30f3775648ecc1f73fdf7ce34da7d Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Tue, 17 Feb 2015 17:17:10 +1100 Subject: [PATCH 08/10] Simple design for client with content-types --- servant-client.cabal | 1 + src/Servant/Client.hs | 24 ++++++++++--------- src/Servant/Common/Req.hs | 26 ++++++++++---------- test/Servant/ClientSpec.hs | 49 ++++++++++++++++++++++---------------- 4 files changed, 57 insertions(+), 43 deletions(-) diff --git a/servant-client.cabal b/servant-client.cabal index a5576cbc..5a04e162 100644 --- a/servant-client.cabal +++ b/servant-client.cabal @@ -50,6 +50,7 @@ library , network-uri >= 2.6 , safe , servant >= 0.2.2 + , servant-server , string-conversions , text , transformers diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs index 88bdc249..7b2fa16b 100644 --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -26,6 +27,7 @@ import Network.HTTP.Media import qualified Network.HTTP.Types as H import Servant.API import Servant.Common.BaseUrl +import Servant.Server.ContentTypes import Servant.Common.Req import Servant.Common.Text @@ -116,10 +118,10 @@ instance HasClient Delete where -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to. -instance FromJSON result => HasClient (Get result) where - type Client (Get result) = BaseUrl -> EitherT String IO result +instance (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where + type Client (Get (ct ': cts) result) = BaseUrl -> EitherT String IO result clientWithRoute Proxy req host = - performRequestJSON H.methodGet req 200 host + performRequestCT (Proxy :: Proxy ct) H.methodGet req 200 host -- | If you use a 'Header' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -162,21 +164,21 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout) -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to. -instance FromJSON a => HasClient (Post a) where - type Client (Post a) = BaseUrl -> EitherT String IO a +instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where + type Client (Post (ct ': cts) a) = BaseUrl -> EitherT String IO a clientWithRoute Proxy req uri = - performRequestJSON H.methodPost req 201 uri + performRequestCT (Proxy :: Proxy ct) H.methodPost req 201 uri -- | If you have a 'Put' endpoint in your API, the client -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to. -instance FromJSON a => HasClient (Put a) where - type Client (Put a) = BaseUrl -> EitherT String IO a +instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where + type Client (Put (ct ': cts) a) = BaseUrl -> EitherT String IO a clientWithRoute Proxy req host = - performRequestJSON H.methodPut req 200 host + performRequestCT (Proxy :: Proxy ct) H.methodPut req 200 host -- | If you use a 'QueryParam' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -437,9 +439,9 @@ instance HasClient Raw where -- > addBook = client myApi -- > -- then you can just use "addBook" to query that endpoint instance (ToJSON a, HasClient sublayout) - => HasClient (ReqBody a :> sublayout) where + => HasClient (ReqBody (ct ': cts) a :> sublayout) where - type Client (ReqBody a :> sublayout) = + type Client (ReqBody (ct ': cts) a :> sublayout) = a -> Client sublayout clientWithRoute Proxy req body = diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index 746ff066..9a868424 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -16,15 +16,17 @@ import Data.Attoparsec.ByteString import Data.ByteString.Lazy hiding (pack, filter, map, null) import Data.String import Data.String.Conversions +import Data.Proxy import Data.Text (Text) import Data.Text.Encoding -import Network.HTTP.Client +import Network.HTTP.Client hiding (Proxy) import Network.HTTP.Client.TLS import Network.HTTP.Media import Network.HTTP.Types import Network.URI import Servant.Common.BaseUrl import Servant.Common.Text +import Servant.Server.ContentTypes import System.IO.Unsafe import qualified Network.HTTP.Client as Client @@ -142,18 +144,18 @@ performRequest reqMethod req isWantedStatus reqHost = do showStatus (Status code message) = show code ++ " - " ++ cs message - -performRequestJSON :: FromJSON result => - Method -> Req -> Int -> BaseUrl -> EitherT String IO result -performRequestJSON reqMethod req wantedStatus reqHost = do - (_status, respBody, contentType) <- - performRequest reqMethod (req { reqAccept = ["application"//"json"] }) (== wantedStatus) reqHost - unless (matches contentType ("application"//"json")) $ - left $ "requested Content-Type application/json, but got " <> show contentType - either - (\ message -> left (displayHttpRequest reqMethod ++ " returned invalid json: " ++ message)) +performRequestCT :: MimeUnrender ct result => + Proxy ct -> Method -> Req -> Int -> BaseUrl -> EitherT String IO result +performRequestCT ct reqMethod req wantedStatus reqHost = do + let acceptCT = contentType ct + (_status, respBody, respCT) <- + performRequest reqMethod (req { reqAccept = [acceptCT] }) (== wantedStatus) reqHost + unless (matches respCT (acceptCT)) $ + left $ "requested Content-Type " <> show acceptCT <> ", but got " <> show respCT + maybe + (left (displayHttpRequest reqMethod ++ " returned invalid response of type: " ++ show respCT)) return - (decodeLenient respBody) + (fromByteString ct respBody) catchStatusCodeException :: IO a -> IO (Either Status a) diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs index 70919bdf..40265dd0 100644 --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -45,24 +45,26 @@ alice :: Person alice = Person "Alice" 42 type Api = - "get" :> Get Person + "get" :> Get '[JSON] Person :<|> "delete" :> Delete - :<|> "capture" :> Capture "name" String :> Get Person - :<|> "body" :> ReqBody Person :> Post Person - :<|> "param" :> QueryParam "name" String :> Get Person - :<|> "params" :> QueryParams "names" String :> Get [Person] - :<|> "flag" :> QueryFlag "flag" :> Get Bool - :<|> "matrixparam" :> MatrixParam "name" String :> Get Person - :<|> "matrixparams" :> MatrixParams "name" String :> Get [Person] - :<|> "matrixflag" :> MatrixFlag "flag" :> Get Bool + :<|> "capture" :> Capture "name" String :> Get '[JSON] Person + :<|> "body" :> ReqBody '[JSON] Person :> Post '[JSON] Person + :<|> "param" :> QueryParam "name" String :> Get '[JSON] Person + :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] + :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool +{- + :<|> "matrixparam" :> MatrixParam "name" String :> Get '[JSON] Person + :<|> "matrixparams" :> MatrixParams "name" String :> Get '[JSON] [Person] + :<|> "matrixflag" :> MatrixFlag "flag" :> Get '[JSON] Bool +-} :<|> "rawSuccess" :> Raw :<|> "rawFailure" :> Raw :<|> "multiple" :> Capture "first" String :> QueryParam "second" Int :> QueryFlag "third" :> - ReqBody [(String, [Rational])] :> - Get (String, Maybe Int, Bool, [(String, [Rational])]) + ReqBody '[JSON] [(String, [Rational])] :> + Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) api :: Proxy Api api = Proxy @@ -78,12 +80,14 @@ server = serve api ( Nothing -> left (400, "missing parameter")) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return +{- :<|> (\ name -> case name of Just "alice" -> return alice Just name -> left (400, name ++ " not found") Nothing -> left (400, "missing parameter")) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return +-} :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") :<|> \ a b c d -> return (a, b, c, d) @@ -99,9 +103,11 @@ getBody :: Person -> BaseUrl -> EitherT String IO Person getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person] getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool +{- getMatrixParam :: Maybe String -> BaseUrl -> EitherT String IO Person getMatrixParams :: [String] -> BaseUrl -> EitherT String IO [Person] getMatrixFlag :: Bool -> BaseUrl -> EitherT String IO Bool +-} getRawSuccess :: Method -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType) getRawFailure :: Method -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType) getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] @@ -114,9 +120,11 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] :<|> getQueryParam :<|> getQueryParams :<|> getQueryFlag +{- :<|> getMatrixParam :<|> getMatrixParams :<|> getMatrixFlag +-} :<|> getRawSuccess :<|> getRawFailure :<|> getMultiple) @@ -152,6 +160,7 @@ spec = do it (show flag) $ withServer $ \ host -> do runEitherT (getQueryFlag flag host) `shouldReturn` Right flag +{- it "Servant.API.MatrixParam" $ withServer $ \ host -> do runEitherT (getMatrixParam (Just "alice") host) `shouldReturn` Right alice Left result <- runEitherT (getMatrixParam (Just "bob") host) @@ -166,6 +175,7 @@ spec = do forM_ [False, True] $ \ flag -> it (show flag) $ withServer $ \ host -> do runEitherT (getMatrixFlag flag host) `shouldReturn` Right flag +-} it "Servant.API.Raw on success" $ withServer $ \ host -> do runEitherT (getRawSuccess methodGet host) `shouldReturn` Right (200, "rawSuccess", "application"//"octet-stream") @@ -184,9 +194,9 @@ spec = do context "client correctly handles error status codes" $ do - let test :: WrappedApi -> Spec - test (WrappedApi api) = - it (show (typeOf api)) $ + let test :: (WrappedApi, String) -> Spec + test (WrappedApi api, desc) = + it desc $ withWaiDaemon (return (serve api (left (500, "error message")))) $ \ host -> do let getResponse :: BaseUrl -> EitherT String IO () @@ -194,16 +204,15 @@ spec = do Left result <- runEitherT (getResponse host) result `shouldContain` "error message" mapM_ test $ - (WrappedApi (Proxy :: Proxy Delete)) : - (WrappedApi (Proxy :: Proxy (Get ()))) : - (WrappedApi (Proxy :: Proxy (Post ()))) : - (WrappedApi (Proxy :: Proxy (Put ()))) : + (WrappedApi (Proxy :: Proxy Delete), "Delete") : + (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Delete") : + (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Delete") : + (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Delete") : [] data WrappedApi where WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a, - HasClient api, Client api ~ (BaseUrl -> EitherT String IO ()), - Typeable api) => + HasClient api, Client api ~ (BaseUrl -> EitherT String IO ())) => Proxy api -> WrappedApi From 40a941e0e384d48f52cdb96ce57d80b423389099 Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Wed, 25 Feb 2015 09:30:31 +1100 Subject: [PATCH 09/10] Don't ignore the content-type in ReqBody --- servant-client.cabal | 1 - src/Servant/Client.hs | 9 +++++---- src/Servant/Common/Req.hs | 13 +++---------- 3 files changed, 8 insertions(+), 15 deletions(-) diff --git a/servant-client.cabal b/servant-client.cabal index 5a04e162..a5576cbc 100644 --- a/servant-client.cabal +++ b/servant-client.cabal @@ -50,7 +50,6 @@ library , network-uri >= 2.6 , safe , servant >= 0.2.2 - , servant-server , string-conversions , text , transformers diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs index 7b2fa16b..46887186 100644 --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -26,8 +26,8 @@ import GHC.TypeLits import Network.HTTP.Media import qualified Network.HTTP.Types as H import Servant.API +import Servant.API.ContentTypes import Servant.Common.BaseUrl -import Servant.Server.ContentTypes import Servant.Common.Req import Servant.Common.Text @@ -438,15 +438,16 @@ instance HasClient Raw where -- > addBook :: Book -> BaseUrl -> EitherT String IO Book -- > addBook = client myApi -- > -- then you can just use "addBook" to query that endpoint -instance (ToJSON a, HasClient sublayout) +instance (MimeRender ct a, HasClient sublayout) => HasClient (ReqBody (ct ': cts) a :> sublayout) where type Client (ReqBody (ct ': cts) a :> sublayout) = a -> Client sublayout clientWithRoute Proxy req body = - clientWithRoute (Proxy :: Proxy sublayout) $ - setRQBody (encode body) ("application" // "json" /: ("charset", "utf-8")) req + clientWithRoute (Proxy :: Proxy sublayout) $ do + let ctProxy = Proxy :: Proxy ct + setRQBody (toByteString ctProxy body) (contentType ctProxy) req -- | Make the querying function append @path@ to the request path. instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index 9a868424..77e077a7 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -24,9 +24,9 @@ import Network.HTTP.Client.TLS import Network.HTTP.Media import Network.HTTP.Types import Network.URI +import Servant.API.ContentTypes import Servant.Common.BaseUrl import Servant.Common.Text -import Servant.Server.ContentTypes import System.IO.Unsafe import qualified Network.HTTP.Client as Client @@ -152,8 +152,8 @@ performRequestCT ct reqMethod req wantedStatus reqHost = do performRequest reqMethod (req { reqAccept = [acceptCT] }) (== wantedStatus) reqHost unless (matches respCT (acceptCT)) $ left $ "requested Content-Type " <> show acceptCT <> ", but got " <> show respCT - maybe - (left (displayHttpRequest reqMethod ++ " returned invalid response of type: " ++ show respCT)) + either + (left . ((displayHttpRequest reqMethod ++ " returned invalid response of type" ++ show respCT) ++)) return (fromByteString ct respBody) @@ -164,10 +164,3 @@ catchStatusCodeException action = case e of Client.StatusCodeException status _ _ -> return $ Left status exc -> throwIO exc - --- | Like 'Data.Aeson.decode' but allows all JSON values instead of just --- objects and arrays. -decodeLenient :: FromJSON a => ByteString -> Either String a -decodeLenient input = do - v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input) - parseEither parseJSON v From da0e1ca87133a916760f7414206969bbaea36ecf Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Wed, 25 Feb 2015 09:56:06 +1100 Subject: [PATCH 10/10] Extend tests and clean up --- servant-client.cabal | 1 + src/Servant/Common/Req.hs | 4 ---- test/Servant/ClientSpec.hs | 34 ++++++++++++++++++++++------------ 3 files changed, 23 insertions(+), 16 deletions(-) diff --git a/servant-client.cabal b/servant-client.cabal index a5576cbc..77b832b7 100644 --- a/servant-client.cabal +++ b/servant-client.cabal @@ -78,5 +78,6 @@ test-suite spec , servant >= 0.2.1 , servant-client , servant-server >= 0.2.1 + , text , wai , warp diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index 77e077a7..446bfd12 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -9,10 +9,6 @@ import Control.Monad import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class import Control.Monad.Trans.Either -import Data.Aeson -import Data.Aeson.Parser -import Data.Aeson.Types -import Data.Attoparsec.ByteString import Data.ByteString.Lazy hiding (pack, filter, map, null) import Data.String import Data.String.Conversions diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs index 40265dd0..063c6345 100644 --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fcontext-stack=25 #-} module Servant.ClientSpec where @@ -14,8 +15,9 @@ import Data.Aeson import Data.ByteString.Lazy (ByteString) import Data.Char import Data.Foldable (forM_) +import Data.Monoid import Data.Proxy -import Data.Typeable +import qualified Data.Text as T import GHC.Generics import Network.HTTP.Media import Network.HTTP.Types @@ -27,6 +29,7 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Servant.API +import Servant.API.ContentTypes import Servant.Client import Servant.Server @@ -41,22 +44,35 @@ data Person = Person { instance ToJSON Person instance FromJSON Person +instance ToFormUrlEncoded Person where + toFormUrlEncoded Person{..} = + [("name", T.pack name), ("age", T.pack (show age))] + +lookupEither :: (Show a, Eq a) => a -> [(a,b)] -> Either String b +lookupEither x xs = do + maybe (Left $ "could not find key " <> show x) return $ lookup x xs + +instance FromFormUrlEncoded Person where + fromFormUrlEncoded xs = do + n <- lookupEither "name" xs + a <- lookupEither "age" xs + return $ Person (T.unpack n) (read $ T.unpack a) + + alice :: Person alice = Person "Alice" 42 type Api = "get" :> Get '[JSON] Person :<|> "delete" :> Delete - :<|> "capture" :> Capture "name" String :> Get '[JSON] Person - :<|> "body" :> ReqBody '[JSON] Person :> Post '[JSON] Person - :<|> "param" :> QueryParam "name" String :> Get '[JSON] Person + :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person + :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person + :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool -{- :<|> "matrixparam" :> MatrixParam "name" String :> Get '[JSON] Person :<|> "matrixparams" :> MatrixParams "name" String :> Get '[JSON] [Person] :<|> "matrixflag" :> MatrixFlag "flag" :> Get '[JSON] Bool --} :<|> "rawSuccess" :> Raw :<|> "rawFailure" :> Raw :<|> "multiple" :> @@ -80,14 +96,12 @@ server = serve api ( Nothing -> left (400, "missing parameter")) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return -{- :<|> (\ name -> case name of Just "alice" -> return alice Just name -> left (400, name ++ " not found") Nothing -> left (400, "missing parameter")) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return --} :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") :<|> \ a b c d -> return (a, b, c, d) @@ -103,11 +117,9 @@ getBody :: Person -> BaseUrl -> EitherT String IO Person getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person] getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool -{- getMatrixParam :: Maybe String -> BaseUrl -> EitherT String IO Person getMatrixParams :: [String] -> BaseUrl -> EitherT String IO [Person] getMatrixFlag :: Bool -> BaseUrl -> EitherT String IO Bool --} getRawSuccess :: Method -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType) getRawFailure :: Method -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType) getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] @@ -120,11 +132,9 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] :<|> getQueryParam :<|> getQueryParams :<|> getQueryFlag -{- :<|> getMatrixParam :<|> getMatrixParams :<|> getMatrixFlag --} :<|> getRawSuccess :<|> getRawFailure :<|> getMultiple)