@@ -15,7 +15,6 @@
1515module Servant.Client.Internal.XhrClient where
1616
1717import Control.Arrow
18−import Data.ByteString.Builder (toLazyByteString)
1918import Control.Concurrent
2019import Control.Exception
2120import Control.Monad
@@ -25,13 +24,15 @@ import Control.Monad.Error.Class (MonadError (..))
2524import Control.Monad.Reader
2625import Control.Monad.Trans.Control (MonadBaseControl (..))
2726import Control.Monad.Trans.Except
28−import qualified Data.ByteString.Char8 as BS
27+import Data.ByteString.Builder (toLazyByteString)
28+import qualified Data.ByteString.Char8 as BS
2929import Data.CaseInsensitive
3030import Data.Char
3131import Data.Foldable (toList)
3232import Data.Functor.Alt (Alt (..))
33+import Data.IORef (modifyIORef, newIORef, readIORef)
3334import Data.Proxy (Proxy (..))
34−import qualified Data.Sequence as Seq
35+import qualified Data.Sequence as Seq
3536import Data.String.Conversions
3637import Foreign.StablePtr
3738import GHC.Generics
@@ -39,8 +40,8 @@ import GHCJS.Foreign.Callback
3940import GHCJS.Prim
4041import GHCJS.Types
4142import JavaScript.Web.Location
43+import Network.HTTP.Media (renderHeader)
4244import Network.HTTP.Types
43−import Network.HTTP.Media (renderHeader)
4445import Servant.Client.Core
4546
4647newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
@@ -152,7 +153,8 @@ performXhr xhr burl request = do
152153
153154 openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
154155 setHeaders xhr request
155− sendXhr xhr (toBody request)
156+ body <- toBody request
157+ sendXhr xhr body
156158 takeMVar waiter
157159
158160 freeStablePtr s
@@ -226,11 +228,31 @@ foreign import javascript unsafe "$1.send()"
226228foreign import javascript unsafe "$1.send($2)"
227229 js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
228230
229−toBody :: Request -> Maybe String
231+toBody :: Request -> IO (Maybe String)
230232toBody request = case requestBody request of
231− Nothing -> Nothing
232− Just (RequestBodyLBS "", _) -> Nothing
233− Just (RequestBodyLBS x, _) -> Just $ cs x
233+ Nothing -> return Nothing
234+ Just (a, _) -> go a
235+
236+ where
237+ go :: RequestBody -> IO (Maybe String)
238+ go x = case x of
239+ RequestBodyLBS x -> return $ mBody x
240+ RequestBodyBS x -> return $ mBody x
241+ RequestBodyBuilder _ x -> return $ mBody $ toLazyByteString x
242+ RequestBodyStream _ x -> mBody <$> readBody x
243+ RequestBodyStreamChunked x -> mBody <$> readBody x
244+ RequestBodyIO x -> x >>= go
245+
246+ mBody :: ConvertibleStrings a String => a -> Maybe String
247+ mBody x = let y = cs x in if y == "" then Nothing else Just y
248+
249+ readBody writer = do
250+ m <- newIORef mempty
251+ _ <- writer (\bsAct -> do
252+ bs <- bsAct
253+ modifyIORef m (<> bs))
254+ readIORef m
255+
234256
235257-- * inspecting the xhr response
236258