From 108df0857e53c3c84c1e4a5000927bdb8902237b Mon Sep 17 00:00:00 2001 From: Falco Peijnenburg Date: Sun, 1 Apr 2018 22:54:37 +0200 Subject: [PATCH] servant-client-ghcjs: Support binary requests Introduces support for both sending and receiving binary data --- .../src/Servant/Client/Internal/XhrClient.hs | 51 ++++++++++++------- 1 file changed, 34 insertions(+), 17 deletions(-) diff --git a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs index 74deb0ab..723edd34 100644 --- a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs +++ b/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,35 +224,38 @@ 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 @@ -253,6 +263,8 @@ toBody request = case requestBody request of 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)