@@ -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