git.iko.soy/jsaddle
on master help sign in
Merge pull request #37 from obsidiansystems/make-debug-optional
d4e1706Hamish Mackenzie
jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+38−28
compare with master
unifiedsplit
@@ -115,10 +115,13 @@ jsaddleOr opts entryPoint otherApp = do
115
115
116
116
117jsaddleApp :: Application
117jsaddleApp :: Application
118+jsaddleApp = jsaddleAppWithJs $ jsaddleJs False
119+
120+jsaddleAppWithJs :: ByteString -> Application
118−jsaddleApp req sendResponse =
121+jsaddleAppWithJs js req sendResponse =
119 fromMaybe
122 fromMaybe
120 (sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
123 (sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
121− (jsaddleAppPartial req sendResponse)
124+ (jsaddleAppPartialWithJs js req sendResponse)
122
125
123jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
126jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
124jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
127jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
@@ -126,15 +129,18 @@ jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sen
126 (jsaddleAppPartial req sendResponse))
129 (jsaddleAppPartial req sendResponse))
127
130
128jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
131jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
132+jsaddleAppPartial = jsaddleAppPartialWithJs $ jsaddleJs False
133+
134+jsaddleAppPartialWithJs :: ByteString -> Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
129−jsaddleAppPartial req sendResponse = case (W.requestMethod req, W.pathInfo req) of
135+jsaddleAppPartialWithJs js req sendResponse = case (W.requestMethod req, W.pathInfo req) of
130 ("GET", []) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
136 ("GET", []) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
131− ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs
137+ ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] js
132 _ -> Nothing
138 _ -> Nothing
133
139
134-- Use this to generate this string for embedding
140-- Use this to generate this string for embedding
135-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
141-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
136−jsaddleJs :: ByteString
142+jsaddleJs :: Bool -> ByteString
137−jsaddleJs = "\
143+jsaddleJs refreshOnLoad = "\
138 \if(typeof global !== \"undefined\") {\n\
144 \if(typeof global !== \"undefined\") {\n\
139 \ global.window = global;\n\
145 \ global.window = global;\n\
140 \ global.WebSocket = require('ws');\n\
146 \ global.WebSocket = require('ws');\n\
@@ -156,15 +162,17 @@ jsaddleJs = "\
156 \ return;\n\
162 \ return;\n\
157 \ }\n\
163 \ }\n\
158 \ if(typeof batch === \"string\") {\n\
164 \ if(typeof batch === \"string\") {\n\
159− \ syncKey = batch;\n\
165+ \ syncKey = batch;\n" <>
166+ (if refreshOnLoad
160− \ var xhr = new XMLHttpRequest();\n\
167+ then " var xhr = new XMLHttpRequest();\n\
161− \ xhr.open('POST', '/reload/'+syncKey, true);\n\
168+ \ xhr.open('POST', '/reload/'+syncKey, true);\n\
162− \ xhr.onreadystatechange = function() {\n\
169+ \ xhr.onreadystatechange = function() {\n\
163− \ if(xhr.readyState === XMLHttpRequest.DONE && xhr.status === 200)\n\
170+ \ if(xhr.readyState === XMLHttpRequest.DONE && xhr.status === 200)\n\
164− \ setTimeout(function(){window.location.reload();}, 500);\n\
171+ \ setTimeout(function(){window.location.reload();}, 500);\n\
165− \ };\n\
172+ \ };\n\
166− \ xhr.send();\n\
173+ \ xhr.send();\n"
174+ else "") <>
167− \ return;\n\
175+ " return;\n\
168 \ }\n\
176 \ }\n\
169 \\n\
177 \\n\
170 \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")
178 \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")
@@ -190,26 +198,28 @@ jsaddleJs = "\
190-- > :def! reload (const $ return "::reload\nLanguage.Javascript.JSaddle.Warp.debug 3708 SomeMainModule.someMainFunction")
198-- > :def! reload (const $ return "::reload\nLanguage.Javascript.JSaddle.Warp.debug 3708 SomeMainModule.someMainFunction")
191debug :: Int -> JSM () -> IO ()
199debug :: Int -> JSM () -> IO ()
192debug port f = do
200debug port f = do
193− debugWrapper $ \refreshMiddleware registerContext ->
201+ debugWrapper $ \withRefresh registerContext ->
194 runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
202 runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
195− jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (refreshMiddleware jsaddleApp)
203+ jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJs $ jsaddleJs True)
196 putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"
204 putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"
197
205
206+refreshMiddleware :: ((Response -> IO ResponseReceived) -> IO ResponseReceived) -> Middleware
207+refreshMiddleware refresh otherApp req sendResponse = case (W.requestMethod req, W.pathInfo req) of
208+ ("POST", ["reload", _syncKey]) -> refresh sendResponse
209+ _ -> otherApp req sendResponse
210+
198debugWrapper :: (Middleware -> JSM () -> IO ()) -> IO ()
211debugWrapper :: (Middleware -> JSM () -> IO ()) -> IO ()
199debugWrapper run = do
212debugWrapper run = do
200 reloadMVar <- newEmptyMVar
213 reloadMVar <- newEmptyMVar
201 reloadDoneMVars <- newMVar []
214 reloadDoneMVars <- newMVar []
202 contexts <- newMVar []
215 contexts <- newMVar []
203− let refreshMiddleware :: Middleware
216+ let refresh sendResponse = do
204− refreshMiddleware otherApp req sendResponse = case (W.requestMethod req, W.pathInfo req) of
205− ("POST", ["reload", _syncKey]) -> do
206− reloadDone <- newEmptyMVar
217+ reloadDone <- newEmptyMVar
207− modifyMVar_ reloadDoneMVars (return . (reloadDone:))
218+ modifyMVar_ reloadDoneMVars (return . (reloadDone:))
208− readMVar reloadMVar
219+ readMVar reloadMVar
209− r <- sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] ("reload" :: ByteString)
220+ r <- sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] ("reload" :: ByteString)
210− putMVar reloadDone ()
221+ putMVar reloadDone ()
211− return r
222+ return r
212− _ -> otherApp req sendResponse
213 start :: Int -> IO (IO Int)
223 start :: Int -> IO (IO Int)
214 start expectedConnections = do
224 start expectedConnections = do
215 serverDone <- newEmptyMVar
225 serverDone <- newEmptyMVar
@@ -221,7 +231,7 @@ debugWrapper run = do
221 addContext
231 addContext
222 when (browsersConnected == expectedConnections) . void . liftIO $ tryPutMVar ready ()
232 when (browsersConnected == expectedConnections) . void . liftIO $ tryPutMVar ready ()
223 thread <- forkIO $
233 thread <- forkIO $
224− finally (run refreshMiddleware registerContext)
234+ finally (run (refreshMiddleware refresh) registerContext)
225 (putMVar serverDone ())
235 (putMVar serverDone ())
226 _ <- forkIO $ threadDelay 10000000 >> void (tryPutMVar ready ())
236 _ <- forkIO $ threadDelay 10000000 >> void (tryPutMVar ready ())
227 when (expectedConnections /= 0) $ takeMVar ready
237 when (expectedConnections /= 0) $ takeMVar ready