0bc7f67 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Allow sending websocket messages in binary or text

0bc7f67Anupam Jain10 years ago

src-ghc/Reflex/Dom/WebSocket/Foreign.hs+29−15

compare with develop

unifiedsplit

@@ -1,3 +1,4 @@

1+{-# LANGUAGE TemplateHaskell #-}

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

@@ -32,12 +33,40 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

32import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

33import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

33import Graphics.UI.Gtk.WebKit.WebView

34import Graphics.UI.Gtk.WebKit.WebView

36+import Foreign.JavaScript.TH

35import Reflex.Dom.Internal.Foreign

37import Reflex.Dom.Internal.Foreign

37data JSWebSocket = JSWebSocket { wsValue :: JSValueRef

39data JSWebSocket = JSWebSocket { wsValue :: JSValueRef

38 , wsContext :: JSContextRef

40 , wsContext :: JSContextRef

39 }

41 }

43+importJS Unsafe "this[0]['send'](this[1])" "_sendWSTextData" [t| forall x m. MonadJS x m => JSRef x -> String -> m () |]

44+

45+sendWSTextData :: JSWebSocket -> String -> IO ()

46+sendWSTextData (JSWebSocket ws c) str = runWithJSContext (_sendWSTextData (JSRef_JavaScriptCore ws) str) c

47+

48+class IsWebSocketMessage a where

49+ webSocketSend :: JSWebSocket -> a -> IO ()

50+

51+-- Use binary websocket communication for ByteString

52+instance IsWebSocketMessage ByteString where

53+ webSocketSend (JSWebSocket ws c) bs = do

54+ elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x

55+ let numElems = length elems

56+ bs' <- bracket (mallocArray numElems) free $ \elemsArr -> do

57+ pokeArray elemsArr elems

58+ a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr

59+ newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"

60+ jsevaluatescript c newUint8Array a nullPtr 1 nullPtr

61+ send <- jsstringcreatewithutf8cstring ""

62+ sendArgs <- toJSObject c [ws, bs']

63+ _ <- jsevaluatescript c send sendArgs nullPtr 1 nullPtr

64+ return ()

65+

66+-- Use plaintext websocket communication for Text

67+instance IsWebSocketMessage Text where

68+ webSocketSend jws t = sendWSTextData jws (T.unpack t)

69+

41newWebSocket :: WebView -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

70newWebSocket :: WebView -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

42newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do

71newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do

43 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring (T.unpack url)

72 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring (T.unpack url)

@@ -66,18 +95,3 @@ newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do

66 addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onclose'] = this[3];"

95 addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onclose'] = this[3];"

67 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr

96 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr

68 return $ JSWebSocket ws c

97 return $ JSWebSocket ws c

69−

70−webSocketSend :: JSWebSocket -> ByteString -> IO ()

71−webSocketSend (JSWebSocket ws c) bs = do

72− elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x

73− let numElems = length elems

74− bs' <- bracket (mallocArray numElems) free $ \elemsArr -> do

75− pokeArray elemsArr elems

76− a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr

77− newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"

78− jsevaluatescript c newUint8Array a nullPtr 1 nullPtr

79− send <- jsstringcreatewithutf8cstring "this[0]['send'](String['fromCharCode']['apply'](null, this[1]))"

80− sendArgs <- toJSObject c [ws, bs']

81− _ <- jsevaluatescript c send sendArgs nullPtr 1 nullPtr

82− return ()

83−

src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+18−8

@@ -10,6 +10,7 @@ import Control.Monad.Reader

10import Data.ByteString (ByteString)

11import qualified Data.ByteString as BS

12import Data.Text (Text)

13+import qualified Data.Text as T (unpack)

13import Data.Text.Encoding

14import Data.Text.Encoding

14import GHCJS.Buffer

15import GHCJS.Buffer

15import GHCJS.DOM.EventM (on)

16import GHCJS.DOM.EventM (on)

@@ -24,6 +25,23 @@ import JavaScript.TypedArray.ArrayBuffer as JS

25data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }

26data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }

28+class IsWebSocketMessage a where

29+ webSocketSend :: JSWebSocket -> a -> IO ()

30+

31+-- Use binary websocket communication for ByteString

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

33+instance IsWebSocketMessage ByteString where

34+ webSocketSend (JSWebSocket ws) bs = do

35+ let (b, off, len) = fromByteString bs

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

37+ then jsval . getArrayBuffer <$> create 0

38+ else return $ js_dataView off len $ jsval $ getArrayBuffer b

39+ GD.send ws $ Just ab

40+

41+-- Use plaintext websocket communication for Text, and String

42+instance IsWebSocketMessage Text where

43+ webSocketSend (JSWebSocket ws) = GD.sendString ws . T.unpack

44+

27newWebSocket :: a -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

45newWebSocket :: a -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

28newWebSocket _ url onMessage onOpen onClose = do

46newWebSocket _ url onMessage onOpen onClose = do

29 ws <- GD.newWebSocket url (Just [] :: Maybe [Text])

47 ws <- GD.newWebSocket url (Just [] :: Maybe [Text])

@@ -40,12 +58,4 @@ newWebSocket _ url onMessage onOpen onClose = do

40 _ <- on ws closeEvent $ liftIO onClose

58 _ <- on ws closeEvent $ liftIO onClose

41 return $ JSWebSocket ws

59 return $ JSWebSocket ws

43−webSocketSend :: JSWebSocket -> ByteString -> IO ()

44−webSocketSend (JSWebSocket ws) bs = do

45− let (b, off, len) = fromByteString 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 jsval . getArrayBuffer <$> create 0

48− else return $ js_dataView off len $ jsval $ getArrayBuffer b

49− GD.send ws $ Just ab

50−

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

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

src/Reflex/Dom/WebSocket.hs+10−4

@@ -42,11 +42,11 @@ import Data.IORef

42import Data.Maybe (isJust)

43import Data.Text

45−data WebSocketConfig t

45+data WebSocketConfig t a

46− = WebSocketConfig { _webSocketConfig_send :: Event t [ByteString]

46+ = WebSocketConfig { _webSocketConfig_send :: Event t [a]

47 }

49−instance Reflex t => Default (WebSocketConfig t) where

49+instance Reflex t => Default (WebSocketConfig t a) where

50 def = WebSocketConfig never

52data WebSocket t

@@ -54,7 +54,13 @@ data WebSocket t

54 , _webSocket_open :: Event t ()

55 }

57+-- This can be used to send either binary or text messages for the same websocket connection

58+instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Either a b) where

59+ webSocketSend jws (Left a) = webSocketSend jws a

60+ webSocketSend jws (Right a) = webSocketSend jws a

61+

62+

57−webSocket :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m) => Text -> WebSocketConfig t -> m (WebSocket t)

63+webSocket :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> m (WebSocket t)

58webSocket url config = do

64webSocket url config = do

59 wv <- fmap unWebViewSingleton askWebView

65 wv <- fmap unWebViewSingleton askWebView

60 (eRecv, onMessage) <- newTriggerEvent

66 (eRecv, onMessage) <- newTriggerEvent