e6ba1fc · jsaddle · git.iko.soy

60import Data.IORef

61 (readIORef, newIORef, atomicModifyIORef')

62import Data.ByteString.Lazy (ByteString)

63−import qualified Data.ByteString.Lazy as LBS (stripPrefix)

63+import qualified Data.ByteString.Lazy as LBS

64+ (toStrict, stripPrefix)

64import Control.Concurrent.MVar

65import Control.Concurrent.MVar

65 (tryTakeMVar, MVar, tryPutMVar, modifyMVar_, putMVar, takeMVar,

66 (tryTakeMVar, MVar, tryPutMVar, modifyMVar_, putMVar, takeMVar,

66 readMVar, newMVar, newEmptyMVar, modifyMVar)

67 readMVar, newMVar, newEmptyMVar, modifyMVar)

67import Network.Wai.Handler.Warp

68import Network.Wai.Handler.Warp

68 (defaultSettings, setTimeout, setPort, runSettings)

69 (defaultSettings, setTimeout, setPort, runSettings)

69−import Foreign.Store (newStore, readStore, lookupStore, writeStore, Store(..))

70+import Foreign.Store (readStore, lookupStore, writeStore, Store(..))

70import Language.Javascript.JSaddle (askJSM)

71import Language.Javascript.JSaddle (askJSM)

71import Control.Monad.IO.Class (MonadIO(..))

72import Control.Monad.IO.Class (MonadIO(..))

72

73

73import Language.Javascript.JSaddle.WebSockets.Compat (getTextMessageByteString)

74import Language.Javascript.JSaddle.WebSockets.Compat (getTextMessageByteString)

75+import qualified Data.Text.Encoding as T (decodeUtf8)

74

76

75jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application

77jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application

76jsaddleOr opts entryPoint otherApp = do

78jsaddleOr opts entryPoint otherApp = do

77 syncHandlers <- newIORef M.empty

79 syncHandlers <- newIORef M.empty

80+ asyncHandlers <- newIORef M.empty

78 let wsApp :: ServerApp

81 let wsApp :: ServerApp

79 wsApp pending_conn = do

82 wsApp pending_conn = do

80 conn <- acceptRequest pending_conn

83 conn <- acceptRequest pending_conn

84+ initMsg <- receiveDataMessage conn

85+ case getTextMessageByteString initMsg of

86+ Just "" -> do

81− rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do

87+ rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do

82− syncKey <- T.pack . show . contextId <$> askJSM

88+ syncKey <- T.pack . show . contextId <$> askJSM

83− liftIO $ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))

89+ liftIO $ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))

90+ liftIO $ atomicModifyIORef' asyncHandlers (\m -> (M.insert syncKey processResult m, ()))

84− liftIO $ sendTextData conn (encode syncKey)

91+ liftIO $ sendTextData conn (encode syncKey)

85− entryPoint

92+ entryPoint

86− _ <- forkIO . forever $

93+ start

87− receiveDataMessage conn >>= \msg -> case getTextMessageByteString msg of

94+ waitTillClosed conn

88− Just t ->

95+ Just syncKey ->

96+ M.lookup (T.decodeUtf8 $ LBS.toStrict syncKey) <$> readIORef syncHandlers >>= \case

97+ Nothing -> error "jsaddle missing sync message handler"

98+ Just processResult ->

99+ forever $

100+ receiveDataMessage conn >>= \msg -> case getTextMessageByteString msg of

101+ Just t ->

89− case decode t of

102+ case decode t of

90− Nothing -> error $ "jsaddle Results decode failed : " <> show t

103+ Nothing -> error $ "jsaddle Results decode failed : " <> show t

91− Just r -> processResult r

104+ Just r -> processResult r

92− _ -> error "jsaddle WebSocket unexpected binary data"

105+ _ -> error "jsaddle WebSocket unexpected binary data"

93− start

106+ _ -> error "jsaddle WebSocket unexpected binary data"

94− waitTillClosed conn

95

107

96 -- Based on Network.WebSocket.forkPingThread

108 -- Based on Network.WebSocket.forkPingThread

97 waitTillClosed conn = ignore `handle` go 1

109 waitTillClosed conn = ignore `handle` go 1

98 where

110 where

99 go :: Int -> IO ()

111 go :: Int -> IO ()

100 go i = do

112 go i = do

101− threadDelay (1 * 1000 * 1000)

113+ threadDelay (10 * 1000 * 1000)

102 sendPing conn (T.pack $ show i)

114 sendPing conn (T.pack $ show i)

103 go (i + 1)

115 go (i + 1)

104

116

176 (jsaddleUri >>= LBS.stripPrefix "http")

188 (jsaddleUri >>= LBS.stripPrefix "http")

177 <> ";\n\

189 <> ";\n\

178 \\n\

190 \\n\

179− \ var ws = new WebSocket(wsaddress);\n\

191+ \ var ws0 = new WebSocket(wsaddress);\n\

180 \ var syncKey = \"\";\n\

192 \ var syncKey = \"\";\n\

181 \\n\

193 \\n\

182− \ ws.onopen = function(e) {\n\

194+ \ ws0.onopen = function(e) {\n\

195+ \ ws0.send(\"\");\n\

196+ \ var initialResults = [];\n\

197+ \ var ws = {send: function(m) {initialResults.push(m);}};\n\

183 \ " <> initState <> "\n\

198 \ " <> initState <> "\n\

184 \\n\

199 \\n\

185− \ ws.onmessage = function(e) {\n\

200+ \ ws0.onmessage = function(e) {\n\

186 \ var batch = JSON.parse(e.data);\n\

201 \ var batch = JSON.parse(e.data);\n\

187 \ if(inCallback > 0) {\n\

202 \ if(inCallback > 0) {\n\

188 \ asyncBatch = batch;\n\

203 \ asyncBatch = batch;\n\

189 \ return;\n\

204 \ return;\n\

190 \ }\n\

205 \ }\n\

191 \ if(typeof batch === \"string\") {\n\

206 \ if(typeof batch === \"string\") {\n\

192− \ syncKey = batch;\n" <>

207+ \ syncKey = batch;\n\

208+ \ var ws1 = new WebSocket(wsaddress);\n\

209+ \ ws1.onopen = function(e) {\n\

210+ \ ws1.send(syncKey);\n\

211+ \ initialResults.forEach(function(m){ ws1.send(m); });\n\

212+ \ initialResults = null;\n\

213+ \ ws = ws1;\n\

214+ \ }\n" <>

193 (if refreshOnLoad

215 (if refreshOnLoad

194 then " var xhr = new XMLHttpRequest();\n\

216 then " var xhr = new XMLHttpRequest();\n\

195 \ xhr.open('POST', '/reload/'+syncKey, true);\n\

217 \ xhr.open('POST', '/reload/'+syncKey, true);\n\

211 \ return JSON.parse(xhr.response);})()")) <> "\

233 \ return JSON.parse(xhr.response);})()")) <> "\

212 \ };\n\

234 \ };\n\

213 \ };\n\

235 \ };\n\

214− \ ws.onerror = function() {\n\

236+ \ ws0.onerror = function() {\n\

215 \ setTimeout(connect, 1000);\n\

237 \ setTimeout(connect, 1000);\n\

216 \ };\n\

238 \ };\n\

217 \}\n\

239 \}\n\