Skip to content

Commit 3750f22

Browse files
jkarnijkarni
authored
Merge pull request #913 from haskell-servant/jkarni/expose-more-request-constructors
Streaming request body for servant-client-core
2 parents 6f4701c + 7c901dc commit 3750f22

File tree

8 files changed

+169
-69
lines changed

8 files changed

+169
-69
lines changed

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

Lines changed: 23 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -1,24 +1,25 @@
1-
{-# LANGUAGE CPP #-}
2-
{-# LANGUAGE DeriveDataTypeable #-}
3-
{-# LANGUAGE DeriveFunctor #-}
4-
{-# LANGUAGE DeriveFoldable #-}
5-
{-# LANGUAGE DeriveTraversable #-}
6-
{-# LANGUAGE DeriveGeneric #-}
7-
{-# LANGUAGE MultiParamTypeClasses #-}
8-
{-# LANGUAGE RankNTypes #-}
9-
{-# LANGUAGE OverloadedStrings #-}
10-
{-# LANGUAGE ScopedTypeVariables #-}
11-
{-# LANGUAGE TypeFamilies #-}
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE DeriveDataTypeable #-}
3+
{-# LANGUAGE DeriveFoldable #-}
4+
{-# LANGUAGE DeriveFunctor #-}
5+
{-# LANGUAGE DeriveGeneric #-}
6+
{-# LANGUAGE DeriveTraversable #-}
7+
{-# LANGUAGE MultiParamTypeClasses #-}
8+
{-# LANGUAGE OverloadedStrings #-}
9+
{-# LANGUAGE RankNTypes #-}
10+
{-# LANGUAGE ScopedTypeVariables #-}
11+
{-# LANGUAGE TypeFamilies #-}
1212

1313
module Servant.Client.Core.Internal.Request where
1414

1515
import Prelude ()
1616
import Prelude.Compat
1717

1818
import Control.Monad.Catch (Exception)
19-
import qualified Data.ByteString.Builder as Builder
2019
import qualified Data.ByteString as BS
20+
import qualified Data.ByteString.Builder as Builder
2121
import qualified Data.ByteString.Lazy as LBS
22+
import Data.Int (Int64)
2223
import Data.Semigroup ((<>))
2324
import qualified Data.Sequence as Seq
2425
import Data.Text (Text)
@@ -58,13 +59,19 @@ data RequestF a = Request
5859
, requestHeaders :: Seq.Seq Header
5960
, requestHttpVersion :: HttpVersion
6061
, requestMethod :: Method
61-
} deriving (Eq, Show, Functor, Generic, Typeable)
62+
} deriving (Generic, Typeable)
6263

6364
type Request = RequestF Builder.Builder
6465

65-
-- | The request body. Currently only lazy ByteStrings are supported.
66-
newtype RequestBody = RequestBodyLBS LBS.ByteString
67-
deriving (Eq, Ord, Read, Show, Typeable)
66+
-- | The request body. A replica of the @http-client@ @RequestBody@.
67+
data RequestBody
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)
74+
deriving (Generic, Typeable)
6875

6976
data GenResponse a = Response
7077
{ responseStatusCode :: Status

‎servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs

Lines changed: 31 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,6 @@
1515
module Servant.Client.Internal.XhrClient where
1616

1717
import Control.Arrow
18-
import Data.ByteString.Builder (toLazyByteString)
1918
import Control.Concurrent
2019
import Control.Exception
2120
import Control.Monad
@@ -25,22 +24,24 @@ import Control.Monad.Error.Class (MonadError (..))
2524
import Control.Monad.Reader
2625
import Control.Monad.Trans.Control (MonadBaseControl (..))
2726
import Control.Monad.Trans.Except
28-
import qualified Data.ByteString.Char8 as BS
27+
import Data.ByteString.Builder (toLazyByteString)
28+
import qualified Data.ByteString.Char8 as BS
2929
import Data.CaseInsensitive
3030
import Data.Char
3131
import Data.Foldable (toList)
3232
import Data.Functor.Alt (Alt (..))
33+
import Data.IORef (modifyIORef, newIORef, readIORef)
3334
import Data.Proxy (Proxy (..))
34-
import qualified Data.Sequence as Seq
35+
import qualified Data.Sequence as Seq
3536
import Data.String.Conversions
3637
import Foreign.StablePtr
3738
import GHC.Generics
3839
import GHCJS.Foreign.Callback
3940
import GHCJS.Prim
4041
import GHCJS.Types
4142
import JavaScript.Web.Location
43+
import Network.HTTP.Media (renderHeader)
4244
import Network.HTTP.Types
43-
import Network.HTTP.Media (renderHeader)
4445
import Servant.Client.Core
4546

4647
newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
@@ -152,7 +153,8 @@ performXhr xhr burl request = do
152153

153154
openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
154155
setHeaders xhr request
155-
sendXhr xhr (toBody request)
156+
body <- toBody request
157+
sendXhr xhr body
156158
takeMVar waiter
157159

158160
freeStablePtr s
@@ -226,11 +228,31 @@ foreign import javascript unsafe "$1.send()"
226228
foreign import javascript unsafe "$1.send($2)"
227229
js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
228230

229-
toBody :: Request -> Maybe String
231+
toBody :: Request -> IO (Maybe String)
230232
toBody request = case requestBody request of
231-
Nothing -> Nothing
232-
Just (RequestBodyLBS "", _) -> Nothing
233-
Just (RequestBodyLBS x, _) -> Just $ cs x
233+
Nothing -> return Nothing
234+
Just (a, _) -> go a
235+
236+
where
237+
go :: RequestBody -> IO (Maybe String)
238+
go x = case x of
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+
234256

235257
-- * inspecting the xhr response
236258

‎servant-client/servant-client.cabal

Lines changed: 10 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -82,7 +82,7 @@ library
8282

8383
test-suite spec
8484
type: exitcode-stdio-1.0
85-
ghc-options: -Wall
85+
ghc-options: -Wall -rtsopts -with-rtsopts=-T
8686
default-language: Haskell2010
8787
hs-source-dirs: test
8888
main-is: Spec.hs
@@ -112,14 +112,15 @@ test-suite spec
112112

113113
-- Additonal dependencies
114114
build-depends:
115-
deepseq >= 1.3.0.2 && < 1.5
116-
, generics-sop >= 0.3.1.0 && < 0.4
117-
, hspec >= 2.4.4 && < 2.5
118-
, HUnit >= 1.6 && < 1.7
119-
, network >= 2.6.3.2 && < 2.7
120-
, QuickCheck >= 2.10.1 && < 2.12
121-
, servant == 0.13.*
122-
, servant-server == 0.13.*
115+
deepseq >= 1.3.0.2 && < 1.5
116+
, generics-sop >= 0.3.1.0 && < 0.4
117+
, hspec >= 2.4.4 && < 2.5
118+
, HUnit >= 1.6 && < 1.7
119+
, random-bytestring >= 0.1 && < 0.2
120+
, network >= 2.6.3.2 && < 2.7
121+
, QuickCheck >= 2.10.1 && < 2.12
122+
, servant == 0.13.*
123+
, servant-server == 0.13.*
123124

124125
build-tool-depends:
125126
hspec-discover:hspec-discover >= 2.4.4 && < 2.5

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

Lines changed: 10 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -183,10 +183,18 @@ requestToClientRequest burl r = Client.defaultRequest
183183
where
184184
hs = toList $ requestAccept r
185185

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+
186194
(body, contentTypeHdr) = case requestBody r of
187195
Nothing -> (Client.RequestBodyLBS "", Nothing)
188-
Just (RequestBodyLBS body', typ)
189-
-> (Client.RequestBodyLBS body', Just (hContentType, renderHeader typ))
196+
Just (body', typ)
197+
-> (convertBody body', Just (hContentType, renderHeader typ))
190198

191199
isSecure = case baseUrlScheme burl of
192200
Http -> False

‎servant-client/test/Servant/ClientSpec.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -103,6 +103,9 @@ instance FromJSON Person
103103
instance ToForm Person
104104
instance FromForm Person
105105

106+
instance Arbitrary Person where
107+
arbitrary = Person <$> arbitrary <*> arbitrary
108+
106109
alice :: Person
107110
alice = Person "Alice" 42
108111

‎servant-client/test/Servant/StreamSpec.hs

Lines changed: 56 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -26,25 +26,26 @@
2626
#include "overlapping-compat.h"
2727
module Servant.StreamSpec (spec) where
2828

29-
import Prelude ()
30-
import Prelude.Compat
29+
import Control.Monad (replicateM_, void)
30+
import qualified Data.ByteString as BS
3131
import Data.Proxy
32-
import qualified Network.HTTP.Client as C
33-
import System.IO.Unsafe (unsafePerformIO)
32+
import GHC.Stats (currentBytesUsed, getGCStats)
33+
import qualified Network.HTTP.Client as C
34+
import Prelude ()
35+
import Prelude.Compat
36+
import System.IO (IOMode (ReadMode), withFile)
37+
import System.IO.Unsafe (unsafePerformIO)
3438
import Test.Hspec
39+
import Test.QuickCheck
3540

36-
import Servant.API ((:<|>) ((:<|>)),
37-
(:>),
38-
EmptyAPI, JSON,
39-
StreamGet,
40-
NewlineFraming,
41-
NetstringFraming,
42-
ResultStream(..),
43-
StreamGenerator(..))
41+
import Servant.API ((:<|>) ((:<|>)), (:>), JSON,
42+
NetstringFraming, NewlineFraming,
43+
OctetStream, ResultStream (..),
44+
StreamGenerator (..), StreamGet)
4445
import Servant.Client
46+
import Servant.ClientSpec (Person (..))
47+
import qualified Servant.ClientSpec as CS
4548
import Servant.Server
46-
import qualified Servant.ClientSpec as CS
47-
import Servant.ClientSpec (Person(..))
4849

4950

5051
spec :: Spec
@@ -54,7 +55,7 @@ spec = describe "Servant.Stream" $ do
5455
type StreamApi f =
5556
"streamGetNewline" :> StreamGet NewlineFraming JSON (f Person)
5657
:<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person)
57-
:<|> EmptyAPI
58+
:<|> "streamALot" :> StreamGet NewlineFraming OctetStream (f BS.ByteString)
5859

5960

6061
capi :: Proxy (StreamApi ResultStream)
@@ -63,12 +64,9 @@ capi = Proxy
6364
sapi :: Proxy (StreamApi StreamGenerator)
6465
sapi = Proxy
6566

66-
67-
getGetNL :<|> getGetNS :<|> EmptyClient = client capi
68-
69-
70-
getGetNL :: ClientM (ResultStream Person)
71-
getGetNS :: ClientM (ResultStream Person)
67+
getGetNL, getGetNS :: ClientM (ResultStream Person)
68+
getGetALot :: ClientM (ResultStream BS.ByteString)
69+
getGetNL :<|> getGetNS :<|> getGetALot = client capi
7270

7371
alice :: Person
7472
alice = Person "Alice" 42
@@ -77,14 +75,24 @@ bob :: Person
7775
bob = Person "Bob" 25
7876

7977
server :: Application
80-
server = serve sapi (
81-
(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))
85-
:: Handler (StreamGenerator Person))
86-
:<|>
87-
emptyServer)
78+
server = serve sapi
79+
$ return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
80+
:<|> return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
81+
:<|> return (StreamGenerator lotsGenerator)
82+
where
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+
8896

8997

9098
{-# NOINLINE manager' #-}
@@ -94,20 +102,35 @@ manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
94102
runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
95103
runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
96104

97-
runResultStream :: ResultStream a -> IO (Maybe (Either String a), Maybe (Either String a), Maybe (Either String a), Maybe (Either String a))
98-
runResultStream (ResultStream k) = k $ \act -> (,,,) <$> act <*> act <*> act <*> act
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))
110+
runResultStream (ResultStream k)
111+
= k $ \act -> (,,,) <$> act <*> act <*> act <*> act
99112

100113
streamSpec :: Spec
101114
streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
102115

103-
it "Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
116+
it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
104117
Right res <- runClient getGetNL baseUrl
105118
let jra = Just (Right alice)
106119
jrb = Just (Right bob)
107120
runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
108121

109-
it "Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do
122+
it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do
110123
Right res <- runClient getGetNS baseUrl
111124
let jra = Just (Right alice)
112125
jrb = Just (Right bob)
113126
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.yaml

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -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
4+
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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,8 @@ extra-deps:
1818
- aeson-compat-0.3.7.1
1919
- free-5.0.1
2020
- lens-4.16
21+
- random-bytestring-0.1.3
22+
- pcg-random-0.1.3.5
2123

2224
# allow-newer: true # ignores all bounds, that's a sledgehammer
2325
# - doc/tutorial/

0 commit comments

Comments
 (0)