diff --git a/changelog.d/pr-1213 b/changelog.d/pr-1213 new file mode 100644 index 00000000..faecdd83 --- /dev/null +++ b/changelog.d/pr-1213 @@ -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. + +} diff --git a/doc/cookbook/using-free-client/UsingFreeClient.lhs b/doc/cookbook/using-free-client/UsingFreeClient.lhs index fe64b6eb..d72ad6d5 100644 --- a/doc/cookbook/using-free-client/UsingFreeClient.lhs +++ b/doc/cookbook/using-free-client/UsingFreeClient.lhs @@ -2,7 +2,7 @@ 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. 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. @@ -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: ```haskell - let req' = I.requestToClientRequest burl req + let req' = I.defaultMakeClientRequest burl req putStrLn $ "Making request: " ++ show req' ``` @@ -136,11 +136,11 @@ and calling the continuation. We should get a `Pure` value. ```haskell let res = I.clientResponseToResponse id res' - + case k res of Pure n -> putStrLn $ "Expected 1764, got " ++ show n - _ -> + _ -> 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. 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. Here is an example of running our small `test` against a running server: diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 1ecc07db..e0c8dab5 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -9,6 +9,7 @@ module Servant.Client , runClientM , ClientEnv(..) , mkClientEnv + , defaultMakeClientRequest , hoistClient , module Servant.Client.Core.Reexport ) where diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index ec8a63e5..c25c8a93 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -72,16 +72,27 @@ import qualified Network.HTTP.Client as Client import qualified Servant.Types.SourceT as S -- | 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 = ClientEnv { manager :: Client.Manager , baseUrl :: BaseUrl , 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. 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. -- @@ -152,8 +163,8 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm performRequest :: Request -> ClientM Response performRequest req = do - ClientEnv m burl cookieJar' <- ask - let clientRequest = requestToClientRequest burl req + ClientEnv m burl cookieJar' createClientRequest <- ask + let clientRequest = createClientRequest burl req request <- case cookieJar' of Nothing -> pure clientRequest Just cj -> liftIO $ do @@ -162,7 +173,7 @@ performRequest req = do oldCookieJar <- readTVar cj let (newRequest, newCookieJar) = Client.insertCookiesIntoRequest - (requestToClientRequest burl req) + clientRequest oldCookieJar now writeTVar cj newCookieJar @@ -215,8 +226,11 @@ clientResponseToResponse f r = Response , responseHttpVersion = Client.responseVersion r } -requestToClientRequest :: BaseUrl -> Request -> Client.Request -requestToClientRequest burl r = Client.defaultRequest +-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request' +-- 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.host = fromString $ baseUrlHost burl , Client.port = baseUrlPort burl diff --git a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs index 449c638d..2f5a1cb7 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs @@ -12,7 +12,7 @@ module Servant.Client.Internal.HttpClient.Streaming ( ClientEnv (..), mkClientEnv, clientResponseToResponse, - requestToClientRequest, + defaultMakeClientRequest, catchConnectionError, ) where @@ -55,7 +55,7 @@ import Servant.Client.Core import Servant.Client.Internal.HttpClient (ClientEnv (..), catchConnectionError, clientResponseToResponse, mkClientEnv, mkFailureResponse, - requestToClientRequest) + defaultMakeClientRequest) import qualified Servant.Types.SourceT as S @@ -139,8 +139,8 @@ runClientM cm env = withClientM cm env (evaluate . force) performRequest :: Request -> ClientM Response performRequest req = do -- TODO: should use Client.withResponse here too - ClientEnv m burl cookieJar' <- ask - let clientRequest = requestToClientRequest burl req + ClientEnv m burl cookieJar' createClientRequest <- ask + let clientRequest = createClientRequest burl req request <- case cookieJar' of Nothing -> pure clientRequest Just cj -> liftIO $ do @@ -149,7 +149,7 @@ performRequest req = do oldCookieJar <- readTVar cj let (newRequest, newCookieJar) = Client.insertCookiesIntoRequest - (requestToClientRequest burl req) + clientRequest oldCookieJar now writeTVar cj newCookieJar @@ -173,7 +173,8 @@ performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM performWithStreamingRequest req k = do m <- asks manager burl <- asks baseUrl - let request = requestToClientRequest burl req + createClientRequest <- asks makeClientRequest + let request = createClientRequest burl req ClientM $ lift $ lift $ Codensity $ \k1 -> Client.withResponse request m $ \res -> do let status = Client.responseStatus res diff --git a/servant-client/src/Servant/Client/Streaming.hs b/servant-client/src/Servant/Client/Streaming.hs index d4e8721d..5800df0d 100644 --- a/servant-client/src/Servant/Client/Streaming.hs +++ b/servant-client/src/Servant/Client/Streaming.hs @@ -10,6 +10,7 @@ module Servant.Client.Streaming , runClientM , ClientEnv(..) , mkClientEnv + , defaultMakeClientRequest , hoistClient , module Servant.Client.Core.Reexport ) where diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index 1509574c..6f385010 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -93,6 +93,7 @@ type Api = :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool :<|> "rawSuccess" :> Raw + :<|> "rawSuccessPassHeaders" :> Raw :<|> "rawFailure" :> Raw :<|> "multiple" :> Capture "first" String :> @@ -118,6 +119,7 @@ getQueryParam :: Maybe String -> ClientM Person getQueryParams :: [String] -> ClientM [Person] getQueryFlag :: Bool -> ClientM Bool getRawSuccess :: HTTP.Method -> ClientM Response +getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response getRawFailure :: HTTP.Method -> ClientM Response getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> ClientM (String, Maybe Int, Bool, [(String, [Rational])]) @@ -135,6 +137,7 @@ getRoot :<|> getQueryParams :<|> getQueryFlag :<|> getRawSuccess + :<|> getRawSuccessPassHeaders :<|> getRawFailure :<|> getMultiple :<|> getRespHeaders @@ -157,6 +160,7 @@ server = serve api ( :<|> (\ names -> return (zipWith Person names [0..])) :<|> return :<|> (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") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) diff --git a/servant-client/test/Servant/SuccessSpec.hs b/servant-client/test/Servant/SuccessSpec.hs index d16cfd79..272b607c 100644 --- a/servant-client/test/Servant/SuccessSpec.hs +++ b/servant-client/test/Servant/SuccessSpec.hs @@ -42,6 +42,7 @@ import Servant.API (NoContent (NoContent), getHeaders) import Servant.Client import qualified Servant.Client.Core.Request as Req +import Servant.Client.Internal.HttpClient (defaultMakeClientRequest) import Servant.Test.ComprehensiveAPI import Servant.ClientTestUtils @@ -125,11 +126,24 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do mgr <- C.newManager C.defaultManagerSettings 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) C.cookie_name <$> cookie `shouldBe` Just "testcookie" 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 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> 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 return $ result === Right (cap, num, flag, body) - diff --git a/stack.yaml b/stack.yaml index a4855c36..47a7eab0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,16 +17,20 @@ packages: extra-deps: - base-compat-0.10.5 +- base-orphans-0.8.1 - conduit-1.3.1 - hspec-2.6.0 - hspec-core-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-types-0.12.3 - network-2.8.0.0 - pipes-safe-2.3.1 - QuickCheck-2.12.6.1 - resourcet-1.2.2 - sop-core-0.4.0.0 +- time-compat-1.9.2.2 +- unordered-containers-0.2.10.0 - wai-extra-3.0.24.3 - tasty-1.1.0.4