git.iko.soy/typeable/servant
on master help sign in
Merge pull request #1110 from haskell-servant/oleg-testcase-1091

Oleg testcase 1091

commit46afc9bcdd86cc134e20d07aec1f316f0964252c authorOleg Grenrus <oleg.grenrus@iki.fi> dateMon 4 Feb 2019, 18:06 (8 years ago) parent109f7b2e9466b7
2 files changed+55−10
compare with master
unifiedsplit
servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs+41−6 servant-client/test/Servant/StreamSpec.hs+14−4
servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs+41−6
@@ -16,6 +16,8 @@ module Servant.Client.Core.Internal.HasClient where
1616import Prelude ()
1717import Prelude.Compat
1818
19+import Control.Concurrent.MVar
20+ (modifyMVar, newMVar)
1921import qualified Data.ByteString as BS
2022import qualified Data.ByteString.Lazy as BL
2123import Data.Foldable
@@ -36,13 +38,14 @@ import qualified Network.HTTP.Types as H
3638import Servant.API
3739 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
3840 BuildHeadersTo (..), Capture', CaptureAll, Description,
39− EmptyAPI, FramingUnrender (..), FromSourceIO (..), Header',
40− Headers (..), HttpVersion, IsSecure, MimeRender (mimeRender),
41+ EmptyAPI, FramingRender (..), FramingUnrender (..),
42+ FromSourceIO (..), Header', Headers (..), HttpVersion,
43+ IsSecure, MimeRender (mimeRender),
4144 MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
4245 QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
4346 ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
44− Vault, Verb, WithNamedContext, contentType, getHeadersHList,
45− getResponse, toQueryParam, toUrlPiece)
47+ ToSourceIO (..), Vault, Verb, WithNamedContext, contentType,
48+ getHeadersHList, getResponse, toQueryParam, toUrlPiece)
4649import Servant.API.ContentTypes
4750 (contentTypes)
4851import Servant.API.Modifiers
@@ -538,7 +541,7 @@ instance (MimeRender ct a, HasClient m api)
538541 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
539542
540543instance
541− ( HasClient m api
544+ ( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a
542545 ) => HasClient m (StreamBody' mods framing ctype a :> api)
543546 where
544547
@@ -547,7 +550,39 @@ instance
547550 hoistClientMonad pm _ f cl = \a ->
548551 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
549552
550− clientWithRoute _pm Proxy _req _body = error "HasClient @StreamBody"
553+ clientWithRoute pm Proxy req body
554+ = clientWithRoute pm (Proxy :: Proxy api)
555+ $ setRequestBody (RequestBodyStreamChunked givesPopper) (contentType ctypeP) req
556+ where
557+ ctypeP = Proxy :: Proxy ctype
558+ framingP = Proxy :: Proxy framing
559+
560+ sourceIO = framingRender
561+ framingP
562+ (mimeRender ctypeP :: chunk -> BL.ByteString)
563+ (toSourceIO body)
564+
565+ -- not pretty.
566+ givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()
567+ givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do
568+ ref <- newMVar step0
569+
570+ -- Note sure we need locking, but it's feels safer.
571+ let popper :: IO BS.ByteString
572+ popper = modifyMVar ref nextBs
573+
574+ needsPopper popper
575+
576+ nextBs S.Stop = return (S.Stop, BS.empty)
577+ nextBs (S.Error err) = fail err
578+ nextBs (S.Skip s) = nextBs s
579+ nextBs (S.Effect ms) = ms >>= nextBs
580+ nextBs (S.Yield lbs s) = case BL.toChunks lbs of
581+ [] -> nextBs s
582+ (x:xs) | BS.null x -> nextBs step'
583+ | otherwise -> return (step', x)
584+ where
585+ step' = S.Yield (BL.fromChunks xs) s
551586
552587-- | Make the querying function append @path@ to the request path.
553588instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
servant-client/test/Servant/StreamSpec.hs+14−4
@@ -35,8 +35,9 @@ import qualified Network.HTTP.Client as C
3535import Prelude ()
3636import Prelude.Compat
3737import Servant.API
38− ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming,
39− NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet)
38+ ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming, StreamBody,
39+ NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet,
40+ )
4041import Servant.Client.Streaming
4142import Servant.ClientSpec
4243 (Person (..))
@@ -72,13 +73,15 @@ type StreamApi =
7273 "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person)
7374 :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person)
7475 :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
76+ :<|> "streamBody" :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString) :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
7577
7678api :: Proxy StreamApi
7779api = Proxy
7880
7981getGetNL, getGetNS :: ClientM (SourceIO Person)
8082getGetALot :: ClientM (SourceIO BS.ByteString)
81−getGetNL :<|> getGetNS :<|> getGetALot = client api
83+getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString)
84+getGetNL :<|> getGetNS :<|> getGetALot :<|> getStreamBody = client api
8285
8386alice :: Person
8487alice = Person "Alice" 42
@@ -90,9 +93,9 @@ server :: Application
9093server = serve api
9194 $ return (source [alice, bob, alice])
9295 :<|> return (source [alice, bob, alice])
93−
9496 -- 2 ^ (18 + 10) = 256M
9597 :<|> return (SourceT ($ lots (powerOfTwo 18)))
98+ :<|> return
9699 where
97100 lots n
98101 | n < 0 = Stop
@@ -126,6 +129,13 @@ streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
126129 withClient getGetNS baseUrl $ \(Right res) ->
127130 testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
128131
132+ it "works with Servant.API.StreamBody" $ \(_, baseUrl) -> do
133+ withClient (getStreamBody (source input)) baseUrl $ \(Right res) ->
134+ testRunSourceIO res `shouldReturn` Right output
135+ where
136+ input = ["foo", "", "bar"]
137+ output = ["foo", "bar"]
138+
129139{-
130140 it "streams in constant memory" $ \(_, baseUrl) -> do
131141 Right rs <- runClient getGetALot baseUrl