diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index 50aadda3..6adb96ee 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# 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. -newtype RequestBody = RequestBodyLBS LBS.ByteString - deriving (Eq, Ord, Read, Show, Typeable) +-- | The request body. A replica of the @http-client@ @RequestBody@. +data RequestBody + = 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 diff --git a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs index 27f09008..74deb0ab 100644 --- a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs +++ b/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 - Just (RequestBodyLBS "", _) -> Nothing - Just (RequestBodyLBS x, _) -> Just $ cs x + Nothing -> return Nothing + Just (a, _) -> go a + + 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 diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 80da8678..f6103507 100644 --- a/servant-client/servant-client.cabal +++ b/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 - , generics-sop >= 0.3.1.0 && < 0.4 - , hspec >= 2.4.4 && < 2.5 - , HUnit >= 1.6 && < 1.7 - , network >= 2.6.3.2 && < 2.7 - , QuickCheck >= 2.10.1 && < 2.12 - , servant == 0.13.* - , servant-server == 0.13.* + deepseq >= 1.3.0.2 && < 1.5 + , generics-sop >= 0.3.1.0 && < 0.4 + , hspec >= 2.4.4 && < 2.5 + , HUnit >= 1.6 && < 1.7 + , random-bytestring >= 0.1 && < 0.2 + , network >= 2.6.3.2 && < 2.7 + , QuickCheck >= 2.10.1 && < 2.12 + , servant == 0.13.* + , servant-server == 0.13.* build-tool-depends: hspec-discover:hspec-discover >= 2.4.4 && < 2.5 diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index f976deed..eddb0afc 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/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) - -> (Client.RequestBodyLBS body', Just (hContentType, renderHeader typ)) + Just (body', typ) + -> (convertBody body', Just (hContentType, renderHeader typ)) isSecure = case baseUrlScheme burl of Http -> False diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index c9a96cab..6d33cd27 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/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 diff --git a/servant-client/test/Servant/StreamSpec.hs b/servant-client/test/Servant/StreamSpec.hs index 2df336da..ad4a2664 100644 --- a/servant-client/test/Servant/StreamSpec.hs +++ b/servant-client/test/Servant/StreamSpec.hs @@ -26,25 +26,26 @@ #include "overlapping-compat.h" module Servant.StreamSpec (spec) where -import Prelude () -import Prelude.Compat +import Control.Monad (replicateM_, void) +import qualified Data.ByteString as BS import Data.Proxy -import qualified Network.HTTP.Client as C -import System.IO.Unsafe (unsafePerformIO) +import GHC.Stats (currentBytesUsed, getGCStats) +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 ((:<|>) ((:<|>)), - (:>), - EmptyAPI, JSON, - StreamGet, - NewlineFraming, - NetstringFraming, - ResultStream(..), - StreamGenerator(..)) +import Servant.API ((:<|>) ((:<|>)), (:>), JSON, + NetstringFraming, NewlineFraming, + OctetStream, ResultStream (..), + StreamGenerator (..), StreamGet) 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 :<|> EmptyClient = client capi - - -getGetNL :: ClientM (ResultStream Person) -getGetNS :: ClientM (ResultStream Person) +getGetNL, getGetNS :: ClientM (ResultStream Person) +getGetALot :: ClientM (ResultStream BS.ByteString) +getGetNL :<|> getGetNS :<|> getGetALot = client capi alice :: Person alice = Person "Alice" 42 @@ -77,14 +75,24 @@ bob :: Person bob = Person "Bob" 25 server :: Application -server = serve sapi ( - (return (StreamGenerator (\f r -> f alice >> r bob >> r alice)) - :: Handler (StreamGenerator Person)) - :<|> - (return (StreamGenerator (\f r -> f alice >> r bob >> r alice)) - :: Handler (StreamGenerator Person)) - :<|> - emptyServer) +server = serve sapi + $ return (StreamGenerator (\f r -> f alice >> r bob >> r alice)) + :<|> return (StreamGenerator (\f r -> f alice >> r bob >> r alice)) + :<|> return (StreamGenerator lotsGenerator) + where + lotsGenerator f r = do + f "" + 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 k) = k $ \act -> (,,,) <$> act <*> act <*> act <*> act +runResultStream :: ResultStream a + -> 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) diff --git a/stack-ghcjs.yaml b/stack-ghcjs.yaml new file mode 100644 index 00000000..479597e7 --- /dev/null +++ b/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 diff --git a/stack.yaml b/stack.yaml index 464bf522..f3f41102 100644 --- a/stack.yaml +++ b/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/