@@ -19,13 +19,9 @@ module Language.Javascript.JSaddle.WebSockets (
1919 jsaddleOr
2020 , jsaddleApp
2121 , jsaddleWithAppOr
22− , jsaddleAppWithJs
23− , jsaddleAppWithJsOr
2422 , jsaddleAppPartial
2523 , jsaddleJs
26− , jsaddleJs'
2724 , debug
28− , debugOr
2925 , debugWrapper
3026) where
3127
@@ -42,12 +38,12 @@ import Network.Wai
4238import Network.WebSockets
4339 (defaultConnectionOptions, ConnectionOptions(..), sendTextData,
4440 receiveDataMessage, acceptRequest, ServerApp, sendPing)
41+import qualified Network.WebSockets as WS (DataMessage(..))
4542import Network.Wai.Handler.WebSockets (websocketsOr)
46−import Network.HTTP.Types (Status(..))
4743
4844import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))
4945import qualified Network.Wai as W
50− (responseLBS, requestMethod, pathInfo, modifyResponse, responseStatus)
46+ (responseLBS, requestMethod, pathInfo)
5147import qualified Data.Text as T (pack)
5248import qualified Network.HTTP.Types as H
5349 (status403, status200)
@@ -60,57 +56,42 @@ import qualified Data.Map as M (empty, insert, lookup)
6056import Data.IORef
6157 (readIORef, newIORef, atomicModifyIORef')
6258import Data.ByteString.Lazy (ByteString)
63−import qualified Data.ByteString.Lazy as LBS
64− (toStrict, stripPrefix)
6559import Control.Concurrent.MVar
6660 (tryTakeMVar, MVar, tryPutMVar, modifyMVar_, putMVar, takeMVar,
6761 readMVar, newMVar, newEmptyMVar, modifyMVar)
6862import Network.Wai.Handler.Warp
6963 (defaultSettings, setTimeout, setPort, runSettings)
70−import Foreign.Store (readStore, lookupStore, writeStore, Store(..))
64+import Foreign.Store (newStore, readStore, lookupStore)
7165import Language.Javascript.JSaddle (askJSM)
7266import Control.Monad.IO.Class (MonadIO(..))
7367
74−import Language.Javascript.JSaddle.WebSockets.Compat (getTextMessageByteString)
75−import qualified Data.Text.Encoding as T (decodeUtf8)
76−
7768jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
7869jsaddleOr opts entryPoint otherApp = do
7970 syncHandlers <- newIORef M.empty
80− asyncHandlers <- newIORef M.empty
8171 let wsApp :: ServerApp
8272 wsApp pending_conn = do
8373 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"
106− _ -> error "jsaddle WebSocket unexpected binary data"
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
10788
10889 -- Based on Network.WebSocket.forkPingThread
10990 waitTillClosed conn = ignore `handle` go 1
11091 where
11192 go :: Int -> IO ()
11293 go i = do
113− threadDelay (10 * 1000 * 1000)
94+ threadDelay (1 * 1000 * 1000)
11495 sendPing conn (T.pack $ show i)
11596 go (i + 1)
11697
@@ -130,11 +111,7 @@ jsaddleOr opts entryPoint otherApp = do
130111 Just handler -> do
131112 next <- encode <$> handler result
132113 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
114+ _ -> otherApp req sendResponse
138115 return $ websocketsOr opts wsApp syncHandler
139116
140117
@@ -143,14 +120,9 @@ jsaddleApp = jsaddleAppWithJs $ jsaddleJs False
143120
144121jsaddleAppWithJs :: ByteString -> Application
145122jsaddleAppWithJs 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)
123+ fromMaybe
124+ (sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
125+ (jsaddleAppPartialWithJs js req sendResponse)
154126
155127jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
156128jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
@@ -160,58 +132,38 @@ jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sen
160132jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
161133jsaddleAppPartial = jsaddleAppPartialWithJs $ jsaddleJs False
162134
163−indexResponse :: Response
164−indexResponse = W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
165−
166135jsaddleAppPartialWithJs :: ByteString -> Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
167136jsaddleAppPartialWithJs js req sendResponse = case (W.requestMethod req, W.pathInfo req) of
168− ("GET", []) -> Just $ sendResponse indexResponse
137+ ("GET", []) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
169138 ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] js
170139 _ -> Nothing
171140
172−jsaddleJs :: Bool -> ByteString
173−jsaddleJs = jsaddleJs' Nothing
174−
175141-- Use this to generate this string for embedding
176142-- 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\
143+jsaddleJs :: Bool -> ByteString
144+jsaddleJs refreshOnLoad = "\
145+ \if(typeof global !== \"undefined\") {\n\
180146 \ global.window = global;\n\
181147 \ global.WebSocket = require('ws');\n\
182148 \}\n\
183149 \\n\
184150 \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\
151+ \ var wsaddress = window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\");\n\
190152 \\n\
191− \ var ws0 = new WebSocket(wsaddress);\n\
153+ \ var ws = new WebSocket(wsaddress);\n\
192154 \ var syncKey = \"\";\n\
193155 \\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\
156+ \ ws.onopen = function(e) {\n\
198157 \ " <> initState <> "\n\
199158 \\n\
200− \ ws0.onmessage = function(e) {\n\
159+ \ ws.onmessage = function(e) {\n\
201160 \ var batch = JSON.parse(e.data);\n\
202161 \ if(inCallback > 0) {\n\
203162 \ asyncBatch = batch;\n\
204163 \ return;\n\
205164 \ }\n\
206165 \ 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" <>
166+ \ syncKey = batch;\n" <>
215167 (if refreshOnLoad
216168 then " var xhr = new XMLHttpRequest();\n\
217169 \ xhr.open('POST', '/reload/'+syncKey, true);\n\
@@ -227,13 +179,13 @@ jsaddleJs' jsaddleUri refreshOnLoad = "\
227179 \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")
228180 (Just (\a -> "(function(){\n\
229181 \ var xhr = new XMLHttpRequest();\n\
230− \ xhr.open('POST', '" <> fromMaybe "" jsaddleUri <> "/sync/'+syncKey, false);\n\
182+ \ xhr.open('POST', '/sync/'+syncKey, false);\n\
231183 \ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\
232184 \ xhr.send(JSON.stringify(" <> a <> "));\n\
233185 \ return JSON.parse(xhr.response);})()")) <> "\
234186 \ };\n\
235187 \ };\n\
236− \ ws0.onerror = function() {\n\
188+ \ ws.onerror = function() {\n\
237189 \ setTimeout(connect, 1000);\n\
238190 \ };\n\
239191 \}\n\
@@ -252,13 +204,6 @@ debug port f = do
252204 jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJs $ jsaddleJs True)
253205 putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"
254206
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−
262207refreshMiddleware :: ((Response -> IO ResponseReceived) -> IO ResponseReceived) -> Middleware
263208refreshMiddleware refresh otherApp req sendResponse = case (W.requestMethod req, W.pathInfo req) of
264209 ("POST", ["reload", _syncKey]) -> refresh sendResponse
@@ -307,13 +252,13 @@ debugWrapper run = do
307252 start' <- takeMVar mvar
308253 n <- stop
309254 start' n >>= restarter mvar
310− lookupStore storeId >>= \case
255+ lookupStore shutdown_0 >>= \case
311256 Nothing -> do
312257 restartMVar <- newMVar start
313258 void . forkIO $ restarter restartMVar (return 0)
314− void $ writeStore (Store storeId) restartMVar
259+ void $ newStore restartMVar
315260 Just shutdownStore -> do
316261 restartMVar :: MVar (Int -> IO (IO Int)) <- readStore shutdownStore
317262 void $ tryTakeMVar restartMVar
318263 putMVar restartMVar start
319− where storeId = 354
264+ where shutdown_0 = 0