Parametrise over body contents only

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/Request.hs

@@ -19,14 +19,20 @@ import           Control.DeepSeq
                  (NFData (..))
 import           Control.Monad.Catch
                  (Exception)
-import qualified Data.ByteString         as BS
+import           Data.Bifoldable
-import qualified Data.ByteString.Builder as Builder
+                 (Bifoldable (..))
-import qualified Data.ByteString.Lazy    as LBS
+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
@@ -40,10 +46,10 @@ 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)
+import           Servant.Client.Core.Internal.BaseUrl
+                 (BaseUrl)
 
 -- | A type representing possible errors in a request
 --
@@ -83,24 +89,36 @@ mediaTypeRnf mt =
 data RequestF body path = Request
   { requestPath        :: path
   , requestQueryString :: Seq.Seq QueryItem
-  , requestBody        :: body
+  , requestBody        :: Maybe (body, MediaType)
   , requestAccept      :: Seq.Seq MediaType
   , requestHeaders     :: Seq.Seq Header
   , requestHttpVersion :: HttpVersion
   , requestMethod      :: Method
-  } deriving (Generic, Typeable, Eq, Show)
+  } deriving (Generic, Typeable, Eq, Show, Functor, Foldable, Traversable)
+
+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 r =
-    rnf (requestPath r)
+        rnf (requestPath r)
-    `seq` rnf (requestQueryString r)
+        `seq` rnf (requestQueryString r)
-    `seq` rnf (requestBody r)
+        `seq` rnfB (requestBody r)
-    `seq` rnf (fmap mediaTypeRnf (requestAccept r))
+        `seq` rnf (fmap mediaTypeRnf (requestAccept r))
-    `seq` rnf (requestHeaders r)
+        `seq` rnf (requestHeaders r)
-    `seq` requestHttpVersion r
+        `seq` requestHttpVersion r
-    `seq` rnf (requestMethod r)
+        `seq` rnf (requestMethod r)
+      where
+        rnfB Nothing        = ()
+        rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt
 
-type Request = RequestF (Maybe (RequestBody, MediaType)) Builder.Builder
+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
@@ -196,9 +198,10 @@ performRequest req = do
           fRes = Client.hrFinalResponse responses
 
 mkFailureResponse :: BaseUrl -> Request -> GenResponse BSL.ByteString -> ServantError
-mkFailureResponse burl request ourResponse =
+mkFailureResponse burl request =
-  FailureResponse (request {requestPath = (burl, path), requestBody = ()}) ourResponse
+    FailureResponse (bimap (const ()) f request)
-  where path = BSL.toStrict $ toLazyByteString $ requestPath request
+  where
+    f b = (burl, BSL.toStrict $ toLazyByteString b)
 
 clientResponseToResponse :: Client.Response a -> GenResponse a
 clientResponseToResponse r = Response