Refactor servant-client(-core)

- Rename GenResponse to ResponseF (analogous to RequestF)
- add NFData Headers
- Make Request and Response bodies be SourceIO,
  i.e. move conversions into specific implementations

doc/cookbook/using-free-client/UsingFreeClient.lhs

@@ -137,7 +137,7 @@ And we continue by turning http-client's `Response` into servant's `Response`,
 and calling the continuation. We should get a `Pure` value.
 
 ```haskell
-        let res = I.clientResponseToResponse res'
+        let res = I.clientResponseToResponse id res'
         
         case k res of
             Pure n ->

servant-client-core/servant-client-core.cabal

@@ -39,10 +39,12 @@ library
       Servant.Client.Core.Internal.Auth
       Servant.Client.Core.Internal.BaseUrl
       Servant.Client.Core.Internal.BasicAuth
+      Servant.Client.Core.Internal.ClientError
       Servant.Client.Core.Internal.ClientF
       Servant.Client.Core.Internal.Generic
       Servant.Client.Core.Internal.HasClient
       Servant.Client.Core.Internal.Request
+      Servant.Client.Core.Internal.Response
       Servant.Client.Core.Internal.RunClient
 
   -- Bundled with GHC: Lower bound to not force re-installs

servant-client-core/src/Servant/Client/Core.hs

@@ -41,7 +41,7 @@ module Servant.Client.Core
 
   -- * Response
   , Response
-  , GenResponse (..)
+  , ResponseF (..)
   , RunClient(..)
   , module Servant.Client.Core.Internal.BaseUrl
   -- ** Streaming
@@ -64,4 +64,6 @@ import           Servant.Client.Core.Internal.BasicAuth
 import           Servant.Client.Core.Internal.Generic
 import           Servant.Client.Core.Internal.HasClient
 import           Servant.Client.Core.Internal.Request
+import           Servant.Client.Core.Internal.Response
+import           Servant.Client.Core.Internal.ClientError
 import           Servant.Client.Core.Internal.RunClient

servant-client-core/src/Servant/Client/Core/Internal/ClientError.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE DeriveDataTypeable    #-}
+{-# LANGUAGE DeriveFoldable        #-}
+{-# LANGUAGE DeriveFunctor         #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE DeriveTraversable     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeFamilies          #-}
+module Servant.Client.Core.Internal.ClientError where
+
+import           Prelude ()
+import           Prelude.Compat
+
+import           Control.DeepSeq
+                 (NFData (..))
+import           Control.Exception
+                 (SomeException (..))
+import           Control.Monad.Catch
+                 (Exception)
+import qualified Data.ByteString                       as BS
+import           Data.Text
+                 (Text)
+import           Data.Typeable
+                 (Typeable, typeOf)
+import           GHC.Generics
+                 (Generic)
+import           Network.HTTP.Media (MediaType)
+import           Network.HTTP.Types ()
+
+import           Servant.Client.Core.Internal.BaseUrl
+import           Servant.Client.Core.Internal.Request
+import           Servant.Client.Core.Internal.Response
+
+
+
+-- | 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 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
+  | UnsupportedContentType MediaType Response
+  -- | The content-type header is invalid
+  | InvalidContentTypeHeader Response
+  -- | There was a connection error, and no response was received
+  | ConnectionError SomeException
+  deriving (Show, Generic, Typeable)
+
+instance Eq ServantError where
+  FailureResponse req res     == FailureResponse req' res'     = req == req' && res == res'
+  DecodeFailure t r           == DecodeFailure t' r'           = t == t' && r == r'
+  UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r'
+  InvalidContentTypeHeader r  == InvalidContentTypeHeader r'   = r == r'
+  ConnectionError exc         == ConnectionError exc'          = eqSomeException exc exc'
+    where
+      -- returns true, if type of exception is the same
+      eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b
+
+  -- prevent wild card blindness
+  FailureResponse          {} == _ = False
+  DecodeFailure            {} == _ = False
+  UnsupportedContentType   {} == _ = False
+  InvalidContentTypeHeader {} == _ = False
+  ConnectionError          {} == _ = False
+
+instance Exception ServantError
+
+-- | Note: an exception in 'ConnectionError' might not be evaluated fully,
+-- We only 'rnf' its 'show'ed value.
+instance NFData ServantError where
+    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
+    rnf (InvalidContentTypeHeader res)   = rnf res
+    rnf (ConnectionError err)            = err `seq` rnf (show err)

servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs

@@ -2,6 +2,8 @@
 module Servant.Client.Core.Internal.ClientF where
 
 import           Servant.Client.Core.Internal.Request
+import           Servant.Client.Core.Internal.Response
+import           Servant.Client.Core.Internal.ClientError
 
 data ClientF a
     = RunRequest Request (Response -> a)

servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs

@@ -16,10 +16,7 @@ module Servant.Client.Core.Internal.HasClient where
 import           Prelude ()
 import           Prelude.Compat
 
-import           Control.Concurrent.MVar
+import qualified Data.ByteString.Lazy                     as BL
-                 (modifyMVar, newMVar)
-import qualified Data.ByteString                        as BS
-import qualified Data.ByteString.Lazy                   as BL
 import           Data.Foldable
                  (toList)
 import           Data.List
@@ -34,7 +31,7 @@ import           Data.Text
                  (Text, pack)
 import           GHC.TypeLits
                  (KnownSymbol, symbolVal)
-import qualified Network.HTTP.Types                     as H
+import qualified Network.HTTP.Types                       as H
 import           Servant.API
                  ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
                  BuildHeadersTo (..), Capture', CaptureAll, Description,
@@ -50,11 +47,12 @@ import           Servant.API.ContentTypes
                  (contentTypes)
 import           Servant.API.Modifiers
                  (FoldRequired, RequiredArgument, foldRequiredArgument)
-import qualified Servant.Types.SourceT                  as S
 
 import           Servant.Client.Core.Internal.Auth
 import           Servant.Client.Core.Internal.BasicAuth
+import           Servant.Client.Core.Internal.ClientError
 import           Servant.Client.Core.Internal.Request
+import           Servant.Client.Core.Internal.Response
 import           Servant.Client.Core.Internal.RunClient
 
 -- * Accessing APIs as a Client
@@ -283,7 +281,7 @@ instance {-# OVERLAPPABLE #-}
   clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
       let mimeUnrender'    = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
           framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
-      return $ fromSourceIO $ framingUnrender' $ S.fromAction BS.null (responseBody gres)
+      return $ fromSourceIO $ framingUnrender' $ responseBody gres
     where
       req' = req
           { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
@@ -552,7 +550,7 @@ instance
 
     clientWithRoute pm Proxy req body
         = clientWithRoute pm (Proxy :: Proxy api)
-        $ setRequestBody (RequestBodyStreamChunked givesPopper) (contentType ctypeP) req
+        $ setRequestBody (RequestBodySource sourceIO) (contentType ctypeP) req
       where
         ctypeP   = Proxy :: Proxy ctype
         framingP = Proxy :: Proxy framing
@@ -562,28 +560,6 @@ instance
             (mimeRender ctypeP :: chunk -> BL.ByteString)
             (toSourceIO body)
 
-        -- not pretty.
-        givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()
-        givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do
-            ref <- newMVar step0
-
-            -- Note sure we need locking, but it's feels safer.
-            let popper :: IO BS.ByteString
-                popper = modifyMVar ref nextBs
-
-            needsPopper popper
-
-        nextBs S.Stop          = return (S.Stop, BS.empty)
-        nextBs (S.Error err)   = fail err
-        nextBs (S.Skip s)      = nextBs s
-        nextBs (S.Effect ms)   = ms >>= nextBs
-        nextBs (S.Yield lbs s) = case BL.toChunks lbs of
-            []     -> nextBs s
-            (x:xs) | BS.null x -> nextBs step'
-                   | otherwise -> return (step', x)
-                where
-                  step' = S.Yield (BL.fromChunks xs) s
-
 -- | Make the querying function append @path@ to the request path.
 instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
   type Client m (path :> api) = Client m api

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

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DeriveDataTypeable    #-}
 {-# LANGUAGE DeriveFoldable        #-}
 {-# LANGUAGE DeriveFunctor         #-}
@@ -17,10 +16,6 @@ import           Prelude.Compat
 
 import           Control.DeepSeq
                  (NFData (..))
-import           Control.Exception
-                 (SomeException (..))
-import           Control.Monad.Catch
-                 (Exception)
 import           Data.Bifoldable
                  (Bifoldable (..))
 import           Data.Bifunctor
@@ -30,8 +25,6 @@ import           Data.Bitraversable
 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
@@ -40,64 +33,16 @@ import           Data.Text
 import           Data.Text.Encoding
                  (encodeUtf8)
 import           Data.Typeable
-                 (Typeable, typeOf)
+                 (Typeable)
 import           GHC.Generics
                  (Generic)
 import           Network.HTTP.Media
                  (MediaType, mainType, parameters, subType)
 import           Network.HTTP.Types
                  (Header, HeaderName, HttpVersion (..), Method, QueryItem,
-                 Status (..), http11, methodGet)
+                 http11, methodGet)
 import           Servant.API
-                 (ToHttpApiData, toEncodedUrlPiece, toHeader)
+                 (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)
-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 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
-  | UnsupportedContentType MediaType Response
-  -- | The content-type header is invalid
-  | InvalidContentTypeHeader Response
-  -- | There was a connection error, and no response was received
-  | ConnectionError SomeException
-  deriving (Show, Generic, Typeable)
-
-instance Eq ServantError where
-  FailureResponse req res     == FailureResponse req' res'     = req == req' && res == res'
-  DecodeFailure t r           == DecodeFailure t' r'           = t == t' && r == r'
-  UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r'
-  InvalidContentTypeHeader r  == InvalidContentTypeHeader r'   = r == r'
-  ConnectionError exc         == ConnectionError exc'          = eqSomeException exc exc'
-    where
-      -- returns true, if type of exception is the same
-      eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b
-
-  -- prevent wild card blindness
-  FailureResponse          {} == _ = False
-  DecodeFailure            {} == _ = False
-  UnsupportedContentType   {} == _ = False
-  InvalidContentTypeHeader {} == _ = False
-  ConnectionError          {} == _ = False
-
-instance Exception ServantError
-
--- | Note: an exception in 'ConnectionError' might not be evaluated fully,
--- We only 'rnf' its 'show'ed value.
-instance NFData ServantError where
-    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
-    rnf (InvalidContentTypeHeader res)   = rnf res
-    rnf (ConnectionError err)            = err `seq` rnf (show err)
 
 mediaTypeRnf :: MediaType -> ()
 mediaTypeRnf mt =
@@ -143,31 +88,13 @@ type Request = RequestF RequestBody Builder.Builder
 data RequestBody
   = RequestBodyLBS LBS.ByteString
   | RequestBodyBS BS.ByteString
-  | RequestBodyBuilder Int64 Builder.Builder
+  | RequestBodySource (SourceIO LBS.ByteString)
-  | RequestBodyStream Int64 ((IO BS.ByteString -> IO ()) -> IO ())
-  | RequestBodyStreamChunked ((IO BS.ByteString -> IO ()) -> IO ())
-  | RequestBodyIO (IO RequestBody)
   deriving (Generic, Typeable)
 
-data GenResponse a = Response
+instance Show RequestBody where
-  { responseStatusCode  :: Status
+    showsPrec d (RequestBodyLBS lbs) = showParen (d > 10)
-  , responseHeaders     :: Seq.Seq Header
+        $ showString "RequestBodyLBS "
-  , responseHttpVersion :: HttpVersion
+        . showsPrec 11 lbs
-  , responseBody        :: a
-  } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)
-
-instance NFData a => NFData (GenResponse a) where
-    rnf (Response sc hs hv body) =
-        rnfStatus sc `seq`
-        rnf hs `seq`
-        rnfHttpVersion hv `seq`
-        rnf body
-      where
-        rnfStatus (Status code msg) = rnf code `seq` rnf msg
-        rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict
-
-type Response = GenResponse LBS.ByteString
-type StreamingResponse = GenResponse (IO BS.ByteString)
 
 -- A GET request to the top-level path
 defaultRequest :: Request

servant-client-core/src/Servant/Client/Core/Internal/Response.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE DeriveDataTypeable    #-}
+{-# LANGUAGE DeriveFoldable        #-}
+{-# LANGUAGE DeriveFunctor         #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE DeriveTraversable     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeFamilies          #-}
+
+module Servant.Client.Core.Internal.Response where
+
+import           Prelude ()
+import           Prelude.Compat
+
+import           Control.DeepSeq
+                 (NFData (..))
+import qualified Data.ByteString      as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Sequence        as Seq
+import           Data.Typeable
+                 (Typeable)
+import           GHC.Generics
+                 (Generic)
+import           Network.HTTP.Types
+                 (Header, HttpVersion (..), Status (..))
+
+import           Servant.API.Stream
+                 (SourceIO)
+
+data ResponseF a = Response
+  { responseStatusCode  :: Status
+  , responseHeaders     :: Seq.Seq Header
+  , responseHttpVersion :: HttpVersion
+  , responseBody        :: a
+  } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)
+
+instance NFData a => NFData (ResponseF a) where
+    rnf (Response sc hs hv body) =
+        rnfStatus sc `seq`
+        rnf hs `seq`
+        rnfHttpVersion hv `seq`
+        rnf body
+      where
+        rnfStatus (Status code msg) = rnf code `seq` rnf msg
+        rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict
+
+type Response = ResponseF LBS.ByteString
+type StreamingResponse = ResponseF (SourceIO BS.ByteString)

servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs

@@ -25,8 +25,8 @@ import           Servant.API
 
 import           Servant.Client.Core.Internal.ClientF
 import           Servant.Client.Core.Internal.Request
-                 (GenResponse (..), Request, Response, ServantError (..),
+import           Servant.Client.Core.Internal.Response
-                 StreamingResponse)
+import           Servant.Client.Core.Internal.ClientError
 
 class Monad m => RunClient m where
   -- | How to make a request.

servant-client-core/src/Servant/Client/Core/Reexport.hs

@@ -9,7 +9,7 @@ module Servant.Client.Core.Reexport
     -- * Response (for @Raw@)
   , Response
   , StreamingResponse
-  , GenResponse(..)
+  , ResponseF(..)
 
   -- * Generic Client
   , ClientLike(..)
@@ -30,4 +30,5 @@ module Servant.Client.Core.Reexport
 import           Servant.Client.Core.Internal.BaseUrl
 import           Servant.Client.Core.Internal.Generic
 import           Servant.Client.Core.Internal.HasClient
-import           Servant.Client.Core.Internal.Request
+import           Servant.Client.Core.Internal.Response
+import           Servant.Client.Core.Internal.ClientError

servant-client/src/Servant/Client/Internal/HttpClient.hs

@@ -14,6 +14,9 @@ module Servant.Client.Internal.HttpClient where
 import           Prelude ()
 import           Prelude.Compat
 
+import           Control.Concurrent.MVar
+                 (modifyMVar, newMVar)
+import qualified Data.ByteString                          as BS
 import           Control.Concurrent.STM.TVar
 import           Control.Exception
 import           Control.Monad
@@ -52,7 +55,6 @@ import           Data.Sequence
                  (fromList)
 import           Data.String
                  (fromString)
-import qualified Data.Text                   as T
 import           Data.Time.Clock
                  (UTCTime, getCurrentTime)
 import           GHC.Generics
@@ -62,6 +64,7 @@ import           Network.HTTP.Types
                  (hContentType, renderQuery, statusCode)
 import           Servant.Client.Core
 
+import qualified Servant.Types.SourceT                    as S
 import qualified Network.HTTP.Client         as Client
 
 -- | The environment in which a request is run.
@@ -167,7 +170,7 @@ performRequest req = do
   response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
   let status = Client.responseStatus response
       status_code = statusCode status
-      ourResponse = clientResponseToResponse response
+      ourResponse = clientResponseToResponse id response
   unless (status_code >= 200 && status_code < 300) $
       throwError $ mkFailureResponse burl req ourResponse
   return ourResponse
@@ -197,34 +200,34 @@ performRequest req = do
           fReq = Client.hrFinalRequest responses
           fRes = Client.hrFinalResponse responses
 
-mkFailureResponse :: BaseUrl -> Request -> GenResponse BSL.ByteString -> ServantError
+mkFailureResponse :: BaseUrl -> Request -> ResponseF 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 :: (a -> b) -> Client.Response a -> ResponseF b
-clientResponseToResponse r = Response
+clientResponseToResponse f r = Response
-  { responseStatusCode = Client.responseStatus r
+    { responseStatusCode  = Client.responseStatus r
-  , responseBody = Client.responseBody r
+    , responseBody        = f (Client.responseBody r)
-  , responseHeaders = fromList $ Client.responseHeaders r
+    , responseHeaders     = fromList $ Client.responseHeaders r
-  , responseHttpVersion = Client.responseVersion r
+    , responseHttpVersion = Client.responseVersion r
-  }
+    }
 
 requestToClientRequest :: BaseUrl -> Request -> Client.Request
 requestToClientRequest burl r = Client.defaultRequest
-  { Client.method = requestMethod r
+    { Client.method = requestMethod r
-  , Client.host = fromString $ baseUrlHost burl
+    , Client.host = fromString $ baseUrlHost burl
-  , Client.port = baseUrlPort burl
+    , Client.port = baseUrlPort burl
-  , Client.path = BSL.toStrict
+    , Client.path = BSL.toStrict
-                $ fromString (baseUrlPath burl)
+                  $ fromString (baseUrlPath burl)
-               <> toLazyByteString (requestPath r)
+                 <> toLazyByteString (requestPath r)
-  , Client.queryString = renderQuery True . toList $ requestQueryString r
+    , Client.queryString = renderQuery True . toList $ requestQueryString r
-  , Client.requestHeaders =
+    , Client.requestHeaders =
-    maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
+      maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
-  , Client.requestBody = body
+    , Client.requestBody = body
-  , Client.secure = isSecure
+    , Client.secure = isSecure
-  }
+    }
   where
     -- Content-Type and Accept are specified by requestBody and requestAccept
     headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
@@ -237,21 +240,38 @@ requestToClientRequest burl r = Client.defaultRequest
         hs = toList $ requestAccept r
 
     convertBody bd = case bd of
-      RequestBodyLBS body' -> Client.RequestBodyLBS body'
+        RequestBodyLBS body'       -> Client.RequestBodyLBS body'
-      RequestBodyBS body' -> Client.RequestBodyBS body'
+        RequestBodyBS body'        -> Client.RequestBodyBS body'
-      RequestBodyBuilder size body' -> Client.RequestBodyBuilder size body'
+        RequestBodySource sourceIO -> Client.RequestBodyStreamChunked givesPopper
-      RequestBodyStream size body' -> Client.RequestBodyStream size body'
+          where
-      RequestBodyStreamChunked body' -> Client.RequestBodyStreamChunked body'
+            givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()
-      RequestBodyIO body' -> Client.RequestBodyIO (convertBody <$> body')
+            givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do
+                ref <- newMVar step0
+
+                -- Note sure we need locking, but it's feels safer.
+                let popper :: IO BS.ByteString
+                    popper = modifyMVar ref nextBs
+
+                needsPopper popper
+
+            nextBs S.Stop          = return (S.Stop, BS.empty)
+            nextBs (S.Error err)   = fail err
+            nextBs (S.Skip s)      = nextBs s
+            nextBs (S.Effect ms)   = ms >>= nextBs
+            nextBs (S.Yield lbs s) = case BSL.toChunks lbs of
+                []     -> nextBs s
+                (x:xs) | BS.null x -> nextBs step'
+                       | otherwise -> return (step', x)
+                    where
+                      step' = S.Yield (BSL.fromChunks xs) s
 
     (body, contentTypeHdr) = case requestBody r of
-      Nothing -> (Client.RequestBodyLBS "", Nothing)
+        Nothing           -> (Client.RequestBodyBS "", Nothing)
-      Just (body', typ)
+        Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ))
-        -> (convertBody body', Just (hContentType, renderHeader typ))
 
     isSecure = case baseUrlScheme burl of
-      Http -> False
+        Http -> False
-      Https -> True
+        Https -> True
 
 catchConnectionError :: IO a -> IO (Either ServantError a)
 catchConnectionError action =

servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs

@@ -35,6 +35,7 @@ import           Control.Monad.Reader
 import           Control.Monad.STM
                  (atomically)
 import           Control.Monad.Trans.Except
+import qualified Data.ByteString                    as BS
 import qualified Data.ByteString.Lazy               as BSL
 import           Data.Foldable
                  (for_)
@@ -53,8 +54,9 @@ import qualified Network.HTTP.Client                as Client
 import           Servant.Client.Core
 import           Servant.Client.Internal.HttpClient
                  (ClientEnv (..), catchConnectionError,
-                 clientResponseToResponse, mkClientEnv, requestToClientRequest,
+                 clientResponseToResponse, mkClientEnv, mkFailureResponse,
-                 mkFailureResponse)
+                 requestToClientRequest)
+import qualified Servant.Types.SourceT              as S
 
 
 -- | Generates a set of client functions for an API.
@@ -165,7 +167,7 @@ performRequest req = do
         atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
       let status = Client.responseStatus response
           status_code = statusCode status
-          ourResponse = clientResponseToResponse response
+          ourResponse = clientResponseToResponse id response
       unless (status_code >= 200 && status_code < 300) $
         throwError $ mkFailureResponse burl req ourResponse
       return ourResponse
@@ -183,7 +185,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 $ mkFailureResponse burl req (clientResponseToResponse res { Client.responseBody = b })
+              throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)
 
-          x <- k (clientResponseToResponse res)
+          x <- k (clientResponseToResponse (S.fromAction BS.null) res)
           k1 x

servant/src/Servant/API/ResponseHeaders.hs

@@ -35,6 +35,8 @@ module Servant.API.ResponseHeaders
     , HList(..)
     ) where
 
+import           Control.DeepSeq
+                 (NFData (..))
 import           Data.ByteString.Char8     as BS
                  (ByteString, init, pack, unlines)
 import qualified Data.CaseInsensitive      as CI
@@ -60,16 +62,32 @@ data Headers ls a = Headers { getResponse :: a
                             -- ^ HList of headers.
                             } deriving (Functor)
 
+instance (NFDataHList ls, NFData a) => NFData (Headers ls a) where
+    rnf (Headers x hdrs) = rnf x `seq` rnf hdrs
+
 data ResponseHeader (sym :: Symbol) a
     = Header a
     | MissingHeader
     | UndecodableHeader ByteString
   deriving (Typeable, Eq, Show, Functor)
 
+instance NFData a => NFData (ResponseHeader sym a) where
+    rnf MissingHeader          = ()
+    rnf (UndecodableHeader bs) = rnf bs
+    rnf (Header x)             = rnf x
+
 data HList a where
     HNil  :: HList '[]
     HCons :: ResponseHeader h x -> HList xs -> HList (Header h x ': xs)
 
+class NFDataHList xs where rnfHList :: HList xs -> ()
+instance NFDataHList '[] where rnfHList HNil = ()
+instance (y ~ Header h x, NFData x, NFDataHList xs) => NFDataHList (y ': xs) where
+    rnfHList (HCons h xs) = rnf h `seq` rnfHList xs
+
+instance NFDataHList xs => NFData (HList xs) where
+    rnf = rnfHList
+
 type family HeaderValMap (f :: * -> *) (xs :: [*]) where
     HeaderValMap f '[]                = '[]
     HeaderValMap f (Header h x ': xs) = Header h (f x) ': HeaderValMap f xs