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

Streaming request body for servant-client-core

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

@@ -1,14 +1,14 @@
-{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveDataTypeable    #-}
-{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveFoldable        #-}
-{-# LANGUAGE DeriveFoldable             #-}
+{-# LANGUAGE DeriveFunctor         #-}
-{-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DeriveTraversable     #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RankNTypes            #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeFamilies          #-}
 
 module Servant.Client.Core.Internal.Request where
 
@@ -16,9 +16,10 @@ import           Prelude                 ()
 import           Prelude.Compat
 
 import           Control.Monad.Catch     (Exception)
-import qualified Data.ByteString.Builder as Builder
 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
 import           Data.Text               (Text)
@@ -58,13 +59,19 @@ data RequestF a = Request
   , requestHeaders     :: Seq.Seq Header
   , requestHttpVersion :: HttpVersion
   , requestMethod      :: Method
-  } deriving (Eq, Show, Functor, Generic, Typeable)
+  } deriving (Generic, Typeable)
 
 type Request = RequestF Builder.Builder
 
--- | The request body. Currently only lazy ByteStrings are supported.
+-- | The request body. A replica of the @http-client@ @RequestBody@.
-newtype RequestBody = RequestBodyLBS LBS.ByteString
+data RequestBody
-  deriving (Eq, Ord, Read, Show, Typeable)
+  = 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)
+  deriving (Generic, Typeable)
 
 data GenResponse a = Response
   { responseStatusCode  :: Status

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

@@ -15,7 +15,6 @@
 module Servant.Client.Internal.XhrClient where
 
 import           Control.Arrow
-import           Data.ByteString.Builder     (toLazyByteString)
 import           Control.Concurrent
 import           Control.Exception
 import           Control.Monad
@@ -25,13 +24,15 @@ import           Control.Monad.Error.Class   (MonadError (..))
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Control (MonadBaseControl (..))
 import           Control.Monad.Trans.Except
-import qualified Data.ByteString.Char8 as BS
+import           Data.ByteString.Builder     (toLazyByteString)
+import qualified Data.ByteString.Char8       as BS
 import           Data.CaseInsensitive
 import           Data.Char
 import           Data.Foldable               (toList)
 import           Data.Functor.Alt            (Alt (..))
+import           Data.IORef                  (modifyIORef, newIORef, readIORef)
 import           Data.Proxy                  (Proxy (..))
-import qualified Data.Sequence           as Seq
+import qualified Data.Sequence               as Seq
 import           Data.String.Conversions
 import           Foreign.StablePtr
 import           GHC.Generics
@@ -39,8 +40,8 @@ import           GHCJS.Foreign.Callback
 import           GHCJS.Prim
 import           GHCJS.Types
 import           JavaScript.Web.Location
+import           Network.HTTP.Media          (renderHeader)
 import           Network.HTTP.Types
-import           Network.HTTP.Media (renderHeader)
 import           Servant.Client.Core
 
 newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
@@ -152,7 +153,8 @@ performXhr xhr burl request = do
 
         openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
         setHeaders xhr request
-        sendXhr xhr (toBody request)
+        body <- toBody request
+        sendXhr xhr body
         takeMVar waiter
 
         freeStablePtr s
@@ -226,11 +228,31 @@ foreign import javascript unsafe "$1.send()"
 foreign import javascript unsafe "$1.send($2)"
   js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
 
-toBody :: Request -> Maybe String
+toBody :: Request -> IO (Maybe String)
 toBody request = case requestBody request of
-  Nothing -> Nothing
+  Nothing -> return Nothing
-  Just (RequestBodyLBS "", _) -> Nothing
+  Just (a, _) -> go a
-  Just (RequestBodyLBS x, _) -> Just $ cs x
+
+  where
+    go :: RequestBody -> IO (Maybe String)
+    go x = case x of
+      RequestBodyLBS x -> return $ mBody x
+      RequestBodyBS x -> return $ mBody x
+      RequestBodyBuilder _ x -> return $ mBody $ toLazyByteString x
+      RequestBodyStream _ x -> mBody <$> readBody x
+      RequestBodyStreamChunked x -> mBody <$> readBody x
+      RequestBodyIO x -> x >>= go
+
+    mBody :: ConvertibleStrings a String => a -> Maybe String
+    mBody x = let y = cs x in if y == "" then Nothing else Just y
+
+    readBody writer = do
+      m <- newIORef mempty
+      _ <- writer (\bsAct -> do
+        bs <- bsAct
+        modifyIORef m (<> bs))
+      readIORef m
+
 
 -- * inspecting the xhr response
 

servant-client/servant-client.cabal

@@ -82,7 +82,7 @@ library
 
 test-suite spec
   type: exitcode-stdio-1.0
-  ghc-options: -Wall
+  ghc-options: -Wall -rtsopts -with-rtsopts=-T
   default-language: Haskell2010
   hs-source-dirs: test
   main-is: Spec.hs
@@ -112,14 +112,15 @@ test-suite spec
 
   -- Additonal dependencies
   build-depends:
-      deepseq        >= 1.3.0.2 && < 1.5
+      deepseq           >= 1.3.0.2 && < 1.5
-    , generics-sop   >= 0.3.1.0 && < 0.4
+    , generics-sop      >= 0.3.1.0 && < 0.4
-    , hspec          >= 2.4.4   && < 2.5
+    , hspec             >= 2.4.4   && < 2.5
-    , HUnit          >= 1.6     && < 1.7
+    , HUnit             >= 1.6     && < 1.7
-    , network        >= 2.6.3.2 && < 2.7
+    , random-bytestring >= 0.1     && < 0.2
-    , QuickCheck     >= 2.10.1  && < 2.12
+    , network           >= 2.6.3.2 && < 2.7
-    , servant        == 0.13.*
+    , QuickCheck        >= 2.10.1  && < 2.12
-    , servant-server == 0.13.*
+    , servant           == 0.13.*
+    , servant-server    == 0.13.*
 
   build-tool-depends:
     hspec-discover:hspec-discover >= 2.4.4 && < 2.5

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

@@ -183,10 +183,18 @@ requestToClientRequest burl r = Client.defaultRequest
       where
         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')
+
     (body, contentTypeHdr) = case requestBody r of
       Nothing -> (Client.RequestBodyLBS "", Nothing)
-      Just (RequestBodyLBS body', typ)
+      Just (body', typ)
-        -> (Client.RequestBodyLBS body', Just (hContentType, renderHeader typ))
+        -> (convertBody body', Just (hContentType, renderHeader typ))
 
     isSecure = case baseUrlScheme burl of
       Http -> False

servant-client/test/Servant/ClientSpec.hs

@@ -103,6 +103,9 @@ instance FromJSON Person
 instance ToForm Person
 instance FromForm Person
 
+instance Arbitrary Person where
+  arbitrary = Person <$> arbitrary <*> arbitrary
+
 alice :: Person
 alice = Person "Alice" 42
 

servant-client/test/Servant/StreamSpec.hs

@@ -26,25 +26,26 @@
 #include "overlapping-compat.h"
 module Servant.StreamSpec (spec) where
 
-import           Prelude                                    ()
+import           Control.Monad       (replicateM_, void)
-import           Prelude.Compat
+import qualified Data.ByteString     as BS
 import           Data.Proxy
-import qualified Network.HTTP.Client                        as C
+import           GHC.Stats           (currentBytesUsed, getGCStats)
-import           System.IO.Unsafe                           (unsafePerformIO)
+import qualified Network.HTTP.Client as C
+import           Prelude             ()
+import           Prelude.Compat
+import           System.IO           (IOMode (ReadMode), withFile)
+import           System.IO.Unsafe    (unsafePerformIO)
 import           Test.Hspec
+import           Test.QuickCheck
 
-import           Servant.API                                ((:<|>) ((:<|>)),
+import           Servant.API         ((:<|>) ((:<|>)), (:>), JSON,
-                                                             (:>),
+                                      NetstringFraming, NewlineFraming,
-                                                             EmptyAPI, JSON,
+                                      OctetStream, ResultStream (..),
-                                                             StreamGet,
+                                      StreamGenerator (..), StreamGet)
-                                                             NewlineFraming,
-                                                             NetstringFraming,
-                                                             ResultStream(..),
-                                                             StreamGenerator(..))
 import           Servant.Client
+import           Servant.ClientSpec  (Person (..))
+import qualified Servant.ClientSpec  as CS
 import           Servant.Server
-import qualified Servant.ClientSpec                          as CS
-import           Servant.ClientSpec                          (Person(..))
 
 
 spec :: Spec
@@ -54,7 +55,7 @@ spec = describe "Servant.Stream" $ do
 type StreamApi f =
        "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person)
   :<|> "streamGetNetstring" :> StreamGet  NetstringFraming JSON (f Person)
-  :<|> EmptyAPI
+  :<|> "streamALot" :> StreamGet NewlineFraming OctetStream (f BS.ByteString)
 
 
 capi :: Proxy (StreamApi ResultStream)
@@ -63,12 +64,9 @@ capi = Proxy
 sapi :: Proxy (StreamApi StreamGenerator)
 sapi = Proxy
 
-
+getGetNL, getGetNS :: ClientM (ResultStream Person)
-getGetNL :<|> getGetNS :<|> EmptyClient = client capi
+getGetALot :: ClientM (ResultStream BS.ByteString)
-
+getGetNL :<|> getGetNS :<|> getGetALot = client capi
-
-getGetNL :: ClientM (ResultStream Person)
-getGetNS :: ClientM (ResultStream Person)
 
 alice :: Person
 alice = Person "Alice" 42
@@ -77,14 +75,24 @@ bob :: Person
 bob = Person "Bob" 25
 
 server :: Application
-server = serve sapi (
+server = serve sapi
-       (return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
+  $    return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
-       :: Handler (StreamGenerator Person))
+  :<|> return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
-       :<|>
+  :<|> return (StreamGenerator lotsGenerator)
-       (return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
+  where
-       :: Handler (StreamGenerator Person))
+    lotsGenerator f r = do
-       :<|>
+      f ""
-       emptyServer)
+      withFile "/dev/urandom" ReadMode $
+        \handle -> streamFiveMBNTimes handle 1000 r
+      return ()
+
+    streamFiveMBNTimes handle left sink
+      | left <= 0 = return ""
+      | otherwise = do
+          msg <- BS.hGet handle (megabytes 5)
+          sink msg
+          streamFiveMBNTimes handle (left - 1) sink
+
 
 
 {-# NOINLINE manager' #-}
@@ -94,20 +102,35 @@ manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
 runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
 runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
 
-runResultStream :: ResultStream a -> IO (Maybe (Either String a), Maybe (Either String a), Maybe (Either String a), Maybe (Either String a))
+runResultStream :: ResultStream a
-runResultStream (ResultStream k) = k $ \act -> (,,,) <$> act <*> act <*> act <*> act
+  -> IO ( Maybe (Either String a)
+        , Maybe (Either String a)
+        , Maybe (Either String a)
+        , Maybe (Either String a))
+runResultStream (ResultStream k)
+  = k $ \act -> (,,,) <$> act <*> act <*> act <*> act
 
 streamSpec :: Spec
 streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
 
-    it "Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
+    it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
        Right res <- runClient getGetNL baseUrl
        let jra = Just (Right alice)
            jrb = Just (Right bob)
        runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
 
-    it "Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do
+    it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do
        Right res <- runClient getGetNS baseUrl
        let jra = Just (Right alice)
            jrb = Just (Right bob)
        runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
+
+    it "streams in constant memory" $ \(_, baseUrl) -> do
+       Right (ResultStream res) <- runClient getGetALot baseUrl
+       let consumeNChunks n = replicateM_ n (res void)
+       consumeNChunks 900
+       memUsed <- currentBytesUsed <$> getGCStats
+       memUsed `shouldSatisfy` (< (megabytes 20))
+
+megabytes :: Num a => a -> a
+megabytes n = n * (1000 ^ 2)

stack-ghcjs.yaml

@@ -0,0 +1,34 @@
+resolver: lts-7.19
+compiler: ghcjs-0.2.1.9007019_ghc-8.0.1
+compiler-check: match-exact
+
+setup-info:
+  ghcjs:
+    source:
+      ghcjs-0.2.1.9007019_ghc-8.0.1:
+           url: http://ghcjs.tolysz.org/ghc-8.0-2017-02-05-lts-7.19-9007019.tar.gz
+           sha1: d2cfc25f9cda32a25a87d9af68891b2186ee52f9
+packages:
+- servant-client-core/
+- servant-client-ghcjs/
+- servant/
+
+extra-deps:
+- cabal-doctest-1.0.6
+- http-api-data-0.3.7.2
+- http-types-0.12
+- text-1.2.3.0
+- aeson-1.2.4.0
+- attoparsec-0.13.2.2
+- attoparsec-iso8601-1.0.0.0
+- base-compat-0.9.3
+- case-insensitive-1.2.0.11
+- generics-sop-0.3.2.0
+- http-media-0.7.1.2
+- mmorph-1.1.1
+- natural-transformation-0.4
+- safe-0.3.17
+- vault-0.3.1.0
+- th-abstraction-0.2.6.0
+- git: https://github.com/ghcjs/ghcjs-base.git
+  commit: 3bb9ed0ffd3f384ed37456b4d6247be732c79c8e

stack.yaml

@@ -18,6 +18,8 @@ extra-deps:
 - aeson-compat-0.3.7.1
 - free-5.0.1
 - lens-4.16
+- random-bytestring-0.1.3
+- pcg-random-0.1.3.5
 
 # allow-newer: true # ignores all bounds, that's a sledgehammer
 # - doc/tutorial/