git.iko.soy/typeable/servant
on master help sign in
servant-client: Run ClientEnv's makeClientRequest in IO (#1595)

* servant-client: Run ClientEnv's makeClientRequest in IO * Add changelog.d entry for #1595

commit489cbd59f4c2627b11a6bef6a165637469009475 authorBart Schuurmans <bart@minnozz.com> dateFri 1 Jul 2022, 13:25 (4 years ago) parent1fba9dc
5 files changed+11−8
compare with master
unifiedsplit
changelog.d/1595+2 doc/cookbook/using-free-client/UsingFreeClient.lhs+1−1 servant-client/src/Servant/Client/Internal/HttpClient.hs+4−4 servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+2−2 servant-client/test/Servant/SuccessSpec.hs+2−1
changelog.d/1595new file+2
@@ -0,0 +1,2 @@
1+synopsis: Run ClientEnv's makeClientRequest in IO.
2+prs: #1595
doc/cookbook/using-free-client/UsingFreeClient.lhs+1−1
@@ -119,7 +119,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request`
119119to http-client's `Request`, and we can inspect it:
120120
121121```haskell
122− let req' = I.defaultMakeClientRequest burl req
122+ req' <- I.defaultMakeClientRequest burl req
123123 putStrLn $ "Making request: " ++ show req'
124124```
125125
servant-client/src/Servant/Client/Internal/HttpClient.hs+4−4
@@ -80,7 +80,7 @@ data ClientEnv
8080 { manager :: Client.Manager
8181 , baseUrl :: BaseUrl
8282 , cookieJar :: Maybe (TVar Client.CookieJar)
83− , makeClientRequest :: BaseUrl -> Request -> Client.Request
83+ , makeClientRequest :: BaseUrl -> Request -> IO Client.Request
8484 -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'
8585 -- Note that:
8686 -- 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
162162performRequest :: Maybe [Status] -> Request -> ClientM Response
163163performRequest acceptStatus req = do
164164 ClientEnv m burl cookieJar' createClientRequest <- ask
165− let clientRequest = createClientRequest burl req
165+ clientRequest <- liftIO $ createClientRequest burl req
166166 request <- case cookieJar' of
167167 Nothing -> pure clientRequest
168168 Just cj -> liftIO $ do
@@ -229,8 +229,8 @@ clientResponseToResponse f r = Response
229229-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
230230-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'
231231-- otherwise the body, headers and query string are derived from the @servant@ 'Request'
232−defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request
233−defaultMakeClientRequest burl r = Client.defaultRequest
232+defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request
233+defaultMakeClientRequest burl r = return Client.defaultRequest
234234 { Client.method = requestMethod r
235235 , Client.host = fromString $ baseUrlHost burl
236236 , Client.port = baseUrlPort burl
servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+2−2
@@ -140,7 +140,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response
140140performRequest acceptStatus req = do
141141 -- TODO: should use Client.withResponse here too
142142 ClientEnv m burl cookieJar' createClientRequest <- ask
143− let clientRequest = createClientRequest burl req
143+ clientRequest <- liftIO $ createClientRequest burl req
144144 request <- case cookieJar' of
145145 Nothing -> pure clientRequest
146146 Just cj -> liftIO $ do
@@ -177,7 +177,7 @@ performWithStreamingRequest req k = do
177177 m <- asks manager
178178 burl <- asks baseUrl
179179 createClientRequest <- asks makeClientRequest
180− let request = createClientRequest burl req
180+ request <- liftIO $ createClientRequest burl req
181181 ClientM $ lift $ lift $ Codensity $ \k1 ->
182182 Client.withResponse request m $ \res -> do
183183 let status = Client.responseStatus res
servant-client/test/Servant/SuccessSpec.hs+2−1
@@ -162,7 +162,8 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
162162 mgr <- C.newManager C.defaultManagerSettings
163163 -- In proper situation, extra headers should probably be visible in API type.
164164 -- However, testing for response timeout is difficult, so we test with something which is easy to observe
165− let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }
165+ let createClientRequest url r = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] })
166+ (defaultMakeClientRequest url r)
166167 clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
167168 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
168169 case res of