git.iko.soy/reflex-dom
on develop help sign in
Add websocket variant that exposes the raw message string value.
8d180ceLuigy Leon
src-ghc/Reflex/Dom/WebSocket/Foreign.hs+7−2
compare with develop
unifiedsplit
@@ -67,7 +67,7 @@ instance IsWebSocketMessage ByteString where
67instance IsWebSocketMessage Text where
67instance IsWebSocketMessage Text where
68 webSocketSend jws t = sendWSTextData jws (T.unpack t)
68 webSocketSend jws t = sendWSTextData jws (T.unpack t)
69
69
70−newWebSocket :: WebView -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket
70+newWebSocket :: WebView -> Text -> (Either ByteString a -> IO ()) -> IO () -> IO () -> IO JSWebSocket
71newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do
71newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do
72 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring (T.unpack url)
72 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring (T.unpack url)
73 newWSArgs <- toJSObject c [url']
73 newWSArgs <- toJSObject c [url']
@@ -80,7 +80,7 @@ newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do
80 msg' <- fromJSStringMaybe c msg
80 msg' <- fromJSStringMaybe c msg
81 case msg' of
81 case msg' of
82 Nothing -> return ()
82 Nothing -> return ()
83− Just m -> onMessage $ encodeUtf8 m
83+ Just m -> onMessage $ Left $ encodeUtf8 m
84 jsvaluemakeundefined c
84 jsvaluemakeundefined c
85 onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'
85 onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'
86 onOpen' <- wrapper $ \_ _ _ _ _ _ -> do
86 onOpen' <- wrapper $ \_ _ _ _ _ _ -> do
@@ -95,3 +95,8 @@ newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do
95 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];"
96 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr
96 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr
97 return $ JSWebSocket ws c
97 return $ JSWebSocket ws c
98+
99+onBSMessage :: Either ByteString b -> ByteString
100+onBSMessage = either id (error "onBSMessage: ghc env expects ByteString.")
101+
102+type JSVal = ()
src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+10−4
@@ -1,7 +1,10 @@
1{-# LANGUAGE ForeignFunctionInterface #-}
1{-# LANGUAGE ForeignFunctionInterface #-}
2{-# LANGUAGE JavaScriptFFI #-}
2{-# LANGUAGE JavaScriptFFI #-}
3
3
4−module Reflex.Dom.WebSocket.Foreign where
4+module Reflex.Dom.WebSocket.Foreign
5+ ( module Reflex.Dom.WebSocket.Foreign
6+ , JSVal
7+ ) where
5
8
6import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)
9import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)
7
10
@@ -42,7 +45,7 @@ instance IsWebSocketMessage ByteString where
42instance IsWebSocketMessage Text where
45instance IsWebSocketMessage Text where
43 webSocketSend (JSWebSocket ws) = GD.sendString ws . T.unpack
46 webSocketSend (JSWebSocket ws) = GD.sendString ws . T.unpack
44
47
45−newWebSocket :: a -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket
48+newWebSocket :: a -> Text -> (Either ByteString JSVal -> IO ()) -> IO () -> IO () -> IO JSWebSocket
46newWebSocket _ url onMessage onOpen onClose = do
49newWebSocket _ url onMessage onOpen onClose = do
47 ws <- GD.newWebSocket url (Just [] :: Maybe [Text])
50 ws <- GD.newWebSocket url (Just [] :: Maybe [Text])
48 _ <- on ws open $ liftIO onOpen
51 _ <- on ws open $ liftIO onOpen
@@ -51,11 +54,14 @@ newWebSocket _ url onMessage onOpen onClose = do
51 e <- ask
54 e <- ask
52 d <- getData e
55 d <- getData e
53 liftIO $ case jsTypeOf d of
56 liftIO $ case jsTypeOf d of
54− String -> onMessage $ encodeUtf8 $ pFromJSVal d
57+ String -> onMessage $ Right d
55 _ -> do
58 _ -> do
56 ab <- unsafeFreeze $ pFromJSVal d
59 ab <- unsafeFreeze $ pFromJSVal d
57− onMessage $ toByteString 0 Nothing $ createFromArrayBuffer ab
60+ onMessage $ Left $ toByteString 0 Nothing $ createFromArrayBuffer ab
58 _ <- on ws closeEvent $ liftIO onClose
61 _ <- on ws closeEvent $ liftIO onClose
59 return $ JSWebSocket ws
62 return $ JSWebSocket ws
60
63
61foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
64foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
65+
66+onBSMessage :: Either ByteString JSVal -> ByteString
67+onBSMessage = either id (encodeUtf8 . pFromJSVal)
src/Reflex/Dom/WebSocket.hs+12−7
@@ -49,10 +49,12 @@ data WebSocketConfig t a
49instance Reflex t => Default (WebSocketConfig t a) where
49instance Reflex t => Default (WebSocketConfig t a) where
50 def = WebSocketConfig never
50 def = WebSocketConfig never
51
51
52−data WebSocket t
52+type WebSocket t = RawWebSocket t ByteString
53+
54+data RawWebSocket t a
53− = WebSocket { _webSocket_recv :: Event t ByteString
55+ = RawWebSocket { _webSocket_recv :: Event t a
54− , _webSocket_open :: Event t ()
56+ , _webSocket_open :: Event t ()
55− }
57+ }
56
58
57-- This can be used to send either binary or text messages for the same websocket connection
59-- This can be used to send either binary or text messages for the same websocket connection
58instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Either a b) where
60instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Either a b) where
@@ -61,7 +63,10 @@ instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Eit
61
63
62
64
63webSocket :: (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)
65webSocket :: (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)
64−webSocket url config = do
66+webSocket url config = webSocket' url config onBSMessage
67+
68+webSocket' :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> (Either ByteString JSVal -> b) -> m (RawWebSocket t b)
69+webSocket' url config onRawMessage = do
65 wv <- fmap unWebViewSingleton askWebView
70 wv <- fmap unWebViewSingleton askWebView
66 (eRecv, onMessage) <- newTriggerEvent
71 (eRecv, onMessage) <- newTriggerEvent
67 currentSocketRef <- liftIO $ newIORef Nothing
72 currentSocketRef <- liftIO $ newIORef Nothing
@@ -78,7 +83,7 @@ webSocket url config = do
78 liftIO $ threadDelay 1000000
83 liftIO $ threadDelay 1000000
79 start
84 start
80 start = do
85 start = do
81− ws <- liftIO $ newWebSocket wv url onMessage onOpen onClose
86+ ws <- liftIO $ newWebSocket wv url (onMessage . onRawMessage) onOpen onClose
82 liftIO $ writeIORef currentSocketRef $ Just ws
87 liftIO $ writeIORef currentSocketRef $ Just ws
83 return ()
88 return ()
84 performEvent_ . (liftIO start <$) =<< getPostBuild
89 performEvent_ . (liftIO start <$) =<< getPostBuild
@@ -98,6 +103,6 @@ webSocket url config = do
98 `catch`
103 `catch`
99 (\(_ :: SomeException) -> return False))
104 (\(_ :: SomeException) -> return False))
100 unless success $ atomically $ unGetTQueue payloadQueue payload
105 unless success $ atomically $ unGetTQueue payloadQueue payload
101− return $ WebSocket eRecv eOpen
106+ return $ RawWebSocket eRecv eOpen
102
107
103makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig
108makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig