9a655fd · typeable/servant

git.iko.soy/typeable/servant

client: Preserve failing request in FailureResponse

This was previously implemented in #470 but later unintentionally reverted in #803. This isn't verbatim the design implemented earlier; we now capture the full RequestF save the request body. Fixes #978.

commit9a655fd68e6c49800bfb9803406de4f687d0742a authorBen Gamari <ben@smart-cactus.org> dateSun 3 Feb 2019, 11:18 (8 years ago) parentaa70459

6 files changed+51−25

compare with master

unifiedsplit

servant-client-core/CHANGELOG.md+3 servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs+5 servant-client-core/src/Servant/Client/Core/Internal/Request.hs+19−14 servant-client/src/Servant/Client/Internal/HttpClient.hs+6−1 servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+4−3 servant-client/test/Servant/ClientSpec.hs+14−7

servant-client-core/CHANGELOG.md+3

@@ -7,6 +7,9 @@

77- `RequestF` is now parametrized on the request body type as well as the path

88 type.

10+- `ServantError`'s `FailureResponse` constructor now carries the `Request` that

11+ caused the failure.

12+

1013

11140.15

1215----

servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs+5

@@ -4,6 +4,8 @@

44{-# LANGUAGE ViewPatterns #-}

55module Servant.Client.Core.Internal.BaseUrl where

7+import Control.DeepSeq

8+ (NFData (..))

79import Control.Monad.Catch

810 (Exception, MonadThrow, throwM)

911import Data.Aeson

@@ -39,6 +41,9 @@ data BaseUrl = BaseUrl

3941 } deriving (Show, Ord, Generic, Lift, Data)

4042-- TODO: Ord is more precise than Eq

4143-- TODO: Add Hashable instance?

44+--

45+instance NFData BaseUrl where

46+ rnf (BaseUrl a b c d) = a `seq` rnf b `seq` rnf c `seq` rnf d

4247

4348instance Eq BaseUrl where

4449 BaseUrl a b c path == BaseUrl a' b' c' path'

servant-client-core/src/Servant/Client/Core/Internal/Request.hs+19−14

@@ -40,6 +40,8 @@ import Network.HTTP.Media

4040import Network.HTTP.Types

4141 (Header, HeaderName, HttpVersion (..), Method, QueryItem,

4242 Status (..), http11, methodGet)

43+import Servant.Client.Core.Internal.BaseUrl

44+ (BaseUrl)

4345import Servant.API

4446 (ToHttpApiData, toEncodedUrlPiece, toHeader)

4547

@@ -47,8 +49,10 @@ import Servant.API

4749--

4850-- Note that this type substantially changed in 0.12.

4951data ServantError =

50− -- | The server returned an error response

51− FailureResponse Response

52+ -- | The server returned an error response including the

53+ -- failing request. 'requestPath' includes the 'BaseUrl' and the

54+ -- path of the request.

55+ FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response

5256 -- | The body could not be decoded at the expected type

5357 | DecodeFailure Text Response

5458 -- | The content-type of the response is not supported

@@ -62,40 +66,41 @@ data ServantError =

6266instance Exception ServantError

6367

6468instance NFData ServantError where

65− rnf (FailureResponse res) = rnf res

69+ rnf (FailureResponse req res) = rnf req `seq` rnf res

6670 rnf (DecodeFailure err res) = rnf err `seq` rnf res

6771 rnf (UnsupportedContentType mt' res) =

6872 mediaTypeRnf mt' `seq`

6973 rnf res

70− where

71− mediaTypeRnf mt =

72− rnf (mainType mt) `seq`

73− rnf (subType mt) `seq`

74− rnf (parameters mt)

7574 rnf (InvalidContentTypeHeader res) = rnf res

7675 rnf (ConnectionError err) = rnf err

7776

77+mediaTypeRnf :: MediaType -> ()

78+mediaTypeRnf mt =

79+ rnf (mainType mt) `seq`

80+ rnf (subType mt) `seq`

81+ rnf (parameters mt)

82+

7883data RequestF body path = Request

7984 { requestPath :: path

8085 , requestQueryString :: Seq.Seq QueryItem

81− , requestBody :: Maybe (body, MediaType)

86+ , requestBody :: body

8287 , requestAccept :: Seq.Seq MediaType

8388 , requestHeaders :: Seq.Seq Header

8489 , requestHttpVersion :: HttpVersion

8590 , requestMethod :: Method

86− } deriving (Generic, Typeable)

91+ } deriving (Generic, Typeable, Eq, Show)

8792

88−instance (NFData path, NFData body) => NFData (Request body path) where

93+instance (NFData path, NFData body) => NFData (RequestF body path) where

8994 rnf r =

9095 rnf (requestPath r)

9196 `seq` rnf (requestQueryString r)

9297 `seq` rnf (requestBody r)

93− `seq` rnf (requestAccept r)

98+ `seq` rnf (fmap mediaTypeRnf (requestAccept r))

9499 `seq` rnf (requestHeaders r)

95− `seq` rnf (requestHttpVersion r)

100+ `seq` requestHttpVersion r

96101 `seq` rnf (requestMethod r)

97102

98−type Request = RequestF RequestBody Builder.Builder

