Merge pull request #1110 from haskell-servant/oleg-testcase-1091

Oleg testcase 1091
This commit is contained in:
Oleg Grenrus 2019-02-04 18:06:48 +02:00 committed by GitHub
commit 46afc9bcdd
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
2 changed files with 55 additions and 10 deletions

View file

@ -16,6 +16,8 @@ module Servant.Client.Core.Internal.HasClient where
import Prelude () import Prelude ()
import Prelude.Compat import Prelude.Compat
import Control.Concurrent.MVar
(modifyMVar, newMVar)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.Foldable import Data.Foldable
@ -36,13 +38,14 @@ import qualified Network.HTTP.Types as H
import Servant.API import Servant.API
((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData, ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
BuildHeadersTo (..), Capture', CaptureAll, Description, BuildHeadersTo (..), Capture', CaptureAll, Description,
EmptyAPI, FramingUnrender (..), FromSourceIO (..), Header', EmptyAPI, FramingRender (..), FramingUnrender (..),
Headers (..), HttpVersion, IsSecure, MimeRender (mimeRender), FromSourceIO (..), Header', Headers (..), HttpVersion,
IsSecure, MimeRender (mimeRender),
MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag, MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost, QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData, ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
Vault, Verb, WithNamedContext, contentType, getHeadersHList, ToSourceIO (..), Vault, Verb, WithNamedContext, contentType,
getResponse, toQueryParam, toUrlPiece) getHeadersHList, getResponse, toQueryParam, toUrlPiece)
import Servant.API.ContentTypes import Servant.API.ContentTypes
(contentTypes) (contentTypes)
import Servant.API.Modifiers import Servant.API.Modifiers
@ -538,7 +541,7 @@ instance (MimeRender ct a, HasClient m api)
hoistClientMonad pm (Proxy :: Proxy api) f (cl a) hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
instance instance
( HasClient m api ( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a
) => HasClient m (StreamBody' mods framing ctype a :> api) ) => HasClient m (StreamBody' mods framing ctype a :> api)
where where
@ -547,7 +550,39 @@ instance
hoistClientMonad pm _ f cl = \a -> hoistClientMonad pm _ f cl = \a ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl a) hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
clientWithRoute _pm Proxy _req _body = error "HasClient @StreamBody" clientWithRoute pm Proxy req body
= clientWithRoute pm (Proxy :: Proxy api)
$ setRequestBody (RequestBodyStreamChunked givesPopper) (contentType ctypeP) req
where
ctypeP = Proxy :: Proxy ctype
framingP = Proxy :: Proxy framing
sourceIO = framingRender
framingP
(mimeRender ctypeP :: chunk -> BL.ByteString)
(toSourceIO body)
-- not pretty.
givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()
givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do
ref <- newMVar step0
-- Note sure we need locking, but it's feels safer.
let popper :: IO BS.ByteString
popper = modifyMVar ref nextBs
needsPopper popper
nextBs S.Stop = return (S.Stop, BS.empty)
nextBs (S.Error err) = fail err
nextBs (S.Skip s) = nextBs s
nextBs (S.Effect ms) = ms >>= nextBs
nextBs (S.Yield lbs s) = case BL.toChunks lbs of
[] -> nextBs s
(x:xs) | BS.null x -> nextBs step'
| otherwise -> return (step', x)
where
step' = S.Yield (BL.fromChunks xs) s
-- | Make the querying function append @path@ to the request path. -- | Make the querying function append @path@ to the request path.
instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where

View file

@ -35,8 +35,9 @@ import qualified Network.HTTP.Client as C
import Prelude () import Prelude ()
import Prelude.Compat import Prelude.Compat
import Servant.API import Servant.API
((:<|>) ((:<|>)), (:>), JSON, NetstringFraming, ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming, StreamBody,
NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet) NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet,
)
import Servant.Client.Streaming import Servant.Client.Streaming
import Servant.ClientSpec import Servant.ClientSpec
(Person (..)) (Person (..))
@ -72,13 +73,15 @@ type StreamApi =
"streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person) "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person)
:<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person) :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person)
:<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString) :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
:<|> "streamBody" :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString) :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
api :: Proxy StreamApi api :: Proxy StreamApi
api = Proxy api = Proxy
getGetNL, getGetNS :: ClientM (SourceIO Person) getGetNL, getGetNS :: ClientM (SourceIO Person)
getGetALot :: ClientM (SourceIO BS.ByteString) getGetALot :: ClientM (SourceIO BS.ByteString)
getGetNL :<|> getGetNS :<|> getGetALot = client api getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString)
getGetNL :<|> getGetNS :<|> getGetALot :<|> getStreamBody = client api
alice :: Person alice :: Person
alice = Person "Alice" 42 alice = Person "Alice" 42
@ -90,9 +93,9 @@ server :: Application
server = serve api server = serve api
$ return (source [alice, bob, alice]) $ return (source [alice, bob, alice])
:<|> return (source [alice, bob, alice]) :<|> return (source [alice, bob, alice])
-- 2 ^ (18 + 10) = 256M -- 2 ^ (18 + 10) = 256M
:<|> return (SourceT ($ lots (powerOfTwo 18))) :<|> return (SourceT ($ lots (powerOfTwo 18)))
:<|> return
where where
lots n lots n
| n < 0 = Stop | n < 0 = Stop
@ -126,6 +129,13 @@ streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
withClient getGetNS baseUrl $ \(Right res) -> withClient getGetNS baseUrl $ \(Right res) ->
testRunSourceIO res `shouldReturn` Right [alice, bob, alice] testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
it "works with Servant.API.StreamBody" $ \(_, baseUrl) -> do
withClient (getStreamBody (source input)) baseUrl $ \(Right res) ->
testRunSourceIO res `shouldReturn` Right output
where
input = ["foo", "", "bar"]
output = ["foo", "bar"]
{- {-
it "streams in constant memory" $ \(_, baseUrl) -> do it "streams in constant memory" $ \(_, baseUrl) -> do
Right rs <- runClient getGetALot baseUrl Right rs <- runClient getGetALot baseUrl