164ae93 · typeable/servant

changelog.d/pr-1213new file+11

compare with master

unifiedsplit

@@ -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: {

5+

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 @@

2

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

4

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)

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

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

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

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

120

121```haskell

122− let req' = I.requestToClientRequest burl req

122+ let req' = I.defaultMakeClientRequest burl req

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

124```

125

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

136

137```haskell

138 let res = I.clientResponseToResponse id res'

139−

139+

140 case k res of

141 Pure n ->

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

143− _ ->

143+ _ ->

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

145```

146

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

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

154

155On 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

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

158

159Here 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

9 , runClientM

10 , ClientEnv(..)

11 , mkClientEnv

12+ , defaultMakeClientRequest

12 , hoistClient

13 , hoistClient

13 , module Servant.Client.Core.Reexport

14 , module Servant.Client.Core.Reexport

14 ) where

15 ) where

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

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

72import qualified Servant.Types.SourceT as S

73

74-- | 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'

75data ClientEnv

80data ClientEnv

76 = ClientEnv

81 = ClientEnv

77 { manager :: Client.Manager

82 { manager :: Client.Manager

78 , baseUrl :: BaseUrl

83 , baseUrl :: BaseUrl

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

84 , 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.

80 }

91 }

81

92

82-- | 'ClientEnv' smart constructor.

93-- | 'ClientEnv' smart constructor.

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

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

84−mkClientEnv mgr burl = ClientEnv mgr burl Nothing

95+mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest

85

96

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

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

87--

98--

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

152

163

153performRequest :: Request -> ClientM Response

164performRequest :: Request -> ClientM Response

154performRequest req = do

165performRequest req = do

155− ClientEnv m burl cookieJar' <- ask

166+ ClientEnv m burl cookieJar' createClientRequest <- ask

156− let clientRequest = requestToClientRequest burl req

167+ let clientRequest = createClientRequest burl req

157 request <- case cookieJar' of

168 request <- case cookieJar' of

158 Nothing -> pure clientRequest

169 Nothing -> pure clientRequest

159 Just cj -> liftIO $ do

170 Just cj -> liftIO $ do

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

162 oldCookieJar <- readTVar cj

173 oldCookieJar <- readTVar cj

163 let (newRequest, newCookieJar) =

174 let (newRequest, newCookieJar) =

164 Client.insertCookiesIntoRequest

175 Client.insertCookiesIntoRequest

165− (requestToClientRequest burl req)

176+ clientRequest

166 oldCookieJar

177 oldCookieJar

167 now

178 now

168 writeTVar cj newCookieJar

179 writeTVar cj newCookieJar

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

215 , responseHttpVersion = Client.responseVersion r

226 , responseHttpVersion = Client.responseVersion r

216 }

227 }

217

228

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'

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

232+defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request

219−requestToClientRequest burl r = Client.defaultRequest

233+defaultMakeClientRequest burl r = Client.defaultRequest

220 { Client.method = requestMethod r

234 { Client.method = requestMethod r

221 , Client.host = fromString $ baseUrlHost burl

235 , Client.host = fromString $ baseUrlHost burl

222 , Client.port = baseUrlPort burl

236 , 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 (

12 ClientEnv (..),

13 mkClientEnv,

14 clientResponseToResponse,

15− requestToClientRequest,

15+ defaultMakeClientRequest,

16 catchConnectionError,

17 ) where

18

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

55import Servant.Client.Internal.HttpClient

56 (ClientEnv (..), catchConnectionError,

57 clientResponseToResponse, mkClientEnv, mkFailureResponse,

58− requestToClientRequest)

58+ defaultMakeClientRequest)

59import qualified Servant.Types.SourceT as S

60

61

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

139performRequest :: Request -> ClientM Response

140performRequest req = do

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

142− ClientEnv m burl cookieJar' <- ask

142+ ClientEnv m burl cookieJar' createClientRequest <- ask

143− let clientRequest = requestToClientRequest burl req

143+ let clientRequest = createClientRequest burl req

144 request <- case cookieJar' of

145 Nothing -> pure clientRequest

146 Just cj -> liftIO $ do

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

149 oldCookieJar <- readTVar cj

150 let (newRequest, newCookieJar) =

151 Client.insertCookiesIntoRequest

152− (requestToClientRequest burl req)

152+ clientRequest

153 oldCookieJar

154 now

155 writeTVar cj newCookieJar

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

173performWithStreamingRequest req k = do

174 m <- asks manager

175 burl <- asks baseUrl

176+ createClientRequest <- asks makeClientRequest

176− let request = requestToClientRequest burl req

177+ let request = createClientRequest burl req

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

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

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

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

179 let status = Client.responseStatus res

180 let status = Client.responseStatus res

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

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

10 , runClientM

11 , ClientEnv(..)

12 , mkClientEnv

13+ , defaultMakeClientRequest

13 , hoistClient

14 , hoistClient

14 , module Servant.Client.Core.Reexport

15 , module Servant.Client.Core.Reexport

15 ) where

