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

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

Browse source 
Bgamari request in failureresponse
This commit is contained in:
Oleg Grenrus 2019-02-05 12:25:50 +02:00 committed by GitHub
commit fdd1c7392b
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
7 changed files with 91 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
servant-client-core/servant-client-core.cabal
View file

@ -58,6 +58,10 @@ library
, transformers >= 0.5.2.0 && < 0.6
, template-haskell >= 2.11.1.0 && < 2.15
if !impl(ghc >= 8.2)
build-depends:
bifunctors >= 5.5.3 && < 5.6
-- Servant dependencies
build-depends:
servant >= 0.15 && <0.16

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'

59
servant-client-core/src/Servant/Client/Core/Internal/Request.hs
View file

@ -19,6 +19,12 @@ import Control.DeepSeq
(NFData (..))
import Control.Monad.Catch
(Exception)
import Data.Bifoldable
(Bifoldable (..))
import Data.Bifunctor
(Bifunctor (..))
import Data.Bitraversable
(Bitraversable (..), bifoldMapDefault, bimapDefault)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Lazy as LBS
@ -42,13 +48,17 @@ import Network.HTTP.Types
Status (..), http11, methodGet)
import Servant.API
(ToHttpApiData, toEncodedUrlPiece, toHeader)
import Servant.Client.Core.Internal.BaseUrl
(BaseUrl)
-- | A type representing possible errors in a request
--
-- 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,30 +72,53 @@ 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
data RequestF a = Request
{ requestPath :: a
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 (RequestBody, MediaType)
, requestBody :: Maybe (body, MediaType)
, requestAccept :: Seq.Seq MediaType
, requestHeaders :: Seq.Seq Header
, requestHttpVersion :: HttpVersion
, requestMethod :: Method
} deriving (Generic, Typeable)
} deriving (Generic, Typeable, Eq, Show, Functor, Foldable, Traversable)
type Request = RequestF Builder.Builder
instance Bifunctor RequestF where bimap = bimapDefault
instance Bifoldable RequestF where bifoldMap = bifoldMapDefault
instance Bitraversable RequestF where
bitraverse f g r = mk
<$> traverse (bitraverse f pure) (requestBody r)
<*> g (requestPath r)
where
mk b p = r { requestBody = b, requestPath = p }
instance (NFData path, NFData body) => NFData (RequestF body path) where
rnf r =
rnf (requestPath r)
`seq` rnf (requestQueryString r)
`seq` rnfB (requestBody r)
`seq` rnf (fmap mediaTypeRnf (requestAccept r))
`seq` rnf (requestHeaders r)
`seq` requestHttpVersion r
`seq` rnf (requestMethod r)
where
rnfB Nothing = ()
rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt
type Request = RequestF RequestBody Builder.Builder
-- | The request body. A replica of the @http-client@ @RequestBody@.
data RequestBody

4
servant-client/servant-client.cabal
View file

@ -55,6 +55,10 @@ library
, time >= 1.6.0.1 && < 1.9
, transformers >= 0.5.2.0 && < 0.6
if !impl(ghc >= 8.2)
build-depends:
bifunctors >= 5.5.3 && < 5.6
-- Servant dependencies.
-- Strict dependency on `servant-client-core` as we re-export things.
build-depends:

10
servant-client/src/Servant/Client/Internal/HttpClient.hs
View file

@ -31,6 +31,8 @@ import Control.Monad.STM
import Control.Monad.Trans.Control
(MonadBaseControl (..))
import Control.Monad.Trans.Except
import Data.Bifunctor
(bimap)
import Data.ByteString.Builder
(toLazyByteString)
import qualified Data.ByteString.Lazy as BSL
@ -167,7 +169,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 +197,12 @@ performRequest req = do
fReq = Client.hrFinalRequest responses
fRes = Client.hrFinalResponse responses
mkFailureResponse :: BaseUrl -> Request -> GenResponse BSL.ByteString -> ServantError
mkFailureResponse burl request =
FailureResponse (bimap (const ()) f request)
where
f b = (burl, BSL.toStrict $ toLazyByteString b)
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