@@ -26,6 +26,7 @@ import Control.Monad.Trans.Control (MonadBaseControl (..))
2626import Control.Monad.Trans.Except
2727import Data.ByteString.Builder (toLazyByteString)
2828import qualified Data.ByteString.Char8 as BS
29+import qualified Data.ByteString.Lazy as BL
2930import Data.CaseInsensitive
3031import Data.Char
3132import Data.Foldable (toList)
@@ -36,9 +37,11 @@ import qualified Data.Sequence as Seq
3637import Data.String.Conversions
3738import Foreign.StablePtr
3839import GHC.Generics
40+import qualified GHCJS.Buffer as Buffer
3941import GHCJS.Foreign.Callback
4042import GHCJS.Prim
4143import GHCJS.Types
44+import JavaScript.TypedArray.ArrayBuffer ( ArrayBuffer )
4245import JavaScript.Web.Location
4346import Network.HTTP.Media (renderHeader)
4447import Network.HTTP.Types
@@ -153,6 +156,7 @@ performXhr xhr burl request = do
153156
154157 openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
155158 setHeaders xhr request
159+ js_setResponseType xhr "arraybuffer"
156160 body <- toBody request
157161 sendXhr xhr body
158162 takeMVar waiter
@@ -187,6 +191,9 @@ openXhr xhr method url =
187191foreign import javascript unsafe "$1.open($2, $3, $4)"
188192 js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
189193
194+foreign import javascript unsafe "$1.responseType = $2;"
195+ js_setResponseType :: JSXMLHttpRequest -> JSString -> IO ()
196+
190197toUrl :: BaseUrl -> Request -> String
191198toUrl burl request =
192199 let pathS = cs $ toLazyByteString $ requestPath request
@@ -217,35 +224,38 @@ setHeaders xhr request = do
217224foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
218225 js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
219226
220−sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()
227+sendXhr :: JSXMLHttpRequest -> Maybe ArrayBuffer -> IO ()
221228sendXhr xhr Nothing = js_sendXhr xhr
222229sendXhr xhr (Just body) =
223− js_sendXhrWithBody xhr (toJSString body)
230+ js_sendXhrWithBody xhr body
224231
225232foreign import javascript unsafe "$1.send()"
226233 js_sendXhr :: JSXMLHttpRequest -> IO ()
227234
228235foreign import javascript unsafe "$1.send($2)"
229− js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
236+ js_sendXhrWithBody :: JSXMLHttpRequest -> ArrayBuffer -> IO ()
230237
231−toBody :: Request -> IO (Maybe String)
238+toBody :: Request -> IO (Maybe ArrayBuffer)
232239toBody request = case requestBody request of
233240 Nothing -> return Nothing
234− Just (a, _) -> go a
241+ Just (a, _) -> Just <$> go a
235242
236243 where
237− go :: RequestBody -> IO (Maybe String)
244+ go :: RequestBody -> IO ArrayBuffer
238245 go x = case x of
239− RequestBodyLBS x -> return $ mBody x
246+ RequestBodyLBS x -> return $ mBody $ BL.toStrict x
240247 RequestBodyBS x -> return $ mBody x
241− RequestBodyBuilder _ x -> return $ mBody $ toLazyByteString x
248+ RequestBodyBuilder _ x -> return $ mBody $ BL.toStrict $ toLazyByteString x
242249 RequestBodyStream _ x -> mBody <$> readBody x
243250 RequestBodyStreamChunked x -> mBody <$> readBody x
244251 RequestBodyIO x -> x >>= go
245252
246− mBody :: ConvertibleStrings a String => a -> Maybe String
247− mBody x = let y = cs x in if y == "" then Nothing else Just y
253+ mBody :: BS.ByteString -> ArrayBuffer
254+ mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer
255+ where
256+ (buffer, offset, len) = Buffer.fromByteString bs
248257
258+ readBody :: ((IO BS.ByteString -> IO ()) -> IO a) -> IO BS.ByteString
249259 readBody writer = do
250260 m <- newIORef mempty
251261 _ <- writer (\bsAct -> do
@@ -253,6 +263,8 @@ toBody request = case requestBody request of
253263 modifyIORef m (<> bs))
254264 readIORef m
255265
266+foreign import javascript unsafe "$3.slice($1, $1 + $2)"
267+ js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer
256268
257269-- * inspecting the xhr response
258270
@@ -266,10 +278,10 @@ toResponse xhr = do
266278 _ -> liftIO $ do
267279 statusText <- cs <$> getStatusText xhr
268280 headers <- parseHeaders <$> getAllResponseHeaders xhr
269− responseText <- cs <$> getResponseText xhr
281+ response <- getResponse xhr
270282 pure Response
271283 { responseStatusCode = mkStatus status statusText
272− , responseBody = responseText
284+ , responseBody = response
273285 , responseHeaders = Seq.fromList headers
274286 , responseHttpVersion = http11 -- this is made up
275287 }
@@ -288,14 +300,19 @@ getAllResponseHeaders xhr =
288300foreign import javascript unsafe "$1.getAllResponseHeaders()"
289301 js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
290302
291−getResponseText :: JSXMLHttpRequest -> IO String
292−getResponseText xhr = fromJSString <$> js_responseText xhr
293−foreign import javascript unsafe "$1.responseText"
294− js_responseText :: JSXMLHttpRequest -> IO JSVal
303+getResponse :: JSXMLHttpRequest -> IO BL.ByteString
304+getResponse xhr =
305+ BL.fromStrict
306+ . Buffer.toByteString 0 Nothing
307+ . Buffer.createFromArrayBuffer
308+ <$> js_response xhr
309+
310+foreign import javascript unsafe "$1.response"
311+ js_response :: JSXMLHttpRequest -> IO ArrayBuffer
295312
296313parseHeaders :: String -> ResponseHeaders
297314parseHeaders s =
298− (first mk . first strip . second strip . parseHeader) <$>
315+ first mk . first strip . second strip . parseHeader <$>
299316 splitOn "\r\n" (cs s)
300317 where
301318 parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)