From 9a655fd68e6c49800bfb9803406de4f687d0742a Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sun, 3 Feb 2019 11:18:55 -0500 Subject: [PATCH] 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. --- servant-client-core/CHANGELOG.md | 3 ++ .../Servant/Client/Core/Internal/BaseUrl.hs | 5 +++ .../Servant/Client/Core/Internal/Request.hs | 33 +++++++++++-------- .../src/Servant/Client/Internal/HttpClient.hs | 7 +++- .../Client/Internal/HttpClient/Streaming.hs | 7 ++-- servant-client/test/Servant/ClientSpec.hs | 21 ++++++++---- 6 files changed, 51 insertions(+), 25 deletions(-) diff --git a/servant-client-core/CHANGELOG.md b/servant-client-core/CHANGELOG.md index 07cfecda..3d2525ff 100644 --- a/servant-client-core/CHANGELOG.md +++ b/servant-client-core/CHANGELOG.md @@ -7,6 +7,9 @@ - `RequestF` is now parametrized on the request body type as well as the path type. +- `ServantError`'s `FailureResponse` constructor now carries the `Request` that + caused the failure. + 0.15 ---- diff --git a/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs b/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs index 585ff733..3c1ec599 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs @@ -4,6 +4,8 @@ {-# LANGUAGE ViewPatterns #-} module Servant.Client.Core.Internal.BaseUrl where +import Control.DeepSeq + (NFData (..)) import Control.Monad.Catch (Exception, MonadThrow, throwM) import Data.Aeson @@ -39,6 +41,9 @@ data BaseUrl = BaseUrl } deriving (Show, Ord, Generic, Lift, Data) -- TODO: Ord is more precise than Eq -- TODO: Add Hashable instance? +-- +instance NFData BaseUrl where + rnf (BaseUrl a b c d) = a `seq` rnf b `seq` rnf c `seq` rnf d instance Eq BaseUrl where BaseUrl a b c path == BaseUrl a' b' c' path' diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index 65dc2c89..001fa3d9 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -40,6 +40,8 @@ import Network.HTTP.Media import Network.HTTP.Types (Header, HeaderName, HttpVersion (..), Method, QueryItem, Status (..), http11, methodGet) +import Servant.Client.Core.Internal.BaseUrl + (BaseUrl) import Servant.API (ToHttpApiData, toEncodedUrlPiece, toHeader) @@ -47,8 +49,10 @@ import Servant.API -- -- Note that this type substantially changed in 0.12. data ServantError = - -- | The server returned an error response - FailureResponse Response + -- | The server returned an error response including the + -- failing request. 'requestPath' includes the 'BaseUrl' and the + -- path of the request. + FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response -- | The body could not be decoded at the expected type | DecodeFailure Text Response -- | The content-type of the response is not supported @@ -62,40 +66,41 @@ data ServantError = instance Exception ServantError instance NFData ServantError where - rnf (FailureResponse res) = rnf res + rnf (FailureResponse req res) = rnf req `seq` rnf res rnf (DecodeFailure err res) = rnf err `seq` rnf res rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res - where - mediaTypeRnf mt = - rnf (mainType mt) `seq` - rnf (subType mt) `seq` - rnf (parameters mt) rnf (InvalidContentTypeHeader res) = rnf res rnf (ConnectionError err) = rnf err +mediaTypeRnf :: MediaType -> () +mediaTypeRnf mt = + rnf (mainType mt) `seq` + rnf (subType mt) `seq` + rnf (parameters mt) + data RequestF body path = Request { requestPath :: path , requestQueryString :: Seq.Seq QueryItem - , requestBody :: Maybe (body, MediaType) + , requestBody :: body , requestAccept :: Seq.Seq MediaType , requestHeaders :: Seq.Seq Header , requestHttpVersion :: HttpVersion , requestMethod :: Method - } deriving (Generic, Typeable) + } deriving (Generic, Typeable, Eq, Show) -instance (NFData path, NFData body) => NFData (Request body path) where +instance (NFData path, NFData body) => NFData (RequestF body path) where rnf r = rnf (requestPath r) `seq` rnf (requestQueryString r) `seq` rnf (requestBody r) - `seq` rnf (requestAccept r) + `seq` rnf (fmap mediaTypeRnf (requestAccept r)) `seq` rnf (requestHeaders r) - `seq` rnf (requestHttpVersion r) + `seq` requestHttpVersion r `seq` rnf (requestMethod r) -type Request = RequestF RequestBody Builder.Builder +type Request = RequestF (Maybe (RequestBody, MediaType)) Builder.Builder -- | The request body. A replica of the @http-client@ @RequestBody@. data RequestBody diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index b0e6a83c..d34e6e29 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -167,7 +167,7 @@ performRequest req = do status_code = statusCode status ourResponse = clientResponseToResponse response unless (status_code >= 200 && status_code < 300) $ - throwError $ FailureResponse ourResponse + throwError $ mkFailureResponse burl req ourResponse return ourResponse where requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString) @@ -195,6 +195,11 @@ performRequest req = do fReq = Client.hrFinalRequest responses fRes = Client.hrFinalResponse responses +mkFailureResponse :: BaseUrl -> Request -> GenResponse BSL.ByteString -> ServantError +mkFailureResponse burl request ourResponse = + FailureResponse (request {requestPath = (burl, path), requestBody = ()}) ourResponse + where path = BSL.toStrict $ toLazyByteString $ requestPath request + clientResponseToResponse :: Client.Response a -> GenResponse a clientResponseToResponse r = Response { responseStatusCode = Client.responseStatus r diff --git a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs index 4303ce74..429c079d 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs @@ -53,7 +53,8 @@ import qualified Network.HTTP.Client as Client import Servant.Client.Core import Servant.Client.Internal.HttpClient (ClientEnv (..), catchConnectionError, - clientResponseToResponse, mkClientEnv, requestToClientRequest) + clientResponseToResponse, mkClientEnv, requestToClientRequest, + mkFailureResponse) -- | Generates a set of client functions for an API. @@ -166,7 +167,7 @@ performRequest req = do status_code = statusCode status ourResponse = clientResponseToResponse response unless (status_code >= 200 && status_code < 300) $ - throwError $ FailureResponse ourResponse + throwError $ mkFailureResponse burl req ourResponse return ourResponse performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a @@ -182,7 +183,7 @@ performWithStreamingRequest req k = do -- we throw FailureResponse in IO :( unless (status_code >= 200 && status_code < 300) $ do b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res) - throwIO $ FailureResponse $ clientResponseToResponse res { Client.responseBody = b } + throwIO $ mkFailureResponse burl req (clientResponseToResponse res { Client.responseBody = b }) x <- k (clientResponseToResponse res) k1 x diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 636ab351..96b4172c 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -40,7 +40,7 @@ import Data.Aeson import Data.Char (chr, isPrint) import Data.Foldable - (forM_) + (forM_, toList) import Data.Maybe (listToMaybe) import Data.Monoid () @@ -336,9 +336,16 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do let p = Person "Clara" 42 left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p + it "Servant.API FailureResponse" $ \(_, baseUrl) -> do + left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice + Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl + Req.requestPath req `shouldBe` (baseUrl, "/param") + toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")] + Req.requestMethod req `shouldBe` HTTP.methodGet + it "Servant.API.QueryParam" $ \(_, baseUrl) -> do left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice - Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) baseUrl + Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found" it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do @@ -362,7 +369,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do res <- runClient (getRawFailure HTTP.methodGet) baseUrl case res of Right _ -> assertFailure "expected Left, but got Right" - Left (FailureResponse r) -> do + Left (FailureResponse _ r) -> do responseStatusCode r `shouldBe` HTTP.status400 responseBody r `shouldBe` "rawFailure" Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e @@ -399,7 +406,7 @@ wrappedApiSpec = describe "error status codes" $ do it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do let getResponse :: ClientM () getResponse = client api - Left (FailureResponse r) <- runClient getResponse baseUrl + Left (FailureResponse _ r) <- runClient getResponse baseUrl responseStatusCode r `shouldBe` (HTTP.Status 500 "error message") in mapM_ test $ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : @@ -416,7 +423,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api Left res <- runClient getDeleteEmpty baseUrl case res of - FailureResponse r | responseStatusCode r == HTTP.status404 -> return () + FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do @@ -466,7 +473,7 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "not" "password" - Left (FailureResponse r) <- runClient (getBasic basicAuthData) baseUrl + Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden" genAuthSpec :: Spec @@ -483,7 +490,7 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do let getProtected = client genAuthAPI let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req) - Left (FailureResponse r) <- runClient (getProtected authRequest) baseUrl + Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized") genericClientSpec :: Spec