eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

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

Browse source 
Streaming request body for servant-client-core
This commit is contained in:
Julian Arni 2018-03-23 18:30:13 +01:00 committed by GitHub
commit 3750f22e01
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
8 changed files with 169 additions and 69 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -1,12 +1,12 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
@ -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

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

@ -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,11 +24,13 @@ import Control.Monad.Error.Class (MonadError (..))
import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Except
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 Data.String.Conversions
@ -39,8 +40,8 @@ import GHCJS.Foreign.Callback
import GHCJS.Prim
import GHCJS.Types
import JavaScript.Web.Location
import Network.HTTP.Types
import Network.HTTP.Media (renderHeader)
import Network.HTTP.Types
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

3
servant-client/servant-client.cabal
View file

@ -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
@ -116,6 +116,7 @@ test-suite spec
, 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.*

12
servant-client/src/Servant/Client/Internal/HttpClient.hs
View file

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

3
servant-client/test/Servant/ClientSpec.hs
View file

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

85
servant-client/test/Servant/StreamSpec.hs
View file

@ -26,25 +26,26 @@
#include "overlapping-compat.h"
module Servant.StreamSpec (spec) where
import Control.Monad (replicateM_, void)
import qualified Data.ByteString as BS
import Data.Proxy
import GHC.Stats (currentBytesUsed, getGCStats)
import qualified Network.HTTP.Client as C
import Prelude ()
import Prelude.Compat
import Data.Proxy
import qualified Network.HTTP.Client as C
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.Server
import qualified Servant.ClientSpec as CS
import Servant.ClientSpec (Person (..))
import qualified Servant.ClientSpec as CS
import Servant.Server
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)

34
stack-ghcjs.yaml Normal file
View file

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

2
stack.yaml
View file

@ -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/