From 34f1715666cbdc694bdbf0c7564ecc4f1f61b8a0 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Mon, 9 Mar 2015 21:50:30 +0100 Subject: [PATCH 1/3] canonicalize api type before generating client functions, to flatten out all the client functions, distributing arguments properly: Client (a :> (b :<|> c)) = Client (a :> b) :<|> Client (a :> c) --- src/Servant/Client.hs | 63 ++++++++++++++++++++++--------------------- 1 file changed, 33 insertions(+), 30 deletions(-) diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs index 7ef664d0..2c619f0d 100644 --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -2,6 +2,7 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverlappingInstances #-} @@ -45,15 +46,17 @@ import Servant.Common.Req -- > getAllBooks :: BaseUrl -> EitherT String IO [Book] -- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book -- > (getAllBooks :<|> postNewBook) = client myApi -client :: HasClient layout => Proxy layout -> Client layout -client p = clientWithRoute p defReq +client :: HasClient (Canonicalize layout) => Proxy layout -> Client layout +client p = clientWithRoute (canonicalize p) defReq -- | This class lets us define how each API combinator -- influences the creation of an HTTP request. It's mostly -- an internal class, you can just use 'client'. class HasClient layout where - type Client layout :: * - clientWithRoute :: Proxy layout -> Req -> Client layout + type Client' layout :: * + clientWithRoute :: Proxy layout -> Req -> Client' layout + +type Client layout = Client' (Canonicalize layout) -- | A client querying function for @a ':<|>' b@ will actually hand you -- one function for querying @a@ and another one for querying @b@, @@ -69,7 +72,7 @@ class HasClient layout where -- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book -- > (getAllBooks :<|> postNewBook) = client myApi instance (HasClient a, HasClient b) => HasClient (a :<|> b) where - type Client (a :<|> b) = Client a :<|> Client b + type Client' (a :<|> b) = Client' a :<|> Client' b clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy a) req :<|> clientWithRoute (Proxy :: Proxy b) req @@ -96,8 +99,8 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where instance (KnownSymbol capture, ToText a, HasClient sublayout) => HasClient (Capture capture a :> sublayout) where - type Client (Capture capture a :> sublayout) = - a -> Client sublayout + type Client' (Capture capture a :> sublayout) = + a -> Client' sublayout clientWithRoute Proxy req val = clientWithRoute (Proxy :: Proxy sublayout) $ @@ -110,7 +113,7 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout) -- will just require an argument that specifies the scheme, host -- and port to send the request to. instance HasClient Delete where - type Client Delete = BaseUrl -> EitherT ServantError IO () + type Client' Delete = BaseUrl -> EitherT ServantError IO () clientWithRoute Proxy req host = void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host @@ -120,7 +123,7 @@ instance HasClient Delete where -- will just require an argument that specifies the scheme, host -- and port to send the request to. instance (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where - type Client (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result + type Client' (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result clientWithRoute Proxy req host = performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host @@ -159,8 +162,8 @@ instance HasClient (Get (ct ': cts) ()) where instance (KnownSymbol sym, ToText a, HasClient sublayout) => HasClient (Header sym a :> sublayout) where - type Client (Header sym a :> sublayout) = - Maybe a -> Client sublayout + type Client' (Header sym a :> sublayout) = + Maybe a -> Client' sublayout clientWithRoute Proxy req mval = clientWithRoute (Proxy :: Proxy sublayout) $ @@ -173,7 +176,7 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout) -- will just require an argument that specifies the scheme, host -- and port to send the request to. instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where - type Client (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a + type Client' (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a clientWithRoute Proxy req uri = performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri @@ -190,7 +193,7 @@ instance HasClient (Post (ct ': cts) ()) where -- will just require an argument that specifies the scheme, host -- and port to send the request to. instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where - type Client (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a + type Client' (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a clientWithRoute Proxy req host = performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host @@ -247,8 +250,8 @@ instance HasClient (Patch (ct ': cts) ()) where instance (KnownSymbol sym, ToText a, HasClient sublayout) => HasClient (QueryParam sym a :> sublayout) where - type Client (QueryParam sym a :> sublayout) = - Maybe a -> Client sublayout + type Client' (QueryParam sym a :> sublayout) = + Maybe a -> Client' sublayout -- if mparam = Nothing, we don't add it to the query string clientWithRoute Proxy req mparam = @@ -289,8 +292,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout) instance (KnownSymbol sym, ToText a, HasClient sublayout) => HasClient (QueryParams sym a :> sublayout) where - type Client (QueryParams sym a :> sublayout) = - [a] -> Client sublayout + type Client' (QueryParams sym a :> sublayout) = + [a] -> Client' sublayout clientWithRoute Proxy req paramlist = clientWithRoute (Proxy :: Proxy sublayout) $ @@ -324,8 +327,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout) instance (KnownSymbol sym, HasClient sublayout) => HasClient (QueryFlag sym :> sublayout) where - type Client (QueryFlag sym :> sublayout) = - Bool -> Client sublayout + type Client' (QueryFlag sym :> sublayout) = + Bool -> Client' sublayout clientWithRoute Proxy req flag = clientWithRoute (Proxy :: Proxy sublayout) $ @@ -363,8 +366,8 @@ instance (KnownSymbol sym, HasClient sublayout) instance (KnownSymbol sym, ToText a, HasClient sublayout) => HasClient (MatrixParam sym a :> sublayout) where - type Client (MatrixParam sym a :> sublayout) = - Maybe a -> Client sublayout + type Client' (MatrixParam sym a :> sublayout) = + Maybe a -> Client' sublayout -- if mparam = Nothing, we don't add it to the query string clientWithRoute Proxy req mparam = @@ -404,8 +407,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout) instance (KnownSymbol sym, ToText a, HasClient sublayout) => HasClient (MatrixParams sym a :> sublayout) where - type Client (MatrixParams sym a :> sublayout) = - [a] -> Client sublayout + type Client' (MatrixParams sym a :> sublayout) = + [a] -> Client' sublayout clientWithRoute Proxy req paramlist = clientWithRoute (Proxy :: Proxy sublayout) $ @@ -439,8 +442,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout) instance (KnownSymbol sym, HasClient sublayout) => HasClient (MatrixFlag sym :> sublayout) where - type Client (MatrixFlag sym :> sublayout) = - Bool -> Client sublayout + type Client' (MatrixFlag sym :> sublayout) = + Bool -> Client' sublayout clientWithRoute Proxy req flag = clientWithRoute (Proxy :: Proxy sublayout) $ @@ -453,9 +456,9 @@ instance (KnownSymbol sym, HasClient sublayout) -- | Pick a 'Method' and specify where the server you want to query is. You get -- back the full `Response`. instance HasClient Raw where - type Client Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString) + type Client' Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString) - clientWithRoute :: Proxy Raw -> Req -> Client Raw + clientWithRoute :: Proxy Raw -> Req -> Client' Raw clientWithRoute Proxy req httpMethod host = do performRequest httpMethod req (const True) host @@ -480,8 +483,8 @@ instance HasClient Raw where instance (MimeRender ct a, HasClient sublayout) => HasClient (ReqBody (ct ': cts) a :> sublayout) where - type Client (ReqBody (ct ': cts) a :> sublayout) = - a -> Client sublayout + type Client' (ReqBody (ct ': cts) a :> sublayout) = + a -> Client' sublayout clientWithRoute Proxy req body = clientWithRoute (Proxy :: Proxy sublayout) $ do @@ -490,7 +493,7 @@ instance (MimeRender ct a, HasClient sublayout) -- | Make the querying function append @path@ to the request path. instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where - type Client (path :> sublayout) = Client sublayout + type Client' (path :> sublayout) = Client' sublayout clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy sublayout) $ From eae2f5f282fb92a7f845c1fcd36db21cb0505bf4 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Wed, 11 Mar 2015 21:38:36 +0100 Subject: [PATCH 2/3] add a changelog entry for canonicalize --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index df677a29..9e7f1090 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,7 @@ * Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example) * Support for PATCH * Make () instances expect No Content status code, and not try to decode body. +* `Canonicalize` API types before generating client functions for them 0.2.2 ----- From d7fcf2b19b2af04ef5104b433f87837722c826fe Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 19 Apr 2015 18:31:23 +0200 Subject: [PATCH 3/3] Fix missing canonicalize changes --- src/Servant/Client.hs | 15 ++++---- src/Servant/Common/Req.hs | 2 +- test/Servant/ClientSpec.hs | 70 +++++++++++++++++++------------------- 3 files changed, 44 insertions(+), 43 deletions(-) diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs index 2c619f0d..c50b5471 100644 --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -13,6 +13,7 @@ module Servant.Client ( client , HasClient(..) + , Client , ServantError(..) , module Servant.Common.BaseUrl ) where @@ -130,7 +131,7 @@ instance (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where -- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content -- HTTP header. instance HasClient (Get (ct ': cts) ()) where - type Client (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () + type Client' (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () clientWithRoute Proxy req host = performRequestNoBody H.methodGet req [204] host @@ -167,7 +168,7 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout) clientWithRoute Proxy req mval = clientWithRoute (Proxy :: Proxy sublayout) $ - maybe req (\value -> addHeader hname value req) mval + maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval where hname = symbolVal (Proxy :: Proxy sym) @@ -184,7 +185,7 @@ instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where -- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content -- HTTP header. instance HasClient (Post (ct ': cts) ()) where - type Client (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () + type Client' (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () clientWithRoute Proxy req host = void $ performRequestNoBody H.methodPost req [204] host @@ -201,7 +202,7 @@ instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where -- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content -- HTTP header. instance HasClient (Put (ct ': cts) ()) where - type Client (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () + type Client' (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () clientWithRoute Proxy req host = void $ performRequestNoBody H.methodPut req [204] host @@ -210,7 +211,7 @@ instance HasClient (Put (ct ': cts) ()) where -- will just require an argument that specifies the scheme, host -- and port to send the request to. instance (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where - type Client (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a + type Client' (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a clientWithRoute Proxy req host = performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host @@ -218,7 +219,7 @@ instance (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where -- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content -- HTTP header. instance HasClient (Patch (ct ': cts) ()) where - type Client (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () + type Client' (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () clientWithRoute Proxy req host = void $ performRequestNoBody H.methodPatch req [204] host @@ -489,7 +490,7 @@ instance (MimeRender ct a, HasClient sublayout) clientWithRoute Proxy req body = clientWithRoute (Proxy :: Proxy sublayout) $ do let ctProxy = Proxy :: Proxy ct - setRQBody (toByteString ctProxy body) (contentType ctProxy) req + setRQBody (mimeRender 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 a0ffbc14..60c53eb8 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -172,7 +172,7 @@ performRequestCT ct reqMethod req wantedStatus reqHost = do either (left . (\s -> DecodeFailure s respCT respBody)) return - (fromByteString ct respBody) + (mimeUnrender ct respBody) performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO () performRequestNoBody reqMethod req wantedStatus reqHost = do diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs index 7b1645c0..ff043ab1 100644 --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -1,42 +1,42 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fcontext-stack=25 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.ClientSpec where -import Control.Applicative -import qualified Control.Arrow as Arrow -import Control.Concurrent -import Control.Exception -import Control.Monad.Trans.Either -import Data.Aeson -import Data.ByteString.Lazy (ByteString) -import Data.Char -import Data.Foldable (forM_) -import Data.Monoid -import Data.Proxy -import qualified Data.Text as T -import GHC.Generics -import qualified Network.HTTP.Client as C -import Network.HTTP.Media -import Network.HTTP.Types -import Network.Socket -import Network.Wai hiding (Response) -import Network.Wai.Handler.Warp -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.HUnit -import Test.QuickCheck +import Control.Applicative +import qualified Control.Arrow as Arrow +import Control.Concurrent +import Control.Exception +import Control.Monad.Trans.Either +import Data.Aeson +import Data.ByteString.Lazy (ByteString) +import Data.Char +import Data.Foldable (forM_) +import Data.Monoid +import Data.Proxy +import qualified Data.Text as T +import GHC.Generics +import qualified Network.HTTP.Client as C +import Network.HTTP.Media +import Network.HTTP.Types +import Network.Socket +import Network.Wai hiding (Response) +import Network.Wai.Handler.Warp +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.HUnit +import Test.QuickCheck -import Servant.API -import Servant.Client -import Servant.Server +import Servant.API +import Servant.Client +import Servant.Server -- * test data types @@ -289,8 +289,8 @@ spec = do _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where - WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a, - HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) => + WrappedApi :: (HasServer (Canonicalize api), Server api ~ EitherT (Int, String) IO a, + HasClient (Canonicalize api), Client api ~ (BaseUrl -> EitherT ServantError IO ())) => Proxy api -> WrappedApi