2c27b42 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Merge pull request #262 from reflex-frp/aa-websocket-race

Fix race condition in websocket connection / registration of callbacks

commit2c27b4294d6bd9fdf1f9416b2c7c53b7b49cfa97 authorLuigy Leon <luichi.19@gmail.com> dateMon 28 Jan 2019, 14:27 (8 years ago) parent707a5a8 110bb18

2 files changed+49−27

compare with develop

unifiedsplit

reflex-dom-core/src/Reflex/Dom/WebSocket.hs+12−4 reflex-dom-core/src/Reflex/Dom/WebSocket/Foreign.hs+37−23

reflex-dom-core/src/Reflex/Dom/WebSocket.hs+12−4

@@ -55,6 +55,7 @@ import Data.Text

5555import Data.Text.Encoding

5656import Foreign.JavaScript.Utils (jsonDecode)

5757import GHCJS.DOM.Types (runJSM, askJSM, MonadJSM, liftJSM, JSM)

58+import GHCJS.DOM.WebSocket (getReadyState)

5859import GHCJS.Marshal

5960import qualified Language.Javascript.JSaddle.Monad as JS (catch)

6061

@@ -101,7 +102,7 @@ webSocket' url config onRawMessage = do

101102 liftIO $ triggerEClose args

102103 _ <- liftIO $ atomically $ tryTakeTMVar isOpen

103104 liftIO $ writeIORef currentSocketRef Nothing

104− when (_webSocketConfig_reconnect config) $ do

105+ when (_webSocketConfig_reconnect config) $ forkJSM $ do

105106 liftIO $ threadDelay 1000000

106107 start

107108 start = do

@@ -127,9 +128,11 @@ webSocket' url config onRawMessage = do

127128 mws <- liftIO $ readIORef currentSocketRef

128129 success <- case mws of

129130 Nothing -> return False

130− Just ws -> runJSM ((webSocketSend ws payload >> return True)

131− `JS.catch`

132− (\(_ :: SomeException) -> return False)) ctx

131+ Just ws -> flip runJSM ctx $ do

132+ rs <- getReadyState $ unWebSocket ws

133+ if rs == 1

134+ then (webSocketSend ws payload >> return True) `JS.catch` (\(_ :: SomeException) -> return False)

135+ else return False

133136 unless success $ atomically $ unGetTQueue payloadQueue payload

134137 return $ RawWebSocket eRecv eOpen eError eClose

135138

@@ -141,6 +144,11 @@ jsonWebSocket url cfg = do

141144 ws <- textWebSocket url $ cfg { _webSocketConfig_send = fmap (decodeUtf8 . toStrict . encode) <$> _webSocketConfig_send cfg }

142145 return ws { _webSocket_recv = jsonDecode . textToJSString <$> _webSocket_recv ws }

143146

147+forkJSM :: JSM () -> JSM ()

148+forkJSM a = do

149+ jsm <- askJSM

150+ void $ liftIO $ forkIO $ runJSM a jsm

151+

144152#ifdef USE_TEMPLATE_HASKELL

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

146154makeLensesWith (lensRules & simpleLenses .~ True) ''RawWebSocket

reflex-dom-core/src/Reflex/Dom/WebSocket/Foreign.hs+37−23

@@ -12,7 +12,6 @@ module Reflex.Dom.WebSocket.Foreign

1212

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

1414

15−import Control.Monad.Reader

1615import Data.Bifoldable

1716import Data.ByteString (ByteString)

1817import qualified Data.ByteString.Lazy as LBS

@@ -20,12 +19,11 @@ import Data.Text (Text)

2019import Data.Text.Encoding

2120import Foreign.JavaScript.Utils (bsFromMutableArrayBuffer, bsToArrayBuffer)

2221import GHCJS.DOM.CloseEvent

23−import GHCJS.DOM.EventM (on)

2422import GHCJS.DOM.MessageEvent

25−import GHCJS.DOM.Types (JSM, JSVal, liftJSM, fromJSValUnchecked)

26−import GHCJS.DOM.WebSocket (WebSocket)

23+import GHCJS.DOM.Types (JSM, JSVal, liftJSM, fromJSValUnchecked, WebSocket(..))

2724import qualified GHCJS.DOM.WebSocket as DOM

2825import GHCJS.Foreign (JSType(..), jsTypeOf)

26+import Language.Javascript.JSaddle (fun, eval, toJSVal, call)

2927import Language.Javascript.JSaddle.Helper (mutableArrayBufferFromJSVal)

3028import Language.Javascript.JSaddle.Types (ghcjsPure)

3129

@@ -64,25 +62,41 @@ newWebSocket

6462 -> ((Bool, Word, Text) -> JSM ()) -- onclose

6563 -> JSM JSWebSocket

6664newWebSocket _ url protocols onMessage onOpen onError onClose = do

67− ws <- DOM.newWebSocket url protocols

68− DOM.setBinaryType ws "arraybuffer"

69− _ <- on ws DOM.open $ liftJSM onOpen

70− _ <- on ws DOM.error $ liftJSM onError

71− _ <- on ws DOM.closeEvent $ do

72− e <- ask

73− wasClean <- getWasClean e

74− code <- getCode e

75− reason <- getReason e

76− liftJSM $ onClose (wasClean, code, reason)

77− _ <- on ws DOM.message $ do

78− e <- ask

79− d <- getData e

80− liftJSM $ ghcjsPure (jsTypeOf d) >>= \case

81− String -> onMessage $ Right d

82− _ -> do

83− ab <- mutableArrayBufferFromJSVal d

84− bsFromMutableArrayBuffer ab >>= onMessage . Left

85− return $ JSWebSocket ws

65+ let onOpenWrapped = fun $ \_ _ _ -> onOpen

66+ onErrorWrapped = fun $ \_ _ _ -> onError

67+ onCloseWrapped = fun $ \_ _ (e:_) -> do

68+ let e' = CloseEvent e

69+ wasClean <- getWasClean e'

70+ code <- getCode e'

71+ reason <- getReason e'

72+ liftJSM $ onClose (wasClean, code, reason)

73+ onMessageWrapped = fun $ \_ _ (e:_) -> do

74+ let e' = MessageEvent e

75+ d <- getData e'

76+ liftJSM $ ghcjsPure (jsTypeOf d) >>= \case

77+ String -> onMessage $ Right d

78+ _ -> do

79+ ab <- mutableArrayBufferFromJSVal d

80+ bsFromMutableArrayBuffer ab >>= onMessage . Left

81+ newWS <- eval $ unlines

82+ [ "(function(url, protos, open, error, close, message) {"

83+ , " var ws = new window['WebSocket'](url, protos);"

84+ , " ws['binaryType'] = 'arraybuffer';"

85+ , " ws['addEventListener']('open', open);"

86+ , " ws['addEventListener']('error', error);"

87+ , " ws['addEventListener']('close', close);"

88+ , " ws['addEventListener']('message', message);"

89+ , " return ws;"

90+ , "})"

91+ ]

92+ url' <- toJSVal url

93+ protocols' <- toJSVal protocols

94+ onOpen' <- toJSVal onOpenWrapped

95+ onError' <- toJSVal onErrorWrapped

96+ onClose' <- toJSVal onCloseWrapped

97+ onMessage' <- toJSVal onMessageWrapped

98+ ws <- call newWS newWS [url', protocols', onOpen', onError', onClose', onMessage']

99+ return $ JSWebSocket $ WebSocket ws

86100

87101onBSMessage :: Either ByteString JSVal -> JSM ByteString

88102onBSMessage = either return $ fmap encodeUtf8 . fromJSValUnchecked