From 7379b7486abebb6be2347710cc14754601dbfd66 Mon Sep 17 00:00:00 2001 From: mbg Date: Mon, 28 Mar 2016 14:11:50 +0100 Subject: [PATCH] Moved BaseUrl and Manager parameters from the client function to the Client type as discussed in #428 --- servant-client/src/Servant/Client.hs | 93 +++++++++++------------- servant-client/src/Servant/Common/Req.hs | 46 +++++++----- 2 files changed, 70 insertions(+), 69 deletions(-) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index e73c05a4..fb94fccb 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -27,14 +27,13 @@ module Servant.Client #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad.Trans.Except import Data.ByteString.Lazy (ByteString) import Data.List import Data.Proxy import Data.String.Conversions import Data.Text (unpack) import GHC.TypeLits -import Network.HTTP.Client (Response, Manager) +import Network.HTTP.Client (Response) import Network.HTTP.Media import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as HTTP @@ -58,15 +57,15 @@ import Servant.Common.Req -- > postNewBook :: Book -> ExceptT String IO Book -- > (getAllBooks :<|> postNewBook) = client myApi host manager -- > where host = BaseUrl Http "localhost" 8080 -client :: HasClient layout => Proxy layout -> BaseUrl -> Manager -> Client layout -client p baseurl = clientWithRoute p defReq baseurl +client :: HasClient layout => Proxy layout -> Client layout +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 layout where type Client layout :: * - clientWithRoute :: Proxy layout -> Req -> BaseUrl -> Manager -> Client layout + clientWithRoute :: Proxy layout -> Req -> Client layout -- | A client querying function for @a ':<|>' b@ will actually hand you @@ -85,9 +84,9 @@ class HasClient layout where -- > where host = BaseUrl Http "localhost" 8080 instance (HasClient a, HasClient b) => HasClient (a :<|> b) where type Client (a :<|> b) = Client a :<|> Client b - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy a) req baseurl manager :<|> - clientWithRoute (Proxy :: Proxy b) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy a) req :<|> + clientWithRoute (Proxy :: Proxy b) req -- | If you use a 'Capture' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -115,11 +114,9 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) type Client (Capture capture a :> sublayout) = a -> Client sublayout - clientWithRoute Proxy req baseurl manager val = + clientWithRoute Proxy req val = clientWithRoute (Proxy :: Proxy sublayout) (appendToPath p req) - baseurl - manager where p = unpack (toUrlPiece val) @@ -127,27 +124,26 @@ instance OVERLAPPABLE_ -- Note [Non-Empty Content Types] (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) ) => HasClient (Verb method status cts' a) where - type Client (Verb method status cts' a) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager + type Client (Verb method status cts' a) = ClientM a + clientWithRoute Proxy req = + snd <$> performRequestCT (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) = ExceptT ServantError IO NoContent - clientWithRoute Proxy req baseurl manager = - performRequestNoBody method req baseurl manager >> return NoContent + type Client (Verb method status cts NoContent) = ClientM NoContent + clientWithRoute Proxy req = + performRequestNoBody 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) ) => HasClient (Verb method status cts' (Headers ls a)) where - type Client (Verb method status cts' (Headers ls a)) - = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager = do + type Client (Verb method status cts' (Headers ls a)) = ClientM (Headers ls a) + clientWithRoute Proxy req = do let method = reflectMethod (Proxy :: Proxy method) - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl manager + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } @@ -156,10 +152,10 @@ instance OVERLAPPING_ ( BuildHeadersTo ls, ReflectMethod method ) => HasClient (Verb method status cts (Headers ls NoContent)) where type Client (Verb method status cts (Headers ls NoContent)) - = ExceptT ServantError IO (Headers ls NoContent) - clientWithRoute Proxy req baseurl manager = do + = ClientM (Headers ls NoContent) + clientWithRoute Proxy req = do let method = reflectMethod (Proxy :: Proxy method) - hdrs <- performRequestNoBody method req baseurl manager + hdrs <- performRequestNoBody method req return $ Headers { getResponse = NoContent , getHeadersHList = buildHeadersTo hdrs } @@ -197,14 +193,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) type Client (Header sym a :> sublayout) = Maybe a -> Client sublayout - clientWithRoute Proxy req baseurl manager mval = + clientWithRoute Proxy req mval = clientWithRoute (Proxy :: Proxy sublayout) (maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval ) - baseurl - manager where hname = symbolVal (Proxy :: Proxy sym) @@ -252,14 +246,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) Maybe a -> Client sublayout -- if mparam = Nothing, we don't add it to the query string - clientWithRoute Proxy req baseurl manager mparam = + clientWithRoute Proxy req mparam = clientWithRoute (Proxy :: Proxy sublayout) (maybe req (flip (appendToQueryString pname) req . Just) mparamText ) - baseurl - manager where pname = cs pname' pname' = symbolVal (Proxy :: Proxy sym) @@ -299,13 +291,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) type Client (QueryParams sym a :> sublayout) = [a] -> Client sublayout - clientWithRoute Proxy req baseurl manager paramlist = + clientWithRoute Proxy req paramlist = clientWithRoute (Proxy :: Proxy sublayout) (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist' ) - baseurl manager where pname = cs pname' pname' = symbolVal (Proxy :: Proxy sym) @@ -339,13 +330,12 @@ instance (KnownSymbol sym, HasClient sublayout) type Client (QueryFlag sym :> sublayout) = Bool -> Client sublayout - clientWithRoute Proxy req baseurl manager flag = + clientWithRoute Proxy req flag = clientWithRoute (Proxy :: Proxy sublayout) (if flag then appendToQueryString paramname Nothing req else req ) - baseurl manager where paramname = cs $ symbolVal (Proxy :: Proxy sym) @@ -353,11 +343,12 @@ 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 -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) + type Client Raw + = H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) - clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw - clientWithRoute Proxy req baseurl manager httpMethod = do - performRequest httpMethod req baseurl manager + clientWithRoute :: Proxy Raw -> Req -> Client Raw + clientWithRoute Proxy req httpMethod = do + performRequest httpMethod req -- | If you use a 'ReqBody' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -384,43 +375,41 @@ instance (MimeRender ct a, HasClient sublayout) type Client (ReqBody (ct ': cts) a :> sublayout) = a -> Client sublayout - clientWithRoute Proxy req baseurl manager body = + clientWithRoute Proxy req body = clientWithRoute (Proxy :: Proxy sublayout) (let ctProxy = Proxy :: Proxy ct in setRQBody (mimeRender ctProxy body) (contentType ctProxy) req ) - baseurl manager -- | 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 - clientWithRoute Proxy req baseurl manager = + clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy sublayout) (appendToPath p req) - baseurl manager where p = symbolVal (Proxy :: Proxy path) instance HasClient api => HasClient (Vault :> api) where type Client (Vault :> api) = Client api - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy api) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy api) req instance HasClient api => HasClient (RemoteHost :> api) where type Client (RemoteHost :> api) = Client api - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy api) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy api) req instance HasClient api => HasClient (IsSecure :> api) where type Client (IsSecure :> api) = Client api - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy api) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy api) req instance HasClient subapi => HasClient (WithNamedContext name context subapi) where @@ -433,16 +422,16 @@ instance ( HasClient api type Client (AuthProtect tag :> api) = AuthenticateReq (AuthProtect tag) -> Client api - clientWithRoute Proxy req baseurl manager (AuthenticateReq (val,func)) = - clientWithRoute (Proxy :: Proxy api) (func val req) baseurl manager + clientWithRoute Proxy req (AuthenticateReq (val,func)) = + clientWithRoute (Proxy :: Proxy api) (func val req) -- * Basic Authentication instance HasClient api => HasClient (BasicAuth realm usr :> api) where type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api - clientWithRoute Proxy req baseurl manager val = - clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) baseurl manager + clientWithRoute Proxy req val = + clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) {- Note [Non-Empty Content Types] diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 3d72acd9..44551464 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -11,7 +11,9 @@ import Control.Exception import Control.Monad import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Control.Monad.Trans.Except +import Control.Monad.Trans.Reader import Data.ByteString.Lazy hiding (pack, filter, map, null, elem) import Data.String import Data.String.Conversions @@ -123,11 +125,21 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) = displayHttpRequest :: Method -> String displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" +type ClientM = ReaderT BaseUrl (ReaderT Manager (ExceptT ServantError IO)) -performRequest :: Method -> Req -> BaseUrl -> Manager - -> ExceptT ServantError IO ( Int, ByteString, MediaType - , [HTTP.Header], Response ByteString) -performRequest reqMethod req reqHost manager = do +runClientM :: ClientM a -> BaseUrl -> Manager -> IO (Either ServantError a) +runClientM m baseUrl manager = runExceptT (runReaderT (runReaderT m baseUrl) manager) + +-- to avoid adding a dependency on mtl +throwError :: ServantError -> ClientM a +throwError = lift . lift . throwE + +performRequest :: Method -> Req + -> ClientM ( Int, ByteString, MediaType + , [HTTP.Header], Response ByteString) +performRequest reqMethod req = do + reqHost <- ask + manager <- lift ask partialRequest <- liftIO $ reqToRequest req reqHost let request = partialRequest { Client.method = reqMethod @@ -137,7 +149,7 @@ performRequest reqMethod req reqHost manager = do eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager case eResponse of Left err -> - throwE . ConnectionError $ SomeException err + throwError . ConnectionError $ SomeException err Right response -> do let status = Client.responseStatus response @@ -147,29 +159,29 @@ performRequest reqMethod req reqHost manager = do ct <- case lookup "Content-Type" $ Client.responseHeaders response of Nothing -> pure $ "application"//"octet-stream" Just t -> case parseAccept t of - Nothing -> throwE $ InvalidContentTypeHeader (cs t) body + Nothing -> throwError $ InvalidContentTypeHeader (cs t) body Just t' -> pure t' unless (status_code >= 200 && status_code < 300) $ - throwE $ FailureResponse status ct body + throwError $ FailureResponse status ct body return (status_code, body, ct, hdrs, response) performRequestCT :: MimeUnrender ct result => - Proxy ct -> Method -> Req -> BaseUrl -> Manager - -> ExceptT ServantError IO ([HTTP.Header], result) -performRequestCT ct reqMethod req reqHost manager = do + Proxy ct -> Method -> Req + -> ClientM ([HTTP.Header], result) +performRequestCT ct reqMethod req = do let acceptCT = contentType ct (_status, respBody, respCT, hdrs, _response) <- - performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager - unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody + performRequest reqMethod (req { reqAccept = [acceptCT] }) + unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of - Left err -> throwE $ DecodeFailure err respCT respBody + Left err -> throwError $ DecodeFailure err respCT respBody Right val -> return (hdrs, val) -performRequestNoBody :: Method -> Req -> BaseUrl -> Manager - -> ExceptT ServantError IO [HTTP.Header] -performRequestNoBody reqMethod req reqHost manager = do - (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager +performRequestNoBody :: Method -> Req + -> ClientM [HTTP.Header] +performRequestNoBody reqMethod req = do + (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req return hdrs catchConnectionError :: IO a -> IO (Either ServantError a)