@@ -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,228 @@ module Language.Javascript.JSaddle.WebSockets (
1618 -- * Running JSM over WebSockets
1719 jsaddleOr
1820 , jsaddleApp
21+ , jsaddleWithAppOr
22+ , jsaddleAppPartial
23+ , debug
24+ , debugWrapper
1925) where
2026
21−import Control.Monad (forever)
22−import Control.Concurrent (forkIO, threadDelay)
23−import Control.Exception (handle, AsyncException, throwIO, fromException)
27+import Control.Monad (when, join, void, forever)
28+import Control.Concurrent (killThread, forkIO, threadDelay)
29+import Control.Exception (handle, AsyncException, throwIO, fromException, finally)
2430
2531import Data.Monoid ((<>))
2632import Data.Aeson (encode, decode)
2733
28−import Network.Wai (Application)
34+import Network.Wai
35+ (Middleware, lazyRequestBody, Application, Request, Response,
36+ ResponseReceived)
2937import Network.WebSockets
30− (ConnectionOptions(..), sendTextData, receiveDataMessage,
31− acceptRequest, ServerApp, sendPing)
38+ (defaultConnectionOptions, ConnectionOptions(..), sendTextData,
39+ receiveDataMessage, acceptRequest, ServerApp, sendPing)
3240import qualified Network.WebSockets as WS (DataMessage(..))
3341import Network.Wai.Handler.WebSockets (websocketsOr)
3442
35−import Language.Javascript.JSaddle.Types (JSM(..))
43+import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))
3644import qualified Network.Wai as W
37− (responseLBS, requestMethod, Application, pathInfo)
38−import Data.Text (Text)
45+ (responseLBS, requestMethod, pathInfo)
3946import qualified Data.Text as T (pack)
4047import 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
58− _ -> 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 ()
48+ (status403, status200)
49+import Language.Javascript.JSaddle.Run (syncPoint, runJavaScript)
50+import Language.Javascript.JSaddle.Run.Files (indexHtml, runBatch, ghcjsHelpers, initState)
51+import Language.Javascript.JSaddle.Debug
52+ (removeContext, addContext)
53+import Data.Maybe (fromMaybe)
54+import qualified Data.Map as M (empty, insert, lookup)
55+import Data.IORef
56+ (writeIORef, IORef, readIORef, newIORef, atomicModifyIORef')
57+import Data.ByteString.Lazy (ByteString)
58+import Data.UUID.Types (toText)
59+import Control.Concurrent.MVar
60+ (tryPutMVar, modifyMVar_, putMVar, takeMVar, readMVar, newMVar,
61+ newEmptyMVar, modifyMVar)
62+import Network.Wai.Handler.Warp
63+ (defaultSettings, setTimeout, setPort, runSettings)
64+import Foreign.Store (newStore, readStore, lookupStore)
65+import Language.Javascript.JSaddle (askJSM)
66+import Control.Monad.IO.Class (MonadIO(..))
67+
68+jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
69+jsaddleOr opts entryPoint otherApp = do
70+ syncHandlers <- newIORef M.empty
71+ let wsApp :: ServerApp
72+ wsApp pending_conn = do
73+ conn <- acceptRequest pending_conn
74+ rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do
75+ syncKey <- toText . contextId <$> askJSM
76+ liftIO $ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))
77+ liftIO $ sendTextData conn (encode syncKey)
78+ entryPoint
79+ _ <- forkIO . forever $
80+ receiveDataMessage conn >>= \case
81+ (WS.Text t) ->
82+ case decode t of
83+ Nothing -> error $ "jsaddle Results decode failed : " <> show t
84+ Just r -> processResult r
85+ _ -> error "jsaddle WebSocket unexpected binary data"
86+ start
87+ waitTillClosed conn
88+
89+ -- Based on Network.WebSocket.forkPingThread
90+ waitTillClosed conn = ignore `handle` go 1
91+ where
92+ go :: Int -> IO ()
93+ go i = do
94+ threadDelay (1 * 1000 * 1000)
95+ sendPing conn (T.pack $ show i)
96+ go (i + 1)
97+
98+ ignore e = case fromException e of
99+ Just async -> throwIO (async :: AsyncException)
100+ Nothing -> return ()
101+
102+ syncHandler :: Application
103+ syncHandler req sendResponse = case (W.requestMethod req, W.pathInfo req) of
104+ ("POST", ["sync", syncKey]) -> do
105+ body <- lazyRequestBody req
106+ case decode body of
107+ Nothing -> error $ "jsaddle sync message decode failed : " <> show body
108+ Just result ->
109+ M.lookup syncKey <$> readIORef syncHandlers >>= \case
110+ Nothing -> error "jsaddle missing sync message handler"
111+ Just handler -> do
112+ next <- encode <$> handler result
113+ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] next
114+ _ -> otherApp req sendResponse
115+ return $ websocketsOr opts wsApp syncHandler
116+
74117
75118jsaddleApp :: 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"
119+jsaddleApp req sendResponse =
120+ fromMaybe
121+ (sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
122+ (jsaddleAppPartial req sendResponse)
123+
124+jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
125+jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
126+ (fromMaybe (otherApp req sendResponse)
127+ (jsaddleAppPartial req sendResponse))
128+
129+jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
130+jsaddleAppPartial req sendResponse = case (W.requestMethod req, W.pathInfo req) of
131+ ("GET", []) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
132+ ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs
133+ _ -> Nothing
134+
135+-- Use this to generate this string for embedding
136+-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
137+jsaddleJs :: ByteString
138+jsaddleJs = "\
139+ \if(typeof global !== \"undefined\") {\n\
140+ \ global.window = global;\n\
141+ \ global.WebSocket = require('ws');\n\
142+ \}\n\
143+ \\n\
144+ \var connect = function() {\n\
145+ \ var wsaddress = window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\");\n\
146+ \\n\
147+ \ var ws = new WebSocket(wsaddress);\n\
148+ \ var syncKey = \"\";\n\
149+ \\n\
150+ \ ws.onopen = function(e) {\n\
151+ \ " <> initState <> "\n\
152+ \ var inXhrSend = false;\n\
153+ \\n\
154+ \ ws.onmessage = function(e) {\n\
155+ \ if(inXhrSend) return;\n\
156+ \ var batch = JSON.parse(e.data);\n\
157+ \ if(typeof batch === \"string\") {\n\
158+ \ syncKey = batch;\n\
159+ \ var xhr = new XMLHttpRequest();\n\
160+ \ xhr.open('POST', '/reload/'+syncKey, true);\n\
161+ \ xhr.onreadystatechange = function() {\n\
162+ \ if(xhr.readyState === XMLHttpRequest.DONE && xhr.status === 200)\n\
163+ \ setTimeout(function(){window.location.reload();}, 500);\n\
164+ \ };\n\
165+ \ xhr.send();\n\
166+ \ return;\n\
167+ \ }\n\
168+ \\n\
169+ \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")
170+ (Just (\a -> "(function(){\n\
171+ \ inXhrSend = true;\n\
172+ \ var xhr = new XMLHttpRequest();\n\
173+ \ xhr.open('POST', '/sync/'+syncKey, false);\n\
174+ \ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\
175+ \ xhr.send(JSON.stringify(" <> a <> "));\n\
176+ \ inXhrSend = false;\n\
177+ \ return JSON.parse(xhr.response);})()")) <> "\
178+ \ };\n\
179+ \ };\n\
180+ \ ws.onerror = function() {\n\
181+ \ setTimeout(connect, 1000);\n\
182+ \ };\n\
183+ \}\n\
184+ \\n\
185+ \ " <> ghcjsHelpers <> "\
186+ \connect();\n\
187+ \"
188+
189+-- | Start or restart the server.
190+-- To run this as part of every :reload use
191+-- > :def! reload (const $ return "::reload\nLanguage.Javascript.JSaddle.Warp.debug 3708 SomeMainModule.someMainFunction")
192+debug :: Int -> JSM () -> IO ()
193+debug port f = do
194+ debugWrapper $ \refreshMiddleware registerContext ->
195+ runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
196+ jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (refreshMiddleware jsaddleApp)
197+ putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"
198+
199+debugWrapper :: (Middleware -> JSM () -> IO ()) -> IO ()
200+debugWrapper run = do
201+ reloadMVar <- newEmptyMVar
202+ reloadDoneMVars <- newMVar []
203+ contexts <- newMVar []
204+ let refreshMiddleware :: Middleware
205+ refreshMiddleware otherApp req sendResponse = case (W.requestMethod req, W.pathInfo req) of
206+ ("POST", ["reload", _syncKey]) -> do
207+ reloadDone <- newEmptyMVar
208+ modifyMVar_ reloadDoneMVars (return . (reloadDone:))
209+ readMVar reloadMVar
210+ r <- sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] ("reload" :: ByteString)
211+ putMVar reloadDone ()
212+ return r
213+ _ -> otherApp req sendResponse
214+ start :: Int -> IO (IO Int)
215+ start expectedConnections = do
216+ serverDone <- newEmptyMVar
217+ ready <- newEmptyMVar
218+ let registerContext :: JSM ()
219+ registerContext = do
220+ uuid <- contextId <$> askJSM
221+ browsersConnected <- liftIO $ modifyMVar contexts (\ctxs -> return (uuid:ctxs, length ctxs + 1))
222+ addContext
223+ when (browsersConnected == expectedConnections) . void . liftIO $ tryPutMVar ready ()
224+ thread <- forkIO $
225+ finally (run refreshMiddleware registerContext)
226+ (putMVar serverDone ())
227+ _ <- forkIO $ threadDelay 10000000 >> void (tryPutMVar ready ())
228+ when (expectedConnections /= 0) $ takeMVar ready
229+ return $ do
230+ putMVar reloadMVar ()
231+ ctxs <- takeMVar contexts
232+ mapM_ removeContext ctxs
233+ takeMVar reloadDoneMVars >>= mapM_ takeMVar
234+ killThread thread
235+ takeMVar serverDone
236+ return $ length ctxs
237+ lookupStore shutdown_0 >>= \case
238+ Nothing -> do
239+ shutdownRef <- newIORef =<< start 0
240+ void $ newStore shutdownRef
241+ Just shutdownStore -> do
242+ shutdownRef :: IORef (IO Int) <- readStore shutdownStore
243+ expectedConnections <- join (readIORef shutdownRef)
244+ writeIORef shutdownRef =<< start expectedConnections
245+ where shutdown_0 = 0