git.iko.soy/jsaddle
on master help sign in
Fix #28 with synchronous XMLHttpRequest send
6c28fa8Hamish Mackenzie
jsaddle-warp/jsaddle-warp.cabal+4−1
compare with master
unifiedsplit
@@ -1,5 +1,5 @@
1name: jsaddle-warp
1name: jsaddle-warp
2−version: 0.9.0.0
2+version: 0.9.1.0
3cabal-version: >=1.10
3cabal-version: >=1.10
4build-type: Simple
4build-type: Simple
5license: MIT
5license: MIT
@@ -26,6 +26,7 @@ library
26 Language.Javascript.JSaddle.WebSockets
26 Language.Javascript.JSaddle.WebSockets
27 build-depends:
27 build-depends:
28 aeson >=0.8.0.2 && <1.3,
28 aeson >=0.8.0.2 && <1.3,
29+ bytestring >=0.10.6.0 && <0.11,
29 containers >=0.5.6.2 && <0.6,
30 containers >=0.5.6.2 && <0.6,
30 http-types >=0.8.6 && <0.10,
31 http-types >=0.8.6 && <0.10,
31 jsaddle >=0.9.0.0 && <0.10,
32 jsaddle >=0.9.0.0 && <0.10,
@@ -33,6 +34,8 @@ library
33 text >=1.2.1.3 && <1.3,
34 text >=1.2.1.3 && <1.3,
34 time >=1.5.0.1 && <1.8,
35 time >=1.5.0.1 && <1.8,
35 transformers >=0.4.2.0 && <0.6,
36 transformers >=0.4.2.0 && <0.6,
37+ uuid >=1.3.13 && <1.4,
38+ uuid-types >=1.0.3 && <1.1,
36 wai >=3.0.3.0 && <3.3,
39 wai >=3.0.3.0 && <3.3,
37 wai-websockets >=3.0.0.6 && <3.1,
40 wai-websockets >=3.0.0.6 && <3.1,
38 warp >=3.1.2 && <3.3,
41 warp >=3.1.2 && <3.3,
jsaddle-warp/src/Language/Javascript/JSaddle/Warp.hs+1−1
@@ -39,6 +39,6 @@ run _port = id
39#else
39#else
40run :: Int -> JSM () -> IO ()
40run :: Int -> JSM () -> IO ()
41run port f =
41run port f =
42− runSettings (setPort port (setTimeout 3600 defaultSettings)) $
42+ runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
43 jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp
43 jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp
44#endif
44#endif
jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+111−42
@@ -27,7 +27,8 @@ import Control.Exception (handle, AsyncException, throwIO, fromException)
27import Data.Monoid ((<>))
27import Data.Monoid ((<>))
28import Data.Aeson (encode, decode)
28import Data.Aeson (encode, decode)
29
29
30+import Network.Wai
30−import Network.Wai (Application, Request, Response, ResponseReceived)
31+ (requestBody, Application, Request, Response, ResponseReceived)
31import Network.WebSockets
32import Network.WebSockets
32 (ConnectionOptions(..), sendTextData, receiveDataMessage,
33 (ConnectionOptions(..), sendTextData, receiveDataMessage,
33 acceptRequest, ServerApp, sendPing)
34 acceptRequest, ServerApp, sendPing)
@@ -41,53 +42,121 @@ import qualified Data.Text as T (pack)
41import qualified Network.HTTP.Types as H
42import qualified Network.HTTP.Types as H
42 (status403, status200)
43 (status403, status200)
43import Language.Javascript.JSaddle.Run (runJavaScript)
44import 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)
45
53
46−jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application
54+jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
47−jsaddleOr opts entryPoint = websocketsOr opts wsApp
55+jsaddleOr opts entryPoint otherApp = do
48− where
56+ syncHandlers <- newIORef M.empty
49− wsApp :: ServerApp
57+ let wsApp :: ServerApp
50− wsApp pending_conn = do
58+ wsApp pending_conn = do
51− conn <- acceptRequest pending_conn
59+ conn <- acceptRequest pending_conn
52− (processResult, _, start) <- runJavaScript (sendTextData conn . encode) entryPoint
60+ (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) entryPoint
53− _ <- forkIO . forever $
61+ _ <- forkIO . forever $
54− receiveDataMessage conn >>= \case
62+ receiveDataMessage conn >>= \case
55− (WS.Text t) ->
63+ (WS.Text t) ->
56− case decode t of
64+ case decode t of
57− Nothing -> error $ "jsaddle Results decode failed : " <> show t
65+ Nothing -> error $ "jsaddle Results decode failed : " <> show t
58− Just r -> processResult r
66+ Just r -> processResult r
59− _ -> error "jsaddle WebSocket unexpected binary data"
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)
60− start
71+ start
61− waitTillClosed conn
72+ waitTillClosed conn
62
73
63− -- Based on Network.WebSocket.forkPingThread
74+ -- Based on Network.WebSocket.forkPingThread
64− waitTillClosed conn = ignore `handle` go 1
75+ waitTillClosed conn = ignore `handle` go 1
65− where
76+ where
66− go :: Int -> IO ()
77+ go :: Int -> IO ()
67− go i = do
78+ go i = do
68− threadDelay (1 * 1000 * 1000)
79+ threadDelay (1 * 1000 * 1000)
69− sendPing conn (T.pack $ show i)
80+ sendPing conn (T.pack $ show i)
70− go (i + 1)
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
71
101
72− ignore e = case fromException e of
73− Just async -> throwIO (async :: AsyncException)
74− Nothing -> return ()
75
102
76jsaddleApp :: Application
103jsaddleApp :: Application
77−jsaddleApp req sendResponse = jsaddleAppPartial req sendResponse >>= \case
104+jsaddleApp req sendResponse =
78− Just r -> return r
105+ fromMaybe
79− Nothing -> sendResponse $ W.responseLBS H.status403
106+ (sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
80− [ ("Content-Type", "text/plain")
107+ (jsaddleAppPartial req sendResponse)
81− ] "Forbidden"
82
108
83−jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> Application
109+jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
84jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
110jsaddleWithAppOr 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))
88
113
89−jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> IO (Maybe ResponseReceived)
114+jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
90jsaddleAppPartial req sendResponse = case (W.requestMethod req, W.pathInfo req) of
115jsaddleAppPartial req sendResponse = case (W.requestMethod req, W.pathInfo req) of
91− ("GET", []) -> fmap Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
116+ ("GET", []) -> 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
117+ ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs
93− _ -> return Nothing
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+