103+type Request = RequestF (Maybe (RequestBody, MediaType)) Builder.Builder

99104

100105-- | The request body. A replica of the @http-client@ @RequestBody@.

101106data RequestBody

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

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

167167 status_code = statusCode status

168168 ourResponse = clientResponseToResponse response

169169 unless (status_code >= 200 && status_code < 300) $

170− throwError $ FailureResponse ourResponse

170+ throwError $ mkFailureResponse burl req ourResponse

171171 return ourResponse

172172 where

173173 requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString)

@@ -195,6 +195,11 @@ performRequest req = do

195195 fReq = Client.hrFinalRequest responses

196196 fRes = Client.hrFinalResponse responses

197197

198+mkFailureResponse :: BaseUrl -> Request -> GenResponse BSL.ByteString -> ServantError

199+mkFailureResponse burl request ourResponse =

200+ FailureResponse (request {requestPath = (burl, path), requestBody = ()}) ourResponse

201+ where path = BSL.toStrict $ toLazyByteString $ requestPath request

202+

198203clientResponseToResponse :: Client.Response a -> GenResponse a

199204clientResponseToResponse r = Response

200205 { responseStatusCode = Client.responseStatus r

servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+4−3

@@ -53,7 +53,8 @@ import qualified Network.HTTP.Client as Client

5353import Servant.Client.Core

5454import Servant.Client.Internal.HttpClient

5555 (ClientEnv (..), catchConnectionError,

56− clientResponseToResponse, mkClientEnv, requestToClientRequest)

56+ clientResponseToResponse, mkClientEnv, requestToClientRequest,

57+ mkFailureResponse)

5758

5859

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

@@ -166,7 +167,7 @@ performRequest req = do

166167 status_code = statusCode status

167168 ourResponse = clientResponseToResponse response

168169 unless (status_code >= 200 && status_code < 300) $

169− throwError $ FailureResponse ourResponse

170+ throwError $ mkFailureResponse burl req ourResponse

170171 return ourResponse

171172

172173performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a

@@ -182,7 +183,7 @@ performWithStreamingRequest req k = do

182183 -- we throw FailureResponse in IO :(

183184 unless (status_code >= 200 && status_code < 300) $ do

184185 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)

185− throwIO $ FailureResponse $ clientResponseToResponse res { Client.responseBody = b }

186+ throwIO $ mkFailureResponse burl req (clientResponseToResponse res { Client.responseBody = b })

186187

187188 x <- k (clientResponseToResponse res)

188189 k1 x

servant-client/test/Servant/ClientSpec.hs+14−7

@@ -40,7 +40,7 @@ import Data.Aeson

4040import Data.Char

4141 (chr, isPrint)

4242import Data.Foldable

43− (forM_)

43+ (forM_, toList)

4444import Data.Maybe

4545 (listToMaybe)

4646import Data.Monoid ()

@@ -336,9 +336,16 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

336336 let p = Person "Clara" 42

337337 left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p

338338

339+ it "Servant.API FailureResponse" $ \(_, baseUrl) -> do

340+ left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice

341+ Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl

342+ Req.requestPath req `shouldBe` (baseUrl, "/param")

343+ toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")]

344+ Req.requestMethod req `shouldBe` HTTP.methodGet

345+

339346 it "Servant.API.QueryParam" $ \(_, baseUrl) -> do

340347 left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice

341− Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) baseUrl

348+ Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl

342349 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"

343350

344351 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do

@@ -362,7 +369,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

362369 res <- runClient (getRawFailure HTTP.methodGet) baseUrl

363370 case res of

364371 Right _ -> assertFailure "expected Left, but got Right"

365− Left (FailureResponse r) -> do

372+ Left (FailureResponse _ r) -> do

366373 responseStatusCode r `shouldBe` HTTP.status400

367374 responseBody r `shouldBe` "rawFailure"

368375 Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e

@@ -399,7 +406,7 @@ wrappedApiSpec = describe "error status codes" $ do

399406 it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do

400407 let getResponse :: ClientM ()

401408 getResponse = client api

402− Left (FailureResponse r) <- runClient getResponse baseUrl

409+ Left (FailureResponse _ r) <- runClient getResponse baseUrl

403410 responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")

404411 in mapM_ test $

405412 (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :

@@ -416,7 +423,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do

416423 let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api

417424 Left res <- runClient getDeleteEmpty baseUrl

418425 case res of

419− FailureResponse r | responseStatusCode r == HTTP.status404 -> return ()

426+ FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()

420427 _ -> fail $ "expected 404 response, but got " <> show res

421428

422429 it "reports DecodeFailure" $ \(_, baseUrl) -> do

@@ -466,7 +473,7 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d

466473 it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do

467474 let getBasic = client basicAuthAPI

468475 let basicAuthData = BasicAuthData "not" "password"

469− Left (FailureResponse r) <- runClient (getBasic basicAuthData) baseUrl

476+ Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl

470477 responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"

471478

472479genAuthSpec :: Spec

@@ -483,7 +490,7 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do

483490 it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do

484491 let getProtected = client genAuthAPI

485492 let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)

486− Left (FailureResponse r) <- runClient (getProtected authRequest) baseUrl

493+ Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl

487494 responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")

488495

489496genericClientSpec :: Spec