@@ -1,7 +1,5 @@
11{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE RecursiveDo #-}
53-----------------------------------------------------------------------------
64--
75-- Module : Language.Javascript.JSaddle.WebSockets
@@ -18,302 +16,73 @@ module Language.Javascript.JSaddle.WebSockets (
1816 -- * Running JSM over WebSockets
1917 jsaddleOr
2018 , jsaddleApp
21− , jsaddleWithAppOr
22− , jsaddleAppWithJs
23− , jsaddleAppWithJsOr
24− , jsaddleAppPartial
25− , jsaddleJs
26− , jsaddleJs'
27− , debug
28− , debugOr
29− , debugWrapper
3019) where
3120
32−import Control.Monad (when, void, forever)
33−import Control.Concurrent (killThread, forkIO, threadDelay)
34−import Control.Exception (handle, AsyncException, throwIO, fromException, finally)
21+import Control.Monad (forever)
22+import Control.Concurrent (forkIO, threadDelay)
23+import Control.Exception (handle, AsyncException, throwIO, fromException)
3524
3625import Data.Monoid ((<>))
3726import Data.Aeson (encode, decode)
3827
39−import Network.Wai
40− (Middleware, lazyRequestBody, Application, Request, Response,
41− ResponseReceived)
28+import Network.Wai (Application)
4229import Network.WebSockets
43− (defaultConnectionOptions, ConnectionOptions(..), sendTextData,
44− receiveDataMessage, acceptRequest, ServerApp, sendPing)
30+ (ConnectionOptions(..), sendTextData, receiveDataMessage,
31+ acceptRequest, ServerApp, sendPing)
32+import qualified Network.WebSockets as WS (DataMessage(..))
4533import Network.Wai.Handler.WebSockets (websocketsOr)
46−import Network.HTTP.Types (Status(..))
4734
48−import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))
35+import Language.Javascript.JSaddle.Types (JSM(..))
4936import qualified Network.Wai as W
50− (responseLBS, requestMethod, pathInfo, modifyResponse, responseStatus)
37+ (responseLBS, requestMethod, Application, pathInfo)
38+import Data.Text (Text)
5139import qualified Data.Text as T (pack)
5240import qualified Network.HTTP.Types as H
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"
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
10658 _ -> error "jsaddle WebSocket unexpected binary data"
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−
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 ()
14074
14175jsaddleApp :: Application
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
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"