3750f22 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Merge pull request #913 from haskell-servant/jkarni/expose-more-request-constructors

3750f22Julian Arni9 years ago

servant-client-core/src/Servant/Client/Core/Internal/Request.hs+23−16

compare with master

unifiedsplit

@@ -1,14 +1,14 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveFoldable #-}

3−{-# LANGUAGE DeriveFunctor #-}

4+{-# LANGUAGE DeriveFunctor #-}

4−{-# LANGUAGE DeriveFoldable #-}

5+{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE DeriveTraversable #-}

6+{-# LANGUAGE DeriveTraversable #-}

6−{-# LANGUAGE DeriveGeneric #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE RankNTypes #-}

9−{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE RankNTypes #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeFamilies #-}

13module Servant.Client.Core.Internal.Request where

@@ -16,9 +16,10 @@ import Prelude ()

16import Prelude.Compat

18import Control.Monad.Catch (Exception)

19−import qualified Data.ByteString.Builder as Builder

20import qualified Data.ByteString as BS

19import qualified Data.ByteString as BS

20+import qualified Data.ByteString.Builder as Builder

21import qualified Data.ByteString.Lazy as LBS

22+import Data.Int (Int64)

22import Data.Semigroup ((<>))

23import Data.Semigroup ((<>))

23import qualified Data.Sequence as Seq

24import qualified Data.Sequence as Seq

24import Data.Text (Text)

25import Data.Text (Text)

@@ -58,13 +59,19 @@ data RequestF a = Request

58 , requestHeaders :: Seq.Seq Header

59 , requestHeaders :: Seq.Seq Header

59 , requestHttpVersion :: HttpVersion

60 , requestHttpVersion :: HttpVersion

60 , requestMethod :: Method

61 , requestMethod :: Method

61− } deriving (Eq, Show, Functor, Generic, Typeable)

62+ } deriving (Generic, Typeable)

63type Request = RequestF Builder.Builder

64type Request = RequestF Builder.Builder

65−-- | The request body. Currently only lazy ByteStrings are supported.

66+-- | The request body. A replica of the @http-client@ @RequestBody@.

67+data RequestBody

66−newtype RequestBody = RequestBodyLBS LBS.ByteString

68+ = RequestBodyLBS LBS.ByteString

69+ | RequestBodyBS BS.ByteString

70+ | RequestBodyBuilder Int64 Builder.Builder

71+ | RequestBodyStream Int64 ((IO BS.ByteString -> IO ()) -> IO ())

72+ | RequestBodyStreamChunked ((IO BS.ByteString -> IO ()) -> IO ())

73+ | RequestBodyIO (IO RequestBody)

67− deriving (Eq, Ord, Read, Show, Typeable)

74+ deriving (Generic, Typeable)

69data GenResponse a = Response

76data GenResponse a = Response

70 { responseStatusCode :: Status

77 { responseStatusCode :: Status

servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+31−9

@@ -15,7 +15,6 @@

15module Servant.Client.Internal.XhrClient where

17import Control.Arrow

18−import Data.ByteString.Builder (toLazyByteString)

19import Control.Concurrent

18import Control.Concurrent

20import Control.Exception

19import Control.Exception

21import Control.Monad

20import Control.Monad

@@ -25,13 +24,15 @@ import Control.Monad.Error.Class (MonadError (..))

25import Control.Monad.Reader

24import Control.Monad.Reader

26import Control.Monad.Trans.Control (MonadBaseControl (..))

25import Control.Monad.Trans.Control (MonadBaseControl (..))

27import Control.Monad.Trans.Except

26import Control.Monad.Trans.Except

27+import Data.ByteString.Builder (toLazyByteString)

28−import qualified Data.ByteString.Char8 as BS

28+import qualified Data.ByteString.Char8 as BS

29import Data.CaseInsensitive

30import Data.Char

31import Data.Foldable (toList)

32import Data.Functor.Alt (Alt (..))

33+import Data.IORef (modifyIORef, newIORef, readIORef)

33import Data.Proxy (Proxy (..))

34import Data.Proxy (Proxy (..))

34−import qualified Data.Sequence as Seq

35+import qualified Data.Sequence as Seq

35import Data.String.Conversions

36import Data.String.Conversions

36import Foreign.StablePtr

37import Foreign.StablePtr

37import GHC.Generics

38import GHC.Generics

@@ -39,8 +40,8 @@ import GHCJS.Foreign.Callback

39import GHCJS.Prim

40import GHCJS.Prim

40import GHCJS.Types

41import GHCJS.Types

41import JavaScript.Web.Location

42import JavaScript.Web.Location

43+import Network.HTTP.Media (renderHeader)

42import Network.HTTP.Types

44import Network.HTTP.Types

43−import Network.HTTP.Media (renderHeader)

44import Servant.Client.Core

45import Servant.Client.Core

46newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal

47newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal

@@ -152,7 +153,8 @@ performXhr xhr burl request = do

152

153

153 openXhr xhr (cs $ requestMethod request) (toUrl burl request) True

154 openXhr xhr (cs $ requestMethod request) (toUrl burl request) True

154 setHeaders xhr request

155 setHeaders xhr request

155− sendXhr xhr (toBody request)

156+ body <- toBody request

157+ sendXhr xhr body

156 takeMVar waiter

158 takeMVar waiter

157

159

158 freeStablePtr s

160 freeStablePtr s

@@ -226,11 +228,31 @@ foreign import javascript unsafe "$1.send()"

226foreign import javascript unsafe "$1.send($2)"

228foreign import javascript unsafe "$1.send($2)"

227 js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()

229 js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()

228

230

229−toBody :: Request -> Maybe String

231+toBody :: Request -> IO (Maybe String)

230toBody request = case requestBody request of

232toBody request = case requestBody request of

231− Nothing -> Nothing

233+ Nothing -> return Nothing

232− Just (RequestBodyLBS "", _) -> Nothing

234+ Just (a, _) -> go a

235+

236+ where

237+ go :: RequestBody -> IO (Maybe String)

238+ go x = case x of

233− Just (RequestBodyLBS x, _) -> Just $ cs x

239+ RequestBodyLBS x -> return $ mBody x

240+ RequestBodyBS x -> return $ mBody x

241+ RequestBodyBuilder _ x -> return $ mBody $ toLazyByteString x

242+ RequestBodyStream _ x -> mBody <$> readBody x

243+ RequestBodyStreamChunked x -> mBody <$> readBody x

244+ RequestBodyIO x -> x >>= go

245+

246+ mBody :: ConvertibleStrings a String => a -> Maybe String

247+ mBody x = let y = cs x in if y == "" then Nothing else Just y

248+

249+ readBody writer = do

250+ m <- newIORef mempty

251+ _ <- writer (\bsAct -> do

252+ bs <- bsAct

253+ modifyIORef m (<> bs))

254+ readIORef m

255+

234

256

235-- * inspecting the xhr response

257-- * inspecting the xhr response

236

258

servant-client/servant-client.cabal+10−9

@@ -82,7 +82,7 @@ library

83test-suite spec

84 type: exitcode-stdio-1.0

85− ghc-options: -Wall

85+ ghc-options: -Wall -rtsopts -with-rtsopts=-T

86 default-language: Haskell2010

87 hs-source-dirs: test

88 main-is: Spec.hs

@@ -112,14 +112,15 @@ test-suite spec

112

113 -- Additonal dependencies

114 build-depends:

115− deepseq >= 1.3.0.2 && < 1.5

115+ deepseq >= 1.3.0.2 && < 1.5

116− , generics-sop >= 0.3.1.0 && < 0.4

116+ , generics-sop >= 0.3.1.0 && < 0.4

117− , hspec >= 2.4.4 && < 2.5

117+ , hspec >= 2.4.4 && < 2.5

118− , HUnit >= 1.6 && < 1.7

118+ , HUnit >= 1.6 && < 1.7

119+ , random-bytestring >= 0.1 && < 0.2

119− , network >= 2.6.3.2 && < 2.7

120+ , network >= 2.6.3.2 && < 2.7

120− , QuickCheck >= 2.10.1 && < 2.12

121+ , QuickCheck >= 2.10.1 && < 2.12

121− , servant == 0.13.*

122+ , servant == 0.13.*

122− , servant-server == 0.13.*

123+ , servant-server == 0.13.*

123

124

124 build-tool-depends:

125 build-tool-depends:

125 hspec-discover:hspec-discover >= 2.4.4 && < 2.5

126 hspec-discover:hspec-discover >= 2.4.4 && < 2.5

servant-client/src/Servant/Client/Internal/HttpClient.hs+10−2

@@ -183,10 +183,18 @@ requestToClientRequest burl r = Client.defaultRequest

183 where

184 hs = toList $ requestAccept r

185

186+ convertBody bd = case bd of

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

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

189+ RequestBodyBuilder size body' -> Client.RequestBodyBuilder size body'

190+ RequestBodyStream size body' -> Client.RequestBodyStream size body'

191+ RequestBodyStreamChunked body' -> Client.RequestBodyStreamChunked body'

192+ RequestBodyIO body' -> Client.RequestBodyIO (convertBody <$> body')

193+

186 (body, contentTypeHdr) = case requestBody r of

194 (body, contentTypeHdr) = case requestBody r of

187 Nothing -> (Client.RequestBodyLBS "", Nothing)

195 Nothing -> (Client.RequestBodyLBS "", Nothing)

188− Just (RequestBodyLBS body', typ)

196+ Just (body', typ)

189− -> (Client.RequestBodyLBS body', Just (hContentType, renderHeader typ))

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

190

198

191 isSecure = case baseUrlScheme burl of

199 isSecure = case baseUrlScheme burl of

192 Http -> False

200 Http -> False

servant-client/test/Servant/ClientSpec.hs+3

@@ -103,6 +103,9 @@ instance FromJSON Person

103instance ToForm Person

104instance FromForm Person

105

106+instance Arbitrary Person where

107+ arbitrary = Person <$> arbitrary <*> arbitrary

108+

106alice :: Person

109alice :: Person

107alice = Person "Alice" 42

110alice = Person "Alice" 42

108

111

servant-client/test/Servant/StreamSpec.hs+56−33

@@ -26,25 +26,26 @@

26#include "overlapping-compat.h"

27module Servant.StreamSpec (spec) where

29−import Prelude ()

29+import Control.Monad (replicateM_, void)

30−import Prelude.Compat

30+import qualified Data.ByteString as BS

31import Data.Proxy

32+import GHC.Stats (currentBytesUsed, getGCStats)

32−import qualified Network.HTTP.Client as C

33+import qualified Network.HTTP.Client as C

34+import Prelude ()

35+import Prelude.Compat

36+import System.IO (IOMode (ReadMode), withFile)

33−import System.IO.Unsafe (unsafePerformIO)

37+import System.IO.Unsafe (unsafePerformIO)

34import Test.Hspec

38import Test.Hspec

39+import Test.QuickCheck

36−import Servant.API ((:<|>) ((:<|>)),

41+import Servant.API ((:<|>) ((:<|>)), (:>), JSON,

37− (:>),

38− EmptyAPI, JSON,

39− StreamGet,

40− NewlineFraming,

42+ NetstringFraming, NewlineFraming,

41− NetstringFraming,

42− ResultStream(..),

43+ OctetStream, ResultStream (..),

43− StreamGenerator(..))

44+ StreamGenerator (..), StreamGet)

44import Servant.Client

45import Servant.Client

46+import Servant.ClientSpec (Person (..))

47+import qualified Servant.ClientSpec as CS

45import Servant.Server

48import Servant.Server

46−import qualified Servant.ClientSpec as CS

47−import Servant.ClientSpec (Person(..))

50spec :: Spec

51spec :: Spec

@@ -54,7 +55,7 @@ spec = describe "Servant.Stream" $ do

54type StreamApi f =

55type StreamApi f =

55 "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person)

56 "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person)

56 :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person)

57 :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person)

57− :<|> EmptyAPI

58+ :<|> "streamALot" :> StreamGet NewlineFraming OctetStream (f BS.ByteString)

60capi :: Proxy (StreamApi ResultStream)

61capi :: Proxy (StreamApi ResultStream)

@@ -63,12 +64,9 @@ capi = Proxy

63sapi :: Proxy (StreamApi StreamGenerator)

64sapi :: Proxy (StreamApi StreamGenerator)

64sapi = Proxy

65sapi = Proxy

66−

67+getGetNL, getGetNS :: ClientM (ResultStream Person)

68+getGetALot :: ClientM (ResultStream BS.ByteString)

67−getGetNL :<|> getGetNS :<|> EmptyClient = client capi

69+getGetNL :<|> getGetNS :<|> getGetALot = client capi

68−

69−

70−getGetNL :: ClientM (ResultStream Person)

71−getGetNS :: ClientM (ResultStream Person)

73alice :: Person

71alice :: Person

74alice = Person "Alice" 42

72alice = Person "Alice" 42

@@ -77,14 +75,24 @@ bob :: Person

77bob = Person "Bob" 25

75bob = Person "Bob" 25

79server :: Application

77server :: Application

80−server = serve sapi (

78+server = serve sapi

81− (return (StreamGenerator (\f r -> f alice >> r bob >> r alice))

79+ $ return (StreamGenerator (\f r -> f alice >> r bob >> r alice))

82− :: Handler (StreamGenerator Person))

83− :<|>

84− (return (StreamGenerator (\f r -> f alice >> r bob >> r alice))

80+ :<|> return (StreamGenerator (\f r -> f alice >> r bob >> r alice))

85− :: Handler (StreamGenerator Person))

81+ :<|> return (StreamGenerator lotsGenerator)

86− :<|>

82+ where

87− emptyServer)

83+ lotsGenerator f r = do

84+ f ""

85+ withFile "/dev/urandom" ReadMode $

86+ \handle -> streamFiveMBNTimes handle 1000 r

87+ return ()

88+

89+ streamFiveMBNTimes handle left sink

90+ | left <= 0 = return ""

91+ | otherwise = do

92+ msg <- BS.hGet handle (megabytes 5)

93+ sink msg

94+ streamFiveMBNTimes handle (left - 1) sink

95+

90{-# NOINLINE manager' #-}

98{-# NOINLINE manager' #-}

@@ -94,20 +102,35 @@ manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings

94runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)

102runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)

95runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')

103runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')

104

97−runResultStream :: ResultStream a -> IO (Maybe (Either String a), Maybe (Either String a), Maybe (Either String a), Maybe (Either String a))

105+runResultStream :: ResultStream a

106+ -> IO ( Maybe (Either String a)

107+ , Maybe (Either String a)

108+ , Maybe (Either String a)

109+ , Maybe (Either String a))

98−runResultStream (ResultStream k) = k $ \act -> (,,,) <$> act <*> act <*> act <*> act

110+runResultStream (ResultStream k)

111+ = k $ \act -> (,,,) <$> act <*> act <*> act <*> act

112

100streamSpec :: Spec

113streamSpec :: Spec

101streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do

114streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do

102

115

103− it "Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do

116+ it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do

104 Right res <- runClient getGetNL baseUrl

117 Right res <- runClient getGetNL baseUrl

105 let jra = Just (Right alice)

118 let jra = Just (Right alice)

106 jrb = Just (Right bob)

119 jrb = Just (Right bob)

107 runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)

120 runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)

108

121

109− it "Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do

122+ it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do

110 Right res <- runClient getGetNS baseUrl

123 Right res <- runClient getGetNS baseUrl

111 let jra = Just (Right alice)

124 let jra = Just (Right alice)

112 jrb = Just (Right bob)

125 jrb = Just (Right bob)

113 runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)

126 runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)

127+

128+ it "streams in constant memory" $ \(_, baseUrl) -> do

129+ Right (ResultStream res) <- runClient getGetALot baseUrl

130+ let consumeNChunks n = replicateM_ n (res void)

131+ consumeNChunks 900

132+ memUsed <- currentBytesUsed <$> getGCStats

133+ memUsed `shouldSatisfy` (< (megabytes 20))

134+

135+megabytes :: Num a => a -> a

136+megabytes n = n * (1000 ^ 2)

stack-ghcjs.yamlnew file+34

@@ -0,0 +1,34 @@

1+resolver: lts-7.19

2+compiler: ghcjs-0.2.1.9007019_ghc-8.0.1

3+compiler-check: match-exact

5+setup-info:

6+ ghcjs:

7+ source:

8+ ghcjs-0.2.1.9007019_ghc-8.0.1:

9+ url: http://ghcjs.tolysz.org/ghc-8.0-2017-02-05-lts-7.19-9007019.tar.gz

10+ sha1: d2cfc25f9cda32a25a87d9af68891b2186ee52f9

11+packages:

12+- servant-client-core/

13+- servant-client-ghcjs/

14+- servant/

15+

16+extra-deps:

17+- cabal-doctest-1.0.6

18+- http-api-data-0.3.7.2

19+- http-types-0.12

20+- text-1.2.3.0

21+- aeson-1.2.4.0

22+- attoparsec-0.13.2.2

23+- attoparsec-iso8601-1.0.0.0

24+- base-compat-0.9.3

25+- case-insensitive-1.2.0.11

26+- generics-sop-0.3.2.0

27+- http-media-0.7.1.2

28+- mmorph-1.1.1

29+- natural-transformation-0.4

30+- safe-0.3.17

31+- vault-0.3.1.0

32+- th-abstraction-0.2.6.0

33+- git: https://github.com/ghcjs/ghcjs-base.git

34+ commit: 3bb9ed0ffd3f384ed37456b4d6247be732c79c8e

stack.yaml+2

@@ -18,6 +18,8 @@ extra-deps:

18- aeson-compat-0.3.7.1

19- free-5.0.1

20- lens-4.16

21+- random-bytestring-0.1.3

22+- pcg-random-0.1.3.5

22# allow-newer: true # ignores all bounds, that's a sledgehammer

24# allow-newer: true # ignores all bounds, that's a sledgehammer

23# - doc/tutorial/

25# - doc/tutorial/