fdd1c73 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Merge pull request #1114 from phadej/bgamari-request-in-failureresponse

fdd1c73Oleg Grenrus8 years ago

servant-client-core/servant-client-core.cabal+5−1

compare with master

unifiedsplit

@@ -58,9 +58,13 @@ library

58 , transformers >= 0.5.2.0 && < 0.6

59 , template-haskell >= 2.11.1.0 && < 2.15

61+ if !impl(ghc >= 8.2)

62+ build-depends:

63+ bifunctors >= 5.5.3 && < 5.6

64+

61 -- Servant dependencies

65 -- Servant dependencies

62 build-depends:

66 build-depends:

63− servant >= 0.15 && <0.16

67+ servant >= 0.15 && <0.16

65 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

69 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

66 -- Here can be exceptions if we really need features from the newer versions.

70 -- Here can be exceptions if we really need features from the newer versions.

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+50−17

@@ -19,14 +19,20 @@ import Control.DeepSeq

19 (NFData (..))

20import Control.Monad.Catch

21 (Exception)

22+import Data.Bifoldable

23+ (Bifoldable (..))

24+import Data.Bifunctor

25+ (Bifunctor (..))

26+import Data.Bitraversable

27+ (Bitraversable (..), bifoldMapDefault, bimapDefault)

22−import qualified Data.ByteString as BS

28+import qualified Data.ByteString as BS

23−import qualified Data.ByteString.Builder as Builder

29+import qualified Data.ByteString.Builder as Builder

24−import qualified Data.ByteString.Lazy as LBS

30+import qualified Data.ByteString.Lazy as LBS

25import Data.Int

31import Data.Int

26 (Int64)

32 (Int64)

27import Data.Semigroup

33import Data.Semigroup

28 ((<>))

34 ((<>))

29−import qualified Data.Sequence as Seq

35+import qualified Data.Sequence as Seq

30import Data.Text

36import Data.Text

31 (Text)

37 (Text)

32import Data.Text.Encoding

38import Data.Text.Encoding

@@ -42,13 +48,17 @@ import Network.HTTP.Types

42 Status (..), http11, methodGet)

48 Status (..), http11, methodGet)

43import Servant.API

49import Servant.API

44 (ToHttpApiData, toEncodedUrlPiece, toHeader)

50 (ToHttpApiData, toEncodedUrlPiece, toHeader)

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

52+ (BaseUrl)

46-- | A type representing possible errors in a request

54-- | A type representing possible errors in a request

47--

55--

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

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

49data ServantError =

57data ServantError =

50− -- | The server returned an error response

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

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

60+ -- path of the request.

51− FailureResponse Response

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

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

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

53 | DecodeFailure Text Response

63 | DecodeFailure Text Response

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

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

@@ -62,30 +72,53 @@ data ServantError =

62instance Exception ServantError

72instance Exception ServantError

64instance NFData ServantError where

74instance NFData ServantError where

65− rnf (FailureResponse res) = rnf res

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

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

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

67 rnf (UnsupportedContentType mt' res) =

77 rnf (UnsupportedContentType mt' res) =

68 mediaTypeRnf mt' `seq`

78 mediaTypeRnf mt' `seq`

69 rnf res

79 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

80 rnf (InvalidContentTypeHeader res) = rnf res

76 rnf (ConnectionError err) = rnf err

81 rnf (ConnectionError err) = rnf err

83+mediaTypeRnf :: MediaType -> ()

84+mediaTypeRnf mt =

85+ rnf (mainType mt) `seq`

86+ rnf (subType mt) `seq`

87+ rnf (parameters mt)

88+

78−data RequestF a = Request

89+data RequestF body path = Request

79− { requestPath :: a

90+ { requestPath :: path

80 , requestQueryString :: Seq.Seq QueryItem

91 , requestQueryString :: Seq.Seq QueryItem

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

92+ , requestBody :: Maybe (body, MediaType)

82 , requestAccept :: Seq.Seq MediaType

93 , requestAccept :: Seq.Seq MediaType

83 , requestHeaders :: Seq.Seq Header

94 , requestHeaders :: Seq.Seq Header

84 , requestHttpVersion :: HttpVersion

95 , requestHttpVersion :: HttpVersion

85 , requestMethod :: Method

96 , requestMethod :: Method

86− } deriving (Generic, Typeable)

97+ } deriving (Generic, Typeable, Eq, Show, Functor, Foldable, Traversable)

98+

99+instance Bifunctor RequestF where bimap = bimapDefault

100+instance Bifoldable RequestF where bifoldMap = bifoldMapDefault

101+instance Bitraversable RequestF where

102+ bitraverse f g r = mk

103+ <$> traverse (bitraverse f pure) (requestBody r)

104+ <*> g (requestPath r)

105+ where

106+ mk b p = r { requestBody = b, requestPath = p }

107+

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

109+ rnf r =

110+ rnf (requestPath r)

111+ `seq` rnf (requestQueryString r)

112+ `seq` rnfB (requestBody r)

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

114+ `seq` rnf (requestHeaders r)

115+ `seq` requestHttpVersion r

116+ `seq` rnf (requestMethod r)

117+ where

118+ rnfB Nothing = ()

119+ rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt

120

88−type Request = RequestF Builder.Builder

121+type Request = RequestF RequestBody Builder.Builder

122

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

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

91data RequestBody

124data RequestBody

servant-client/servant-client.cabal+4

@@ -55,6 +55,10 @@ library

55 , time >= 1.6.0.1 && < 1.9

56 , transformers >= 0.5.2.0 && < 0.6

58+ if !impl(ghc >= 8.2)

59+ build-depends:

60+ bifunctors >= 5.5.3 && < 5.6

61+

58 -- Servant dependencies.

62 -- Servant dependencies.

59 -- Strict dependency on `servant-client-core` as we re-export things.

63 -- Strict dependency on `servant-client-core` as we re-export things.

60 build-depends:

64 build-depends:

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

@@ -31,6 +31,8 @@ import Control.Monad.STM

31import Control.Monad.Trans.Control

32 (MonadBaseControl (..))

33import Control.Monad.Trans.Except

34+import Data.Bifunctor

35+ (bimap)

34import Data.ByteString.Builder

36import Data.ByteString.Builder

35 (toLazyByteString)

37 (toLazyByteString)

36import qualified Data.ByteString.Lazy as BSL

38import qualified Data.ByteString.Lazy as BSL

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

167 status_code = statusCode status

169 status_code = statusCode status

168 ourResponse = clientResponseToResponse response

170 ourResponse = clientResponseToResponse response

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

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

170− throwError $ FailureResponse ourResponse

172+ throwError $ mkFailureResponse burl req ourResponse

171 return ourResponse

173 return ourResponse

172 where

174 where

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

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

@@ -195,6 +197,12 @@ performRequest req = do

195 fReq = Client.hrFinalRequest responses

197 fReq = Client.hrFinalRequest responses

196 fRes = Client.hrFinalResponse responses

198 fRes = Client.hrFinalResponse responses

197

199

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

201+mkFailureResponse burl request =

202+ FailureResponse (bimap (const ()) f request)

203+ where

204+ f b = (burl, BSL.toStrict $ toLazyByteString b)

205+

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

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

199clientResponseToResponse r = Response

207clientResponseToResponse r = Response

200 { responseStatusCode = Client.responseStatus r

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