@@ -20,12 +20,9 @@ module Language.Javascript.JSaddle.WebSockets (
2020 , jsaddleApp
2121 , jsaddleWithAppOr
2222 , jsaddleAppWithJs
23− , jsaddleAppWithJsOr
2423 , jsaddleAppPartial
2524 , jsaddleJs
26− , jsaddleJs'
2725 , debug
28− , debugOr
2926 , debugWrapper
3027) where
3128
@@ -60,57 +57,45 @@ import qualified Data.Map as M (empty, insert, lookup)
6057import Data.IORef
6158 (readIORef, newIORef, atomicModifyIORef')
6259import Data.ByteString.Lazy (ByteString)
63−import qualified Data.ByteString.Lazy as LBS
64− (toStrict, stripPrefix)
60+import qualified Data.ByteString.Lazy as LBS (stripPrefix)
6561import Control.Concurrent.MVar
6662 (tryTakeMVar, MVar, tryPutMVar, modifyMVar_, putMVar, takeMVar,
6763 readMVar, newMVar, newEmptyMVar, modifyMVar)
6864import Network.Wai.Handler.Warp
6965 (defaultSettings, setTimeout, setPort, runSettings)
70−import Foreign.Store (readStore, lookupStore, writeStore, Store(..))
66+import Foreign.Store (newStore, readStore, lookupStore)
7167import Language.Javascript.JSaddle (askJSM)
7268import Control.Monad.IO.Class (MonadIO(..))
7369
7470import Language.Javascript.JSaddle.WebSockets.Compat (getTextMessageByteString)
75−import qualified Data.Text.Encoding as T (decodeUtf8)
7671
7772jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
7873jsaddleOr opts entryPoint otherApp = do
7974 syncHandlers <- newIORef M.empty
80− asyncHandlers <- newIORef M.empty
8175 let wsApp :: ServerApp
8276 wsApp pending_conn = do
8377 conn <- acceptRequest pending_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"
78+ rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do
79+ syncKey <- T.pack . show . contextId <$> askJSM
80+ liftIO $ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))
81+ liftIO $ sendTextData conn (encode syncKey)
82+ entryPoint
83+ _ <- forkIO . forever $
84+ receiveDataMessage conn >>= \msg -> case getTextMessageByteString msg of
85+ Just t ->
86+ case decode t of
87+ Nothing -> error $ "jsaddle Results decode failed : " <> show t
88+ Just r -> processResult r
89+ _ -> error "jsaddle WebSocket unexpected binary data"
90+ start
91+ waitTillClosed conn
10792
10893 -- Based on Network.WebSocket.forkPingThread
10994 waitTillClosed conn = ignore `handle` go 1
11095 where
11196 go :: Int -> IO ()
11297 go i = do
113− threadDelay (10 * 1000 * 1000)
98+ threadDelay (1 * 1000 * 1000)
11499 sendPing conn (T.pack $ show i)
115100 go (i + 1)
116101
@@ -139,18 +124,13 @@ jsaddleOr opts entryPoint otherApp = do
139124
140125
141126jsaddleApp :: Application
142−jsaddleApp = jsaddleAppWithJs $ jsaddleJs False
127+jsaddleApp = jsaddleAppWithJs $ jsaddleJs Nothing False
143128
144129jsaddleAppWithJs :: ByteString -> Application
145130jsaddleAppWithJs js req sendResponse =
146− jsaddleAppWithJsOr js
147− (\_ _ -> sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
148− req sendResponse
149−
150−jsaddleAppWithJsOr :: ByteString -> Application -> Application
151−jsaddleAppWithJsOr js otherApp req sendResponse =
152− fromMaybe (otherApp req sendResponse)
153− (jsaddleAppPartialWithJs js req sendResponse)
131+ fromMaybe
132+ (sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
133+ (jsaddleAppPartialWithJs js req sendResponse)
154134
155135jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
156136jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
@@ -158,7 +138,7 @@ jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sen
158138 (jsaddleAppPartial req sendResponse))
159139
160140jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
161−jsaddleAppPartial = jsaddleAppPartialWithJs $ jsaddleJs False
141+jsaddleAppPartial = jsaddleAppPartialWithJs $ jsaddleJs Nothing False
162142
163143indexResponse :: Response
164144indexResponse = W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
@@ -169,14 +149,11 @@ jsaddleAppPartialWithJs js req sendResponse = case (W.requestMethod req, W.pathI
169149 ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] js
170150 _ -> Nothing
171151
172−jsaddleJs :: Bool -> ByteString
173−jsaddleJs = jsaddleJs' Nothing
174−
175152-- Use this to generate this string for embedding
176153-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
177−jsaddleJs' :: Maybe ByteString -> Bool -> ByteString
178−jsaddleJs' jsaddleUri refreshOnLoad = "\
179− \if(typeof global !== \"undefined\" && typeof require === \"function\") {\n\
154+jsaddleJs :: Maybe ByteString -> Bool -> ByteString
155+jsaddleJs jsaddleUri refreshOnLoad = "\
156+ \if(typeof global !== \"undefined\") {\n\
180157 \ global.window = global;\n\
181158 \ global.WebSocket = require('ws');\n\
182159 \}\n\
@@ -188,30 +165,20 @@ jsaddleJs' jsaddleUri refreshOnLoad = "\
188165 (jsaddleUri >>= LBS.stripPrefix "http")
189166 <> ";\n\
190167 \\n\
191− \ var ws0 = new WebSocket(wsaddress);\n\
168+ \ var ws = new WebSocket(wsaddress);\n\
192169 \ var syncKey = \"\";\n\
193170 \\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\
171+ \ ws.onopen = function(e) {\n\
198172 \ " <> initState <> "\n\
199173 \\n\
200− \ ws0.onmessage = function(e) {\n\
174+ \ ws.onmessage = function(e) {\n\
201175 \ var batch = JSON.parse(e.data);\n\
202176 \ if(inCallback > 0) {\n\
203177 \ asyncBatch = batch;\n\
204178 \ return;\n\
205179 \ }\n\
206180 \ if(typeof batch === \"string\") {\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" <>
181+ \ syncKey = batch;\n" <>
215182 (if refreshOnLoad
216183 then " var xhr = new XMLHttpRequest();\n\
217184 \ xhr.open('POST', '/reload/'+syncKey, true);\n\
@@ -233,7 +200,7 @@ jsaddleJs' jsaddleUri refreshOnLoad = "\
233200 \ return JSON.parse(xhr.response);})()")) <> "\
234201 \ };\n\
235202 \ };\n\
236− \ ws0.onerror = function() {\n\
203+ \ ws.onerror = function() {\n\
237204 \ setTimeout(connect, 1000);\n\
238205 \ };\n\
239206 \}\n\
@@ -249,14 +216,7 @@ debug :: Int -> JSM () -> IO ()
249216debug port f = do
250217 debugWrapper $ \withRefresh registerContext ->
251218 runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
252− jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJs $ jsaddleJs True)
253− putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"
254−
255−debugOr :: Int -> JSM () -> Application -> IO ()
256−debugOr port f b = do
257− debugWrapper $ \withRefresh registerContext ->
258− runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
259− jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJsOr (jsaddleJs True) b)
219+ jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJs $ jsaddleJs Nothing True)
260220 putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"
261221
262222refreshMiddleware :: ((Response -> IO ResponseReceived) -> IO ResponseReceived) -> Middleware
@@ -307,13 +267,13 @@ debugWrapper run = do
307267 start' <- takeMVar mvar
308268 n <- stop
309269 start' n >>= restarter mvar
310− lookupStore storeId >>= \case
270+ lookupStore shutdown_0 >>= \case
311271 Nothing -> do
312272 restartMVar <- newMVar start
313273 void . forkIO $ restarter restartMVar (return 0)
314− void $ writeStore (Store storeId) restartMVar
274+ void $ newStore restartMVar
315275 Just shutdownStore -> do
316276 restartMVar :: MVar (Int -> IO (IO Int)) <- readStore shutdownStore
317277 void $ tryTakeMVar restartMVar
318278 putMVar restartMVar start
319− where storeId = 354
279+ where shutdown_0 = 0