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

Bgamari request in failureresponse

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.

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'

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

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:

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

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

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