git.iko.soy/reflex-dom
on develop help sign in
Merge pull request #107 from mulderr/websocket-close

Improve websocket API

commit5de242b220e12e6fc1f5c1fb80045f2b273842b0 authorRyan Trinkle <ryan.trinkle@gmail.com> dateWed 19 Oct 2016, 09:50 (10 years ago) parent8d2037680d6b88
4 files changed+104−24
compare with develop
unifiedsplit
src-ghc/Reflex/Dom/Internal/Foreign.hs+12 src-ghc/Reflex/Dom/WebSocket/Foreign.hs+34−6 src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+28−6 src/Reflex/Dom/WebSocket.hs+30−12
src-ghc/Reflex/Dom/Internal/Foreign.hs+12
@@ -126,6 +126,18 @@ fromJSStringMaybe c t = do
126126 peekCString ps
127127 return $ Just $ T.pack s
128128
129+fromJSBoolMaybe :: JSContextRef -> JSValueRef -> IO (Maybe Bool)
130+fromJSBoolMaybe c t = do
131+ isBool <- jsvalueisboolean c t
132+ if not isBool then return Nothing else
133+ fmap Just $ jsvaluetoboolean c t
134+
135+fromJSNumMaybe :: JSContextRef -> JSValueRef -> IO (Maybe Double)
136+fromJSNumMaybe c t = do
137+ isNum <- jsvalueisnumber c t
138+ if not isNum then return Nothing else
139+ fmap Just $ jsvaluetonumber c t nullPtr
140+
129141getLocationHost :: WebView -> IO Text
130142getLocationHost wv = withWebViewContext wv $ \c -> do
131143 script <- jsstringcreatewithutf8cstring "location.host"
src-ghc/Reflex/Dom/WebSocket/Foreign.hs+34−6
@@ -21,6 +21,7 @@ import Control.Exception
2121import Control.Monad.State
2222import Data.ByteString (ByteString)
2323import qualified Data.ByteString as BS
24+import Data.Maybe (fromMaybe)
2425import Data.Text (Text)
2526import qualified Data.Text as T
2627import Data.Text.Encoding
@@ -67,8 +68,21 @@ instance IsWebSocketMessage ByteString where
6768instance IsWebSocketMessage Text where
6869 webSocketSend jws t = sendWSTextData jws (T.unpack t)
6970
70−newWebSocket :: WebView -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket
71−newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do
71+importJS Unsafe "this[0]['close'](this[1], this[2])" "_closeWS" [t| forall x m. MonadJS x m => JSRef x -> Double -> String -> m () |]
72+
73+closeWebSocket :: JSWebSocket -> Double -> Text -> IO ()
74+closeWebSocket (JSWebSocket ws c) code reason = do
75+ runWithJSContext (_closeWS (JSRef_JavaScriptCore ws) code (T.unpack reason)) c
76+
77+newWebSocket
78+ :: WebView
79+ -> Text -- url
80+ -> (ByteString -> IO ()) -- onmessage
81+ -> IO () -- onopen
82+ -> IO () -- onerror
83+ -> ((Bool, Word, Text) -> IO ()) -- onclose
84+ -> IO JSWebSocket
85+newWebSocket wv url onMessage onOpen onError onClose = withWebViewContext wv $ \c -> do
7286 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring (T.unpack url)
7387 newWSArgs <- toJSObject c [url']
7488 newWS <- jsstringcreatewithutf8cstring "(function(that) { var ws = new WebSocket(that[0]); ws['binaryType'] = 'arraybuffer'; return ws; })(this)"
@@ -87,11 +101,25 @@ newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do
87101 onOpen
88102 jsvaluemakeundefined c
89103 onOpenCb <- jsobjectmakefunctionwithcallback c nullPtr onOpen'
90− onClose' <- wrapper $ \_ _ _ _ _ _ -> do
91− onClose
104+ onError' <- wrapper $ \_ _ _ _ _ _ -> do
105+ onError
106+ jsvaluemakeundefined c
107+ onErrorCb <- jsobjectmakefunctionwithcallback c nullPtr onError'
108+ onClose' <- wrapper $ \_ _ _ _ args _ -> do
109+ e <- peekElemOff args 0
110+ propWasClean <- jsstringcreatewithutf8cstring "wasClean"
111+ propCode <- jsstringcreatewithutf8cstring "code"
112+ propReason <- jsstringcreatewithutf8cstring "reason"
113+ wasClean <- fmap (fromMaybe False) $ fromJSBoolMaybe c
114+ =<< jsobjectgetproperty c e propWasClean nullPtr
115+ code <- fmap (fromMaybe 1000) $ fromJSNumMaybe c
116+ =<< jsobjectgetproperty c e propCode nullPtr
117+ reason <- fmap (fromMaybe mempty) $ fromJSStringMaybe c
118+ =<< jsobjectgetproperty c e propReason nullPtr
119+ onClose (wasClean, truncate code, reason)
92120 jsvaluemakeundefined c
93121 onCloseCb <- jsobjectmakefunctionwithcallback c nullPtr onClose'
94− o <- toJSObject c [ws, onMessageCb, onOpenCb, onCloseCb]
95− addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onclose'] = this[3];"
122+ o <- toJSObject c [ws, onMessageCb, onOpenCb, onErrorCb, onCloseCb]
123+ addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onerror'] = this[3]; this[0]['onclose'] = this[4];"
96124 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr
97125 return $ JSWebSocket ws c
src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+28−6
@@ -14,9 +14,10 @@ import qualified Data.Text as T (unpack)
1414import Data.Text.Encoding
1515import GHCJS.Buffer
1616import GHCJS.DOM.EventM (on)
17+import GHCJS.DOM.EventTargetClosures (EventName, unsafeEventName)
1718import GHCJS.DOM.MessageEvent
19+import GHCJS.DOM.CloseEvent
1820import GHCJS.DOM.Types hiding (Text)
19−import GHCJS.DOM.WebSocket (closeEvent, message, open)
2021import qualified GHCJS.DOM.WebSocket as GD
2122import GHCJS.Foreign.Internal
2223import GHCJS.Marshal.Pure
@@ -42,12 +43,34 @@ instance IsWebSocketMessage ByteString where
4243instance IsWebSocketMessage Text where
4344 webSocketSend (JSWebSocket ws) = GD.sendString ws . T.unpack
4445
45−newWebSocket :: a -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket
46−newWebSocket _ url onMessage onOpen onClose = do
46+closeWebSocket :: JSWebSocket -> Word -> Text -> IO ()
47+closeWebSocket (JSWebSocket ws) = GD.close ws
48+
49+-- TODO: remove after upgrade to ghcjs-dom >= 0.3
50+-- in ghcjs-dom 0.2 this has type Event, we want CloseEvent
51+closeEvent :: EventName WebSocket CloseEvent
52+closeEvent = unsafeEventName (toJSString "close")
53+
54+newWebSocket
55+ :: a
56+ -> Text -- url
57+ -> (ByteString -> IO ()) -- onmessage
58+ -> IO () -- onopen
59+ -> IO () -- onerror
60+ -> ((Bool, Word, Text) -> IO ()) -- onclose
61+ -> IO JSWebSocket
62+newWebSocket _ url onMessage onOpen onError onClose = do
4763 ws <- GD.newWebSocket url (Just [] :: Maybe [Text])
48− _ <- on ws open $ liftIO onOpen
4964 GD.setBinaryType ws "arraybuffer"
50− _ <- on ws message $ do
65+ _ <- on ws GD.open $ liftIO onOpen
66+ _ <- on ws GD.error $ liftIO onError
67+ _ <- on ws closeEvent $ do
68+ e <- ask
69+ wasClean <- getWasClean e
70+ code <- getCode e
71+ reason <- getReason e
72+ liftIO $ onClose (wasClean, code, reason)
73+ _ <- on ws GD.message $ do
5174 e <- ask
5275 d <- getData e
5376 liftIO $ case jsTypeOf d of
@@ -55,7 +78,6 @@ newWebSocket _ url onMessage onOpen onClose = do
5578 _ -> do
5679 ab <- unsafeFreeze $ pFromJSVal d
5780 onMessage $ toByteString 0 Nothing $ createFromArrayBuffer ab
58− _ <- on ws closeEvent $ liftIO onClose
5981 return $ JSWebSocket ws
6082
6183foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
src/Reflex/Dom/WebSocket.hs+30−12
@@ -44,14 +44,23 @@ import Data.Text
4444
4545data WebSocketConfig t a
4646 = WebSocketConfig { _webSocketConfig_send :: Event t [a]
47+ , _webSocketConfig_close :: Event t (Word, Text)
48+ , _webSocketConfig_reconnect :: Bool
4749 }
4850
4951instance Reflex t => Default (WebSocketConfig t a) where
50− def = WebSocketConfig never
52+ def = WebSocketConfig never never True
5153
5254data WebSocket t
5355 = WebSocket { _webSocket_recv :: Event t ByteString
5456 , _webSocket_open :: Event t ()
57+ , _webSocket_error :: Event t () -- eror event does not carry any data and is always
58+ -- followed by termination of the connection
59+ -- for details see the close event
60+ , _webSocket_close :: Event t ( Bool -- wasClean
61+ , Word -- code
62+ , Text -- reason
63+ )
5564 }
5665
5766-- This can be used to send either binary or text messages for the same websocket connection
@@ -65,25 +74,34 @@ webSocket url config = do
6574 wv <- fmap unWebViewSingleton askWebView
6675 (eRecv, onMessage) <- newTriggerEvent
6776 currentSocketRef <- liftIO $ newIORef Nothing
68− --TODO: Disconnect if value no longer needed
6977 (eOpen, triggerEOpen) <- newTriggerEventWithOnComplete
78+ (eError, triggerEError) <- newTriggerEvent
79+ (eClose, triggerEClose) <- newTriggerEvent
7080 payloadQueue <- liftIO newTQueueIO
7181 isOpen <- liftIO newEmptyTMVarIO
72− let onOpen = triggerEOpen () $ do
73− liftIO $ void $ atomically $ tryPutTMVar isOpen ()
74− --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?
75− onClose = void $ forkIO $ do
76− _ <- liftIO $ atomically $ tryTakeTMVar isOpen
77− liftIO $ writeIORef currentSocketRef Nothing
78− liftIO $ threadDelay 1000000
79− start
82+ let onOpen = triggerEOpen () $ liftIO $ void $ atomically $ tryPutTMVar isOpen ()
83+ onError = triggerEError ()
84+ onClose args = do
85+ triggerEClose args
86+ --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?
87+ void $ forkIO $ do
88+ _ <- liftIO $ atomically $ tryTakeTMVar isOpen
89+ liftIO $ writeIORef currentSocketRef Nothing
90+ when (_webSocketConfig_reconnect config) $ do
91+ liftIO $ threadDelay 1000000
92+ start
8093 start = do
81− ws <- liftIO $ newWebSocket wv url onMessage onOpen onClose
94+ ws <- liftIO $ newWebSocket wv url onMessage onOpen onError onClose
8295 liftIO $ writeIORef currentSocketRef $ Just ws
8396 return ()
8497 performEvent_ . (liftIO start <$) =<< getPostBuild
8598 performEvent_ $ ffor (_webSocketConfig_send config) $ \payloads -> forM_ payloads $ \payload ->
8699 liftIO $ atomically $ writeTQueue payloadQueue payload
100+ performEvent_ $ ffor (_webSocketConfig_close config) $ \(code,reason) -> liftIO $ do
101+ mws <- readIORef currentSocketRef
102+ case mws of
103+ Nothing -> return ()
104+ Just ws -> closeWebSocket ws (fromIntegral code) reason
87105
88106 _ <- liftIO $ forkIO $ forever $ do
89107 payload <- atomically $ do
@@ -98,6 +116,6 @@ webSocket url config = do
98116 `catch`
99117 (\(_ :: SomeException) -> return False))
100118 unless success $ atomically $ unGetTQueue payloadQueue payload
101− return $ WebSocket eRecv eOpen
119+ return $ WebSocket eRecv eOpen eError eClose
102120
103121makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig