@@ -27,7 +27,8 @@ import Control.Exception (handle, AsyncException, throwIO, fromException)
2727import Data.Monoid ((<>))
2828import Data.Aeson (encode, decode)
2929
30−import Network.Wai (Application, Request, Response, ResponseReceived)
30+import Network.Wai
31+ (requestBody, Application, Request, Response, ResponseReceived)
3132import Network.WebSockets
3233 (ConnectionOptions(..), sendTextData, receiveDataMessage,
3334 acceptRequest, ServerApp, sendPing)
@@ -41,53 +42,121 @@ import qualified Data.Text as T (pack)
4142import qualified Network.HTTP.Types as H
4243 (status403, status200)
4344import Language.Javascript.JSaddle.Run (runJavaScript)
44−import Language.Javascript.JSaddle.Run.Files (indexHtml, jsaddleJs)
45+import Language.Javascript.JSaddle.Run.Files (indexHtml, runBatch, ghcjsHelpers, initState)
46+import Data.Maybe (fromMaybe)
47+import 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)
4553
46−jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application
47−jsaddleOr opts entryPoint = websocketsOr opts wsApp
48− where
49− wsApp :: ServerApp
50− wsApp pending_conn = do
51− conn <- acceptRequest pending_conn
52− (processResult, _, start) <- runJavaScript (sendTextData conn . encode) entryPoint
53− _ <- forkIO . forever $
54− receiveDataMessage conn >>= \case
55− (WS.Text t) ->
56− case decode t of
57− Nothing -> error $ "jsaddle Results decode failed : " <> show t
58− Just r -> processResult r
59− _ -> error "jsaddle WebSocket unexpected binary data"
60− start
61− waitTillClosed conn
54+jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
55+jsaddleOr opts entryPoint otherApp = do
56+ syncHandlers <- newIORef M.empty
57+ let wsApp :: ServerApp
58+ wsApp pending_conn = do
59+ 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
6273
63− -- Based on Network.WebSocket.forkPingThread
64− waitTillClosed conn = ignore `handle` go 1
65− where
66− go :: Int -> IO ()
67− go i = do
68− threadDelay (1 * 1000 * 1000)
69− sendPing conn (T.pack $ show i)
70− go (i + 1)
74+ -- Based on Network.WebSocket.forkPingThread
75+ waitTillClosed conn = ignore `handle` go 1
76+ where
77+ go :: Int -> IO ()
78+ go i = do
79+ threadDelay (1 * 1000 * 1000)
80+ sendPing conn (T.pack $ show i)
81+ go (i + 1)
82+
83+ ignore e = case fromException e of
84+ Just async -> throwIO (async :: AsyncException)
85+ Nothing -> return ()
86+
87+ syncHandler :: Application
88+ syncHandler req sendResponse = case (W.requestMethod req, W.pathInfo req) of
89+ ("POST", ["sync", syncKey]) -> do
90+ body <- requestBody req
91+ case decode $ fromStrict body of
92+ Nothing -> error $ "jsaddle sync message decode failed : " <> show body
93+ Just result ->
94+ M.lookup syncKey <$> readIORef syncHandlers >>= \case
95+ Nothing -> error "jsaddle missing sync message handler"
96+ Just handler -> do
97+ next <- encode <$> handler result
98+ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] next
99+ _ -> otherApp req sendResponse
100+ return $ websocketsOr opts wsApp syncHandler
71101
72− ignore e = case fromException e of
73− Just async -> throwIO (async :: AsyncException)
74− Nothing -> return ()
75102
76103jsaddleApp :: Application
77−jsaddleApp req sendResponse = jsaddleAppPartial req sendResponse >>= \case
78− Just r -> return r
79− Nothing -> sendResponse $ W.responseLBS H.status403
80− [ ("Content-Type", "text/plain")
81− ] "Forbidden"
104+jsaddleApp req sendResponse =
105+ fromMaybe
106+ (sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
107+ (jsaddleAppPartial req sendResponse)
82108
83−jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> Application
109+jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
84110jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
85− jsaddleAppPartial req sendResponse >>= \case
86− Just r -> return r
87− Nothing -> otherApp req sendResponse
111+ (fromMaybe (otherApp req sendResponse)
112+ (jsaddleAppPartial req sendResponse))
88113
89−jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> IO (Maybe ResponseReceived)
114+jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
90115jsaddleAppPartial req sendResponse = case (W.requestMethod req, W.pathInfo req) of
91− ("GET", []) -> fmap Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
92− ("GET", ["jsaddle.js"]) -> fmap Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs
93− _ -> return Nothing
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
118+ _ -> Nothing
119+
120+-- Use this to generate this string for embedding
121+-- 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\
125+ \ global.window = global;\n\
126+ \ global.WebSocket = require('ws');\n\
127+ \}\n\
128+ \\n\
129+ \var connect = function() {\n\
130+ \ var wsaddress = window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\");\n\
131+ \\n\
132+ \ var ws = new WebSocket(wsaddress);\n\
133+ \ var syncKey = \"\";\n\
134+ \\n\
135+ \ ws.onopen = function(e) {\n\
136+ \ " <> initState <> "\
137+ \\n\
138+ \ ws.onmessage = function(e) {\n\
139+ \ var batch = JSON.parse(e.data);\n\
140+ \ if(typeof batch === \"string\") {\n\
141+ \ syncKey = batch;\n\
142+ \ return;\n\
143+ \ }\n\
144+ \\n\
145+ \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")
146+ (Just (\a -> "(function(){\n\
147+ \ var xhr = new XMLHttpRequest();\n\
148+ \ xhr.open('POST', '/sync/'+syncKey, false);\n\
149+ \ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\
150+ \ xhr.send(JSON.stringify(" <> a <> "));\n\
151+ \ return JSON.parse(xhr.response);})()")) <> "\
152+ \ };\n\
153+ \ };\n\
154+ \ ws.onerror = function() {\n\
155+ \ setTimeout(connect, 1000);\n\
156+ \ };\n\
157+ \}\n\
158+ \\n\
159+ \ " <> ghcjsHelpers <> "\
160+ \connect();\n\
161+ \"
162+