diff --git a/changelog.d/1595 b/changelog.d/1595 new file mode 100644 index 00000000..fe8afd92 --- /dev/null +++ b/changelog.d/1595 @@ -0,0 +1,2 @@ +synopsis: Run ClientEnv's makeClientRequest in IO. +prs: #1595 diff --git a/doc/cookbook/using-free-client/UsingFreeClient.lhs b/doc/cookbook/using-free-client/UsingFreeClient.lhs index 0185c514..8b668582 100644 --- a/doc/cookbook/using-free-client/UsingFreeClient.lhs +++ b/doc/cookbook/using-free-client/UsingFreeClient.lhs @@ -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.defaultMakeClientRequest burl req + req' <- I.defaultMakeClientRequest burl req putStrLn $ "Making request: " ++ show req' ``` diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index ee146cc7..8db0c9f2 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -80,7 +80,7 @@ data ClientEnv { manager :: Client.Manager , baseUrl :: BaseUrl , cookieJar :: Maybe (TVar Client.CookieJar) - , makeClientRequest :: BaseUrl -> Request -> Client.Request + , makeClientRequest :: BaseUrl -> Request -> IO 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, @@ -162,7 +162,7 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm performRequest :: Maybe [Status] -> Request -> ClientM Response performRequest acceptStatus req = do ClientEnv m burl cookieJar' createClientRequest <- ask - let clientRequest = createClientRequest burl req + clientRequest <- liftIO $ createClientRequest burl req request <- case cookieJar' of Nothing -> pure clientRequest Just cj -> liftIO $ do @@ -229,8 +229,8 @@ clientResponseToResponse f r = Response -- | 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 +defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request +defaultMakeClientRequest burl r = return 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 644a8224..24b00f7b 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs @@ -140,7 +140,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response performRequest acceptStatus req = do -- TODO: should use Client.withResponse here too ClientEnv m burl cookieJar' createClientRequest <- ask - let clientRequest = createClientRequest burl req + clientRequest <- liftIO $ createClientRequest burl req request <- case cookieJar' of Nothing -> pure clientRequest Just cj -> liftIO $ do @@ -177,7 +177,7 @@ performWithStreamingRequest req k = do m <- asks manager burl <- asks baseUrl createClientRequest <- asks makeClientRequest - let request = createClientRequest burl req + request <- liftIO $ createClientRequest burl req ClientM $ lift $ lift $ Codensity $ \k1 -> Client.withResponse request m $ \res -> do let status = Client.responseStatus res diff --git a/servant-client/test/Servant/SuccessSpec.hs b/servant-client/test/Servant/SuccessSpec.hs index b5e25bb9..06437ca6 100644 --- a/servant-client/test/Servant/SuccessSpec.hs +++ b/servant-client/test/Servant/SuccessSpec.hs @@ -162,7 +162,8 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ 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 createClientRequest url r = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] }) + (defaultMakeClientRequest url r) clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest } res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv case res of