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