1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
diff --git a/src/Servant/Client/Core/Internal/HasClient.hs b/src/Servant/Client/Core/Internal/HasClient.hs
index 712007006..6be92ec6d 100644
--- a/src/Servant/Client/Core/Internal/HasClient.hs
+++ b/src/Servant/Client/Core/Internal/HasClient.hs
@@ -16,6 +16,8 @@ module Servant.Client.Core.Internal.HasClient where
import Prelude ()
import Prelude.Compat
+import Control.Concurrent.MVar
+ (modifyMVar, newMVar)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.Foldable
@@ -36,13 +38,14 @@ import qualified Network.HTTP.Types as H
import Servant.API
((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
BuildHeadersTo (..), Capture', CaptureAll, Description,
- EmptyAPI, FramingUnrender (..), FromSourceIO (..), Header',
- Headers (..), HttpVersion, IsSecure, MimeRender (mimeRender),
+ EmptyAPI, FramingRender (..), FramingUnrender (..),
+ FromSourceIO (..), Header', Headers (..), HttpVersion,
+ IsSecure, MimeRender (mimeRender),
MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
- Vault, Verb, WithNamedContext, contentType, getHeadersHList,
- getResponse, toQueryParam, toUrlPiece)
+ ToSourceIO (..), Vault, Verb, WithNamedContext, contentType,
+ getHeadersHList, getResponse, toQueryParam, toUrlPiece)
import Servant.API.ContentTypes
(contentTypes)
import Servant.API.Modifiers
@@ -538,7 +541,7 @@ instance (MimeRender ct a, HasClient m api)
hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
instance
- ( HasClient m api
+ ( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a
) => HasClient m (StreamBody' mods framing ctype a :> api)
where
@@ -547,7 +550,39 @@ instance
hoistClientMonad pm _ 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
|