eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Moved BaseUrl and Manager parameters from the client function to the Client type as discussed in #428

Browse source
This commit is contained in:
mbg 2016-03-28 14:11:50 +01:00
parent 5890d5253b
commit 7379b7486a
2 changed files with 70 additions and 69 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

93
servant-client/src/Servant/Client.hs
View file

@ -27,14 +27,13 @@ module Servant.Client
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
#endif #endif
import Control.Monad.Trans.Except
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
import Data.List import Data.List
import Data.Proxy import Data.Proxy
import Data.String.Conversions import Data.String.Conversions
import Data.Text (unpack) import Data.Text (unpack)
import GHC.TypeLits import GHC.TypeLits
import Network.HTTP.Client (Response, Manager) import Network.HTTP.Client (Response)
import Network.HTTP.Media import Network.HTTP.Media
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP import qualified Network.HTTP.Types.Header as HTTP
@ -58,15 +57,15 @@ import Servant.Common.Req
-- > postNewBook :: Book -> ExceptT String IO Book -- > postNewBook :: Book -> ExceptT String IO Book
-- > (getAllBooks :<|> postNewBook) = client myApi host manager -- > (getAllBooks :<|> postNewBook) = client myApi host manager
-- > where host = BaseUrl Http "localhost" 8080 -- > where host = BaseUrl Http "localhost" 8080
client :: HasClient layout => Proxy layout -> BaseUrl -> Manager -> Client layout client :: HasClient layout => Proxy layout -> Client layout
client p baseurl = clientWithRoute p defReq baseurl client p = clientWithRoute p defReq
-- | This class lets us define how each API combinator -- | This class lets us define how each API combinator
-- influences the creation of an HTTP request. It's mostly -- influences the creation of an HTTP request. It's mostly
-- an internal class, you can just use 'client'. -- an internal class, you can just use 'client'.
class HasClient layout where class HasClient layout where
type Client layout :: * 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 -- | 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 -- > where host = BaseUrl Http "localhost" 8080
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where 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 baseurl manager = clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy a) req baseurl manager :<|> clientWithRoute (Proxy :: Proxy a) req :<|>
clientWithRoute (Proxy :: Proxy b) req baseurl manager clientWithRoute (Proxy :: Proxy b) req
-- | If you use a 'Capture' in one of your endpoints in your API, -- | If you use a 'Capture' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
@ -115,11 +114,9 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
type Client (Capture capture a :> sublayout) = type Client (Capture capture a :> sublayout) =
a -> Client sublayout a -> Client sublayout
clientWithRoute Proxy req baseurl manager val = clientWithRoute Proxy req val =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(appendToPath p req) (appendToPath p req)
baseurl
manager
where p = unpack (toUrlPiece val) where p = unpack (toUrlPiece val)
@ -127,27 +124,26 @@ instance OVERLAPPABLE_
-- Note [Non-Empty Content Types] -- Note [Non-Empty Content Types]
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' a) where ) => HasClient (Verb method status cts' a) where
type Client (Verb method status cts' a) = ExceptT ServantError IO a type Client (Verb method status cts' a) = ClientM a
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req =
snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager snd <$> performRequestCT (Proxy :: Proxy ct) method req
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_ instance OVERLAPPING_
(ReflectMethod method) => HasClient (Verb method status cts NoContent) where (ReflectMethod method) => HasClient (Verb method status cts NoContent) where
type Client (Verb method status cts NoContent) = ExceptT ServantError IO NoContent type Client (Verb method status cts NoContent) = ClientM NoContent
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req =
performRequestNoBody method req baseurl manager >> return NoContent performRequestNoBody method req >> return NoContent
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_ instance OVERLAPPING_
-- Note [Non-Empty Content Types] -- Note [Non-Empty Content Types]
( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' (Headers ls a)) where ) => HasClient (Verb method status cts' (Headers ls a)) where
type Client (Verb method status cts' (Headers ls a)) type Client (Verb method status cts' (Headers ls a)) = ClientM (Headers ls a)
= ExceptT ServantError IO (Headers ls a) clientWithRoute Proxy req = do
clientWithRoute Proxy req baseurl manager = do
let method = reflectMethod (Proxy :: Proxy method) 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 return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -156,10 +152,10 @@ instance OVERLAPPING_
( BuildHeadersTo ls, ReflectMethod method ( BuildHeadersTo ls, ReflectMethod method
) => HasClient (Verb method status cts (Headers ls NoContent)) where ) => HasClient (Verb method status cts (Headers ls NoContent)) where
type Client (Verb method status cts (Headers ls NoContent)) type Client (Verb method status cts (Headers ls NoContent))
= ExceptT ServantError IO (Headers ls NoContent) = ClientM (Headers ls NoContent)
clientWithRoute Proxy req baseurl manager = do clientWithRoute Proxy req = do
let method = reflectMethod (Proxy :: Proxy method) let method = reflectMethod (Proxy :: Proxy method)
hdrs <- performRequestNoBody method req baseurl manager hdrs <- performRequestNoBody method req
return $ Headers { getResponse = NoContent return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -197,14 +193,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
type Client (Header sym a :> sublayout) = type Client (Header sym a :> sublayout) =
Maybe a -> Client sublayout Maybe a -> Client sublayout
clientWithRoute Proxy req baseurl manager mval = clientWithRoute Proxy req mval =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(maybe req (maybe req
(\value -> Servant.Common.Req.addHeader hname value req) (\value -> Servant.Common.Req.addHeader hname value req)
mval mval
) )
baseurl
manager
where hname = symbolVal (Proxy :: Proxy sym) where hname = symbolVal (Proxy :: Proxy sym)
@ -252,14 +246,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
Maybe a -> Client sublayout Maybe a -> Client sublayout
-- if mparam = Nothing, we don't add it to the query string -- 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) clientWithRoute (Proxy :: Proxy sublayout)
(maybe req (maybe req
(flip (appendToQueryString pname) req . Just) (flip (appendToQueryString pname) req . Just)
mparamText mparamText
) )
baseurl
manager
where pname = cs pname' where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym) pname' = symbolVal (Proxy :: Proxy sym)
@ -299,13 +291,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
type Client (QueryParams sym a :> sublayout) = type Client (QueryParams sym a :> sublayout) =
[a] -> Client sublayout [a] -> Client sublayout
clientWithRoute Proxy req baseurl manager paramlist = clientWithRoute Proxy req paramlist =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
req req
paramlist' paramlist'
) )
baseurl manager
where pname = cs pname' where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym) pname' = symbolVal (Proxy :: Proxy sym)
@ -339,13 +330,12 @@ instance (KnownSymbol sym, HasClient sublayout)
type Client (QueryFlag sym :> sublayout) = type Client (QueryFlag sym :> sublayout) =
Bool -> Client sublayout Bool -> Client sublayout
clientWithRoute Proxy req baseurl manager flag = clientWithRoute Proxy req flag =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(if flag (if flag
then appendToQueryString paramname Nothing req then appendToQueryString paramname Nothing req
else req else req
) )
baseurl manager
where paramname = cs $ symbolVal (Proxy :: Proxy sym) 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 -- | Pick a 'Method' and specify where the server you want to query is. You get
-- back the full `Response`. -- back the full `Response`.
instance HasClient Raw where 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 Raw -> Req -> Client Raw
clientWithRoute Proxy req baseurl manager httpMethod = do clientWithRoute Proxy req httpMethod = do
performRequest httpMethod req baseurl manager performRequest httpMethod req
-- | If you use a 'ReqBody' in one of your endpoints in your API, -- | If you use a 'ReqBody' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
@ -384,43 +375,41 @@ instance (MimeRender ct a, HasClient sublayout)
type Client (ReqBody (ct ': cts) a :> sublayout) = type Client (ReqBody (ct ': cts) a :> sublayout) =
a -> Client sublayout a -> Client sublayout
clientWithRoute Proxy req baseurl manager body = clientWithRoute Proxy req body =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(let ctProxy = Proxy :: Proxy ct (let ctProxy = Proxy :: Proxy ct
in setRQBody (mimeRender ctProxy body) in setRQBody (mimeRender ctProxy body)
(contentType ctProxy) (contentType ctProxy)
req req
) )
baseurl manager
-- | Make the querying function append @path@ to the request path. -- | Make the querying function append @path@ to the request path.
instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
type Client (path :> sublayout) = Client sublayout type Client (path :> sublayout) = Client sublayout
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(appendToPath p req) (appendToPath p req)
baseurl manager
where p = symbolVal (Proxy :: Proxy path) where p = symbolVal (Proxy :: Proxy path)
instance HasClient api => HasClient (Vault :> api) where instance HasClient api => HasClient (Vault :> api) where
type Client (Vault :> api) = Client api type Client (Vault :> api) = Client api
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy api) req baseurl manager clientWithRoute (Proxy :: Proxy api) req
instance HasClient api => HasClient (RemoteHost :> api) where instance HasClient api => HasClient (RemoteHost :> api) where
type Client (RemoteHost :> api) = Client api type Client (RemoteHost :> api) = Client api
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy api) req baseurl manager clientWithRoute (Proxy :: Proxy api) req
instance HasClient api => HasClient (IsSecure :> api) where instance HasClient api => HasClient (IsSecure :> api) where
type Client (IsSecure :> api) = Client api type Client (IsSecure :> api) = Client api
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy api) req baseurl manager clientWithRoute (Proxy :: Proxy api) req
instance HasClient subapi => instance HasClient subapi =>
HasClient (WithNamedContext name context subapi) where HasClient (WithNamedContext name context subapi) where
@ -433,16 +422,16 @@ instance ( HasClient api
type Client (AuthProtect tag :> api) type Client (AuthProtect tag :> api)
= AuthenticateReq (AuthProtect tag) -> Client api = AuthenticateReq (AuthProtect tag) -> Client api
clientWithRoute Proxy req baseurl manager (AuthenticateReq (val,func)) = clientWithRoute Proxy req (AuthenticateReq (val,func)) =
clientWithRoute (Proxy :: Proxy api) (func val req) baseurl manager clientWithRoute (Proxy :: Proxy api) (func val req)
-- * Basic Authentication -- * Basic Authentication
instance HasClient api => HasClient (BasicAuth realm usr :> api) where instance HasClient api => HasClient (BasicAuth realm usr :> api) where
type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api
clientWithRoute Proxy req baseurl manager val = clientWithRoute Proxy req val =
clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) baseurl manager clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req)
{- Note [Non-Empty Content Types] {- Note [Non-Empty Content Types]

44
servant-client/src/Servant/Common/Req.hs
View file

@ -11,7 +11,9 @@ import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.Catch (MonadThrow) import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem) import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
import Data.String import Data.String
import Data.String.Conversions import Data.String.Conversions
@ -123,11 +125,21 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
displayHttpRequest :: Method -> String displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
type ClientM = ReaderT BaseUrl (ReaderT Manager (ExceptT ServantError IO))
performRequest :: Method -> Req -> BaseUrl -> Manager runClientM :: ClientM a -> BaseUrl -> Manager -> IO (Either ServantError a)
-> ExceptT ServantError IO ( Int, ByteString, MediaType 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) , [HTTP.Header], Response ByteString)
performRequest reqMethod req reqHost manager = do performRequest reqMethod req = do
reqHost <- ask
manager <- lift ask
partialRequest <- liftIO $ reqToRequest req reqHost partialRequest <- liftIO $ reqToRequest req reqHost
let request = partialRequest { Client.method = reqMethod let request = partialRequest { Client.method = reqMethod
@ -137,7 +149,7 @@ performRequest reqMethod req reqHost manager = do
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
case eResponse of case eResponse of
Left err -> Left err ->
throwE . ConnectionError $ SomeException err throwError . ConnectionError $ SomeException err
Right response -> do Right response -> do
let status = Client.responseStatus response let status = Client.responseStatus response
@ -147,29 +159,29 @@ performRequest reqMethod req reqHost manager = do
ct <- case lookup "Content-Type" $ Client.responseHeaders response of ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream" Nothing -> pure $ "application"//"octet-stream"
Just t -> case parseAccept t of Just t -> case parseAccept t of
Nothing -> throwE $ InvalidContentTypeHeader (cs t) body Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
Just t' -> pure t' Just t' -> pure t'
unless (status_code >= 200 && status_code < 300) $ unless (status_code >= 200 && status_code < 300) $
throwE $ FailureResponse status ct body throwError $ FailureResponse status ct body
return (status_code, body, ct, hdrs, response) return (status_code, body, ct, hdrs, response)
performRequestCT :: MimeUnrender ct result => performRequestCT :: MimeUnrender ct result =>
Proxy ct -> Method -> Req -> BaseUrl -> Manager Proxy ct -> Method -> Req
-> ExceptT ServantError IO ([HTTP.Header], result) -> ClientM ([HTTP.Header], result)
performRequestCT ct reqMethod req reqHost manager = do performRequestCT ct reqMethod req = do
let acceptCT = contentType ct let acceptCT = contentType ct
(_status, respBody, respCT, hdrs, _response) <- (_status, respBody, respCT, hdrs, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager performRequest reqMethod (req { reqAccept = [acceptCT] })
unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of case mimeUnrender ct respBody of
Left err -> throwE $ DecodeFailure err respCT respBody Left err -> throwError $ DecodeFailure err respCT respBody
Right val -> return (hdrs, val) Right val -> return (hdrs, val)
performRequestNoBody :: Method -> Req -> BaseUrl -> Manager performRequestNoBody :: Method -> Req
-> ExceptT ServantError IO [HTTP.Header] -> ClientM [HTTP.Header]
performRequestNoBody reqMethod req reqHost manager = do performRequestNoBody reqMethod req = do
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
return hdrs return hdrs
catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError :: IO a -> IO (Either ServantError a)