16 ) where

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

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

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

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

95 :<|> "rawSuccess" :> Raw

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

96 :<|> "rawFailure" :> Raw

97 :<|> "rawFailure" :> Raw

97 :<|> "multiple" :>

98 :<|> "multiple" :>

98 Capture "first" String :>

99 Capture "first" String :>

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

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

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

119getQueryFlag :: Bool -> ClientM Bool

120getQueryFlag :: Bool -> ClientM Bool

120getRawSuccess :: HTTP.Method -> ClientM Response

121getRawSuccess :: HTTP.Method -> ClientM Response

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

121getRawFailure :: HTTP.Method -> ClientM Response

123getRawFailure :: HTTP.Method -> ClientM Response

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

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

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

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

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

135 :<|> getQueryParams

137 :<|> getQueryParams

136 :<|> getQueryFlag

138 :<|> getQueryFlag

137 :<|> getRawSuccess

139 :<|> getRawSuccess

140+ :<|> getRawSuccessPassHeaders

138 :<|> getRawFailure

141 :<|> getRawFailure

139 :<|> getMultiple

142 :<|> getMultiple

140 :<|> getRespHeaders

143 :<|> getRespHeaders

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

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

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

158 :<|> return

161 :<|> return

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

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

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

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

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

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

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

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

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

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

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

42 (NoContent (NoContent), getHeaders)

43import Servant.Client

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

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

45import Servant.Test.ComprehensiveAPI

46import Servant.Test.ComprehensiveAPI

46import Servant.ClientTestUtils

47import Servant.ClientTestUtils

47

48

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

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

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

126 mgr <- C.newManager C.defaultManagerSettings

127 mgr <- C.newManager C.defaultManagerSettings

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

128 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)

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

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

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

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

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

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

132

133

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+

133 modifyMaxSuccess (const 20) $ do

147 modifyMaxSuccess (const 20) $ do

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

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

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

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

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

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

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

138 return $

152 return $

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

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

140−

stack.yaml+5−1

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

17

18extra-deps:

19- base-compat-0.10.5

20+- base-orphans-0.8.1

20- conduit-1.3.1

21- conduit-1.3.1

21- hspec-2.6.0

22- hspec-2.6.0

22- hspec-core-2.6.0

23- hspec-core-2.6.0

23- hspec-discover-2.6.0

24- hspec-discover-2.6.0

24−- http-api-data-0.4

25+- http-api-data-0.4.1

25- http-media-0.7.1.3

26- http-media-0.7.1.3

27+- http-types-0.12.3

26- network-2.8.0.0

28- network-2.8.0.0

27- pipes-safe-2.3.1

29- pipes-safe-2.3.1

28- QuickCheck-2.12.6.1

30- QuickCheck-2.12.6.1

29- resourcet-1.2.2

31- resourcet-1.2.2

30- sop-core-0.4.0.0

32- sop-core-0.4.0.0

33+- time-compat-1.9.2.2

34+- unordered-containers-0.2.10.0

31- wai-extra-3.0.24.3

35- wai-extra-3.0.24.3

32- tasty-1.1.0.4

36- tasty-1.1.0.4