servant-client-ghcjs: Support binary requests
Introduces support for both sending and receiving binary data
This commit is contained in:
Falco Peijnenburg
Falco Peijnenburg
parent
0c66b9c055
commit
108df0857e
1 changed files with 34 additions and 17 deletions
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue