eeva/servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

client: Preserve failing request in FailureResponse

Browse Source 
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.
This commit is contained in:
Ben Gamari 2019-02-03 11:18:55 -05:00
parent aa704596be
commit 9a655fd68e
6 changed files with 51 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
servant-client-core/CHANGELOG.md
View File

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

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

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

33
servant-client-core/src/Servant/Client/Core/Internal/Request.hs
View File

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

7
servant-client/src/Servant/Client/Internal/HttpClient.hs
View File

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

7
servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs
View File

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

21
servant-client/test/Servant/ClientSpec.hs
View File

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