@@ -19,9 +19,13 @@ module Language.Javascript.JSaddle.WebSockets (
1919 jsaddleOr
2020 , jsaddleApp
2121 , jsaddleWithAppOr
22+ , jsaddleAppWithJs
23+ , jsaddleAppWithJsOr
2224 , jsaddleAppPartial
2325 , jsaddleJs
26+ , jsaddleJs'
2427 , debug
28+ , debugOr
2529 , debugWrapper
2630) where
2731
@@ -38,12 +42,12 @@ import Network.Wai
3842import Network.WebSockets
3943 (defaultConnectionOptions, ConnectionOptions(..), sendTextData,
4044 receiveDataMessage, acceptRequest, ServerApp, sendPing)
41−import qualified Network.WebSockets as WS (DataMessage(..))
4245import Network.Wai.Handler.WebSockets (websocketsOr)
46+import Network.HTTP.Types (Status(..))
4347
4448import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))
4549import qualified Network.Wai as W
46− (responseLBS, requestMethod, pathInfo)
50+ (responseLBS, requestMethod, pathInfo, modifyResponse, responseStatus)
4751import qualified Data.Text as T (pack)
4852import qualified Network.HTTP.Types as H
4953 (status403, status200)
@@ -56,42 +60,57 @@ import qualified Data.Map as M (empty, insert, lookup)
5660import Data.IORef
5761 (readIORef, newIORef, atomicModifyIORef')
5862import Data.ByteString.Lazy (ByteString)
63+import qualified Data.ByteString.Lazy as LBS
64+ (toStrict, stripPrefix)
5965import Control.Concurrent.MVar
6066 (tryTakeMVar, MVar, tryPutMVar, modifyMVar_, putMVar, takeMVar,
6167 readMVar, newMVar, newEmptyMVar, modifyMVar)
6268import Network.Wai.Handler.Warp
6369 (defaultSettings, setTimeout, setPort, runSettings)
64−import Foreign.Store (newStore, readStore, lookupStore)
70+import Foreign.Store (readStore, lookupStore, writeStore, Store(..))
6571import Language.Javascript.JSaddle (askJSM)
6672import Control.Monad.IO.Class (MonadIO(..))
6773
74+import Language.Javascript.JSaddle.WebSockets.Compat (getTextMessageByteString)
75+import qualified Data.Text.Encoding as T (decodeUtf8)
76+
6877jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
6978jsaddleOr opts entryPoint otherApp = do
7079 syncHandlers <- newIORef M.empty
80+ asyncHandlers <- newIORef M.empty
7181 let wsApp :: ServerApp
7282 wsApp pending_conn = do
7383 conn <- acceptRequest pending_conn
74− rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do
75− syncKey <- T.pack . show . 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
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"
106+ _ -> error "jsaddle WebSocket unexpected binary data"
88107
89108 -- Based on Network.WebSocket.forkPingThread
90109 waitTillClosed conn = ignore `handle` go 1
91110 where
92111 go :: Int -> IO ()
93112 go i = do
94− threadDelay (1 * 1000 * 1000)
113+ threadDelay (10 * 1000 * 1000)
95114 sendPing conn (T.pack $ show i)
96115 go (i + 1)
97116
@@ -111,7 +130,11 @@ jsaddleOr opts entryPoint otherApp = do
111130 Just handler -> do
112131 next <- encode <$> handler result
113132 sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] next
114− _ -> otherApp req sendResponse
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
115138 return $ websocketsOr opts wsApp syncHandler
116139
117140
@@ -120,9 +143,14 @@ jsaddleApp = jsaddleAppWithJs $ jsaddleJs False
120143
121144jsaddleAppWithJs :: ByteString -> Application
122145jsaddleAppWithJs js req sendResponse =
123− fromMaybe
124− (sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
125− (jsaddleAppPartialWithJs 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)
126154
127155jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
128156jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
@@ -132,38 +160,58 @@ jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sen
132160jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
133161jsaddleAppPartial = jsaddleAppPartialWithJs $ jsaddleJs False
134162
163+indexResponse :: Response
164+indexResponse = W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
165+
135166jsaddleAppPartialWithJs :: ByteString -> Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
136167jsaddleAppPartialWithJs js req sendResponse = case (W.requestMethod req, W.pathInfo req) of
137− ("GET", []) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
168+ ("GET", []) -> Just $ sendResponse indexResponse
138169 ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] js
139170 _ -> Nothing
140171
172+jsaddleJs :: Bool -> ByteString
173+jsaddleJs = jsaddleJs' Nothing
174+
141175-- Use this to generate this string for embedding
142176-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
143−jsaddleJs :: Bool -> ByteString
144−jsaddleJs refreshOnLoad = "\
145− \if(typeof global !== \"undefined\") {\n\
177+jsaddleJs' :: Maybe ByteString -> Bool -> ByteString
178+jsaddleJs' jsaddleUri refreshOnLoad = "\
179+ \if(typeof global !== \"undefined\" && typeof require === \"function\") {\n\
146180 \ global.window = global;\n\
147181 \ global.WebSocket = require('ws');\n\
148182 \}\n\
149183 \\n\
150184 \var connect = function() {\n\
151− \ var wsaddress = window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\");\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\
152190 \\n\
153− \ var ws = new WebSocket(wsaddress);\n\
191+ \ var ws0 = new WebSocket(wsaddress);\n\
154192 \ var syncKey = \"\";\n\
155193 \\n\
156− \ ws.onopen = function(e) {\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\
157198 \ " <> initState <> "\n\
158199 \\n\
159− \ ws.onmessage = function(e) {\n\
200+ \ ws0.onmessage = function(e) {\n\
160201 \ var batch = JSON.parse(e.data);\n\
161202 \ if(inCallback > 0) {\n\
162203 \ asyncBatch = batch;\n\
163204 \ return;\n\
164205 \ }\n\
165206 \ if(typeof batch === \"string\") {\n\
166− \ syncKey = batch;\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" <>
167215 (if refreshOnLoad
168216 then " var xhr = new XMLHttpRequest();\n\
169217 \ xhr.open('POST', '/reload/'+syncKey, true);\n\
@@ -179,13 +227,13 @@ jsaddleJs refreshOnLoad = "\
179227 \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")
180228 (Just (\a -> "(function(){\n\
181229 \ var xhr = new XMLHttpRequest();\n\
182− \ xhr.open('POST', '/sync/'+syncKey, false);\n\
230+ \ xhr.open('POST', '" <> fromMaybe "" jsaddleUri <> "/sync/'+syncKey, false);\n\
183231 \ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\
184232 \ xhr.send(JSON.stringify(" <> a <> "));\n\
185233 \ return JSON.parse(xhr.response);})()")) <> "\
186234 \ };\n\
187235 \ };\n\
188− \ ws.onerror = function() {\n\
236+ \ ws0.onerror = function() {\n\
189237 \ setTimeout(connect, 1000);\n\
190238 \ };\n\
191239 \}\n\
@@ -204,6 +252,13 @@ debug port f = do
204252 jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJs $ jsaddleJs True)
205253 putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"
206254
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+
207262refreshMiddleware :: ((Response -> IO ResponseReceived) -> IO ResponseReceived) -> Middleware
208263refreshMiddleware refresh otherApp req sendResponse = case (W.requestMethod req, W.pathInfo req) of
209264 ("POST", ["reload", _syncKey]) -> refresh sendResponse
@@ -252,13 +307,13 @@ debugWrapper run = do
252307 start' <- takeMVar mvar
253308 n <- stop
254309 start' n >>= restarter mvar
255− lookupStore shutdown_0 >>= \case
310+ lookupStore storeId >>= \case
256311 Nothing -> do
257312 restartMVar <- newMVar start
258313 void . forkIO $ restarter restartMVar (return 0)
259− void $ newStore restartMVar
314+ void $ writeStore (Store storeId) restartMVar
260315 Just shutdownStore -> do
261316 restartMVar :: MVar (Int -> IO (IO Int)) <- readStore shutdownStore
262317 void $ tryTakeMVar restartMVar
263318 putMVar restartMVar start
264− where shutdown_0 = 0
319+ where storeId = 354