@@ -60,45 +60,57 @@ import qualified Data.Map as M (empty, insert, lookup)
6060import Data.IORef
6161 (readIORef, newIORef, atomicModifyIORef')
6262import Data.ByteString.Lazy (ByteString)
63−import qualified Data.ByteString.Lazy as LBS (stripPrefix)
63+import qualified Data.ByteString.Lazy as LBS
64+ (toStrict, stripPrefix)
6465import Control.Concurrent.MVar
6566 (tryTakeMVar, MVar, tryPutMVar, modifyMVar_, putMVar, takeMVar,
6667 readMVar, newMVar, newEmptyMVar, modifyMVar)
6768import Network.Wai.Handler.Warp
6869 (defaultSettings, setTimeout, setPort, runSettings)
69−import Foreign.Store (newStore, readStore, lookupStore, writeStore, Store(..))
70+import Foreign.Store (readStore, lookupStore, writeStore, Store(..))
7071import Language.Javascript.JSaddle (askJSM)
7172import Control.Monad.IO.Class (MonadIO(..))
7273
7374import Language.Javascript.JSaddle.WebSockets.Compat (getTextMessageByteString)
75+import qualified Data.Text.Encoding as T (decodeUtf8)
7476
7577jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
7678jsaddleOr opts entryPoint otherApp = do
7779 syncHandlers <- newIORef M.empty
80+ asyncHandlers <- newIORef M.empty
7881 let wsApp :: ServerApp
7982 wsApp pending_conn = do
8083 conn <- acceptRequest pending_conn
81− rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do
82− syncKey <- T.pack . show . contextId <$> askJSM
83− liftIO $ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))
84− liftIO $ sendTextData conn (encode syncKey)
85− entryPoint
86− _ <- forkIO . forever $
87− receiveDataMessage conn >>= \msg -> case getTextMessageByteString msg of
88− Just t ->
89− case decode t of
90− Nothing -> error $ "jsaddle Results decode failed : " <> show t
91− Just r -> processResult r
92− _ -> error "jsaddle WebSocket unexpected binary data"
93− start
94− waitTillClosed conn
84+ initMsg <- receiveDataMessage conn
85+ case getTextMessageByteString initMsg of
86+ Just "" -> do
87+ rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do
88+ syncKey <- T.pack . show . contextId <$> askJSM
89+ liftIO $ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))
90+ liftIO $ atomicModifyIORef' asyncHandlers (\m -> (M.insert syncKey processResult m, ()))
91+ liftIO $ sendTextData conn (encode syncKey)
92+ entryPoint
93+ start
94+ waitTillClosed conn
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 ->
102+ case decode t of
103+ Nothing -> error $ "jsaddle Results decode failed : " <> show t
104+ Just r -> processResult r
105+ _ -> error "jsaddle WebSocket unexpected binary data"
106+ _ -> error "jsaddle WebSocket unexpected binary data"
95107
96108 -- Based on Network.WebSocket.forkPingThread
97109 waitTillClosed conn = ignore `handle` go 1
98110 where
99111 go :: Int -> IO ()
100112 go i = do
101− threadDelay (1 * 1000 * 1000)
113+ threadDelay (10 * 1000 * 1000)
102114 sendPing conn (T.pack $ show i)
103115 go (i + 1)
104116
@@ -176,20 +188,30 @@ jsaddleJs' jsaddleUri refreshOnLoad = "\
176188 (jsaddleUri >>= LBS.stripPrefix "http")
177189 <> ";\n\
178190 \\n\
179− \ var ws = new WebSocket(wsaddress);\n\
191+ \ var ws0 = new WebSocket(wsaddress);\n\
180192 \ var syncKey = \"\";\n\
181193 \\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\
183198 \ " <> initState <> "\n\
184199 \\n\
185− \ ws.onmessage = function(e) {\n\
200+ \ ws0.onmessage = function(e) {\n\
186201 \ var batch = JSON.parse(e.data);\n\
187202 \ if(inCallback > 0) {\n\
188203 \ asyncBatch = batch;\n\
189204 \ return;\n\
190205 \ }\n\
191206 \ 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" <>
193215 (if refreshOnLoad
194216 then " var xhr = new XMLHttpRequest();\n\
195217 \ xhr.open('POST', '/reload/'+syncKey, true);\n\
@@ -211,7 +233,7 @@ jsaddleJs' jsaddleUri refreshOnLoad = "\
211233 \ return JSON.parse(xhr.response);})()")) <> "\
212234 \ };\n\
213235 \ };\n\
214− \ ws.onerror = function() {\n\
236+ \ ws0.onerror = function() {\n\
215237 \ setTimeout(connect, 1000);\n\
216238 \ };\n\
217239 \}\n\