65c6298 · typeable/servant

git.iko.soy/typeable/servant

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

added a function to create Client.Request in ClientEnv

commit65c6298e89dd5f223f116dc6cda5d8fd786bf223 authorOleg Grenrus <oleg.grenrus@iki.fi> dateSat 14 Dec 2019, 23:13 (7 years ago) parente229efd 164ae93

9 files changed+69−20

compare with master

unifiedsplit

changelog.d/pr-1213+11 doc/cookbook/using-free-client/UsingFreeClient.lhs+5−5 servant-client/src/Servant/Client.hs+1 servant-client/src/Servant/Client/Internal/HttpClient.hs+20−6 servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+7−6 servant-client/src/Servant/Client/Streaming.hs+1 servant-client/test/Servant/ClientTestUtils.hs+4 servant-client/test/Servant/SuccessSpec.hs+15−2 stack.yaml+5−1

changelog.d/pr-1213new file+11

@@ -0,0 +1,11 @@

1+synopsis: Added a function to create Client.Request in ClientEnv

2+packages: servant-client

3+prs: #1213 #1255

4+description: {

6+The new member `makeClientRequest` of `ClientEnv` is used to create

7+`http-client` `Request` from `servant-client-core` `Request`.

8+This functionality can be used for example to set

9+dynamic timeouts for each request.

10+

11+}

doc/cookbook/using-free-client/UsingFreeClient.lhs+5−5

@@ -2,7 +2,7 @@

33or simply put: _a practical introduction to `Servant.Client.Free`_.

5−Someone asked on IRC how one could access the intermediate Requests (resp. Responses)

5+Someone asked on IRC how one could access the intermediate Requests (resp. Responses)

66produced (resp. received) by client functions derived using servant-client.

77My response to such inquiries is: to extend `servant-client` in an ad-hoc way (e.g for testing or debugging

88purposes), 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`

119119to http-client's `Request`, and we can inspect it:

120120

121121```haskell

122− let req' = I.requestToClientRequest burl req

122+ let req' = I.defaultMakeClientRequest burl req

123123 putStrLn $ "Making request: " ++ show req'

124124```

125125

@@ -136,11 +136,11 @@ and calling the continuation. We should get a `Pure` value.

136136

137137```haskell

138138 let res = I.clientResponseToResponse id res'

139−

139+

140140 case k res of

141141 Pure n ->

142142 putStrLn $ "Expected 1764, got " ++ show n

143− _ ->

143+ _ ->

144144 putStrLn "ERROR: didn't got a response"

145145```

146146

@@ -153,7 +153,7 @@ and responses available for us to inspect, since `RunClient` only gives us

153153access to one `Request` or `Response` at a time.

154154

155155On the other hand, a "batch collection" of requests and/or responses can be achieved

156−with both free clients and a custom `RunClient` instance rather easily, for example

156+with both free clients and a custom `RunClient` instance rather easily, for example

157157by using a `Writer [(Request, Response)]` monad.

158158

159159Here is an example of running our small `test` against a running server:

servant-client/src/Servant/Client.hs+1

@@ -9,6 +9,7 @@ module Servant.Client

99 , runClientM

1010 , ClientEnv(..)

1111 , mkClientEnv

12+ , defaultMakeClientRequest

1213 , hoistClient

1314 , module Servant.Client.Core.Reexport

1415 ) where

servant-client/src/Servant/Client/Internal/HttpClient.hs+20−6

@@ -72,16 +72,27 @@ import qualified Network.HTTP.Client as Client

7272import qualified Servant.Types.SourceT as S

7373

7474-- | The environment in which a request is run.

75+-- The 'baseUrl' and 'makeClientRequest' function are used to create a @http-client@ request.

76+-- Cookies are then added to that request if a 'CookieJar' is set on the environment.

77+-- Finally the request is executed with the 'manager'.

78+-- The 'makeClientRequest' function can be used to modify the request to execute and set values which

79+-- are not specified on a @servant@ 'Request' like 'responseTimeout' or 'redirectCount'

7580data ClientEnv

7681 = ClientEnv

7782 { manager :: Client.Manager

7883 , baseUrl :: BaseUrl

7984 , cookieJar :: Maybe (TVar Client.CookieJar)

85+ , makeClientRequest :: BaseUrl -> Request -> Client.Request

86+ -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'

87+ -- Note that:

88+ -- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,

89+ -- If you need global modifications, you should use 'managerModifyRequest'

90+ -- 2. the 'cookieJar', if defined, is being applied after 'makeClientRequest' is called.

8091 }

8192

8293-- | 'ClientEnv' smart constructor.

8394mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv

84−mkClientEnv mgr burl = ClientEnv mgr burl Nothing

95+mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest

8596

8697-- | Generates a set of client functions for an API.

8798--

@@ -152,8 +163,8 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm

152163

153164performRequest :: Request -> ClientM Response

154165performRequest req = do

155− ClientEnv m burl cookieJar' <- ask

156− let clientRequest = requestToClientRequest burl req

166+ ClientEnv m burl cookieJar' createClientRequest <- ask

167+ let clientRequest = createClientRequest burl req

157168 request <- case cookieJar' of

158169 Nothing -> pure clientRequest

159170 Just cj -> liftIO $ do

@@ -162,7 +173,7 @@ performRequest req = do

162173 oldCookieJar <- readTVar cj

163174 let (newRequest, newCookieJar) =

164175 Client.insertCookiesIntoRequest

165− (requestToClientRequest burl req)

176+ clientRequest

166177 oldCookieJar

167178 now

168179 writeTVar cj newCookieJar

@@ -215,8 +226,11 @@ clientResponseToResponse f r = Response

215226 , responseHttpVersion = Client.responseVersion r

216227 }

217228

218−requestToClientRequest :: BaseUrl -> Request -> Client.Request

219−requestToClientRequest burl r = Client.defaultRequest

229+-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'

230+-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'

231+-- 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

220234 { Client.method = requestMethod r

221235 , Client.host = fromString $ baseUrlHost burl

222236 , Client.port = baseUrlPort burl

servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+7−6

@@ -12,7 +12,7 @@ module Servant.Client.Internal.HttpClient.Streaming (

1212 ClientEnv (..),

1313 mkClientEnv,

1414 clientResponseToResponse,

15− requestToClientRequest,

15+ defaultMakeClientRequest,

1616 catchConnectionError,

1717 ) where

1818

@@ -55,7 +55,7 @@ import Servant.Client.Core

5555import Servant.Client.Internal.HttpClient

5656 (ClientEnv (..), catchConnectionError,

5757 clientResponseToResponse, mkClientEnv, mkFailureResponse,

58− requestToClientRequest)

58+ defaultMakeClientRequest)

5959import qualified Servant.Types.SourceT as S

6060

6161

@@ -139,8 +139,8 @@ runClientM cm env = withClientM cm env (evaluate . force)

139139performRequest :: Request -> ClientM Response

140140performRequest req = do

141141 -- TODO: should use Client.withResponse here too

142− ClientEnv m burl cookieJar' <- ask

143− let clientRequest = requestToClientRequest burl req

142+ ClientEnv m burl cookieJar' createClientRequest <- ask

143+ let clientRequest = createClientRequest burl req

144144 request <- case cookieJar' of

145145 Nothing -> pure clientRequest

146146 Just cj -> liftIO $ do

@@ -149,7 +149,7 @@ performRequest req = do

149149 oldCookieJar <- readTVar cj

150150 let (newRequest, newCookieJar) =

151151 Client.insertCookiesIntoRequest

152− (requestToClientRequest burl req)

152+ clientRequest

153153 oldCookieJar

154154 now

155155 writeTVar cj newCookieJar

@@ -173,7 +173,8 @@ performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM

173173performWithStreamingRequest req k = do

174174 m <- asks manager

175175 burl <- asks baseUrl

176− let request = requestToClientRequest burl req

176+ createClientRequest <- asks makeClientRequest

177+ let request = createClientRequest burl req

177178 ClientM $ lift $ lift $ Codensity $ \k1 ->

178179 Client.withResponse request m $ \res -> do

179180 let status = Client.responseStatus res

servant-client/src/Servant/Client/Streaming.hs+1

@@ -10,6 +10,7 @@ module Servant.Client.Streaming

1010 , runClientM

1111 , ClientEnv(..)

1212 , mkClientEnv

13+ , defaultMakeClientRequest

1314 , hoistClient

1415 , module Servant.Client.Core.Reexport

1516 ) where

servant-client/test/Servant/ClientTestUtils.hs+4

@@ -93,6 +93,7 @@ type Api =

9393 :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]

9494 :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool

9595 :<|> "rawSuccess" :> Raw

96+ :<|> "rawSuccessPassHeaders" :> Raw

9697 :<|> "rawFailure" :> Raw

9798 :<|> "multiple" :>

9899 Capture "first" String :>

@@ -118,6 +119,7 @@ getQueryParam :: Maybe String -> ClientM Person

118119getQueryParams :: [String] -> ClientM [Person]

119120getQueryFlag :: Bool -> ClientM Bool

120121getRawSuccess :: HTTP.Method -> ClientM Response

122+getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response

121123getRawFailure :: HTTP.Method -> ClientM Response

122124getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]

123125 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])

@@ -135,6 +137,7 @@ getRoot

135137 :<|> getQueryParams

136138 :<|> getQueryFlag

137139 :<|> getRawSuccess

140+ :<|> getRawSuccessPassHeaders

138141 :<|> getRawFailure

139142 :<|> getMultiple

140143 :<|> getRespHeaders

@@ -157,6 +160,7 @@ server = serve api (

157160 :<|> (\ names -> return (zipWith Person names [0..]))

158161 :<|> return

159162 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")

163+ :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess"))

160164 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")

161165 :<|> (\ a b c d -> return (a, b, c, d))

162166 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

servant-client/test/Servant/SuccessSpec.hs+15−2

@@ -42,6 +42,7 @@ import Servant.API

4242 (NoContent (NoContent), getHeaders)

4343import Servant.Client

4444import qualified Servant.Client.Core.Request as Req

45+import Servant.Client.Internal.HttpClient (defaultMakeClientRequest)

4546import Servant.Test.ComprehensiveAPI

4647import Servant.ClientTestUtils

4748

@@ -125,11 +126,24 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

125126 it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do

126127 mgr <- C.newManager C.defaultManagerSettings

127128 cj <- atomically . newTVar $ C.createCookieJar []

128− _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj))

129+ _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj) defaultMakeClientRequest)

129130 cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj)

130131 C.cookie_name <$> cookie `shouldBe` Just "testcookie"

131132 C.cookie_value <$> cookie `shouldBe` Just "test"

132133

134+ it "Can modify the outgoing Request using the ClientEnv" $ \(_, baseUrl) -> do

135+ mgr <- C.newManager C.defaultManagerSettings

136+ -- In proper situation, extra headers should probably be visible in API type.

137+ -- However, testing for response timeout is difficult, so we test with something which is easy to observe

138+ let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }

139+ let clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }

140+ res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv

141+ case res of

142+ Left e ->

143+ assertFailure $ show e

144+ Right r ->

145+ ("X-Added-Header", "XXX") `elem` toList (responseHeaders r) `shouldBe` True

146+

133147 modifyMaxSuccess (const 20) $ do

134148 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->

135149 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->

@@ -137,4 +151,3 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

137151 result <- left show <$> runClient (getMultiple cap num flag body) baseUrl

138152 return $

139153 result === Right (cap, num, flag, body)

140−

stack.yaml+5−1

@@ -17,16 +17,20 @@ packages:

1717

1818extra-deps:

1919- base-compat-0.10.5

20+- base-orphans-0.8.1

2021- conduit-1.3.1

2122- hspec-2.6.0

2223- hspec-core-2.6.0

2324- hspec-discover-2.6.0

24−- http-api-data-0.4

25+- http-api-data-0.4.1

2526- http-media-0.7.1.3

27+- http-types-0.12.3

2628- network-2.8.0.0

2729- pipes-safe-2.3.1

2830- QuickCheck-2.12.6.1

2931- resourcet-1.2.2

3032- sop-core-0.4.0.0

33+- time-compat-1.9.2.2

34+- unordered-containers-0.2.10.0

3135- wai-extra-3.0.24.3

3236- tasty-1.1.0.4