diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index dda7aea9..08c79e85 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -58,9 +58,13 @@ 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 + servant >= 0.15 && <0.16 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. 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 e90ee0bd..6a32eb9e 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -19,14 +19,20 @@ import Control.DeepSeq (NFData (..)) import Control.Monad.Catch (Exception) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as Builder -import qualified Data.ByteString.Lazy as LBS +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 import Data.Int (Int64) import Data.Semigroup ((<>)) -import qualified Data.Sequence as Seq +import qualified Data.Sequence as Seq import Data.Text (Text) import Data.Text.Encoding @@ -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 diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index b93c75e8..73654fd5 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -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: diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index b0e6a83c..f489ed0f 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -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 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