Merge pull request #1255 from haskell-servant/pr-1213

added a function to create Client.Request in ClientEnv
This commit is contained in:
Oleg Grenrus 2019-12-14 23:13:20 +02:00 committed by GitHub
commit 65c6298e89
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
9 changed files with 69 additions and 20 deletions

11
changelog.d/pr-1213 Normal file
View File

@ -0,0 +1,11 @@
synopsis: Added a function to create Client.Request in ClientEnv
packages: servant-client
prs: #1213 #1255
description: {
The new member `makeClientRequest` of `ClientEnv` is used to create
`http-client` `Request` from `servant-client-core` `Request`.
This functionality can be used for example to set
dynamic timeouts for each request.
}

View File

@ -2,7 +2,7 @@
or simply put: _a practical introduction to `Servant.Client.Free`_. or simply put: _a practical introduction to `Servant.Client.Free`_.
Someone asked on IRC how one could access the intermediate Requests (resp. Responses) Someone asked on IRC how one could access the intermediate Requests (resp. Responses)
produced (resp. received) by client functions derived using servant-client. produced (resp. received) by client functions derived using servant-client.
My response to such inquiries is: to extend `servant-client` in an ad-hoc way (e.g for testing or debugging My response to such inquiries is: to extend `servant-client` in an ad-hoc way (e.g for testing or debugging
purposes), use `Servant.Client.Free`. This recipe shows how. purposes), use `Servant.Client.Free`. This recipe shows how.
@ -119,7 +119,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request`
to http-client's `Request`, and we can inspect it: to http-client's `Request`, and we can inspect it:
```haskell ```haskell
let req' = I.requestToClientRequest burl req let req' = I.defaultMakeClientRequest burl req
putStrLn $ "Making request: " ++ show req' putStrLn $ "Making request: " ++ show req'
``` ```
@ -136,11 +136,11 @@ and calling the continuation. We should get a `Pure` value.
```haskell ```haskell
let res = I.clientResponseToResponse id res' let res = I.clientResponseToResponse id res'
case k res of case k res of
Pure n -> Pure n ->
putStrLn $ "Expected 1764, got " ++ show n putStrLn $ "Expected 1764, got " ++ show n
_ -> _ ->
putStrLn "ERROR: didn't got a response" putStrLn "ERROR: didn't got a response"
``` ```
@ -153,7 +153,7 @@ and responses available for us to inspect, since `RunClient` only gives us
access to one `Request` or `Response` at a time. access to one `Request` or `Response` at a time.
On the other hand, a "batch collection" of requests and/or responses can be achieved On the other hand, a "batch collection" of requests and/or responses can be achieved
with both free clients and a custom `RunClient` instance rather easily, for example with both free clients and a custom `RunClient` instance rather easily, for example
by using a `Writer [(Request, Response)]` monad. by using a `Writer [(Request, Response)]` monad.
Here is an example of running our small `test` against a running server: Here is an example of running our small `test` against a running server:

View File

@ -9,6 +9,7 @@ module Servant.Client
, runClientM , runClientM
, ClientEnv(..) , ClientEnv(..)
, mkClientEnv , mkClientEnv
, defaultMakeClientRequest
, hoistClient , hoistClient
, module Servant.Client.Core.Reexport , module Servant.Client.Core.Reexport
) where ) where

View File

@ -72,16 +72,27 @@ import qualified Network.HTTP.Client as Client
import qualified Servant.Types.SourceT as S import qualified Servant.Types.SourceT as S
-- | The environment in which a request is run. -- | The environment in which a request is run.
-- The 'baseUrl' and 'makeClientRequest' function are used to create a @http-client@ request.
-- Cookies are then added to that request if a 'CookieJar' is set on the environment.
-- Finally the request is executed with the 'manager'.
-- The 'makeClientRequest' function can be used to modify the request to execute and set values which
-- are not specified on a @servant@ 'Request' like 'responseTimeout' or 'redirectCount'
data ClientEnv data ClientEnv
= ClientEnv = ClientEnv
{ manager :: Client.Manager { manager :: Client.Manager
, baseUrl :: BaseUrl , baseUrl :: BaseUrl
, cookieJar :: Maybe (TVar Client.CookieJar) , cookieJar :: Maybe (TVar Client.CookieJar)
, makeClientRequest :: BaseUrl -> Request -> Client.Request
-- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'
-- Note that:
-- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,
-- If you need global modifications, you should use 'managerModifyRequest'
-- 2. the 'cookieJar', if defined, is being applied after 'makeClientRequest' is called.
} }
-- | 'ClientEnv' smart constructor. -- | 'ClientEnv' smart constructor.
mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv
mkClientEnv mgr burl = ClientEnv mgr burl Nothing mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest
-- | Generates a set of client functions for an API. -- | Generates a set of client functions for an API.
-- --
@ -152,8 +163,8 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
performRequest :: Request -> ClientM Response performRequest :: Request -> ClientM Response
performRequest req = do performRequest req = do
ClientEnv m burl cookieJar' <- ask ClientEnv m burl cookieJar' createClientRequest <- ask
let clientRequest = requestToClientRequest burl req let clientRequest = createClientRequest burl req
request <- case cookieJar' of request <- case cookieJar' of
Nothing -> pure clientRequest Nothing -> pure clientRequest
Just cj -> liftIO $ do Just cj -> liftIO $ do
@ -162,7 +173,7 @@ performRequest req = do
oldCookieJar <- readTVar cj oldCookieJar <- readTVar cj
let (newRequest, newCookieJar) = let (newRequest, newCookieJar) =
Client.insertCookiesIntoRequest Client.insertCookiesIntoRequest
(requestToClientRequest burl req) clientRequest
oldCookieJar oldCookieJar
now now
writeTVar cj newCookieJar writeTVar cj newCookieJar
@ -215,8 +226,11 @@ clientResponseToResponse f r = Response
, responseHttpVersion = Client.responseVersion r , responseHttpVersion = Client.responseVersion r
} }
requestToClientRequest :: BaseUrl -> Request -> Client.Request -- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
requestToClientRequest burl r = Client.defaultRequest -- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'
-- otherwise the body, headers and query string are derived from the @servant@ 'Request'
defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request
defaultMakeClientRequest burl r = Client.defaultRequest
{ Client.method = requestMethod r { Client.method = requestMethod r
, Client.host = fromString $ baseUrlHost burl , Client.host = fromString $ baseUrlHost burl
, Client.port = baseUrlPort burl , Client.port = baseUrlPort burl

View File

@ -12,7 +12,7 @@ module Servant.Client.Internal.HttpClient.Streaming (
ClientEnv (..), ClientEnv (..),
mkClientEnv, mkClientEnv,
clientResponseToResponse, clientResponseToResponse,
requestToClientRequest, defaultMakeClientRequest,
catchConnectionError, catchConnectionError,
) where ) where
@ -55,7 +55,7 @@ import Servant.Client.Core
import Servant.Client.Internal.HttpClient import Servant.Client.Internal.HttpClient
(ClientEnv (..), catchConnectionError, (ClientEnv (..), catchConnectionError,
clientResponseToResponse, mkClientEnv, mkFailureResponse, clientResponseToResponse, mkClientEnv, mkFailureResponse,
requestToClientRequest) defaultMakeClientRequest)
import qualified Servant.Types.SourceT as S import qualified Servant.Types.SourceT as S
@ -139,8 +139,8 @@ runClientM cm env = withClientM cm env (evaluate . force)
performRequest :: Request -> ClientM Response performRequest :: Request -> ClientM Response
performRequest req = do performRequest req = do
-- TODO: should use Client.withResponse here too -- TODO: should use Client.withResponse here too
ClientEnv m burl cookieJar' <- ask ClientEnv m burl cookieJar' createClientRequest <- ask
let clientRequest = requestToClientRequest burl req let clientRequest = createClientRequest burl req
request <- case cookieJar' of request <- case cookieJar' of
Nothing -> pure clientRequest Nothing -> pure clientRequest
Just cj -> liftIO $ do Just cj -> liftIO $ do
@ -149,7 +149,7 @@ performRequest req = do
oldCookieJar <- readTVar cj oldCookieJar <- readTVar cj
let (newRequest, newCookieJar) = let (newRequest, newCookieJar) =
Client.insertCookiesIntoRequest Client.insertCookiesIntoRequest
(requestToClientRequest burl req) clientRequest
oldCookieJar oldCookieJar
now now
writeTVar cj newCookieJar writeTVar cj newCookieJar
@ -173,7 +173,8 @@ performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM
performWithStreamingRequest req k = do performWithStreamingRequest req k = do
m <- asks manager m <- asks manager
burl <- asks baseUrl burl <- asks baseUrl
let request = requestToClientRequest burl req createClientRequest <- asks makeClientRequest
let request = createClientRequest burl req
ClientM $ lift $ lift $ Codensity $ \k1 -> ClientM $ lift $ lift $ Codensity $ \k1 ->
Client.withResponse request m $ \res -> do Client.withResponse request m $ \res -> do
let status = Client.responseStatus res let status = Client.responseStatus res

View File

@ -10,6 +10,7 @@ module Servant.Client.Streaming
, runClientM , runClientM
, ClientEnv(..) , ClientEnv(..)
, mkClientEnv , mkClientEnv
, defaultMakeClientRequest
, hoistClient , hoistClient
, module Servant.Client.Core.Reexport , module Servant.Client.Core.Reexport
) where ) where

View File

@ -93,6 +93,7 @@ type Api =
:<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
:<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
:<|> "rawSuccess" :> Raw :<|> "rawSuccess" :> Raw
:<|> "rawSuccessPassHeaders" :> Raw
:<|> "rawFailure" :> Raw :<|> "rawFailure" :> Raw
:<|> "multiple" :> :<|> "multiple" :>
Capture "first" String :> Capture "first" String :>
@ -118,6 +119,7 @@ getQueryParam :: Maybe String -> ClientM Person
getQueryParams :: [String] -> ClientM [Person] getQueryParams :: [String] -> ClientM [Person]
getQueryFlag :: Bool -> ClientM Bool getQueryFlag :: Bool -> ClientM Bool
getRawSuccess :: HTTP.Method -> ClientM Response getRawSuccess :: HTTP.Method -> ClientM Response
getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response
getRawFailure :: HTTP.Method -> ClientM Response getRawFailure :: HTTP.Method -> ClientM Response
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
-> ClientM (String, Maybe Int, Bool, [(String, [Rational])]) -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
@ -135,6 +137,7 @@ getRoot
:<|> getQueryParams :<|> getQueryParams
:<|> getQueryFlag :<|> getQueryFlag
:<|> getRawSuccess :<|> getRawSuccess
:<|> getRawSuccessPassHeaders
:<|> getRawFailure :<|> getRawFailure
:<|> getMultiple :<|> getMultiple
:<|> getRespHeaders :<|> getRespHeaders
@ -157,6 +160,7 @@ server = serve api (
:<|> (\ names -> return (zipWith Person names [0..])) :<|> (\ names -> return (zipWith Person names [0..]))
:<|> return :<|> return
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
:<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess"))
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d)) :<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

View File

@ -42,6 +42,7 @@ import Servant.API
(NoContent (NoContent), getHeaders) (NoContent (NoContent), getHeaders)
import Servant.Client import Servant.Client
import qualified Servant.Client.Core.Request as Req import qualified Servant.Client.Core.Request as Req
import Servant.Client.Internal.HttpClient (defaultMakeClientRequest)
import Servant.Test.ComprehensiveAPI import Servant.Test.ComprehensiveAPI
import Servant.ClientTestUtils import Servant.ClientTestUtils
@ -125,11 +126,24 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
mgr <- C.newManager C.defaultManagerSettings mgr <- C.newManager C.defaultManagerSettings
cj <- atomically . newTVar $ C.createCookieJar [] cj <- atomically . newTVar $ C.createCookieJar []
_ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj)) _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj) defaultMakeClientRequest)
cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj) cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj)
C.cookie_name <$> cookie `shouldBe` Just "testcookie" C.cookie_name <$> cookie `shouldBe` Just "testcookie"
C.cookie_value <$> cookie `shouldBe` Just "test" C.cookie_value <$> cookie `shouldBe` Just "test"
it "Can modify the outgoing Request using the ClientEnv" $ \(_, baseUrl) -> do
mgr <- C.newManager C.defaultManagerSettings
-- In proper situation, extra headers should probably be visible in API type.
-- However, testing for response timeout is difficult, so we test with something which is easy to observe
let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }
let clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
case res of
Left e ->
assertFailure $ show e
Right r ->
("X-Added-Header", "XXX") `elem` toList (responseHeaders r) `shouldBe` True
modifyMaxSuccess (const 20) $ do modifyMaxSuccess (const 20) $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
@ -137,4 +151,3 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
result <- left show <$> runClient (getMultiple cap num flag body) baseUrl result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
return $ return $
result === Right (cap, num, flag, body) result === Right (cap, num, flag, body)

View File

@ -17,16 +17,20 @@ packages:
extra-deps: extra-deps:
- base-compat-0.10.5 - base-compat-0.10.5
- base-orphans-0.8.1
- conduit-1.3.1 - conduit-1.3.1
- hspec-2.6.0 - hspec-2.6.0
- hspec-core-2.6.0 - hspec-core-2.6.0
- hspec-discover-2.6.0 - hspec-discover-2.6.0
- http-api-data-0.4 - http-api-data-0.4.1
- http-media-0.7.1.3 - http-media-0.7.1.3
- http-types-0.12.3
- network-2.8.0.0 - network-2.8.0.0
- pipes-safe-2.3.1 - pipes-safe-2.3.1
- QuickCheck-2.12.6.1 - QuickCheck-2.12.6.1
- resourcet-1.2.2 - resourcet-1.2.2
- sop-core-0.4.0.0 - sop-core-0.4.0.0
- time-compat-1.9.2.2
- unordered-containers-0.2.10.0
- wai-extra-3.0.24.3 - wai-extra-3.0.24.3
- tasty-1.1.0.4 - tasty-1.1.0.4