From 9df16f9f1a81b0b9ae605820a4348627b102c75d Mon Sep 17 00:00:00 2001
From: Bart Schuurmans <bart@lumiguide.nl>
Date: Fri, 17 Jun 2022 18:55:26 +0200
Subject: [PATCH] servant-client: Run ClientEnv's makeClientRequest in IO

---
 doc/cookbook/using-free-client/UsingFreeClient.lhs        | 2 +-
 servant-client/src/Servant/Client/Internal/HttpClient.hs  | 8 ++++----
 .../src/Servant/Client/Internal/HttpClient/Streaming.hs   | 4 ++--
 servant-client/test/Servant/SuccessSpec.hs                | 3 ++-
 4 files changed, 9 insertions(+), 8 deletions(-)

diff --git a/doc/cookbook/using-free-client/UsingFreeClient.lhs b/doc/cookbook/using-free-client/UsingFreeClient.lhs
index 0185c5144..8b668582c 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 ee146cc76..8db0c9f24 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 644a8224e..24b00f7b0 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 b5e25bb97..06437ca64 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