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

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

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

@@ -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
+  -- | The server returned an error response including the
-    FailureResponse Response
+  -- 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

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

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