From 175c9532f1cdb1d1325713fe25f63636c1f1c056 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Mon, 28 Aug 2017 19:27:05 +0200 Subject: [PATCH] [wip] expose client runner as a typeclass --- servant-client/src/Servant/Client.hs | 100 +++++++++--------- servant-client/src/Servant/Client/Class.hs | 15 +++ .../src/Servant/Client/HttpClient.hs | 12 +++ 3 files changed, 78 insertions(+), 49 deletions(-) create mode 100644 servant-client/src/Servant/Client/Class.hs diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index af97db54..c6e7017a 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -43,6 +44,7 @@ import Prelude.Compat import Servant.API import Servant.Client.Experimental.Auth import Servant.Client.HttpClient +import Servant.Client.Class import Servant.Common.BaseUrl import Servant.Common.BasicAuth import Servant.Common.Req @@ -60,15 +62,15 @@ import Servant.Common.Req -- > getAllBooks :: ClientM [Book] -- > postNewBook :: Book -> ClientM Book -- > (getAllBooks :<|> postNewBook) = client myApi -client :: HasClient api => Proxy api -> Client api +client :: HasClient api => Proxy api -> Client m api client p = clientWithRoute 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 api where - type Client api :: * - clientWithRoute :: Proxy api -> Req -> Client api + type Client (m :: * -> *) (api :: *) :: * + clientWithRoute :: Proxy api -> Req -> Client m api -- | A client querying function for @a ':<|>' b@ will actually hand you @@ -85,7 +87,7 @@ class HasClient api where -- > postNewBook :: Book -> ClientM Book -- > (getAllBooks :<|> postNewBook) = client myApi instance (HasClient a, HasClient b) => HasClient (a :<|> b) where - type Client (a :<|> b) = Client a :<|> Client b + type Client m (a :<|> b) = Client m a :<|> Client m b clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy a) req :<|> clientWithRoute (Proxy :: Proxy b) req @@ -104,7 +106,7 @@ data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) -- > getAllBooks :: ClientM [Book] -- > (getAllBooks :<|> EmptyClient) = client myApi instance HasClient EmptyAPI where - type Client EmptyAPI = EmptyClient + type Client m EmptyAPI = EmptyClient clientWithRoute Proxy _ = EmptyClient -- | If you use a 'Capture' in one of your endpoints in your API, @@ -129,8 +131,8 @@ instance HasClient EmptyAPI where instance (KnownSymbol capture, ToHttpApiData a, HasClient api) => HasClient (Capture capture a :> api) where - type Client (Capture capture a :> api) = - a -> Client api + type Client m (Capture capture a :> api) = + a -> Client m api clientWithRoute Proxy req val = clientWithRoute (Proxy :: Proxy api) @@ -161,8 +163,8 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient api) instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) => HasClient (CaptureAll capture a :> sublayout) where - type Client (CaptureAll capture a :> sublayout) = - [a] -> Client sublayout + type Client m (CaptureAll capture a :> sublayout) = + [a] -> Client m sublayout clientWithRoute Proxy req vals = clientWithRoute (Proxy :: Proxy sublayout) @@ -172,42 +174,42 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) instance OVERLAPPABLE_ -- Note [Non-Empty Content Types] - (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) + (RunClient m ct ([H.Header], a), MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) ) => HasClient (Verb method status cts' a) where - type Client (Verb method status cts' a) = ClientM a + type Client m (Verb method status cts' a) = m a clientWithRoute Proxy req = do - snd <$> performRequestCT (Proxy :: Proxy ct) method req + snd <$> runRequest (Proxy :: Proxy ct) method req where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ - (ReflectMethod method) => HasClient (Verb method status cts NoContent) where - type Client (Verb method status cts NoContent) - = ClientM NoContent + (RunClient m NoContent [H.Header], ReflectMethod method) => HasClient (Verb method status cts NoContent) where + type Client m (Verb method status cts NoContent) + = m NoContent clientWithRoute Proxy req = do - performRequestNoBody method req >> return NoContent + runRequest (Proxy :: Proxy NoContent) method req >> return NoContent where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ -- Note [Non-Empty Content Types] - ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) + ( RunClient m ct ([H.Header], a), MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) ) => HasClient (Verb method status cts' (Headers ls a)) where - type Client (Verb method status cts' (Headers ls a)) - = ClientM (Headers ls a) + type Client m (Verb method status cts' (Headers ls a)) + = m (Headers ls a) clientWithRoute Proxy req = do let method = reflectMethod (Proxy :: Proxy method) - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req + (hdrs, resp) <- runRequest (Proxy :: Proxy ct) method req return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } instance OVERLAPPING_ - ( BuildHeadersTo ls, ReflectMethod method + ( RunClient m NoContent [H.Header], BuildHeadersTo ls, ReflectMethod method ) => HasClient (Verb method status cts (Headers ls NoContent)) where - type Client (Verb method status cts (Headers ls NoContent)) - = ClientM (Headers ls NoContent) + type Client m (Verb method status cts (Headers ls NoContent)) + = m (Headers ls NoContent) clientWithRoute Proxy req = do let method = reflectMethod (Proxy :: Proxy method) - hdrs <- performRequestNoBody method req + hdrs <- runRequest method req return $ Headers { getResponse = NoContent , getHeadersHList = buildHeadersTo hdrs } @@ -241,8 +243,8 @@ instance OVERLAPPING_ instance (KnownSymbol sym, ToHttpApiData a, HasClient api) => HasClient (Header sym a :> api) where - type Client (Header sym a :> api) = - Maybe a -> Client api + type Client m (Header sym a :> api) = + Maybe a -> Client m api clientWithRoute Proxy req mval = clientWithRoute (Proxy :: Proxy api) @@ -258,21 +260,21 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient api) instance HasClient api => HasClient (HttpVersion :> api) where - type Client (HttpVersion :> api) = - Client api + type Client m (HttpVersion :> api) = + Client m api clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api) -- | Ignore @'Summary'@ in client functions. instance HasClient api => HasClient (Summary desc :> api) where - type Client (Summary desc :> api) = Client api + type Client m (Summary desc :> api) = Client m api clientWithRoute _ = clientWithRoute (Proxy :: Proxy api) -- | Ignore @'Description'@ in client functions. instance HasClient api => HasClient (Description desc :> api) where - type Client (Description desc :> api) = Client api + type Client m (Description desc :> api) = Client m api clientWithRoute _ = clientWithRoute (Proxy :: Proxy api) @@ -304,8 +306,8 @@ instance HasClient api => HasClient (Description desc :> api) where instance (KnownSymbol sym, ToHttpApiData a, HasClient api) => HasClient (QueryParam sym a :> api) where - type Client (QueryParam sym a :> api) = - Maybe a -> Client api + type Client m (QueryParam sym a :> api) = + Maybe a -> Client m api -- if mparam = Nothing, we don't add it to the query string clientWithRoute Proxy req mparam = @@ -349,8 +351,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient api) instance (KnownSymbol sym, ToHttpApiData a, HasClient api) => HasClient (QueryParams sym a :> api) where - type Client (QueryParams sym a :> api) = - [a] -> Client api + type Client m (QueryParams sym a :> api) = + [a] -> Client m api clientWithRoute Proxy req paramlist = clientWithRoute (Proxy :: Proxy api) @@ -387,8 +389,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient api) instance (KnownSymbol sym, HasClient api) => HasClient (QueryFlag sym :> api) where - type Client (QueryFlag sym :> api) = - Bool -> Client api + type Client m (QueryFlag sym :> api) = + Bool -> Client m api clientWithRoute Proxy req flag = clientWithRoute (Proxy :: Proxy api) @@ -403,12 +405,12 @@ instance (KnownSymbol sym, HasClient api) -- | 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 -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) + type Client m Raw + = H.Method -> m (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) clientWithRoute :: Proxy Raw -> Req -> Client Raw clientWithRoute Proxy req httpMethod = do - performRequest httpMethod req + runRequest (Proxy :: Proxy NoContent) httpMethod req -- | If you use a 'ReqBody' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -431,8 +433,8 @@ instance HasClient Raw where instance (MimeRender ct a, HasClient api) => HasClient (ReqBody (ct ': cts) a :> api) where - type Client (ReqBody (ct ': cts) a :> api) = - a -> Client api + type Client m (ReqBody (ct ': cts) a :> api) = + a -> Client m api clientWithRoute Proxy req body = clientWithRoute (Proxy :: Proxy api) @@ -445,7 +447,7 @@ instance (MimeRender ct a, HasClient api) -- | Make the querying function append @path@ to the request path. instance (KnownSymbol path, HasClient api) => HasClient (path :> api) where - type Client (path :> api) = Client api + type Client m (path :> api) = Client m api clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy api) @@ -454,19 +456,19 @@ instance (KnownSymbol path, HasClient api) => HasClient (path :> api) where where p = symbolVal (Proxy :: Proxy path) instance HasClient api => HasClient (Vault :> api) where - type Client (Vault :> api) = Client api + type Client m (Vault :> api) = Client m api clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy api) req instance HasClient api => HasClient (RemoteHost :> api) where - type Client (RemoteHost :> api) = Client api + type Client m (RemoteHost :> api) = Client m api clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy api) req instance HasClient api => HasClient (IsSecure :> api) where - type Client (IsSecure :> api) = Client api + type Client m (IsSecure :> api) = Client m api clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy api) req @@ -474,13 +476,13 @@ instance HasClient api => HasClient (IsSecure :> api) where instance HasClient subapi => HasClient (WithNamedContext name context subapi) where - type Client (WithNamedContext name context subapi) = Client subapi + type Client m (WithNamedContext name context subapi) = Client m subapi clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi) instance ( HasClient api ) => HasClient (AuthProtect tag :> api) where - type Client (AuthProtect tag :> api) - = AuthenticateReq (AuthProtect tag) -> Client api + type Client m (AuthProtect tag :> api) + = AuthenticateReq (AuthProtect tag) -> Client m api clientWithRoute Proxy req (AuthenticateReq (val,func)) = clientWithRoute (Proxy :: Proxy api) (func val req) @@ -488,7 +490,7 @@ instance ( HasClient api -- * Basic Authentication instance HasClient api => HasClient (BasicAuth realm usr :> api) where - type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api + type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api clientWithRoute Proxy req val = clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) diff --git a/servant-client/src/Servant/Client/Class.hs b/servant-client/src/Servant/Client/Class.hs new file mode 100644 index 00000000..e880188f --- /dev/null +++ b/servant-client/src/Servant/Client/Class.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-| Types for possible backends to run client-side `Req` queries -} +module Servant.Client.Class + (RunClient(..)) +where + +import Data.Proxy +import Network.HTTP.Types +import Servant.API +import Servant.Common.Req + +class (Monad m) => RunClient m ct result where + runRequest :: MimeUnrender ct result + => Proxy ct + -> Method -> Req -> m result diff --git a/servant-client/src/Servant/Client/HttpClient.hs b/servant-client/src/Servant/Client/HttpClient.hs index aead1489..3d972db7 100644 --- a/servant-client/src/Servant/Client/HttpClient.hs +++ b/servant-client/src/Servant/Client/HttpClient.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} @@ -36,11 +37,22 @@ import Network.HTTP.Types import Network.HTTP.Client hiding (Proxy, path) import qualified Network.HTTP.Types.Header as HTTP import Servant.API.ContentTypes +import Servant.Client.Class import Servant.Common.BaseUrl import Servant.Common.Req import qualified Network.HTTP.Client as Client +instance RunClient ClientM NoContent ( Int, ByteString, MediaType + , [HTTP.Header], Response ByteString) where + runRequest _ meth req = performRequest meth req + +instance (MimeUnrender ct a) => + RunClient ClientM ct ([HTTP.Header], a) where + runRequest p meth req = performRequestCT p meth req + +instance RunClient ClientM NoContent [HTTP.Header] where + runRequest _ meth req = performRequestNoBody meth req data ClientEnv = ClientEnv