9a655fd · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

client: Preserve failing request in FailureResponse

9a655fdBen Gamari8 years ago

servant-client-core/CHANGELOG.md+3

compare with master

unifiedsplit

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

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

8 type.

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

11+ caused the failure.

12+

110.15

140.15

12----

15----

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

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

4{-# LANGUAGE ViewPatterns #-}

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

7+import Control.DeepSeq

8+ (NFData (..))

7import Control.Monad.Catch

9import Control.Monad.Catch

8 (Exception, MonadThrow, throwM)

10 (Exception, MonadThrow, throwM)

9import Data.Aeson

11import Data.Aeson

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

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

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

40-- TODO: Ord is more precise than Eq

42-- TODO: Ord is more precise than Eq

41-- TODO: Add Hashable instance?

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

43instance Eq BaseUrl where

48instance Eq BaseUrl where

44 BaseUrl a b c path == BaseUrl a' b' c' path'

49 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

40import Network.HTTP.Types

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

42 Status (..), http11, methodGet)

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

44+ (BaseUrl)

43import Servant.API

45import Servant.API

44 (ToHttpApiData, toEncodedUrlPiece, toHeader)

46 (ToHttpApiData, toEncodedUrlPiece, toHeader)

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

47--

49--

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

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

49data ServantError =

51data ServantError =

50− -- | The server returned an error response

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

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

54+ -- path of the request.

51− FailureResponse Response

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

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

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

53 | DecodeFailure Text Response

57 | DecodeFailure Text Response

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

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

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

62instance Exception ServantError

66instance Exception ServantError

64instance NFData ServantError where

68instance NFData ServantError where

65− rnf (FailureResponse res) = rnf res

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

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

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

67 rnf (UnsupportedContentType mt' res) =

71 rnf (UnsupportedContentType mt' res) =

68 mediaTypeRnf mt' `seq`

72 mediaTypeRnf mt' `seq`

69 rnf res

73 rnf res

70− where

71− mediaTypeRnf mt =

72− rnf (mainType mt) `seq`

73− rnf (subType mt) `seq`

74− rnf (parameters mt)

75 rnf (InvalidContentTypeHeader res) = rnf res

74 rnf (InvalidContentTypeHeader res) = rnf res

76 rnf (ConnectionError err) = rnf err

75 rnf (ConnectionError err) = rnf err

77+mediaTypeRnf :: MediaType -> ()

78+mediaTypeRnf mt =

79+ rnf (mainType mt) `seq`

80+ rnf (subType mt) `seq`

81+ rnf (parameters mt)

82+

78data RequestF body path = Request

83data RequestF body path = Request

79 { requestPath :: path

84 { requestPath :: path

80 , requestQueryString :: Seq.Seq QueryItem

85 , requestQueryString :: Seq.Seq QueryItem

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

86+ , requestBody :: body

82 , requestAccept :: Seq.Seq MediaType

87 , requestAccept :: Seq.Seq MediaType

83 , requestHeaders :: Seq.Seq Header

88 , requestHeaders :: Seq.Seq Header

84 , requestHttpVersion :: HttpVersion

89 , requestHttpVersion :: HttpVersion

85 , requestMethod :: Method

90 , requestMethod :: Method

86− } deriving (Generic, Typeable)

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

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

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

89 rnf r =

94 rnf r =

90 rnf (requestPath r)

95 rnf (requestPath r)

91 `seq` rnf (requestQueryString r)

96 `seq` rnf (requestQueryString r)

92 `seq` rnf (requestBody r)

97 `seq` rnf (requestBody r)

93− `seq` rnf (requestAccept r)

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

94 `seq` rnf (requestHeaders r)

99 `seq` rnf (requestHeaders r)

95− `seq` rnf (requestHttpVersion r)

100+ `seq` requestHttpVersion r

96 `seq` rnf (requestMethod r)

101 `seq` rnf (requestMethod r)

102

98−type Request = RequestF RequestBody Builder.Builder

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

104

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

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

101data RequestBody

106data RequestBody

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

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

167 status_code = statusCode status

168 ourResponse = clientResponseToResponse response

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

170− throwError $ FailureResponse ourResponse

170+ throwError $ mkFailureResponse burl req ourResponse

171 return ourResponse

172 where

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

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

195 fReq = Client.hrFinalRequest responses

196 fRes = Client.hrFinalResponse responses

197

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+

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

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

199clientResponseToResponse r = Response

204clientResponseToResponse r = Response

200 { responseStatusCode = Client.responseStatus r

205 { 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

53import Servant.Client.Core

54import Servant.Client.Internal.HttpClient

55 (ClientEnv (..), catchConnectionError,

56− clientResponseToResponse, mkClientEnv, requestToClientRequest)

56+ clientResponseToResponse, mkClientEnv, requestToClientRequest,

57+ mkFailureResponse)

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

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

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

166 status_code = statusCode status

167 status_code = statusCode status

167 ourResponse = clientResponseToResponse response

168 ourResponse = clientResponseToResponse response

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

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

169− throwError $ FailureResponse ourResponse

170+ throwError $ mkFailureResponse burl req ourResponse

170 return ourResponse

171 return ourResponse

171

172

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

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

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

182 -- we throw FailureResponse in IO :(

183 -- we throw FailureResponse in IO :(

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

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

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

185 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 })

186

187

187 x <- k (clientResponseToResponse res)

188 x <- k (clientResponseToResponse res)

188 k1 x

189 k1 x

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

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

40import Data.Char

41 (chr, isPrint)

42import Data.Foldable

43− (forM_)

43+ (forM_, toList)

44import Data.Maybe

45 (listToMaybe)

46import Data.Monoid ()

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

336 let p = Person "Clara" 42

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

338

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+

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

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

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

347 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

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

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

343

350

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

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

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

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

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

363 case res of

370 case res of

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

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

365− Left (FailureResponse r) -> do

372+ Left (FailureResponse _ r) -> do

366 responseStatusCode r `shouldBe` HTTP.status400

373 responseStatusCode r `shouldBe` HTTP.status400

367 responseBody r `shouldBe` "rawFailure"

374 responseBody r `shouldBe` "rawFailure"

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

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

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

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

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

400 let getResponse :: ClientM ()

407 let getResponse :: ClientM ()

401 getResponse = client api

408 getResponse = client api

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

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

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

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

404 in mapM_ test $

411 in mapM_ test $

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

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

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

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

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

417 Left res <- runClient getDeleteEmpty baseUrl

424 Left res <- runClient getDeleteEmpty baseUrl

418 case res of

425 case res of

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

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

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

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

421

428

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

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

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

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

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

467 let getBasic = client basicAuthAPI

474 let getBasic = client basicAuthAPI

468 let basicAuthData = BasicAuthData "not" "password"

475 let basicAuthData = BasicAuthData "not" "password"

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

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

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

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

471

478

472genAuthSpec :: Spec

479genAuthSpec :: Spec

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

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

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

484 let getProtected = client genAuthAPI

491 let getProtected = client genAuthAPI

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

492 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

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

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

488

495

489genericClientSpec :: Spec

496genericClientSpec :: Spec