git.iko.soy/reflex-dom
on develop help sign in
Allow sending websocket messages in binary or text
commit0bc7f678b2685781807e422ca9a44e271e75d2f1 authorAnupam Jain <ajnsit@gmail.com> dateWed 24 Aug 2016, 00:34 (10 years ago) parentd7c49fb
3 files changed+57−27
compare with develop
unifiedsplit
src-ghc/Reflex/Dom/WebSocket/Foreign.hs+29−15 src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+18−8 src/Reflex/Dom/WebSocket.hs+10−4
src-ghc/Reflex/Dom/WebSocket/Foreign.hs+29−15
@@ -1,3 +1,4 @@
1+{-# LANGUAGE TemplateHaskell #-}
12{-# LANGUAGE AllowAmbiguousTypes #-}
23{-# LANGUAGE ConstraintKinds #-}
34{-# LANGUAGE FlexibleContexts #-}
@@ -32,12 +33,40 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
3233import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
3334import Graphics.UI.Gtk.WebKit.WebView
3435
36+import Foreign.JavaScript.TH
3537import Reflex.Dom.Internal.Foreign
3638
3739data JSWebSocket = JSWebSocket { wsValue :: JSValueRef
3840 , wsContext :: JSContextRef
3941 }
4042
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+
4170newWebSocket :: WebView -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket
4271newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do
4372 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring (T.unpack url)
@@ -66,18 +95,3 @@ newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do
6695 addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onclose'] = this[3];"
6796 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr
6897 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
1010import Data.ByteString (ByteString)
1111import qualified Data.ByteString as BS
1212import Data.Text (Text)
13+import qualified Data.Text as T (unpack)
1314import Data.Text.Encoding
1415import GHCJS.Buffer
1516import GHCJS.DOM.EventM (on)
@@ -24,6 +25,23 @@ import JavaScript.TypedArray.ArrayBuffer as JS
2425
2526data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }
2627
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+
2745newWebSocket :: a -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket
2846newWebSocket _ url onMessage onOpen onClose = do
2947 ws <- GD.newWebSocket url (Just [] :: Maybe [Text])
@@ -40,12 +58,4 @@ newWebSocket _ url onMessage onOpen onClose = do
4058 _ <- on ws closeEvent $ liftIO onClose
4159 return $ JSWebSocket ws
4260
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−
5161foreign 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
4242import Data.Maybe (isJust)
4343import Data.Text
4444
45−data WebSocketConfig t
46− = WebSocketConfig { _webSocketConfig_send :: Event t [ByteString]
45+data WebSocketConfig t a
46+ = WebSocketConfig { _webSocketConfig_send :: Event t [a]
4747 }
4848
49−instance Reflex t => Default (WebSocketConfig t) where
49+instance Reflex t => Default (WebSocketConfig t a) where
5050 def = WebSocketConfig never
5151
5252data WebSocket t
@@ -54,7 +54,13 @@ data WebSocket t
5454 , _webSocket_open :: Event t ()
5555 }
5656
57−webSocket :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m) => Text -> WebSocketConfig t -> m (WebSocket t)
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+
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)
5864webSocket url config = do
5965 wv <- fmap unWebViewSingleton askWebView
6066 (eRecv, onMessage) <- newTriggerEvent