@@ -1,5 +1,7 @@
11{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE RecursiveDo #-}
35-----------------------------------------------------------------------------
46--
57-- Module : Language.Javascript.JSaddle.WebSockets
@@ -17,66 +19,98 @@ module Language.Javascript.JSaddle.WebSockets (
1719 jsaddleOr
1820 , jsaddleApp
1921 , jsaddleWithAppOr
22+ , jsaddleAppWithJs
23+ , jsaddleAppWithJsOr
2024 , jsaddleAppPartial
25+ , jsaddleJs
26+ , jsaddleJs'
27+ , debug
28+ , debugOr
29+ , debugWrapper
2130) where
2231
23−import Control.Monad (forever)
24−import Control.Concurrent (forkIO, threadDelay)
25−import Control.Exception (handle, AsyncException, throwIO, fromException)
32+import Control.Monad (when, void, forever)
33+import Control.Concurrent (killThread, forkIO, threadDelay)
34+import Control.Exception (handle, AsyncException, throwIO, fromException, finally)
2635
2736import Data.Monoid ((<>))
2837import Data.Aeson (encode, decode)
2938
3039import Network.Wai
31− (lazyRequestBody, Application, Request, Response, ResponseReceived)
40+ (Middleware, lazyRequestBody, Application, Request, Response,
41+ ResponseReceived)
3242import Network.WebSockets
33− (ConnectionOptions(..), sendTextData, receiveDataMessage,
34− acceptRequest, ServerApp, sendPing)
35−import qualified Network.WebSockets as WS (DataMessage(..))
43+ (defaultConnectionOptions, ConnectionOptions(..), sendTextData,
44+ receiveDataMessage, acceptRequest, ServerApp, sendPing)
3645import Network.Wai.Handler.WebSockets (websocketsOr)
46+import Network.HTTP.Types (Status(..))
3747
38−import Language.Javascript.JSaddle.Types (JSM(..))
48+import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))
3949import qualified Network.Wai as W
40− (responseLBS, requestMethod, pathInfo)
50+ (responseLBS, requestMethod, pathInfo, modifyResponse, responseStatus)
4151import qualified Data.Text as T (pack)
4252import qualified Network.HTTP.Types as H
4353 (status403, status200)
44−import Language.Javascript.JSaddle.Run (runJavaScript)
54+import Language.Javascript.JSaddle.Run (syncPoint, runJavaScript)
4555import Language.Javascript.JSaddle.Run.Files (indexHtml, runBatch, ghcjsHelpers, initState)
56+import Language.Javascript.JSaddle.Debug
57+ (removeContext, addContext)
4658import Data.Maybe (fromMaybe)
4759import qualified Data.Map as M (empty, insert, lookup)
48−import Data.IORef (readIORef, newIORef, atomicModifyIORef')
49−import Data.ByteString.Lazy (fromStrict, ByteString)
50−import Data.Text (Text)
51−import Data.UUID.Types (toText)
52−import Data.UUID.V4 (nextRandom)
60+import Data.IORef
61+ (readIORef, newIORef, atomicModifyIORef')
62+import Data.ByteString.Lazy (ByteString)
63+import qualified Data.ByteString.Lazy as LBS
64+ (toStrict, stripPrefix)
65+import Control.Concurrent.MVar
66+ (tryTakeMVar, MVar, tryPutMVar, modifyMVar_, putMVar, takeMVar,
67+ readMVar, newMVar, newEmptyMVar, modifyMVar)
68+import Network.Wai.Handler.Warp
69+ (defaultSettings, setTimeout, setPort, runSettings)
70+import Foreign.Store (readStore, lookupStore, writeStore, Store(..))
71+import Language.Javascript.JSaddle (askJSM)
72+import Control.Monad.IO.Class (MonadIO(..))
73+
74+import Language.Javascript.JSaddle.WebSockets.Compat (getTextMessageByteString)
75+import qualified Data.Text.Encoding as T (decodeUtf8)
5376
5477jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
5578jsaddleOr opts entryPoint otherApp = do
5679 syncHandlers <- newIORef M.empty
80+ asyncHandlers <- newIORef M.empty
5781 let wsApp :: ServerApp
5882 wsApp pending_conn = do
5983 conn <- acceptRequest pending_conn
60− (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) entryPoint
61− _ <- forkIO . forever $
62− receiveDataMessage conn >>= \case
63− (WS.Text t) ->
64− case decode t of
65− Nothing -> error $ "jsaddle Results decode failed : " <> show t
66− Just r -> processResult r
67− _ -> error "jsaddle WebSocket unexpected binary data"
68− syncKey <- toText <$> nextRandom
69− atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))
70− sendTextData conn (encode syncKey)
71− start
72− 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"
73107
74108 -- Based on Network.WebSocket.forkPingThread
75109 waitTillClosed conn = ignore `handle` go 1
76110 where
77111 go :: Int -> IO ()
78112 go i = do
79− threadDelay (1 * 1000 * 1000)
113+ threadDelay (10 * 1000 * 1000)
80114 sendPing conn (T.pack $ show i)
81115 go (i + 1)
82116
@@ -96,15 +130,27 @@ jsaddleOr opts entryPoint otherApp = do
96130 Just handler -> do
97131 next <- encode <$> handler result
98132 sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] next
99− _ -> 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
100138 return $ websocketsOr opts wsApp syncHandler
101139
102140
103141jsaddleApp :: Application
104−jsaddleApp req sendResponse =
105− fromMaybe
106− (sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
107− (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)
108154
109155jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
110156jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
@@ -112,50 +158,82 @@ jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sen
112158 (jsaddleAppPartial req sendResponse))
113159
114160jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
115−jsaddleAppPartial req sendResponse = case (W.requestMethod req, W.pathInfo req) of
116− ("GET", []) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
117− ("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
118170 _ -> Nothing
119171
172+jsaddleJs :: Bool -> ByteString
173+jsaddleJs = jsaddleJs' Nothing
174+
120175-- Use this to generate this string for embedding
121176-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
122−jsaddleJs :: ByteString
123−jsaddleJs = "\
124− \if(typeof global !== \"undefined\") {\n\
177+jsaddleJs' :: Maybe ByteString -> Bool -> ByteString
178+jsaddleJs' jsaddleUri refreshOnLoad = "\
179+ \if(typeof global !== \"undefined\" && typeof require === \"function\") {\n\
125180 \ global.window = global;\n\
126181 \ global.WebSocket = require('ws');\n\
127182 \}\n\
128183 \\n\
129184 \var connect = function() {\n\
130− \ 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\
131190 \\n\
132− \ var ws = new WebSocket(wsaddress);\n\
191+ \ var ws0 = new WebSocket(wsaddress);\n\
133192 \ var syncKey = \"\";\n\
134193 \\n\
135− \ 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\
136198 \ " <> initState <> "\n\
137− \ var inXhrSend = false;\n\
138199 \\n\
139− \ ws.onmessage = function(e) {\n\
140− \ if(inXhrSend) return;\n\
200+ \ ws0.onmessage = function(e) {\n\
141201 \ var batch = JSON.parse(e.data);\n\
202+ \ if(inCallback > 0) {\n\
203+ \ asyncBatch = batch;\n\
204+ \ return;\n\
205+ \ }\n\
142206 \ if(typeof batch === \"string\") {\n\
143207 \ syncKey = batch;\n\
144− \ 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\
145225 \ }\n\
146226 \\n\
147227 \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")
148228 (Just (\a -> "(function(){\n\
149− \ inXhrSend = true;\n\
150229 \ var xhr = new XMLHttpRequest();\n\
151− \ xhr.open('POST', '/sync/'+syncKey, false);\n\
230+ \ xhr.open('POST', '" <> fromMaybe "" jsaddleUri <> "/sync/'+syncKey, false);\n\
152231 \ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\
153232 \ xhr.send(JSON.stringify(" <> a <> "));\n\
154− \ inXhrSend = false;\n\
155233 \ return JSON.parse(xhr.response);})()")) <> "\
156234 \ };\n\
157235 \ };\n\
158− \ ws.onerror = function() {\n\
236+ \ ws0.onerror = function() {\n\
159237 \ setTimeout(connect, 1000);\n\
160238 \ };\n\
161239 \}\n\
@@ -164,3 +242,78 @@ jsaddleJs = "\
164242 \connect();\n\
165243 \"
166244
245+-- | Start or restart the server.
246+-- To run this as part of every :reload use
247+-- > :def! reload (const $ return "::reload\nLanguage.Javascript.JSaddle.Warp.debug 3708 SomeMainModule.someMainFunction")
248+debug :: Int -> JSM () -> IO ()
249+debug port f = do
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 ->
258+ runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
259+ jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJsOr (jsaddleJs True) b)
260+ putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"
261+
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+
267+debugWrapper :: (Middleware -> JSM () -> IO ()) -> IO ()
268+debugWrapper run = do
269+ reloadMVar <- newEmptyMVar
270+ reloadDoneMVars <- newMVar []
271+ contexts <- newMVar []
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
279+ start :: Int -> IO (IO Int)
280+ start expectedConnections = do
281+ serverDone <- newEmptyMVar
282+ ready <- newEmptyMVar
283+ let registerContext :: JSM ()
284+ registerContext = do
285+ uuid <- contextId <$> askJSM
286+ browsersConnected <- liftIO $ modifyMVar contexts (\ctxs -> return (uuid:ctxs, length ctxs + 1))
287+ addContext
288+ when (browsersConnected == expectedConnections) . void . liftIO $ tryPutMVar ready ()
289+ thread <- forkIO $
290+ finally (run (refreshMiddleware refresh) registerContext)
291+ (putMVar serverDone ())
292+ _ <- forkIO $ threadDelay 10000000 >> void (tryPutMVar ready ())
293+ when (expectedConnections /= 0) $ takeMVar ready
294+ return $ do
295+ putMVar reloadMVar ()
296+ ctxs <- takeMVar contexts
297+ mapM_ removeContext ctxs
298+ takeMVar reloadDoneMVars >>= mapM_ takeMVar
299+ tryTakeMVar serverDone >>= \case
300+ Nothing -> do
301+ killThread thread
302+ takeMVar serverDone
303+ Just _ -> return ()
304+ return $ length ctxs
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
311+ Nothing -> do
312+ restartMVar <- newMVar start
313+ void . forkIO $ restarter restartMVar (return 0)
314+ void $ writeStore (Store storeId) restartMVar
315+ Just shutdownStore -> do
316+ restartMVar :: MVar (Int -> IO (IO Int)) <- readStore shutdownStore
317+ void $ tryTakeMVar restartMVar
318+ putMVar restartMVar start
319+ where storeId = 354