git.iko.soy/typeable/servant
on master help sign in
Merge pull request #1110 from haskell-servant/oleg-testcase-1091
46afc9bOleg Grenrus
servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs+41−6
compare with master
unifiedsplit
@@ -16,6 +16,8 @@ module Servant.Client.Core.Internal.HasClient where
16import Prelude ()
16import Prelude ()
17import Prelude.Compat
17import Prelude.Compat
18
18
19+import Control.Concurrent.MVar
20+ (modifyMVar, newMVar)
19import qualified Data.ByteString as BS
21import qualified Data.ByteString as BS
20import qualified Data.ByteString.Lazy as BL
22import qualified Data.ByteString.Lazy as BL
21import Data.Foldable
23import Data.Foldable
@@ -36,13 +38,14 @@ import qualified Network.HTTP.Types as H
36import Servant.API
38import Servant.API
37 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
39 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
38 BuildHeadersTo (..), Capture', CaptureAll, Description,
40 BuildHeadersTo (..), Capture', CaptureAll, Description,
39− EmptyAPI, FramingUnrender (..), FromSourceIO (..), Header',
41+ EmptyAPI, FramingRender (..), FramingUnrender (..),
42+ FromSourceIO (..), Header', Headers (..), HttpVersion,
40− Headers (..), HttpVersion, IsSecure, MimeRender (mimeRender),
43+ IsSecure, MimeRender (mimeRender),
41 MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
44 MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
42 QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
45 QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
43 ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
46 ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
44− Vault, Verb, WithNamedContext, contentType, getHeadersHList,
47+ ToSourceIO (..), Vault, Verb, WithNamedContext, contentType,
45− getResponse, toQueryParam, toUrlPiece)
48+ getHeadersHList, getResponse, toQueryParam, toUrlPiece)
46import Servant.API.ContentTypes
49import Servant.API.ContentTypes
47 (contentTypes)
50 (contentTypes)
48import Servant.API.Modifiers
51import Servant.API.Modifiers
@@ -538,7 +541,7 @@ instance (MimeRender ct a, HasClient m api)
538 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
541 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
539
542
540instance
543instance
541− ( HasClient m api
544+ ( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a
542 ) => HasClient m (StreamBody' mods framing ctype a :> api)
545 ) => HasClient m (StreamBody' mods framing ctype a :> api)
543 where
546 where
544
547
@@ -547,7 +550,39 @@ instance
547 hoistClientMonad pm _ f cl = \a ->
550 hoistClientMonad pm _ f cl = \a ->
548 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
551 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
549
552
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
551
586
552-- | Make the querying function append @path@ to the request path.
587-- | Make the querying function append @path@ to the request path.
553instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
588instance (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
35import Prelude ()
35import Prelude ()
36import Prelude.Compat
36import Prelude.Compat
37import Servant.API
37import Servant.API
38− ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming,
38+ ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming, StreamBody,
39− NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet)
39+ NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet,
40+ )
40import Servant.Client.Streaming
41import Servant.Client.Streaming
41import Servant.ClientSpec
42import Servant.ClientSpec
42 (Person (..))
43 (Person (..))
@@ -72,13 +73,15 @@ type StreamApi =
72 "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person)
73 "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person)
73 :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person)
74 :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person)
74 :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
75 :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
76+ :<|> "streamBody" :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString) :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
75
77
76api :: Proxy StreamApi
78api :: Proxy StreamApi
77api = Proxy
79api = Proxy
78
80
79getGetNL, getGetNS :: ClientM (SourceIO Person)
81getGetNL, getGetNS :: ClientM (SourceIO Person)
80getGetALot :: ClientM (SourceIO BS.ByteString)
82getGetALot :: ClientM (SourceIO BS.ByteString)
83+getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString)
81−getGetNL :<|> getGetNS :<|> getGetALot = client api
84+getGetNL :<|> getGetNS :<|> getGetALot :<|> getStreamBody = client api
82
85
83alice :: Person
86alice :: Person
84alice = Person "Alice" 42
87alice = Person "Alice" 42
@@ -90,9 +93,9 @@ server :: Application
90server = serve api
93server = serve api
91 $ return (source [alice, bob, alice])
94 $ return (source [alice, bob, alice])
92 :<|> return (source [alice, bob, alice])
95 :<|> return (source [alice, bob, alice])
93−
94 -- 2 ^ (18 + 10) = 256M
96 -- 2 ^ (18 + 10) = 256M
95 :<|> return (SourceT ($ lots (powerOfTwo 18)))
97 :<|> return (SourceT ($ lots (powerOfTwo 18)))
98+ :<|> return
96 where
99 where
97 lots n
100 lots n
98 | n < 0 = Stop
101 | n < 0 = Stop
@@ -126,6 +129,13 @@ streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
126 withClient getGetNS baseUrl $ \(Right res) ->
129 withClient getGetNS baseUrl $ \(Right res) ->
127 testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
130 testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
128
131
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+
129{-
139{-
130 it "streams in constant memory" $ \(_, baseUrl) -> do
140 it "streams in constant memory" $ \(_, baseUrl) -> do
131 Right rs <- runClient getGetALot baseUrl
141 Right rs <- runClient getGetALot baseUrl