servant-client-ghcjs: Support binary requests

Introduces support for both sending and receiving binary data

Author: Falco Peijnenburg

servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs

@@ -26,6 +26,7 @@ import           Control.Monad.Trans.Control (MonadBaseControl (..))
 import           Control.Monad.Trans.Except
 import           Data.ByteString.Builder     (toLazyByteString)
 import qualified Data.ByteString.Char8       as BS
+import qualified Data.ByteString.Lazy        as BL
 import           Data.CaseInsensitive
 import           Data.Char
 import           Data.Foldable               (toList)
@@ -36,9 +37,11 @@ import qualified Data.Sequence               as Seq
 import           Data.String.Conversions
 import           Foreign.StablePtr
 import           GHC.Generics
+import qualified GHCJS.Buffer as Buffer
 import           GHCJS.Foreign.Callback
 import           GHCJS.Prim
 import           GHCJS.Types
+import           JavaScript.TypedArray.ArrayBuffer ( ArrayBuffer )
 import           JavaScript.Web.Location
 import           Network.HTTP.Media          (renderHeader)
 import           Network.HTTP.Types
@@ -153,6 +156,7 @@ performXhr xhr burl request = do
 
         openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
         setHeaders xhr request
+        js_setResponseType xhr "arraybuffer"
         body <- toBody request
         sendXhr xhr body
         takeMVar waiter
@@ -187,6 +191,9 @@ openXhr xhr method url =
 foreign import javascript unsafe "$1.open($2, $3, $4)"
   js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
 
+foreign import javascript unsafe "$1.responseType = $2;"
+  js_setResponseType :: JSXMLHttpRequest -> JSString -> IO ()
+
 toUrl :: BaseUrl -> Request -> String
 toUrl burl request =
   let pathS = cs $ toLazyByteString $ requestPath request
@@ -217,42 +224,47 @@ setHeaders xhr request = do
 foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
   js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
 
-sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()
+sendXhr :: JSXMLHttpRequest -> Maybe ArrayBuffer -> IO ()
 sendXhr xhr Nothing = js_sendXhr xhr
 sendXhr xhr (Just body) =
-  js_sendXhrWithBody xhr (toJSString body)
+  js_sendXhrWithBody xhr body
 
 foreign import javascript unsafe "$1.send()"
   js_sendXhr :: JSXMLHttpRequest -> IO ()
 
 foreign import javascript unsafe "$1.send($2)"
-  js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
+  js_sendXhrWithBody :: JSXMLHttpRequest -> ArrayBuffer -> IO ()
 
-toBody :: Request -> IO (Maybe String)
+toBody :: Request -> IO (Maybe ArrayBuffer)
 toBody request = case requestBody request of
   Nothing -> return Nothing
-  Just (a, _) -> go a
+  Just (a, _) -> Just <$> go a
 
   where
-    go :: RequestBody -> IO (Maybe String)
+    go :: RequestBody -> IO ArrayBuffer
     go x = case x of
-      RequestBodyLBS x -> return $ mBody x
+      RequestBodyLBS x -> return $ mBody $ BL.toStrict x
       RequestBodyBS x -> return $ mBody x
-      RequestBodyBuilder _ x -> return $ mBody $ toLazyByteString x
+      RequestBodyBuilder _ x -> return $ mBody $ BL.toStrict $ toLazyByteString x
       RequestBodyStream _ x -> mBody <$> readBody x
       RequestBodyStreamChunked x -> mBody <$> readBody x
       RequestBodyIO x -> x >>= go
 
-    mBody :: ConvertibleStrings a String => a -> Maybe String
-    mBody x = let y = cs x in if y == "" then Nothing else Just y
+    mBody :: BS.ByteString -> ArrayBuffer
+    mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer
+      where
+        (buffer, offset, len) = Buffer.fromByteString bs
 
+    readBody :: ((IO BS.ByteString -> IO ()) -> IO a) -> IO BS.ByteString
     readBody writer = do
       m <- newIORef mempty
       _ <- writer (\bsAct -> do
         bs <- bsAct
         modifyIORef m (<> bs))
       readIORef m
 
+foreign import javascript unsafe "$3.slice($1, $1 + $2)"
+  js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer
 
 -- * inspecting the xhr response
 
@@ -266,10 +278,10 @@ toResponse xhr = do
     _ -> liftIO $ do
       statusText <- cs <$> getStatusText xhr
       headers <- parseHeaders <$> getAllResponseHeaders xhr
-      responseText <- cs <$> getResponseText xhr
+      response <- getResponse xhr
       pure Response
         { responseStatusCode = mkStatus status statusText
-        , responseBody = responseText
+        , responseBody = response
         , responseHeaders = Seq.fromList headers
         , responseHttpVersion = http11 -- this is made up
         }
@@ -288,14 +300,19 @@ getAllResponseHeaders xhr =
 foreign import javascript unsafe "$1.getAllResponseHeaders()"
   js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
 
-getResponseText :: JSXMLHttpRequest -> IO String
-getResponseText xhr = fromJSString <$> js_responseText xhr
-foreign import javascript unsafe "$1.responseText"
-  js_responseText :: JSXMLHttpRequest -> IO JSVal
+getResponse :: JSXMLHttpRequest -> IO BL.ByteString
+getResponse xhr =
+    BL.fromStrict
+  . Buffer.toByteString 0 Nothing
+  . Buffer.createFromArrayBuffer
+  <$> js_response xhr
+
+foreign import javascript unsafe "$1.response"
+  js_response :: JSXMLHttpRequest -> IO ArrayBuffer
 
 parseHeaders :: String -> ResponseHeaders
 parseHeaders s =
-  (first mk . first strip . second strip . parseHeader) <$>
+  first mk . first strip . second strip . parseHeader <$>
   splitOn "\r\n" (cs s)
   where
     parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)