@@ -20,9 +20,12 @@ module Language.Javascript.JSaddle.WebSockets (
2020 , jsaddleApp
2121 , jsaddleWithAppOr
2222 , jsaddleAppWithJs
23+ , jsaddleAppWithJsOr
2324 , jsaddleAppPartial
2425 , jsaddleJs
26+ , jsaddleJs'
2527 , debug
28+ , debugOr
2629 , debugWrapper
2730) where
2831
@@ -57,45 +60,57 @@ import qualified Data.Map as M (empty, insert, lookup)
5760import Data.IORef
5861 (readIORef, newIORef, atomicModifyIORef')
5962import Data.ByteString.Lazy (ByteString)
60−import qualified Data.ByteString.Lazy as LBS (stripPrefix)
63+import qualified Data.ByteString.Lazy as LBS
64+ (toStrict, stripPrefix)
6165import Control.Concurrent.MVar
6266 (tryTakeMVar, MVar, tryPutMVar, modifyMVar_, putMVar, takeMVar,
6367 readMVar, newMVar, newEmptyMVar, modifyMVar)
6468import Network.Wai.Handler.Warp
6569 (defaultSettings, setTimeout, setPort, runSettings)
66−import Foreign.Store (newStore, readStore, lookupStore)
70+import Foreign.Store (readStore, lookupStore, writeStore, Store(..))
6771import Language.Javascript.JSaddle (askJSM)
6872import Control.Monad.IO.Class (MonadIO(..))
6973
7074import Language.Javascript.JSaddle.WebSockets.Compat (getTextMessageByteString)
75+import qualified Data.Text.Encoding as T (decodeUtf8)
7176
7277jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
7378jsaddleOr opts entryPoint otherApp = do
7479 syncHandlers <- newIORef M.empty
80+ asyncHandlers <- newIORef M.empty
7581 let wsApp :: ServerApp
7682 wsApp pending_conn = do
7783 conn <- acceptRequest pending_conn
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
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"
92107
93108 -- Based on Network.WebSocket.forkPingThread
94109 waitTillClosed conn = ignore `handle` go 1
95110 where
96111 go :: Int -> IO ()
97112 go i = do
98− threadDelay (1 * 1000 * 1000)
113+ threadDelay (10 * 1000 * 1000)
99114 sendPing conn (T.pack $ show i)
100115 go (i + 1)
101116
@@ -124,13 +139,18 @@ jsaddleOr opts entryPoint otherApp = do
124139
125140
126141jsaddleApp :: Application
127−jsaddleApp = jsaddleAppWithJs $ jsaddleJs Nothing False
142+jsaddleApp = jsaddleAppWithJs $ jsaddleJs False
128143
129144jsaddleAppWithJs :: ByteString -> Application
130145jsaddleAppWithJs js req sendResponse =
131− fromMaybe
132− (sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
133− (jsaddleAppPartialWithJs 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)
134154
135155jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
136156jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
@@ -138,7 +158,7 @@ jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sen
138158 (jsaddleAppPartial req sendResponse))
139159
140160jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
141−jsaddleAppPartial = jsaddleAppPartialWithJs $ jsaddleJs Nothing False
161+jsaddleAppPartial = jsaddleAppPartialWithJs $ jsaddleJs False
142162
143163indexResponse :: Response
144164indexResponse = W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
@@ -149,11 +169,14 @@ jsaddleAppPartialWithJs js req sendResponse = case (W.requestMethod req, W.pathI
149169 ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] js
150170 _ -> Nothing
151171
172+jsaddleJs :: Bool -> ByteString
173+jsaddleJs = jsaddleJs' Nothing
174+
152175-- Use this to generate this string for embedding
153176-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
154−jsaddleJs :: Maybe ByteString -> Bool -> ByteString
155−jsaddleJs jsaddleUri refreshOnLoad = "\
156− \if(typeof global !== \"undefined\") {\n\
177+jsaddleJs' :: Maybe ByteString -> Bool -> ByteString
178+jsaddleJs' jsaddleUri refreshOnLoad = "\
179+ \if(typeof global !== \"undefined\" && typeof require === \"function\") {\n\
157180 \ global.window = global;\n\
158181 \ global.WebSocket = require('ws');\n\
159182 \}\n\
@@ -165,20 +188,30 @@ jsaddleJs jsaddleUri refreshOnLoad = "\
165188 (jsaddleUri >>= LBS.stripPrefix "http")
166189 <> ";\n\
167190 \\n\
168− \ var ws = new WebSocket(wsaddress);\n\
191+ \ var ws0 = new WebSocket(wsaddress);\n\
169192 \ var syncKey = \"\";\n\
170193 \\n\
171− \ 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\
172198 \ " <> initState <> "\n\
173199 \\n\
174− \ ws.onmessage = function(e) {\n\
200+ \ ws0.onmessage = function(e) {\n\
175201 \ var batch = JSON.parse(e.data);\n\
176202 \ if(inCallback > 0) {\n\
177203 \ asyncBatch = batch;\n\
178204 \ return;\n\
179205 \ }\n\
180206 \ if(typeof batch === \"string\") {\n\
181− \ 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" <>
182215 (if refreshOnLoad
183216 then " var xhr = new XMLHttpRequest();\n\
184217 \ xhr.open('POST', '/reload/'+syncKey, true);\n\
@@ -200,7 +233,7 @@ jsaddleJs jsaddleUri refreshOnLoad = "\
200233 \ return JSON.parse(xhr.response);})()")) <> "\
201234 \ };\n\
202235 \ };\n\
203− \ ws.onerror = function() {\n\
236+ \ ws0.onerror = function() {\n\
204237 \ setTimeout(connect, 1000);\n\
205238 \ };\n\
206239 \}\n\
@@ -216,7 +249,14 @@ debug :: Int -> JSM () -> IO ()
216249debug port f = do
217250 debugWrapper $ \withRefresh registerContext ->
218251 runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
219− jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJs $ jsaddleJs Nothing True)
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)
220260 putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"
221261
222262refreshMiddleware :: ((Response -> IO ResponseReceived) -> IO ResponseReceived) -> Middleware
@@ -267,13 +307,13 @@ debugWrapper run = do
267307 start' <- takeMVar mvar
268308 n <- stop
269309 start' n >>= restarter mvar
270− lookupStore shutdown_0 >>= \case
310+ lookupStore storeId >>= \case
271311 Nothing -> do
272312 restartMVar <- newMVar start
273313 void . forkIO $ restarter restartMVar (return 0)
274− void $ newStore restartMVar
314+ void $ writeStore (Store storeId) restartMVar
275315 Just shutdownStore -> do
276316 restartMVar :: MVar (Int -> IO (IO Int)) <- readStore shutdownStore
277317 void $ tryTakeMVar restartMVar
278318 putMVar restartMVar start
279− where shutdown_0 = 0
319+ where storeId = 354