8d180ce · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Add websocket variant that exposes the raw message string value.

commit8d180ce0c06f820e723ae2c18ecd57e05f125f1a authorLuigy Leon <luigy@outlook.com> dateWed 12 Oct 2016, 14:30 (10 years ago) parentcab0ab0

3 files changed+29−13

compare with develop

unifiedsplit

src-ghc/Reflex/Dom/WebSocket/Foreign.hs+7−2 src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+10−4 src/Reflex/Dom/WebSocket.hs+12−7

src-ghc/Reflex/Dom/WebSocket/Foreign.hs+7−2

@@ -67,7 +67,7 @@ instance IsWebSocketMessage ByteString where

6767instance IsWebSocketMessage Text where

6868 webSocketSend jws t = sendWSTextData jws (T.unpack t)

6969

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

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

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

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

7373 newWSArgs <- toJSObject c [url']

@@ -80,7 +80,7 @@ newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do

8080 msg' <- fromJSStringMaybe c msg

8181 case msg' of

8282 Nothing -> return ()

83− Just m -> onMessage $ encodeUtf8 m

83+ Just m -> onMessage $ Left $ encodeUtf8 m

8484 jsvaluemakeundefined c

8585 onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'

8686 onOpen' <- wrapper $ \_ _ _ _ _ _ -> do

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

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

9696 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr

9797 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 @@

11{-# LANGUAGE ForeignFunctionInterface #-}

22{-# LANGUAGE JavaScriptFFI #-}

4−module Reflex.Dom.WebSocket.Foreign where

4+module Reflex.Dom.WebSocket.Foreign

5+ ( module Reflex.Dom.WebSocket.Foreign

6+ , JSVal

7+ ) where

69import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)

710

@@ -42,7 +45,7 @@ instance IsWebSocketMessage ByteString where

4245instance IsWebSocketMessage Text where

4346 webSocketSend (JSWebSocket ws) = GD.sendString ws . T.unpack

4447

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

48+newWebSocket :: a -> Text -> (Either ByteString JSVal -> IO ()) -> IO () -> IO () -> IO JSWebSocket

4649newWebSocket _ url onMessage onOpen onClose = do

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

4851 _ <- on ws open $ liftIO onOpen

@@ -51,11 +54,14 @@ newWebSocket _ url onMessage onOpen onClose = do

5154 e <- ask

5255 d <- getData e

5356 liftIO $ case jsTypeOf d of

54− String -> onMessage $ encodeUtf8 $ pFromJSVal d

57+ String -> onMessage $ Right d

5558 _ -> do

5659 ab <- unsafeFreeze $ pFromJSVal d

57− onMessage $ toByteString 0 Nothing $ createFromArrayBuffer ab

60+ onMessage $ Left $ toByteString 0 Nothing $ createFromArrayBuffer ab

5861 _ <- on ws closeEvent $ liftIO onClose

5962 return $ JSWebSocket ws

6063

6164foreign 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

4949instance Reflex t => Default (WebSocketConfig t a) where

5050 def = WebSocketConfig never

5151

52−data WebSocket t

53− = WebSocket { _webSocket_recv :: Event t ByteString

54− , _webSocket_open :: Event t ()

55− }

52+type WebSocket t = RawWebSocket t ByteString

53+

54+data RawWebSocket t a

55+ = RawWebSocket { _webSocket_recv :: Event t a

56+ , _webSocket_open :: Event t ()

57+ }

5658

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

5860instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Either a b) where

@@ -61,7 +63,10 @@ instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Eit

6163

6264

6365webSocket :: (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

6570 wv <- fmap unWebViewSingleton askWebView

6671 (eRecv, onMessage) <- newTriggerEvent

6772 currentSocketRef <- liftIO $ newIORef Nothing

@@ -78,7 +83,7 @@ webSocket url config = do

7883 liftIO $ threadDelay 1000000

7984 start

8085 start = do

81− ws <- liftIO $ newWebSocket wv url onMessage onOpen onClose

86+ ws <- liftIO $ newWebSocket wv url (onMessage . onRawMessage) onOpen onClose

8287 liftIO $ writeIORef currentSocketRef $ Just ws

8388 return ()

8489 performEvent_ . (liftIO start <$) =<< getPostBuild

@@ -98,6 +103,6 @@ webSocket url config = do

98103 `catch`

99104 (\(_ :: SomeException) -> return False))

100105 unless success $ atomically $ unGetTQueue payloadQueue payload

101− return $ WebSocket eRecv eOpen

106+ return $ RawWebSocket eRecv eOpen

102107

103108makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig