4fab471 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Refactor servant-client(-core)

4fab471Oleg Grenrus8 years ago

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

compare with master

unifiedsplit

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

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

138

139```haskell

140− let res = I.clientResponseToResponse res'

140+ let res = I.clientResponseToResponse id res'

141

142 case k res of

143 Pure n ->

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

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

39 Servant.Client.Core.Internal.Auth

40 Servant.Client.Core.Internal.BaseUrl

41 Servant.Client.Core.Internal.BasicAuth

42+ Servant.Client.Core.Internal.ClientError

42 Servant.Client.Core.Internal.ClientF

43 Servant.Client.Core.Internal.ClientF

43 Servant.Client.Core.Internal.Generic

44 Servant.Client.Core.Internal.Generic

44 Servant.Client.Core.Internal.HasClient

45 Servant.Client.Core.Internal.HasClient

45 Servant.Client.Core.Internal.Request

46 Servant.Client.Core.Internal.Request

47+ Servant.Client.Core.Internal.Response

46 Servant.Client.Core.Internal.RunClient

48 Servant.Client.Core.Internal.RunClient

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

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

42 -- * Response

43 , Response

44− , GenResponse (..)

44+ , ResponseF (..)

45 , RunClient(..)

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

47 -- ** Streaming

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

64import Servant.Client.Core.Internal.Generic

65import Servant.Client.Core.Internal.HasClient

66import Servant.Client.Core.Internal.Request

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

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

67import Servant.Client.Core.Internal.RunClient

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

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

4import Servant.Client.Core.Internal.Request

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

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

6data ClientF a

8data ClientF a

7 = RunRequest Request (Response -> a)

9 = 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

16import Prelude ()

17import Prelude.Compat

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

23import Data.Foldable

20import Data.Foldable

24 (toList)

21 (toList)

25import Data.List

22import Data.List

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

34 (Text, pack)

31 (Text, pack)

35import GHC.TypeLits

32import GHC.TypeLits

36 (KnownSymbol, symbolVal)

33 (KnownSymbol, symbolVal)

37−import qualified Network.HTTP.Types as H

34+import qualified Network.HTTP.Types as H

38import Servant.API

35import Servant.API

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

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

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

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

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

50 (contentTypes)

47 (contentTypes)

51import Servant.API.Modifiers

48import Servant.API.Modifiers

52 (FoldRequired, RequiredArgument, foldRequiredArgument)

49 (FoldRequired, RequiredArgument, foldRequiredArgument)

53−import qualified Servant.Types.SourceT as S

55import Servant.Client.Core.Internal.Auth

51import Servant.Client.Core.Internal.Auth

56import Servant.Client.Core.Internal.BasicAuth

52import Servant.Client.Core.Internal.BasicAuth

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

57import Servant.Client.Core.Internal.Request

54import Servant.Client.Core.Internal.Request

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

58import Servant.Client.Core.Internal.RunClient

56import Servant.Client.Core.Internal.RunClient

60-- * Accessing APIs as a Client

58-- * Accessing APIs as a Client

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

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

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

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

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

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

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

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

284+ return $ fromSourceIO $ framingUnrender' $ responseBody gres

287 where

285 where

288 req' = req

286 req' = req

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

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

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

552

550

553 clientWithRoute pm Proxy req body

551 clientWithRoute pm Proxy req body

554 = clientWithRoute pm (Proxy :: Proxy api)

552 = clientWithRoute pm (Proxy :: Proxy api)

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

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

556 where

554 where

557 ctypeP = Proxy :: Proxy ctype

555 ctypeP = Proxy :: Proxy ctype

558 framingP = Proxy :: Proxy framing

556 framingP = Proxy :: Proxy framing

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

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

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

563 (toSourceIO body)

561 (toSourceIO body)

564

562

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−

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

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

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

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

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

565 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 #-}

2{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE DeriveFoldable #-}

2{-# LANGUAGE DeriveFoldable #-}

4{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE DeriveFunctor #-}

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

18import Control.DeepSeq

17import Control.DeepSeq

19 (NFData (..))

18 (NFData (..))

20−import Control.Exception

21− (SomeException (..))

22−import Control.Monad.Catch

23− (Exception)

24import Data.Bifoldable

19import Data.Bifoldable

25 (Bifoldable (..))

20 (Bifoldable (..))

26import Data.Bifunctor

21import Data.Bifunctor

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

30import qualified Data.ByteString as BS

25import qualified Data.ByteString as BS

31import qualified Data.ByteString.Builder as Builder

26import qualified Data.ByteString.Builder as Builder

32import qualified Data.ByteString.Lazy as LBS

27import qualified Data.ByteString.Lazy as LBS

33−import Data.Int

34− (Int64)

35import Data.Semigroup

28import Data.Semigroup

36 ((<>))

29 ((<>))

37import qualified Data.Sequence as Seq

30import qualified Data.Sequence as Seq

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

40import Data.Text.Encoding

33import Data.Text.Encoding

41 (encodeUtf8)

34 (encodeUtf8)

42import Data.Typeable

35import Data.Typeable

43− (Typeable, typeOf)

36+ (Typeable)

44import GHC.Generics

37import GHC.Generics

45 (Generic)

38 (Generic)

46import Network.HTTP.Media

39import Network.HTTP.Media

47 (MediaType, mainType, parameters, subType)

40 (MediaType, mainType, parameters, subType)

48import Network.HTTP.Types

41import Network.HTTP.Types

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

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

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

43+ http11, methodGet)

51import Servant.API

44import Servant.API

52− (ToHttpApiData, toEncodedUrlPiece, toHeader)

45+ (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)

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)

101

102mediaTypeRnf :: MediaType -> ()

47mediaTypeRnf :: MediaType -> ()

103mediaTypeRnf mt =

48mediaTypeRnf mt =

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

143data RequestBody

88data RequestBody

144 = RequestBodyLBS LBS.ByteString

89 = RequestBodyLBS LBS.ByteString

145 | RequestBodyBS BS.ByteString

90 | RequestBodyBS BS.ByteString

146− | RequestBodyBuilder Int64 Builder.Builder

91+ | RequestBodySource (SourceIO LBS.ByteString)

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

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

149− | RequestBodyIO (IO RequestBody)

150 deriving (Generic, Typeable)

92 deriving (Generic, Typeable)

151

152−data GenResponse a = Response

94+instance Show RequestBody where

153− { responseStatusCode :: Status

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

154− , responseHeaders :: Seq.Seq Header

96+ $ showString "RequestBodyLBS "

155− , responseHttpVersion :: HttpVersion

97+ . showsPrec 11 lbs

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)

171

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

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

173defaultRequest :: Request

100defaultRequest :: 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

26import Servant.Client.Core.Internal.ClientF

27import Servant.Client.Core.Internal.Request

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

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

29− StreamingResponse)

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

31class Monad m => RunClient m where

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

9 -- * Response (for @Raw@)

10 , Response

11 , StreamingResponse

12− , GenResponse(..)

12+ , ResponseF(..)

14 -- * Generic Client

15 , ClientLike(..)

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

30import Servant.Client.Core.Internal.BaseUrl

31import Servant.Client.Core.Internal.Generic

32import 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

14import Prelude ()

15import Prelude.Compat

17+import Control.Concurrent.MVar

18+ (modifyMVar, newMVar)

19+import qualified Data.ByteString as BS

17import Control.Concurrent.STM.TVar

20import Control.Concurrent.STM.TVar

18import Control.Exception

21import Control.Exception

19import Control.Monad

22import Control.Monad

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

52 (fromList)

55 (fromList)

53import Data.String

56import Data.String

54 (fromString)

57 (fromString)

55−import qualified Data.Text as T

56import Data.Time.Clock

58import Data.Time.Clock

57 (UTCTime, getCurrentTime)

59 (UTCTime, getCurrentTime)

58import GHC.Generics

60import GHC.Generics

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

62 (hContentType, renderQuery, statusCode)

64 (hContentType, renderQuery, statusCode)

63import Servant.Client.Core

65import Servant.Client.Core

67+import qualified Servant.Types.SourceT as S

65import qualified Network.HTTP.Client as Client

68import qualified Network.HTTP.Client as Client

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

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

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

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

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

168 let status = Client.responseStatus response

171 let status = Client.responseStatus response

169 status_code = statusCode status

172 status_code = statusCode status

170− ourResponse = clientResponseToResponse response

173+ ourResponse = clientResponseToResponse id response

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

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

172 throwError $ mkFailureResponse burl req ourResponse

175 throwError $ mkFailureResponse burl req ourResponse

173 return ourResponse

176 return ourResponse

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

197 fReq = Client.hrFinalRequest responses

200 fReq = Client.hrFinalRequest responses

198 fRes = Client.hrFinalResponse responses

201 fRes = Client.hrFinalResponse responses

199

202

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

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

201mkFailureResponse burl request =

204mkFailureResponse burl request =

202 FailureResponse (bimap (const ()) f request)

205 FailureResponse (bimap (const ()) f request)

203 where

206 where

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

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

205

208

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

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

207−clientResponseToResponse r = Response

210+clientResponseToResponse f r = Response

208− { responseStatusCode = Client.responseStatus r

211+ { responseStatusCode = Client.responseStatus r

209− , responseBody = Client.responseBody r

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

210− , responseHeaders = fromList $ Client.responseHeaders r

213+ , responseHeaders = fromList $ Client.responseHeaders r

211− , responseHttpVersion = Client.responseVersion r

214+ , responseHttpVersion = Client.responseVersion r

212− }

215+ }

213

216

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

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

215requestToClientRequest burl r = Client.defaultRequest

218requestToClientRequest burl r = Client.defaultRequest

216− { Client.method = requestMethod r

219+ { Client.method = requestMethod r

217− , Client.host = fromString $ baseUrlHost burl

220+ , Client.host = fromString $ baseUrlHost burl

218− , Client.port = baseUrlPort burl

221+ , Client.port = baseUrlPort burl

219− , Client.path = BSL.toStrict

222+ , Client.path = BSL.toStrict

220− $ fromString (baseUrlPath burl)

223+ $ fromString (baseUrlPath burl)

221− <> toLazyByteString (requestPath r)

224+ <> toLazyByteString (requestPath r)

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

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

223− , Client.requestHeaders =

226+ , Client.requestHeaders =

224− maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers

227+ maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers

225− , Client.requestBody = body

228+ , Client.requestBody = body

226− , Client.secure = isSecure

229+ , Client.secure = isSecure

227− }

230+ }

228 where

231 where

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

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

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

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

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

237 hs = toList $ requestAccept r

240 hs = toList $ requestAccept r

238

241

239 convertBody bd = case bd of

242 convertBody bd = case bd of

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

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

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

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

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

245+ RequestBodySource sourceIO -> Client.RequestBodyStreamChunked givesPopper

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

246+ where

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

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

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

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

246

267

247 (body, contentTypeHdr) = case requestBody r of

268 (body, contentTypeHdr) = case requestBody r of

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

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

249− Just (body', typ)

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

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

251

271

252 isSecure = case baseUrlScheme burl of

272 isSecure = case baseUrlScheme burl of

253− Http -> False

273+ Http -> False

254− Https -> True

274+ Https -> True

255

275

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

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

257catchConnectionError action =

277catchConnectionError action =

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

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

35import Control.Monad.STM

36 (atomically)

37import Control.Monad.Trans.Except

38+import qualified Data.ByteString as BS

38import qualified Data.ByteString.Lazy as BSL

39import qualified Data.ByteString.Lazy as BSL

39import Data.Foldable

40import Data.Foldable

40 (for_)

41 (for_)

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

53import Servant.Client.Core

54import Servant.Client.Core

54import Servant.Client.Internal.HttpClient

55import Servant.Client.Internal.HttpClient

55 (ClientEnv (..), catchConnectionError,

56 (ClientEnv (..), catchConnectionError,

56− clientResponseToResponse, mkClientEnv, requestToClientRequest,

57+ clientResponseToResponse, mkClientEnv, mkFailureResponse,

57− mkFailureResponse)

58+ requestToClientRequest)

59+import qualified Servant.Types.SourceT as S

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

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

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

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

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

166 let status = Client.responseStatus response

168 let status = Client.responseStatus response

167 status_code = statusCode status

169 status_code = statusCode status

168− ourResponse = clientResponseToResponse response

170+ ourResponse = clientResponseToResponse id response

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

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

170 throwError $ mkFailureResponse burl req ourResponse

172 throwError $ mkFailureResponse burl req ourResponse

171 return ourResponse

173 return ourResponse

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

183 -- we throw FailureResponse in IO :(

185 -- we throw FailureResponse in IO :(

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

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

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

187 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)

187

189

188− x <- k (clientResponseToResponse res)

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

189 k1 x

191 k1 x

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

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

35 , HList(..)

36 ) where

38+import Control.DeepSeq

39+ (NFData (..))

38import Data.ByteString.Char8 as BS

40import Data.ByteString.Char8 as BS

39 (ByteString, init, pack, unlines)

41 (ByteString, init, pack, unlines)

40import qualified Data.CaseInsensitive as CI

42import qualified Data.CaseInsensitive as CI

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

60 -- ^ HList of headers.

62 -- ^ HList of headers.

61 } deriving (Functor)

63 } deriving (Functor)

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

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

67+

63data ResponseHeader (sym :: Symbol) a

68data ResponseHeader (sym :: Symbol) a

64 = Header a

69 = Header a

65 | MissingHeader

70 | MissingHeader

66 | UndecodableHeader ByteString

71 | UndecodableHeader ByteString

67 deriving (Typeable, Eq, Show, Functor)

72 deriving (Typeable, Eq, Show, Functor)

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+

69data HList a where

79data HList a where

70 HNil :: HList '[]

80 HNil :: HList '[]

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

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

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+

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

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

74 HeaderValMap f '[] = '[]

92 HeaderValMap f '[] = '[]

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

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