4fab471 · typeable/servant

doc/cookbook/using-free-client/UsingFreeClient.lhs+1−1

@@ -137,7 +137,7 @@ And we continue by turning http-client's `Response` into servant's `Response`,

137137and calling the continuation. We should get a `Pure` value.

138138

139139```haskell

140− let res = I.clientResponseToResponse res'

140+ let res = I.clientResponseToResponse id res'

141141

142142 case k res of

143143 Pure n ->

servant-client-core/servant-client-core.cabal+2

@@ -39,10 +39,12 @@ library

3939 Servant.Client.Core.Internal.Auth

4040 Servant.Client.Core.Internal.BaseUrl

4141 Servant.Client.Core.Internal.BasicAuth

42+ Servant.Client.Core.Internal.ClientError

4243 Servant.Client.Core.Internal.ClientF

4344 Servant.Client.Core.Internal.Generic

4445 Servant.Client.Core.Internal.HasClient

4546 Servant.Client.Core.Internal.Request

47+ Servant.Client.Core.Internal.Response

4648 Servant.Client.Core.Internal.RunClient

4749

4850 -- Bundled with GHC: Lower bound to not force re-installs

servant-client-core/src/Servant/Client/Core.hs+3−1

@@ -41,7 +41,7 @@ module Servant.Client.Core

4141

4242 -- * Response

4343 , Response

44− , GenResponse (..)

44+ , ResponseF (..)

4545 , RunClient(..)

4646 , module Servant.Client.Core.Internal.BaseUrl

4747 -- ** Streaming

@@ -64,4 +64,6 @@ import Servant.Client.Core.Internal.BasicAuth

6464import Servant.Client.Core.Internal.Generic

6565import Servant.Client.Core.Internal.HasClient

6666import Servant.Client.Core.Internal.Request

67+import Servant.Client.Core.Internal.Response

68+import Servant.Client.Core.Internal.ClientError

6769import Servant.Client.Core.Internal.RunClient

servant-client-core/src/Servant/Client/Core/Internal/ClientError.hsnew file+82

@@ -0,0 +1,82 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE DeriveFoldable #-}

3+{-# LANGUAGE DeriveFunctor #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# LANGUAGE DeriveTraversable #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeFamilies #-}

11+module Servant.Client.Core.Internal.ClientError where

12+

13+import Prelude ()

14+import Prelude.Compat

15+

16+import Control.DeepSeq

17+ (NFData (..))

18+import Control.Exception

19+ (SomeException (..))

20+import Control.Monad.Catch

21+ (Exception)

22+import qualified Data.ByteString as BS

23+import Data.Text

24+ (Text)

25+import Data.Typeable

26+ (Typeable, typeOf)

27+import GHC.Generics

28+ (Generic)

29+import Network.HTTP.Media (MediaType)

30+import Network.HTTP.Types ()

31+

32+import Servant.Client.Core.Internal.BaseUrl

33+import Servant.Client.Core.Internal.Request

34+import Servant.Client.Core.Internal.Response

35+

36+

37+

38+-- | A type representing possible errors in a request

39+--

40+-- Note that this type substantially changed in 0.12.

41+data ServantError =

42+ -- | The server returned an error response including the

43+ -- failing request. 'requestPath' includes the 'BaseUrl' and the

44+ -- path of the request.

45+ FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response

46+ -- | The body could not be decoded at the expected type

47+ | DecodeFailure Text Response

48+ -- | The content-type of the response is not supported

49+ | UnsupportedContentType MediaType Response

50+ -- | The content-type header is invalid

51+ | InvalidContentTypeHeader Response

52+ -- | There was a connection error, and no response was received

53+ | ConnectionError SomeException

54+ deriving (Show, Generic, Typeable)

55+

56+instance Eq ServantError where

57+ FailureResponse req res == FailureResponse req' res' = req == req' && res == res'

58+ DecodeFailure t r == DecodeFailure t' r' = t == t' && r == r'

59+ UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r'

60+ InvalidContentTypeHeader r == InvalidContentTypeHeader r' = r == r'

61+ ConnectionError exc == ConnectionError exc' = eqSomeException exc exc'

62+ where

63+ -- returns true, if type of exception is the same

64+ eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b

65+

66+ -- prevent wild card blindness

67+ FailureResponse {} == _ = False

68+ DecodeFailure {} == _ = False

69+ UnsupportedContentType {} == _ = False

70+ InvalidContentTypeHeader {} == _ = False

71+ ConnectionError {} == _ = False

72+

73+instance Exception ServantError

74+

75+-- | Note: an exception in 'ConnectionError' might not be evaluated fully,

76+-- We only 'rnf' its 'show'ed value.

77+instance NFData ServantError where

78+ rnf (FailureResponse req res) = rnf req `seq` rnf res

79+ rnf (DecodeFailure err res) = rnf err `seq` rnf res

80+ rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res

81+ rnf (InvalidContentTypeHeader res) = rnf res

82+ rnf (ConnectionError err) = err `seq` rnf (show err)

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

@@ -2,6 +2,8 @@

22module Servant.Client.Core.Internal.ClientF where

33

44import Servant.Client.Core.Internal.Request

5+import Servant.Client.Core.Internal.Response

6+import Servant.Client.Core.Internal.ClientError

57

68data ClientF a

79 = RunRequest Request (Response -> a)

servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs+6−30

@@ -16,10 +16,7 @@ module Servant.Client.Core.Internal.HasClient where

1616import Prelude ()

1717import Prelude.Compat

1818

19−import Control.Concurrent.MVar

20− (modifyMVar, newMVar)

21−import qualified Data.ByteString as BS

22−import qualified Data.ByteString.Lazy as BL

19+import qualified Data.ByteString.Lazy as BL

2320import Data.Foldable

2421 (toList)

2522import Data.List

@@ -34,7 +31,7 @@ import Data.Text

3431 (Text, pack)

3532import GHC.TypeLits

3633 (KnownSymbol, symbolVal)

37−import qualified Network.HTTP.Types as H

34+import qualified Network.HTTP.Types as H

3835import Servant.API

3936 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,

4037 BuildHeadersTo (..), Capture', CaptureAll, Description,

@@ -50,11 +47,12 @@ import Servant.API.ContentTypes

5047 (contentTypes)

5148import Servant.API.Modifiers

5249 (FoldRequired, RequiredArgument, foldRequiredArgument)

53−import qualified Servant.Types.SourceT as S

5450

5551import Servant.Client.Core.Internal.Auth

5652import Servant.Client.Core.Internal.BasicAuth

53+import Servant.Client.Core.Internal.ClientError

5754import Servant.Client.Core.Internal.Request

55+import Servant.Client.Core.Internal.Response

5856import Servant.Client.Core.Internal.RunClient

5957

6058-- * Accessing APIs as a Client

@@ -283,7 +281,7 @@ instance {-# OVERLAPPABLE #-}

283281 clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do

284282 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk

285283 framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'

286− return $ fromSourceIO $ framingUnrender' $ S.fromAction BS.null (responseBody gres)

284+ return $ fromSourceIO $ framingUnrender' $ responseBody gres

287285 where

288286 req' = req

289287 { requestAccept = fromList [contentType (Proxy :: Proxy ct)]

@@ -552,7 +550,7 @@ instance

552550

553551 clientWithRoute pm Proxy req body

554552 = clientWithRoute pm (Proxy :: Proxy api)

555− $ setRequestBody (RequestBodyStreamChunked givesPopper) (contentType ctypeP) req

553+ $ setRequestBody (RequestBodySource sourceIO) (contentType ctypeP) req

556554 where

557555 ctypeP = Proxy :: Proxy ctype

558556 framingP = Proxy :: Proxy framing

@@ -562,28 +560,6 @@ instance

562560 (mimeRender ctypeP :: chunk -> BL.ByteString)

563561 (toSourceIO body)

564562

565− -- not pretty.

566− givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()

567− givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do

568− ref <- newMVar step0

569−

570− -- Note sure we need locking, but it's feels safer.

571− let popper :: IO BS.ByteString

572− popper = modifyMVar ref nextBs

573−

574− needsPopper popper

575−

576− nextBs S.Stop = return (S.Stop, BS.empty)

577− nextBs (S.Error err) = fail err

578− nextBs (S.Skip s) = nextBs s

579− nextBs (S.Effect ms) = ms >>= nextBs

580− nextBs (S.Yield lbs s) = case BL.toChunks lbs of

581− [] -> nextBs s

582− (x:xs) | BS.null x -> nextBs step'

583− | otherwise -> return (step', x)

584− where

585− step' = S.Yield (BL.fromChunks xs) s

586−

587563-- | Make the querying function append @path@ to the request path.

588564instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where

589565 type Client m (path :> api) = Client m api

servant-client-core/src/Servant/Client/Core/Internal/Request.hs+8−81

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DeriveDataTypeable #-}

32{-# LANGUAGE DeriveFoldable #-}

43{-# LANGUAGE DeriveFunctor #-}

@@ -17,10 +16,6 @@ import Prelude.Compat

1716

1817import Control.DeepSeq

1918 (NFData (..))

20−import Control.Exception

21− (SomeException (..))

22−import Control.Monad.Catch

23− (Exception)

2419import Data.Bifoldable

2520 (Bifoldable (..))

2621import Data.Bifunctor

@@ -30,8 +25,6 @@ import Data.Bitraversable

3025import qualified Data.ByteString as BS

3126import qualified Data.ByteString.Builder as Builder

3227import qualified Data.ByteString.Lazy as LBS

33−import Data.Int

34− (Int64)

3528import Data.Semigroup

3629 ((<>))

3730import qualified Data.Sequence as Seq

@@ -40,64 +33,16 @@ import Data.Text

4033import Data.Text.Encoding

4134 (encodeUtf8)

4235import Data.Typeable

43− (Typeable, typeOf)

36+ (Typeable)

4437import GHC.Generics

4538 (Generic)

4639import Network.HTTP.Media

4740 (MediaType, mainType, parameters, subType)

4841import Network.HTTP.Types

4942 (Header, HeaderName, HttpVersion (..), Method, QueryItem,

50− Status (..), http11, methodGet)

43+ http11, methodGet)

5144import Servant.API

52− (ToHttpApiData, toEncodedUrlPiece, toHeader)

53−import Servant.Client.Core.Internal.BaseUrl

54− (BaseUrl)

55−

56−-- | A type representing possible errors in a request

57−--

58−-- Note that this type substantially changed in 0.12.

59−data ServantError =

60− -- | The server returned an error response including the

61− -- failing request. 'requestPath' includes the 'BaseUrl' and the

62− -- path of the request.

63− FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response

64− -- | The body could not be decoded at the expected type

65− | DecodeFailure Text Response

66− -- | The content-type of the response is not supported

67− | UnsupportedContentType MediaType Response

68− -- | The content-type header is invalid

69− | InvalidContentTypeHeader Response

70− -- | There was a connection error, and no response was received

71− | ConnectionError SomeException

72− deriving (Show, Generic, Typeable)

73−

74−instance Eq ServantError where

75− FailureResponse req res == FailureResponse req' res' = req == req' && res == res'

76− DecodeFailure t r == DecodeFailure t' r' = t == t' && r == r'

77− UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r'

78− InvalidContentTypeHeader r == InvalidContentTypeHeader r' = r == r'

79− ConnectionError exc == ConnectionError exc' = eqSomeException exc exc'

80− where

81− -- returns true, if type of exception is the same

82− eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b

83−

84− -- prevent wild card blindness

85− FailureResponse {} == _ = False

86− DecodeFailure {} == _ = False

87− UnsupportedContentType {} == _ = False

88− InvalidContentTypeHeader {} == _ = False

89− ConnectionError {} == _ = False

90−

91−instance Exception ServantError

92−

93−-- | Note: an exception in 'ConnectionError' might not be evaluated fully,

94−-- We only 'rnf' its 'show'ed value.

95−instance NFData ServantError where

96− rnf (FailureResponse req res) = rnf req `seq` rnf res

97− rnf (DecodeFailure err res) = rnf err `seq` rnf res

98− rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res

99− rnf (InvalidContentTypeHeader res) = rnf res

100− rnf (ConnectionError err) = err `seq` rnf (show err)

45+ (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)

10146

10247mediaTypeRnf :: MediaType -> ()

10348mediaTypeRnf mt =

@@ -143,31 +88,13 @@ type Request = RequestF RequestBody Builder.Builder

14388data RequestBody

14489 = RequestBodyLBS LBS.ByteString

14590 | RequestBodyBS BS.ByteString

146− | RequestBodyBuilder Int64 Builder.Builder

147− | RequestBodyStream Int64 ((IO BS.ByteString -> IO ()) -> IO ())

148− | RequestBodyStreamChunked ((IO BS.ByteString -> IO ()) -> IO ())

149− | RequestBodyIO (IO RequestBody)

91+ | RequestBodySource (SourceIO LBS.ByteString)

15092 deriving (Generic, Typeable)

15193

152−data GenResponse a = Response

153− { responseStatusCode :: Status

154− , responseHeaders :: Seq.Seq Header

155− , responseHttpVersion :: HttpVersion

156− , responseBody :: a

157− } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)

158−

159−instance NFData a => NFData (GenResponse a) where

160− rnf (Response sc hs hv body) =

161− rnfStatus sc `seq`

162− rnf hs `seq`

163− rnfHttpVersion hv `seq`

164− rnf body

165− where

166− rnfStatus (Status code msg) = rnf code `seq` rnf msg

167− rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict

168−

169−type Response = GenResponse LBS.ByteString

170−type StreamingResponse = GenResponse (IO BS.ByteString)

94+instance Show RequestBody where

95+ showsPrec d (RequestBodyLBS lbs) = showParen (d > 10)

96+ $ showString "RequestBodyLBS "

97+ . showsPrec 11 lbs

17198

17299-- A GET request to the top-level path

173100defaultRequest :: Request

servant-client-core/src/Servant/Client/Core/Internal/Response.hsnew file+49

@@ -0,0 +1,49 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE DeriveFoldable #-}

3+{-# LANGUAGE DeriveFunctor #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# LANGUAGE DeriveTraversable #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE RankNTypes #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TypeFamilies #-}

10+

11+module Servant.Client.Core.Internal.Response where

12+

13+import Prelude ()

14+import Prelude.Compat

15+

16+import Control.DeepSeq

17+ (NFData (..))

18+import qualified Data.ByteString as BS

19+import qualified Data.ByteString.Lazy as LBS

20+import qualified Data.Sequence as Seq

21+import Data.Typeable

22+ (Typeable)

23+import GHC.Generics

24+ (Generic)

25+import Network.HTTP.Types

26+ (Header, HttpVersion (..), Status (..))

27+

28+import Servant.API.Stream

29+ (SourceIO)

30+

31+data ResponseF a = Response

32+ { responseStatusCode :: Status

33+ , responseHeaders :: Seq.Seq Header

34+ , responseHttpVersion :: HttpVersion

35+ , responseBody :: a

36+ } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)

37+

38+instance NFData a => NFData (ResponseF a) where

39+ rnf (Response sc hs hv body) =

40+ rnfStatus sc `seq`

41+ rnf hs `seq`

42+ rnfHttpVersion hv `seq`

43+ rnf body

44+ where

45+ rnfStatus (Status code msg) = rnf code `seq` rnf msg

46+ rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict

47+

48+type Response = ResponseF LBS.ByteString

49+type StreamingResponse = ResponseF (SourceIO BS.ByteString)

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

@@ -25,8 +25,8 @@ import Servant.API

2525

2626import Servant.Client.Core.Internal.ClientF

2727import Servant.Client.Core.Internal.Request

28− (GenResponse (..), Request, Response, ServantError (..),

29− StreamingResponse)

28+import Servant.Client.Core.Internal.Response

29+import Servant.Client.Core.Internal.ClientError

3030

3131class Monad m => RunClient m where

3232 -- | How to make a request.

servant-client-core/src/Servant/Client/Core/Reexport.hs+3−2

@@ -9,7 +9,7 @@ module Servant.Client.Core.Reexport

99 -- * Response (for @Raw@)

1010 , Response

1111 , StreamingResponse

12− , GenResponse(..)

12+ , ResponseF(..)

1313

1414 -- * Generic Client

1515 , ClientLike(..)

@@ -30,4 +30,5 @@ module Servant.Client.Core.Reexport

3030import Servant.Client.Core.Internal.BaseUrl

3131import Servant.Client.Core.Internal.Generic

3232import Servant.Client.Core.Internal.HasClient

33−import Servant.Client.Core.Internal.Request

33+import Servant.Client.Core.Internal.Response

34+import Servant.Client.Core.Internal.ClientError

servant-client/src/Servant/Client/Internal/HttpClient.hs+53−33

@@ -14,6 +14,9 @@ module Servant.Client.Internal.HttpClient where

1414import Prelude ()

1515import Prelude.Compat

1616

17+import Control.Concurrent.MVar

18+ (modifyMVar, newMVar)

19+import qualified Data.ByteString as BS

1720import Control.Concurrent.STM.TVar

1821import Control.Exception

1922import Control.Monad

@@ -52,7 +55,6 @@ import Data.Sequence

5255 (fromList)

5356import Data.String

5457 (fromString)

55−import qualified Data.Text as T

5658import Data.Time.Clock

5759 (UTCTime, getCurrentTime)

5860import GHC.Generics

@@ -62,6 +64,7 @@ import Network.HTTP.Types

6264 (hContentType, renderQuery, statusCode)

6365import Servant.Client.Core

6466

67+import qualified Servant.Types.SourceT as S

6568import qualified Network.HTTP.Client as Client

6669

6770-- | The environment in which a request is run.

@@ -167,7 +170,7 @@ performRequest req = do

167170 response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'

168171 let status = Client.responseStatus response

169172 status_code = statusCode status

170− ourResponse = clientResponseToResponse response

173+ ourResponse = clientResponseToResponse id response

171174 unless (status_code >= 200 && status_code < 300) $

172175 throwError $ mkFailureResponse burl req ourResponse

173176 return ourResponse

@@ -197,34 +200,34 @@ performRequest req = do

197200 fReq = Client.hrFinalRequest responses

198201 fRes = Client.hrFinalResponse responses

199202

200−mkFailureResponse :: BaseUrl -> Request -> GenResponse BSL.ByteString -> ServantError

203+mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ServantError

201204mkFailureResponse burl request =

202205 FailureResponse (bimap (const ()) f request)

203206 where

204207 f b = (burl, BSL.toStrict $ toLazyByteString b)

205208

206−clientResponseToResponse :: Client.Response a -> GenResponse a

207−clientResponseToResponse r = Response

208− { responseStatusCode = Client.responseStatus r

209− , responseBody = Client.responseBody r

210− , responseHeaders = fromList $ Client.responseHeaders r

211− , responseHttpVersion = Client.responseVersion r

212− }

209+clientResponseToResponse :: (a -> b) -> Client.Response a -> ResponseF b

210+clientResponseToResponse f r = Response

211+ { responseStatusCode = Client.responseStatus r

212+ , responseBody = f (Client.responseBody r)

213+ , responseHeaders = fromList $ Client.responseHeaders r

214+ , responseHttpVersion = Client.responseVersion r

215+ }

213216

214217requestToClientRequest :: BaseUrl -> Request -> Client.Request

215218requestToClientRequest burl r = Client.defaultRequest

216− { Client.method = requestMethod r

217− , Client.host = fromString $ baseUrlHost burl

218− , Client.port = baseUrlPort burl

219− , Client.path = BSL.toStrict

220− $ fromString (baseUrlPath burl)

221− <> toLazyByteString (requestPath r)

222− , Client.queryString = renderQuery True . toList $ requestQueryString r

223− , Client.requestHeaders =

224− maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers

225− , Client.requestBody = body

226− , Client.secure = isSecure

227− }

219+ { Client.method = requestMethod r

220+ , Client.host = fromString $ baseUrlHost burl

221+ , Client.port = baseUrlPort burl

222+ , Client.path = BSL.toStrict

223+ $ fromString (baseUrlPath burl)

224+ <> toLazyByteString (requestPath r)

225+ , Client.queryString = renderQuery True . toList $ requestQueryString r

226+ , Client.requestHeaders =

227+ maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers

228+ , Client.requestBody = body

229+ , Client.secure = isSecure

230+ }

228231 where

229232 -- Content-Type and Accept are specified by requestBody and requestAccept

230233 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $

@@ -237,21 +240,38 @@ requestToClientRequest burl r = Client.defaultRequest

237240 hs = toList $ requestAccept r

238241

239242 convertBody bd = case bd of

240− RequestBodyLBS body' -> Client.RequestBodyLBS body'

241− RequestBodyBS body' -> Client.RequestBodyBS body'

242− RequestBodyBuilder size body' -> Client.RequestBodyBuilder size body'

243− RequestBodyStream size body' -> Client.RequestBodyStream size body'

244− RequestBodyStreamChunked body' -> Client.RequestBodyStreamChunked body'

245− RequestBodyIO body' -> Client.RequestBodyIO (convertBody <$> body')

243+ RequestBodyLBS body' -> Client.RequestBodyLBS body'

244+ RequestBodyBS body' -> Client.RequestBodyBS body'

245+ RequestBodySource sourceIO -> Client.RequestBodyStreamChunked givesPopper

246+ where

247+ givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()

248+ givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do

249+ ref <- newMVar step0

250+

251+ -- Note sure we need locking, but it's feels safer.

252+ let popper :: IO BS.ByteString

253+ popper = modifyMVar ref nextBs

254+

255+ needsPopper popper

256+

257+ nextBs S.Stop = return (S.Stop, BS.empty)

258+ nextBs (S.Error err) = fail err

259+ nextBs (S.Skip s) = nextBs s

260+ nextBs (S.Effect ms) = ms >>= nextBs

261+ nextBs (S.Yield lbs s) = case BSL.toChunks lbs of

262+ [] -> nextBs s

263+ (x:xs) | BS.null x -> nextBs step'

264+ | otherwise -> return (step', x)

265+ where

266+ step' = S.Yield (BSL.fromChunks xs) s

246267

247268 (body, contentTypeHdr) = case requestBody r of

248− Nothing -> (Client.RequestBodyLBS "", Nothing)

249− Just (body', typ)

250− -> (convertBody body', Just (hContentType, renderHeader typ))

269+ Nothing -> (Client.RequestBodyBS "", Nothing)

270+ Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ))

251271

252272 isSecure = case baseUrlScheme burl of

253− Http -> False

254− Https -> True

273+ Http -> False

274+ Https -> True

255275

256276catchConnectionError :: IO a -> IO (Either ServantError a)

257277catchConnectionError action =

servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+7−5

@@ -35,6 +35,7 @@ import Control.Monad.Reader

3535import Control.Monad.STM

3636 (atomically)

3737import Control.Monad.Trans.Except

38+import qualified Data.ByteString as BS

3839import qualified Data.ByteString.Lazy as BSL

3940import Data.Foldable

4041 (for_)

@@ -53,8 +54,9 @@ import qualified Network.HTTP.Client as Client

5354import Servant.Client.Core

5455import Servant.Client.Internal.HttpClient

5556 (ClientEnv (..), catchConnectionError,

56− clientResponseToResponse, mkClientEnv, requestToClientRequest,

57− mkFailureResponse)

57+ clientResponseToResponse, mkClientEnv, mkFailureResponse,

58+ requestToClientRequest)

59+import qualified Servant.Types.SourceT as S

5860

5961

6062-- | Generates a set of client functions for an API.

@@ -165,7 +167,7 @@ performRequest req = do

165167 atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')

166168 let status = Client.responseStatus response

167169 status_code = statusCode status

168− ourResponse = clientResponseToResponse response

170+ ourResponse = clientResponseToResponse id response

169171 unless (status_code >= 200 && status_code < 300) $

170172 throwError $ mkFailureResponse burl req ourResponse

171173 return ourResponse

@@ -183,7 +185,7 @@ performWithStreamingRequest req k = do

183185 -- we throw FailureResponse in IO :(

184186 unless (status_code >= 200 && status_code < 300) $ do

185187 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)

186− throwIO $ mkFailureResponse burl req (clientResponseToResponse res { Client.responseBody = b })

188+ throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)

187189

188− x <- k (clientResponseToResponse res)

190+ x <- k (clientResponseToResponse (S.fromAction BS.null) res)

189191 k1 x

servant/src/Servant/API/ResponseHeaders.hs+18

@@ -35,6 +35,8 @@ module Servant.API.ResponseHeaders

3535 , HList(..)

3636 ) where

3737

38+import Control.DeepSeq

39+ (NFData (..))

3840import Data.ByteString.Char8 as BS

3941 (ByteString, init, pack, unlines)

4042import qualified Data.CaseInsensitive as CI

@@ -60,16 +62,32 @@ data Headers ls a = Headers { getResponse :: a

6062 -- ^ HList of headers.

6163 } deriving (Functor)

6264

65+instance (NFDataHList ls, NFData a) => NFData (Headers ls a) where

66+ rnf (Headers x hdrs) = rnf x `seq` rnf hdrs

67+

6368data ResponseHeader (sym :: Symbol) a

6469 = Header a

6570 | MissingHeader

6671 | UndecodableHeader ByteString

6772 deriving (Typeable, Eq, Show, Functor)

6873

74+instance NFData a => NFData (ResponseHeader sym a) where

75+ rnf MissingHeader = ()

76+ rnf (UndecodableHeader bs) = rnf bs

77+ rnf (Header x) = rnf x

78+

6979data HList a where

7080 HNil :: HList '[]

7181 HCons :: ResponseHeader h x -> HList xs -> HList (Header h x ': xs)

7282

83+class NFDataHList xs where rnfHList :: HList xs -> ()

84+instance NFDataHList '[] where rnfHList HNil = ()

85+instance (y ~ Header h x, NFData x, NFDataHList xs) => NFDataHList (y ': xs) where

86+ rnfHList (HCons h xs) = rnf h `seq` rnfHList xs

87+

88+instance NFDataHList xs => NFData (HList xs) where

89+ rnf = rnfHList

90+

7391type family HeaderValMap (f :: * -> *) (xs :: [*]) where

7492 HeaderValMap f '[] = '[]

7593 HeaderValMap f (Header h x ': xs) = Header h (f x) ': HeaderValMap f xs