haskellPackages.servant-client-core: patch out runtime error

1 files changed, 82 insertions, 0 deletions

diff --git a/pkgs/development/haskell-modules/patches/servant-client-core-streamBody.patch b/pkgs/development/haskell-modules/patches/servant-client-core-streamBody.patch
new file mode 100644
index 00000000000..ebadd215cb7
--- /dev/null
+++ b/pkgs/development/haskell-modules/patches/servant-client-core-streamBody.patch
@@ -0,0 +1,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
+
+
+