1d87931 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Provide instance XhrPayload ByteString, factor out ByteString ArrayBuffer conversions

1d87931Maciej Kazulak10 years ago

reflex-dom-core/src/Foreign/JavaScript/Utils.hsnew file+42

compare with develop

unifiedsplit

@@ -0,0 +1,42 @@

1+{-# LANGUAGE CPP #-}

2+#ifdef __GHCJS__

3+{-# LANGUAGE ForeignFunctionInterface #-}

4+{-# LANGUAGE JavaScriptFFI #-}

5+#endif

7+module Foreign.JavaScript.Utils

8+ ( bsFromMutableArrayBuffer

9+ , bsToArrayBuffer

10+ ) where

11+

12+import Data.ByteString (ByteString)

13+import qualified Data.ByteString as BS

14+import qualified GHCJS.Buffer as JS

15+import GHCJS.DOM.Types (ArrayBuffer (..))

16+import qualified JavaScript.TypedArray.ArrayBuffer as JS

17+import Language.Javascript.JSaddle.Types (JSVal, JSM, MonadJSM, liftJSM, ghcjsPure, jsval)

18+#ifndef __GHCJS__

19+import Language.Javascript.JSaddle.Object (new, jsg)

20+#endif

21+

22+{-# INLINABLE bsFromMutableArrayBuffer #-}

23+bsFromMutableArrayBuffer :: MonadJSM m => JS.MutableArrayBuffer -> m ByteString

24+bsFromMutableArrayBuffer ab = liftJSM $ JS.unsafeFreeze ab >>=

25+ ghcjsPure . JS.createFromArrayBuffer >>= ghcjsPure . JS.toByteString 0 Nothing

26+

27+{-# INLINABLE bsToArrayBuffer #-}

28+bsToArrayBuffer :: MonadJSM m => ByteString -> m ArrayBuffer

29+bsToArrayBuffer bs = liftJSM $ do

30+ (b, off, len) <- ghcjsPure $ JS.fromByteString bs

31+ ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed

32+ then JS.create 0 >>= ghcjsPure . JS.getArrayBuffer >>= ghcjsPure . jsval

33+ else do

34+ ref <- ghcjsPure (JS.getArrayBuffer b) >>= ghcjsPure . jsval

35+ js_dataView off len ref

36+

37+#ifdef __GHCJS__

38+foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> IO JSVal

39+#else

40+js_dataView :: Int -> Int -> JSVal -> JSM JSVal

41+js_dataView off len ref = new (jsg "DataView") (ref, off, len)

42+#endif

reflex-dom-core/src/Reflex/Dom/WebSocket/Foreign.hs+4−22

@@ -14,24 +14,18 @@ import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)

15import Control.Monad.Reader

16import Data.ByteString (ByteString)

17−import qualified Data.ByteString as BS

18import Data.Text (Text)

17import Data.Text (Text)

19import qualified Data.Text as T (unpack)

18import qualified Data.Text as T (unpack)

20import Data.Text.Encoding

19import Data.Text.Encoding

21−import GHCJS.Buffer

20+import Foreign.JavaScript.Utils (bsFromMutableArrayBuffer, bsToArrayBuffer)

22import GHCJS.DOM.CloseEvent

21import GHCJS.DOM.CloseEvent

23import GHCJS.DOM.EventM (on)

22import GHCJS.DOM.EventM (on)

24import GHCJS.DOM.MessageEvent

23import GHCJS.DOM.MessageEvent

25import GHCJS.DOM.Types hiding (Text)

24import GHCJS.DOM.Types hiding (Text)

26import qualified GHCJS.DOM.WebSocket as GD

25import qualified GHCJS.DOM.WebSocket as GD

27import GHCJS.Foreign (JSType(..), jsTypeOf)

26import GHCJS.Foreign (JSType(..), jsTypeOf)

28−import GHCJS.Types

29−import JavaScript.TypedArray.ArrayBuffer as JS

30import Language.Javascript.JSaddle.Helper (mutableArrayBufferFromJSVal)

27import Language.Javascript.JSaddle.Helper (mutableArrayBufferFromJSVal)

31import Language.Javascript.JSaddle.Types (ghcjsPure)

28import Language.Javascript.JSaddle.Types (ghcjsPure)

32−#ifndef ghcjs_HOST_OS

33−import Language.Javascript.JSaddle.Object (new, jsg)

34−#endif

36data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }

30data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }

@@ -42,12 +36,7 @@ class IsWebSocketMessage a where

42-- Note: Binary websockets may not work correctly in IE 11 and below

36-- Note: Binary websockets may not work correctly in IE 11 and below

43instance IsWebSocketMessage ByteString where

37instance IsWebSocketMessage ByteString where

44 webSocketSend (JSWebSocket ws) bs = do

38 webSocketSend (JSWebSocket ws) bs = do

45− (b, off, len) <- ghcjsPure $ fromByteString bs

39+ ab <- bsToArrayBuffer bs

46− ab <- ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed

47− then create 0 >>= ghcjsPure . getArrayBuffer >>= ghcjsPure . jsval

48− else do

49− ref <- ghcjsPure (getArrayBuffer b) >>= ghcjsPure . jsval

50− js_dataView off len ref -- new (jsg "DataView") (ref, off, len)

51 GD.send ws $ Just ab

40 GD.send ws $ Just ab

53-- Use plaintext websocket communication for Text, and String

42-- Use plaintext websocket communication for Text, and String

@@ -82,16 +71,9 @@ newWebSocket _ url onMessage onOpen onError onClose = do

82 liftJSM $ ghcjsPure (jsTypeOf d) >>= \case

71 liftJSM $ ghcjsPure (jsTypeOf d) >>= \case

83 String -> onMessage $ Right d

72 String -> onMessage $ Right d

84 _ -> do

73 _ -> do

85− ab <- mutableArrayBufferFromJSVal d >>= unsafeFreeze

74+ ab <- mutableArrayBufferFromJSVal d

86− ghcjsPure (createFromArrayBuffer ab) >>= ghcjsPure . toByteString 0 Nothing >>= onMessage . Left

75+ bsFromMutableArrayBuffer ab >>= onMessage . Left

87 return $ JSWebSocket ws

76 return $ JSWebSocket ws

89−#ifdef ghcjs_HOST_OS

90−foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> IO JSVal

91−#else

92−js_dataView :: Int -> Int -> JSVal -> JSM JSVal

93−js_dataView off len ref = new (jsg "DataView") (ref, off, len)

94−#endif

95−

96onBSMessage :: Either ByteString JSVal -> JSM ByteString

78onBSMessage :: Either ByteString JSVal -> JSM ByteString

97onBSMessage = either return (\v -> encodeUtf8 <$> fromJSValUnchecked v)

79onBSMessage = either return (\v -> encodeUtf8 <$> fromJSValUnchecked v)

reflex-dom-core/src/Reflex/Dom/Xhr/Foreign.hs+12−12

@@ -15,21 +15,17 @@ import Control.Monad.IO.Class (MonadIO(..))

15import Data.Maybe (fromMaybe)

16import Data.Text (Text)

17import Data.ByteString (ByteString)

18+import Foreign.JavaScript.Utils (bsFromMutableArrayBuffer, bsToArrayBuffer)

18import GHCJS.DOM.Enums

19import GHCJS.DOM.Enums

19import GHCJS.DOM.EventM (EventM, on)

20import GHCJS.DOM.EventM (EventM, on)

20import GHCJS.DOM.EventTarget (dispatchEvent)

21import GHCJS.DOM.EventTarget (dispatchEvent)

21import GHCJS.DOM.Types hiding (Text)

22import GHCJS.DOM.Types hiding (Text)

22import GHCJS.DOM.XMLHttpRequest

23import GHCJS.DOM.XMLHttpRequest

23−-- import GHCJS.Types

24+import Language.Javascript.JSaddle.Helper (mutableArrayBufferFromJSVal)

25+import qualified Language.Javascript.JSaddle.Monad as JS (catch)

24import Prelude hiding (error)

26import Prelude hiding (error)

25import Reflex.Dom.Xhr.Exception

27import Reflex.Dom.Xhr.Exception

26import Reflex.Dom.Xhr.ResponseType

28import Reflex.Dom.Xhr.ResponseType

27−import Language.Javascript.JSaddle.Types (ghcjsPure)

28−import qualified Language.Javascript.JSaddle.Monad as JS (catch)

29−import qualified GHCJS.Buffer as JS

30− (createFromArrayBuffer, toByteString)

31−import qualified JavaScript.TypedArray.ArrayBuffer as JS

32− (unsafeFreeze, MutableArrayBuffer)

34xmlHttpRequestNew :: MonadJSM m => m XMLHttpRequest

30xmlHttpRequestNew :: MonadJSM m => m XMLHttpRequest

35xmlHttpRequestNew = newXMLHttpRequest

31xmlHttpRequestNew = newXMLHttpRequest

@@ -65,6 +61,12 @@ instance IsXhrPayload Document where

65instance IsXhrPayload Blob where

61instance IsXhrPayload Blob where

66 sendXhrPayload = sendBlob

62 sendXhrPayload = sendBlob

64+instance IsXhrPayload ArrayBuffer where

65+ sendXhrPayload xhr ab = sendArrayBuffer xhr (ArrayBufferView $ unArrayBuffer ab)

66+

67+instance IsXhrPayload ByteString where

68+ sendXhrPayload xhr bs = sendXhrPayload xhr =<< liftJSM (bsToArrayBuffer bs)

69+

68newtype XhrPayload = XhrPayload { unXhrPayload :: JSVal }

70newtype XhrPayload = XhrPayload { unXhrPayload :: JSVal }

70-- This used to be a non blocking call, but now it uses an interruptible ffi

72-- This used to be a non blocking call, but now it uses an interruptible ffi

@@ -178,9 +180,7 @@ xmlHttpRequestGetResponse xhr = do

178 Just XhrResponseType_Default -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr

180 Just XhrResponseType_Default -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr

179 Just XhrResponseType_ArrayBuffer -> case fmap unGObject mr of

181 Just XhrResponseType_ArrayBuffer -> case fmap unGObject mr of

180 Nothing -> return Nothing

182 Nothing -> return Nothing

183+ Just ptr -> do

184+ ab <- liftJSM $ mutableArrayBufferFromJSVal ptr

181− Just ptr -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer (pFromJSVal ptr)

185+ Just . XhrResponseBody_ArrayBuffer <$> bsFromMutableArrayBuffer ab

182 _ -> return Nothing

186 _ -> return Nothing

183−

184−bsFromArrayBuffer :: MonadJSM m => JS.MutableArrayBuffer -> m ByteString

185−bsFromArrayBuffer ab = liftJSM $ JS.unsafeFreeze ab >>=

186− ghcjsPure . JS.createFromArrayBuffer >>= ghcjsPure . JS.toByteString 0 Nothing