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

added a function to create Client.Request in ClientEnv

Author: phadej

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.
+
+}

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:

servant-client/src/Servant/Client.hs

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

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

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

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

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)

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,16 +126,28 @@ 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 ->
           ioProperty $ do
             result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
             return $
               result === Right (cap, num, flag, body)
-

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