From 4fab471c29db5f8fe18b6718b7569cb209538ef8 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 6 Feb 2019 12:12:56 +0200 Subject: [PATCH] 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 --- .../using-free-client/UsingFreeClient.lhs | 2 +- servant-client-core/servant-client-core.cabal | 2 + .../src/Servant/Client/Core.hs | 4 +- .../Client/Core/Internal/ClientError.hs | 82 +++++++++++++++++ .../Servant/Client/Core/Internal/ClientF.hs | 2 + .../Servant/Client/Core/Internal/HasClient.hs | 36 ++------ .../Servant/Client/Core/Internal/Request.hs | 89 ++----------------- .../Servant/Client/Core/Internal/Response.hs | 49 ++++++++++ .../Servant/Client/Core/Internal/RunClient.hs | 4 +- .../src/Servant/Client/Core/Reexport.hs | 5 +- .../src/Servant/Client/Internal/HttpClient.hs | 86 +++++++++++------- .../Client/Internal/HttpClient/Streaming.hs | 12 +-- servant/src/Servant/API/ResponseHeaders.hs | 18 ++++ 13 files changed, 236 insertions(+), 155 deletions(-) create mode 100644 servant-client-core/src/Servant/Client/Core/Internal/ClientError.hs create mode 100644 servant-client-core/src/Servant/Client/Core/Internal/Response.hs diff --git a/doc/cookbook/using-free-client/UsingFreeClient.lhs b/doc/cookbook/using-free-client/UsingFreeClient.lhs index 5eb9cd2d..ca2811be 100644 --- a/doc/cookbook/using-free-client/UsingFreeClient.lhs +++ b/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 -> diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 08c79e85..d1e444ba 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/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 diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index 09527eaa..635df2ed 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/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 diff --git a/servant-client-core/src/Servant/Client/Core/Internal/ClientError.hs b/servant-client-core/src/Servant/Client/Core/Internal/ClientError.hs new file mode 100644 index 00000000..25715f87 --- /dev/null +++ b/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) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs b/servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs index 20035c0b..7b2a0deb 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs +++ b/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) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs index 6be92ec6..f480e655 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs +++ b/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 - (modifyMVar, newMVar) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL +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 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 ffa1c674..08e06f25 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/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) -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) + (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO) 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 - | RequestBodyStream Int64 ((IO BS.ByteString -> IO ()) -> IO ()) - | RequestBodyStreamChunked ((IO BS.ByteString -> IO ()) -> IO ()) - | RequestBodyIO (IO RequestBody) + | RequestBodySource (SourceIO LBS.ByteString) deriving (Generic, Typeable) -data GenResponse a = Response - { responseStatusCode :: Status - , responseHeaders :: Seq.Seq Header - , responseHttpVersion :: HttpVersion - , 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) +instance Show RequestBody where + showsPrec d (RequestBodyLBS lbs) = showParen (d > 10) + $ showString "RequestBodyLBS " + . showsPrec 11 lbs -- A GET request to the top-level path defaultRequest :: Request diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Response.hs b/servant-client-core/src/Servant/Client/Core/Internal/Response.hs new file mode 100644 index 00000000..0186be26 --- /dev/null +++ b/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) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs index 9ef71e86..197e570e 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs +++ b/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 (..), - StreamingResponse) +import Servant.Client.Core.Internal.Response +import Servant.Client.Core.Internal.ClientError class Monad m => RunClient m where -- | How to make a request. diff --git a/servant-client-core/src/Servant/Client/Core/Reexport.hs b/servant-client-core/src/Servant/Client/Core/Reexport.hs index 401b1e8f..b13b72bf 100644 --- a/servant-client-core/src/Servant/Client/Core/Reexport.hs +++ b/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 diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index 9edc6dbf..8340e245 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/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 r = Response - { responseStatusCode = Client.responseStatus r - , responseBody = Client.responseBody r - , responseHeaders = fromList $ Client.responseHeaders r - , responseHttpVersion = Client.responseVersion r - } +clientResponseToResponse :: (a -> b) -> Client.Response a -> ResponseF b +clientResponseToResponse f r = Response + { responseStatusCode = Client.responseStatus r + , responseBody = f (Client.responseBody r) + , responseHeaders = fromList $ Client.responseHeaders r + , responseHttpVersion = Client.responseVersion r + } requestToClientRequest :: BaseUrl -> Request -> Client.Request requestToClientRequest burl r = Client.defaultRequest - { Client.method = requestMethod r - , Client.host = fromString $ baseUrlHost burl - , Client.port = baseUrlPort burl - , Client.path = BSL.toStrict - $ fromString (baseUrlPath burl) - <> toLazyByteString (requestPath r) - , Client.queryString = renderQuery True . toList $ requestQueryString r - , Client.requestHeaders = - maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers - , Client.requestBody = body - , Client.secure = isSecure - } + { Client.method = requestMethod r + , Client.host = fromString $ baseUrlHost burl + , Client.port = baseUrlPort burl + , Client.path = BSL.toStrict + $ fromString (baseUrlPath burl) + <> toLazyByteString (requestPath r) + , Client.queryString = renderQuery True . toList $ requestQueryString r + , Client.requestHeaders = + maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers + , Client.requestBody = body + , 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' - RequestBodyBS body' -> Client.RequestBodyBS body' - RequestBodyBuilder size body' -> Client.RequestBodyBuilder size body' - RequestBodyStream size body' -> Client.RequestBodyStream size body' - RequestBodyStreamChunked body' -> Client.RequestBodyStreamChunked body' - RequestBodyIO body' -> Client.RequestBodyIO (convertBody <$> body') + RequestBodyLBS body' -> Client.RequestBodyLBS body' + RequestBodyBS body' -> Client.RequestBodyBS body' + RequestBodySource sourceIO -> Client.RequestBodyStreamChunked givesPopper + where + 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 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) - Just (body', typ) - -> (convertBody body', Just (hContentType, renderHeader typ)) + Nothing -> (Client.RequestBodyBS "", Nothing) + Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ)) isSecure = case baseUrlScheme burl of - Http -> False - Https -> True + Http -> False + Https -> True catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError action = diff --git a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs index 429c079d..fbf82c2d 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs +++ b/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, - mkFailureResponse) + clientResponseToResponse, mkClientEnv, 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 diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index e5ff1ed9..6ca42b6f 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/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