@@ -1,5 +1,7 @@
11{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE RecursiveDo #-}
35-----------------------------------------------------------------------------
46--
57-- Module : Language.Javascript.JSaddle.WebSockets
@@ -16,73 +18,302 @@ module Language.Javascript.JSaddle.WebSockets (
1618 -- * Running JSM over WebSockets
1719 jsaddleOr
1820 , jsaddleApp
21+ , jsaddleWithAppOr
22+ , jsaddleAppWithJs
23+ , jsaddleAppWithJsOr
24+ , jsaddleAppPartial
25+ , jsaddleJs
26+ , jsaddleJs'
27+ , debug
28+ , debugOr
29+ , debugWrapper
1930) where
2031
21−import Control.Monad (forever)
22−import Control.Concurrent (forkIO, threadDelay)
23−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)
2435
2536import Data.Monoid ((<>))
2637import Data.Aeson (encode, decode)
2738
28−import Network.Wai (Application)
39+import Network.Wai
40+ (Middleware, lazyRequestBody, Application, Request, Response,
41+ ResponseReceived)
2942import Network.WebSockets
30− (ConnectionOptions(..), sendTextData, receiveDataMessage,
31− acceptRequest, ServerApp, sendPing)
32−import qualified Network.WebSockets as WS (DataMessage(..))
43+ (defaultConnectionOptions, ConnectionOptions(..), sendTextData,
44+ receiveDataMessage, acceptRequest, ServerApp, sendPing)
3345import Network.Wai.Handler.WebSockets (websocketsOr)
46+import Network.HTTP.Types (Status(..))
3447
35−import Language.Javascript.JSaddle.Types (JSM(..))
48+import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))
3649import qualified Network.Wai as W
37− (responseLBS, requestMethod, Application, pathInfo)
38−import Data.Text (Text)
50+ (responseLBS, requestMethod, pathInfo, modifyResponse, responseStatus)
3951import qualified Data.Text as T (pack)
4052import qualified Network.HTTP.Types as H
41− (status403, status200, status405)
42−import Language.Javascript.JSaddle.Run (runJavaScript)
43−import Language.Javascript.JSaddle.Run.Files (indexHtml, jsaddleJs)
44−
45−jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application
46−jsaddleOr opts entryPoint = websocketsOr opts wsApp
47− where
48− wsApp :: ServerApp
49− wsApp pending_conn = do
50− conn <- acceptRequest pending_conn
51− (processResult, _, start) <- runJavaScript (sendTextData conn . encode) entryPoint
52− _ <- forkIO . forever $
53− receiveDataMessage conn >>= \case
54− (WS.Text t) ->
55− case decode t of
56− Nothing -> error $ "jsaddle Results decode failed : " <> show t
57− Just r -> processResult r
53+ (status403, status200)
54+import Language.Javascript.JSaddle.Run (syncPoint, runJavaScript)
55+import Language.Javascript.JSaddle.Run.Files (indexHtml, runBatch, ghcjsHelpers, initState)
56+import Language.Javascript.JSaddle.Debug
57+ (removeContext, addContext)
58+import Data.Maybe (fromMaybe)
59+import qualified Data.Map as M (empty, insert, lookup)
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)
76+
77+jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
78+jsaddleOr opts entryPoint otherApp = do
79+ syncHandlers <- newIORef M.empty
80+ asyncHandlers <- newIORef M.empty
81+ let wsApp :: ServerApp
82+ wsApp pending_conn = do
83+ 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"
58106 _ -> error "jsaddle WebSocket unexpected binary data"
59− start
60− waitTillClosed conn
61−
62− -- Based on Network.WebSocket.forkPingThread
63− waitTillClosed conn = ignore `handle` go 1
64− where
65− go :: Int -> IO ()
66− go i = do
67− threadDelay (1 * 1000 * 1000)
68− sendPing conn (T.pack $ show i)
69− go (i + 1)
70−
71− ignore e = case fromException e of
72− Just async -> throwIO (async :: AsyncException)
73− Nothing -> return ()
107+
108+ -- Based on Network.WebSocket.forkPingThread
109+ waitTillClosed conn = ignore `handle` go 1
110+ where
111+ go :: Int -> IO ()
112+ go i = do
113+ threadDelay (10 * 1000 * 1000)
114+ sendPing conn (T.pack $ show i)
115+ go (i + 1)
116+
117+ ignore e = case fromException e of
118+ Just async -> throwIO (async :: AsyncException)
119+ Nothing -> return ()
120+
121+ syncHandler :: Application
122+ syncHandler req sendResponse = case (W.requestMethod req, W.pathInfo req) of
123+ ("POST", ["sync", syncKey]) -> do
124+ body <- lazyRequestBody req
125+ case decode body of
126+ Nothing -> error $ "jsaddle sync message decode failed : " <> show body
127+ Just result ->
128+ M.lookup syncKey <$> readIORef syncHandlers >>= \case
129+ Nothing -> error "jsaddle missing sync message handler"
130+ Just handler -> do
131+ next <- encode <$> handler result
132+ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] next
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
138+ return $ websocketsOr opts wsApp syncHandler
139+
74140
75141jsaddleApp :: Application
76−jsaddleApp req = jsaddleAppPieces (W.pathInfo req) req
77−
78−jsaddleAppPieces :: [Text] -> W.Application
79−jsaddleAppPieces _ req sendResponse
80− | W.requestMethod req `notElem` ["GET", "HEAD"] = sendResponse $ W.responseLBS
81− H.status405
82− [("Content-Type", "text/plain")]
83− "Only GET or HEAD is supported"
84−jsaddleAppPieces [] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
85−jsaddleAppPieces ["jsaddle.js"] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs
86−jsaddleAppPieces _rawPieces _req sendResponse = sendResponse $ W.responseLBS H.status403
87− [ ("Content-Type", "text/plain")
88− ] "Forbidden"
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)
154+
155+jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
156+jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
157+ (fromMaybe (otherApp req sendResponse)
158+ (jsaddleAppPartial req sendResponse))
159+
160+jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
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
170+ _ -> Nothing
171+
172+jsaddleJs :: Bool -> ByteString
173+jsaddleJs = jsaddleJs' Nothing
174+
175+-- Use this to generate this string for embedding
176+-- 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\
180+ \ global.window = global;\n\
181+ \ global.WebSocket = require('ws');\n\
182+ \}\n\
183+ \\n\
184+ \var connect = function() {\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\
190+ \\n\
191+ \ var ws0 = new WebSocket(wsaddress);\n\
192+ \ var syncKey = \"\";\n\
193+ \\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\
198+ \ " <> initState <> "\n\
199+ \\n\
200+ \ ws0.onmessage = function(e) {\n\
201+ \ var batch = JSON.parse(e.data);\n\
202+ \ if(inCallback > 0) {\n\
203+ \ asyncBatch = batch;\n\
204+ \ return;\n\
205+ \ }\n\
206+ \ 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" <>
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\
225+ \ }\n\
226+ \\n\
227+ \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")
228+ (Just (\a -> "(function(){\n\
229+ \ var xhr = new XMLHttpRequest();\n\
230+ \ xhr.open('POST', '" <> fromMaybe "" jsaddleUri <> "/sync/'+syncKey, false);\n\
231+ \ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\
232+ \ xhr.send(JSON.stringify(" <> a <> "));\n\
233+ \ return JSON.parse(xhr.response);})()")) <> "\
234+ \ };\n\
235+ \ };\n\
236+ \ ws0.onerror = function() {\n\
237+ \ setTimeout(connect, 1000);\n\
238+ \ };\n\
239+ \}\n\
240+ \\n\
241+ \ " <> ghcjsHelpers <> "\
242+ \connect();\n\
243+ \"
244+
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