@@ -19,12 +19,17 @@ module Language.Javascript.JSaddle.WebSockets (
1919 jsaddleOr
2020 , jsaddleApp
2121 , jsaddleWithAppOr
22+ , jsaddleAppWithJs
23+ , jsaddleAppWithJsOr
2224 , jsaddleAppPartial
25+ , jsaddleJs
26+ , jsaddleJs'
2327 , debug
28+ , debugOr
2429 , debugWrapper
2530) where
2631
27−import Control.Monad (when, join, void, forever)
32+import Control.Monad (when, void, forever)
2833import Control.Concurrent (killThread, forkIO, threadDelay)
2934import Control.Exception (handle, AsyncException, throwIO, fromException, finally)
3035
@@ -37,12 +42,12 @@ import Network.Wai
3742import Network.WebSockets
3843 (defaultConnectionOptions, ConnectionOptions(..), sendTextData,
3944 receiveDataMessage, acceptRequest, ServerApp, sendPing)
40−import qualified Network.WebSockets as WS (DataMessage(..))
4145import Network.Wai.Handler.WebSockets (websocketsOr)
46+import Network.HTTP.Types (Status(..))
4247
4348import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))
4449import qualified Network.Wai as W
45− (responseLBS, requestMethod, pathInfo)
50+ (responseLBS, requestMethod, pathInfo, modifyResponse, responseStatus)
4651import qualified Data.Text as T (pack)
4752import qualified Network.HTTP.Types as H
4853 (status403, status200)
@@ -53,44 +58,59 @@ import Language.Javascript.JSaddle.Debug
5358import Data.Maybe (fromMaybe)
5459import qualified Data.Map as M (empty, insert, lookup)
5560import Data.IORef
56− (writeIORef, IORef, readIORef, newIORef, atomicModifyIORef')
61+ (readIORef, newIORef, atomicModifyIORef')
5762import Data.ByteString.Lazy (ByteString)
63+import qualified Data.ByteString.Lazy as LBS
64+ (toStrict, stripPrefix)
5865import Control.Concurrent.MVar
59− (tryPutMVar, modifyMVar_, putMVar, takeMVar, readMVar, newMVar,
60− newEmptyMVar, modifyMVar)
66+ (tryTakeMVar, MVar, tryPutMVar, modifyMVar_, putMVar, takeMVar,
67+ readMVar, newMVar, newEmptyMVar, modifyMVar)
6168import Network.Wai.Handler.Warp
6269 (defaultSettings, setTimeout, setPort, runSettings)
63−import Foreign.Store (newStore, readStore, lookupStore)
70+import Foreign.Store (readStore, lookupStore, writeStore, Store(..))
6471import Language.Javascript.JSaddle (askJSM)
6572import Control.Monad.IO.Class (MonadIO(..))
6673
74+import Language.Javascript.JSaddle.WebSockets.Compat (getTextMessageByteString)
75+import qualified Data.Text.Encoding as T (decodeUtf8)
76+
6777jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
6878jsaddleOr opts entryPoint otherApp = do
6979 syncHandlers <- newIORef M.empty
80+ asyncHandlers <- newIORef M.empty
7081 let wsApp :: ServerApp
7182 wsApp pending_conn = do
7283 conn <- acceptRequest pending_conn
73− rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do
74− syncKey <- T.pack . show . contextId <$> askJSM
75− liftIO $ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))
76− liftIO $ sendTextData conn (encode syncKey)
77− entryPoint
78− _ <- forkIO . forever $
79− receiveDataMessage conn >>= \case
80− (WS.Text t) ->
81− case decode t of
82− Nothing -> error $ "jsaddle Results decode failed : " <> show t
83− Just r -> processResult r
84− _ -> error "jsaddle WebSocket unexpected binary data"
85− start
86− 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"
87107
88108 -- Based on Network.WebSocket.forkPingThread
89109 waitTillClosed conn = ignore `handle` go 1
90110 where
91111 go :: Int -> IO ()
92112 go i = do
93− threadDelay (1 * 1000 * 1000)
113+ threadDelay (10 * 1000 * 1000)
94114 sendPing conn (T.pack $ show i)
95115 go (i + 1)
96116
@@ -110,15 +130,27 @@ jsaddleOr opts entryPoint otherApp = do
110130 Just handler -> do
111131 next <- encode <$> handler result
112132 sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] next
113− _ -> otherApp req sendResponse
133+ (method, _) -> (catch404 otherApp) req sendResponse
134+ where catch404 = W.modifyResponse $ \resp ->
135+ case (method, W.responseStatus resp) of
136+ ("GET", Status 404 _) -> indexResponse
137+ _ -> resp
114138 return $ websocketsOr opts wsApp syncHandler
115139
116140
117141jsaddleApp :: Application
118−jsaddleApp req sendResponse =
119− fromMaybe
120− (sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
121− (jsaddleAppPartial req sendResponse)
142+jsaddleApp = jsaddleAppWithJs $ jsaddleJs False
143+
144+jsaddleAppWithJs :: ByteString -> Application
145+jsaddleAppWithJs 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)
122154
123155jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
124156jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
@@ -126,57 +158,82 @@ jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sen
126158 (jsaddleAppPartial req sendResponse))
127159
128160jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
129−jsaddleAppPartial req sendResponse = case (W.requestMethod req, W.pathInfo req) of
130− ("GET", []) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
131− ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs
161+jsaddleAppPartial = jsaddleAppPartialWithJs $ jsaddleJs False
162+
163+indexResponse :: Response
164+indexResponse = W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
165+
166+jsaddleAppPartialWithJs :: ByteString -> Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
167+jsaddleAppPartialWithJs js req sendResponse = case (W.requestMethod req, W.pathInfo req) of
168+ ("GET", []) -> Just $ sendResponse indexResponse
169+ ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] js
132170 _ -> Nothing
133171
172+jsaddleJs :: Bool -> ByteString
173+jsaddleJs = jsaddleJs' Nothing
174+
134175-- Use this to generate this string for embedding
135176-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
136−jsaddleJs :: ByteString
137−jsaddleJs = "\
138− \if(typeof global !== \"undefined\") {\n\
177+jsaddleJs' :: Maybe ByteString -> Bool -> ByteString
178+jsaddleJs' jsaddleUri refreshOnLoad = "\
179+ \if(typeof global !== \"undefined\" && typeof require === \"function\") {\n\
139180 \ global.window = global;\n\
140181 \ global.WebSocket = require('ws');\n\
141182 \}\n\
142183 \\n\
143184 \var connect = function() {\n\
144− \ var wsaddress = window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\");\n\
185+ \ var wsaddress = "
186+ <> maybe "window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\")"
187+ (\ s -> "\"ws" <> s <> "\"")
188+ (jsaddleUri >>= LBS.stripPrefix "http")
189+ <> ";\n\
145190 \\n\
146− \ var ws = new WebSocket(wsaddress);\n\
191+ \ var ws0 = new WebSocket(wsaddress);\n\
147192 \ var syncKey = \"\";\n\
148193 \\n\
149− \ 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\
150198 \ " <> initState <> "\n\
151− \ var inXhrSend = false;\n\
152199 \\n\
153− \ ws.onmessage = function(e) {\n\
154− \ if(inXhrSend) return;\n\
200+ \ ws0.onmessage = function(e) {\n\
155201 \ var batch = JSON.parse(e.data);\n\
202+ \ if(inCallback > 0) {\n\
203+ \ asyncBatch = batch;\n\
204+ \ return;\n\
205+ \ }\n\
156206 \ if(typeof batch === \"string\") {\n\
157207 \ syncKey = batch;\n\
158− \ var xhr = new XMLHttpRequest();\n\
159− \ xhr.open('POST', '/reload/'+syncKey, true);\n\
160− \ xhr.onreadystatechange = function() {\n\
161− \ if(xhr.readyState === XMLHttpRequest.DONE && xhr.status === 200)\n\
162− \ setTimeout(function(){window.location.reload();}, 500);\n\
163− \ };\n\
164− \ xhr.send();\n\
165− \ return;\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" <>
215+ (if refreshOnLoad
216+ then " var xhr = new XMLHttpRequest();\n\
217+ \ xhr.open('POST', '/reload/'+syncKey, true);\n\
218+ \ xhr.onreadystatechange = function() {\n\
219+ \ if(xhr.readyState === XMLHttpRequest.DONE && xhr.status === 200)\n\
220+ \ setTimeout(function(){window.location.reload();}, 100);\n\
221+ \ };\n\
222+ \ xhr.send();\n"
223+ else "") <>
224+ " return;\n\
166225 \ }\n\
167226 \\n\
168227 \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")
169228 (Just (\a -> "(function(){\n\
170− \ inXhrSend = true;\n\
171229 \ var xhr = new XMLHttpRequest();\n\
172− \ xhr.open('POST', '/sync/'+syncKey, false);\n\
230+ \ xhr.open('POST', '" <> fromMaybe "" jsaddleUri <> "/sync/'+syncKey, false);\n\
173231 \ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\
174232 \ xhr.send(JSON.stringify(" <> a <> "));\n\
175− \ inXhrSend = false;\n\
176233 \ return JSON.parse(xhr.response);})()")) <> "\
177234 \ };\n\
178235 \ };\n\
179− \ ws.onerror = function() {\n\
236+ \ ws0.onerror = function() {\n\
180237 \ setTimeout(connect, 1000);\n\
181238 \ };\n\
182239 \}\n\
@@ -190,26 +247,35 @@ jsaddleJs = "\
190247-- > :def! reload (const $ return "::reload\nLanguage.Javascript.JSaddle.Warp.debug 3708 SomeMainModule.someMainFunction")
191248debug :: Int -> JSM () -> IO ()
192249debug port f = do
193− debugWrapper $ \refreshMiddleware registerContext ->
250+ debugWrapper $ \withRefresh registerContext ->
251+ 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 ->
194258 runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
195− jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (refreshMiddleware jsaddleApp)
259+ jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJsOr (jsaddleJs True) b)
196260 putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"
197261
262+refreshMiddleware :: ((Response -> IO ResponseReceived) -> IO ResponseReceived) -> Middleware
263+refreshMiddleware refresh otherApp req sendResponse = case (W.requestMethod req, W.pathInfo req) of
264+ ("POST", ["reload", _syncKey]) -> refresh sendResponse
265+ _ -> otherApp req sendResponse
266+
198267debugWrapper :: (Middleware -> JSM () -> IO ()) -> IO ()
199268debugWrapper run = do
200269 reloadMVar <- newEmptyMVar
201270 reloadDoneMVars <- newMVar []
202271 contexts <- newMVar []
203− let refreshMiddleware :: Middleware
204− refreshMiddleware otherApp req sendResponse = case (W.requestMethod req, W.pathInfo req) of
205− ("POST", ["reload", _syncKey]) -> do
206− reloadDone <- newEmptyMVar
207− modifyMVar_ reloadDoneMVars (return . (reloadDone:))
208− readMVar reloadMVar
209− r <- sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] ("reload" :: ByteString)
210− putMVar reloadDone ()
211− return r
212− _ -> otherApp req sendResponse
272+ let refresh sendResponse = do
273+ reloadDone <- newEmptyMVar
274+ modifyMVar_ reloadDoneMVars (return . (reloadDone:))
275+ readMVar reloadMVar
276+ r <- sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] ("reload" :: ByteString)
277+ putMVar reloadDone ()
278+ return r
213279 start :: Int -> IO (IO Int)
214280 start expectedConnections = do
215281 serverDone <- newEmptyMVar
@@ -221,7 +287,7 @@ debugWrapper run = do
221287 addContext
222288 when (browsersConnected == expectedConnections) . void . liftIO $ tryPutMVar ready ()
223289 thread <- forkIO $
224− finally (run refreshMiddleware registerContext)
290+ finally (run (refreshMiddleware refresh) registerContext)
225291 (putMVar serverDone ())
226292 _ <- forkIO $ threadDelay 10000000 >> void (tryPutMVar ready ())
227293 when (expectedConnections /= 0) $ takeMVar ready
@@ -230,15 +296,24 @@ debugWrapper run = do
230296 ctxs <- takeMVar contexts
231297 mapM_ removeContext ctxs
232298 takeMVar reloadDoneMVars >>= mapM_ takeMVar
233− killThread thread
234− takeMVar serverDone
299+ tryTakeMVar serverDone >>= \case
300+ Nothing -> do
301+ killThread thread
302+ takeMVar serverDone
303+ Just _ -> return ()
235304 return $ length ctxs
236− lookupStore shutdown_0 >>= \case
305+ restarter :: MVar (Int -> IO (IO Int)) -> IO Int -> IO ()
306+ restarter mvar stop = do
307+ start' <- takeMVar mvar
308+ n <- stop
309+ start' n >>= restarter mvar
310+ lookupStore storeId >>= \case
237311 Nothing -> do
238− shutdownRef <- newIORef =<< start 0
239− void $ newStore shutdownRef
312+ restartMVar <- newMVar start
313+ void . forkIO $ restarter restartMVar (return 0)
314+ void $ writeStore (Store storeId) restartMVar
240315 Just shutdownStore -> do
241− shutdownRef :: IORef (IO Int) <- readStore shutdownStore
242− expectedConnections <- join (readIORef shutdownRef)
243− writeIORef shutdownRef =<< start expectedConnections
244− where shutdown_0 = 0
316+ restartMVar :: MVar (Int -> IO (IO Int)) <- readStore shutdownStore
317+ void $ tryTakeMVar restartMVar
318+ putMVar restartMVar start
319+ where storeId = 354