servant-client: Run ClientEnv's makeClientRequest in IO (#1595)

* servant-client: Run ClientEnv's makeClientRequest in IO * Add changelog.d entry for #1595
haskell-servant · Jul 1, 2022 · 489cbd5 · 489cbd5
1 parent 1fba9dc
commit 489cbd5
Show file tree

Hide file tree

Showing 5 changed files with 11 additions and 8 deletions.
diff --git a/changelog.d/1595 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
@@ -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
@@ -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
@@ -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
@@ -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