git.iko.soy/reflex-dom
on develop help sign in
Merge remote-tracking branch 'origin/develop' into fix-dyn-pattern-match
commit6f958965d84653052b516820ecb8909109de905c authorAli Abrar <aliabrar@gmail.com> dateTue 1 Dec 2015, 10:59 (11 years ago) parent23e45fea10ddfd
3 files changed+27−13
compare with develop
unifiedsplit
src-ghc/Reflex/Dom/WebSocket/Foreign.hs+8−4 src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+12−7 src/Reflex/Dom/WebSocket.hs+7−2
src-ghc/Reflex/Dom/WebSocket/Foreign.hs+8−4
@@ -26,8 +26,8 @@ data JSWebSocket = JSWebSocket { wsValue :: JSValueRef
2626 , wsContext :: JSContextRef
2727 }
2828
29−newWebSocket :: WebView -> String -> (ByteString -> IO ()) -> IO () -> IO JSWebSocket
30−newWebSocket wv url onMessage onClose = do
29+newWebSocket :: WebView -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket
30+newWebSocket wv url onMessage onOpen onClose = do
3131 c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv
3232 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring url
3333 newWSArgs <- toJSObject c [url']
@@ -43,12 +43,16 @@ newWebSocket wv url onMessage onClose = do
4343 Just m -> onMessage $ encodeUtf8 $ T.pack m
4444 jsvaluemakeundefined c
4545 onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'
46+ onOpen' <- wrapper $ \_ _ _ _ _ _ -> do
47+ onOpen
48+ jsvaluemakeundefined c
49+ onOpenCb <- jsobjectmakefunctionwithcallback c nullPtr onOpen'
4650 onClose' <- wrapper $ \_ _ _ _ _ _ -> do
4751 onClose
4852 jsvaluemakeundefined c
4953 onCloseCb <- jsobjectmakefunctionwithcallback c nullPtr onClose'
50− o <- toJSObject c [ws, onMessageCb, onCloseCb]
51− addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onclose'] = this[2];"
54+ o <- toJSObject c [ws, onMessageCb, onOpenCb, onCloseCb]
55+ addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onclose'] = this[3];"
5256 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr
5357 return $ JSWebSocket ws c
5458
src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+12−7
@@ -10,30 +10,35 @@ import Data.Text.Encoding
1010import qualified Data.ByteString as BS
1111import Foreign.Ptr
1212import GHCJS.Foreign
13+import GHCJS.Marshal
1314import GHCJS.Types
15+import GHCJS.DOM.EventM
16+import GHCJS.DOM.Types
1417
1518#define JS(name, js, type) foreign import javascript unsafe js name :: type
1619
17−newtype JSWebSocket = JSWebSocket { unWebSocket :: JSRef JSWebSocket }
20+newtype JSWebSocket = JSWebSocket { unJSWebSocket :: JSRef JSWebSocket }
1821
1922data JSByteArray
2023JS(extractByteArray, "new Uint8Array($1_1.buf, $1_2, $2)", Ptr a -> Int -> IO (JSRef JSByteArray))
2124
22−JS(newWebSocket_, "(function() { var ws = new WebSocket($1); ws['binaryType'] = 'arraybuffer'; ws['onmessage'] = function(e){ $2(e['data']); }; ws['onclose'] = function(e){ $3(); }; return ws; })()", JSString -> JSFun (JSString -> IO ()) -> JSFun (IO ()) -> IO (JSRef JSWebSocket))
25+JS(newWebSocket_, "(function() { var ws = new WebSocket($1); ws['binaryType'] = 'arraybuffer'; ws['onmessage'] = function(e){ $2(e['data']); }; ws['onopen'] = function(e){ $3(); }; ws['onclose'] = function(e){ $4(); }; return ws; })()", JSString -> JSFun (JSString -> IO ()) -> JSFun (IO ()) -> JSFun (IO ()) -> IO (JSRef JSWebSocket))
2326
2427JS(webSocketSend_, "$1['send'](String.fromCharCode.apply(null, $2))", JSRef JSWebSocket -> JSRef JSByteArray -> IO ())
2528
2629webSocketSend :: JSWebSocket -> ByteString -> IO ()
2730webSocketSend ws bs = BS.useAsCString bs $ \cStr -> do
2831 ba <- extractByteArray cStr $ BS.length bs
29− webSocketSend_ (unWebSocket ws) ba
32+ webSocketSend_ (unJSWebSocket ws) ba
3033
31−newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO JSWebSocket
32−newWebSocket _ url onMessage onClose = do
34+newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket
35+newWebSocket _ url onMessage onOpen onClose = do
3336 onMessageFun <- syncCallback1 AlwaysRetain True $ onMessage <=< return . encodeUtf8 . fromJSString
3437 rec onCloseFun <- syncCallback AlwaysRetain True $ do
3538 release onMessageFun
3639 release onCloseFun
3740 onClose
38− liftM JSWebSocket $ newWebSocket_ (toJSString url) onMessageFun onCloseFun
39−
41+ onOpenFun <- syncCallback AlwaysRetain True $ do
42+ release onOpenFun
43+ onOpen
44+ liftM JSWebSocket $ newWebSocket_ (toJSString url) onMessageFun onOpenFun onCloseFun
src/Reflex/Dom/WebSocket.hs+7−2
@@ -29,6 +29,7 @@ instance Reflex t => Default (WebSocketConfig t) where
2929
3030data WebSocket t
3131 = WebSocket { _webSocket_recv :: Event t ByteString
32+ , _webSocket_open :: Event t ()
3233 }
3334
3435webSocket :: forall t m. (HasWebView m, MonadWidget t m) => String -> WebSocketConfig t -> m (WebSocket t)
@@ -39,12 +40,16 @@ webSocket url config = do
3940 (eRecv, eRecvTriggerRef) <- newEventWithTriggerRef
4041 currentSocketRef <- liftIO $ newIORef Nothing
4142 --TODO: Disconnect if value no longer needed
43+ (eOpen, eOpenTriggerRef) <- newEventWithTriggerRef
4244 let onMessage :: ByteString -> IO ()
4345 onMessage m = postGui $ do
4446 mt <- readRef eRecvTriggerRef
4547 forM_ mt $ \t -> runWithActions [t :=> m]
48+ onOpen = postGui $ do
49+ mt <- readRef eOpenTriggerRef
50+ forM_ mt $ \t -> runWithActions [t :=> ()]
4651 start = do
47− ws <- liftIO $ newWebSocket wv url onMessage $ do
52+ ws <- liftIO $ newWebSocket wv url onMessage onOpen $ do
4853 void $ forkIO $ do --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?
4954 liftIO $ writeIORef currentSocketRef Nothing
5055 liftIO $ threadDelay 1000000
@@ -58,6 +63,6 @@ webSocket url config = do
5863 Nothing -> return () -- Discard --TODO: should we do something better here? probably buffer it, since we handle reconnection logic; how do we verify that the server has received things?
5964 Just ws -> do
6065 liftIO $ webSocketSend ws payload
61− return $ WebSocket eRecv
66+ return $ WebSocket eRecv eOpen
6267
6368makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig