tjh.dev
nixpkgs mirror (for testing)
github.com/NixOS/nixpkgs
nix
1diff --git a/src/Servant/Client/Core/Internal/HasClient.hs b/src/Servant/Client/Core/Internal/HasClient.hs
2index 712007006..6be92ec6d 100644
3--- a/src/Servant/Client/Core/Internal/HasClient.hs
4+++ b/src/Servant/Client/Core/Internal/HasClient.hs
5@@ -16,6 +16,8 @@ module Servant.Client.Core.Internal.HasClient where
6 import Prelude ()
7 import Prelude.Compat
8
9+import Control.Concurrent.MVar
10+ (modifyMVar, newMVar)
11 import qualified Data.ByteString as BS
12 import qualified Data.ByteString.Lazy as BL
13 import Data.Foldable
14@@ -36,13 +38,14 @@ import qualified Network.HTTP.Types as H
15 import Servant.API
16 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
17 BuildHeadersTo (..), Capture', CaptureAll, Description,
18- EmptyAPI, FramingUnrender (..), FromSourceIO (..), Header',
19- Headers (..), HttpVersion, IsSecure, MimeRender (mimeRender),
20+ EmptyAPI, FramingRender (..), FramingUnrender (..),
21+ FromSourceIO (..), Header', Headers (..), HttpVersion,
22+ IsSecure, MimeRender (mimeRender),
23 MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
24 QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
25 ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
26- Vault, Verb, WithNamedContext, contentType, getHeadersHList,
27- getResponse, toQueryParam, toUrlPiece)
28+ ToSourceIO (..), Vault, Verb, WithNamedContext, contentType,
29+ getHeadersHList, getResponse, toQueryParam, toUrlPiece)
30 import Servant.API.ContentTypes
31 (contentTypes)
32 import Servant.API.Modifiers
33@@ -538,7 +541,7 @@ instance (MimeRender ct a, HasClient m api)
34 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
35
36 instance
37- ( HasClient m api
38+ ( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a
39 ) => HasClient m (StreamBody' mods framing ctype a :> api)
40 where
41
42@@ -547,7 +550,39 @@ instance
43 hoistClientMonad pm _ f cl = \a ->
44 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
45
46- clientWithRoute _pm Proxy _req _body = error "HasClient @StreamBody"
47+ clientWithRoute pm Proxy req body
48+ = clientWithRoute pm (Proxy :: Proxy api)
49+ $ setRequestBody (RequestBodyStreamChunked givesPopper) (contentType ctypeP) req
50+ where
51+ ctypeP = Proxy :: Proxy ctype
52+ framingP = Proxy :: Proxy framing
53+
54+ sourceIO = framingRender
55+ framingP
56+ (mimeRender ctypeP :: chunk -> BL.ByteString)
57+ (toSourceIO body)
58+
59+ -- not pretty.
60+ givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()
61+ givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do
62+ ref <- newMVar step0
63+
64+ -- Note sure we need locking, but it's feels safer.
65+ let popper :: IO BS.ByteString
66+ popper = modifyMVar ref nextBs
67+
68+ needsPopper popper
69+
70+ nextBs S.Stop = return (S.Stop, BS.empty)
71+ nextBs (S.Error err) = fail err
72+ nextBs (S.Skip s) = nextBs s
73+ nextBs (S.Effect ms) = ms >>= nextBs
74+ nextBs (S.Yield lbs s) = case BL.toChunks lbs of
75+ [] -> nextBs s
76+ (x:xs) | BS.null x -> nextBs step'
77+ | otherwise -> return (step', x)
78+ where
79+ step' = S.Yield (BL.fromChunks xs) s
80
81
82