module Language.Javascript.JSaddle.WebSockets (
jsaddleOr
, jsaddleApp
, jsaddleWithAppOr
, jsaddleAppPartial
, debug
, debugWrapper
) where
import Control.Monad (when, void, forever)
import Control.Concurrent (killThread, forkIO, threadDelay)
import Control.Exception (handle, AsyncException, throwIO, fromException, finally)
import Data.Monoid ((<>))
import Data.Aeson (encode, decode)
import Network.Wai
(Middleware, lazyRequestBody, Application, Request, Response,
ResponseReceived)
import Network.WebSockets
(defaultConnectionOptions, ConnectionOptions(..), sendTextData,
receiveDataMessage, acceptRequest, ServerApp, sendPing)
import qualified Network.WebSockets as WS (DataMessage(..))
import Network.Wai.Handler.WebSockets (websocketsOr)
import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))
import qualified Network.Wai as W
(responseLBS, requestMethod, pathInfo)
import qualified Data.Text as T (pack)
import qualified Network.HTTP.Types as H
(status403, status200)
import Language.Javascript.JSaddle.Run (syncPoint, runJavaScript)
import Language.Javascript.JSaddle.Run.Files (indexHtml, runBatch, ghcjsHelpers, initState)
import Language.Javascript.JSaddle.Debug
(removeContext, addContext)
import Data.Maybe (fromMaybe)
import qualified Data.Map as M (empty, insert, lookup)
import Data.IORef
(readIORef, newIORef, atomicModifyIORef')
import Data.ByteString.Lazy (ByteString)
import Control.Concurrent.MVar
(tryTakeMVar, MVar, tryPutMVar, modifyMVar_, putMVar, takeMVar,
readMVar, newMVar, newEmptyMVar, modifyMVar)
import Network.Wai.Handler.Warp
(defaultSettings, setTimeout, setPort, runSettings)
import Foreign.Store (newStore, readStore, lookupStore)
import Language.Javascript.JSaddle (askJSM)
import Control.Monad.IO.Class (MonadIO(..))
jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
jsaddleOr opts entryPoint otherApp = do
syncHandlers <- newIORef M.empty
let wsApp :: ServerApp
wsApp pending_conn = do
conn <- acceptRequest pending_conn
rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do
syncKey <- T.pack . show . contextId <$> askJSM
liftIO $ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))
liftIO $ sendTextData conn (encode syncKey)
entryPoint
_ <- forkIO . forever $
receiveDataMessage conn >>= \case
(WS.Text t) ->
case decode t of
Nothing -> error $ "jsaddle Results decode failed : " <> show t
Just r -> processResult r
_ -> error "jsaddle WebSocket unexpected binary data"
start
waitTillClosed conn
waitTillClosed conn = ignore `handle` go 1
where
go :: Int -> IO ()
go i = do
threadDelay (1 * 1000 * 1000)
sendPing conn (T.pack $ show i)
go (i + 1)
ignore e = case fromException e of
Just async -> throwIO (async :: AsyncException)
Nothing -> return ()
syncHandler :: Application
syncHandler req sendResponse = case (W.requestMethod req, W.pathInfo req) of
("POST", ["sync", syncKey]) -> do
body <- lazyRequestBody req
case decode body of
Nothing -> error $ "jsaddle sync message decode failed : " <> show body
Just result ->
M.lookup syncKey <$> readIORef syncHandlers >>= \case
Nothing -> error "jsaddle missing sync message handler"
Just handler -> do
next <- encode <$> handler result
sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] next
_ -> otherApp req sendResponse
return $ websocketsOr opts wsApp syncHandler
jsaddleApp :: Application
jsaddleApp = jsaddleAppWithJs $ jsaddleJs False
jsaddleAppWithJs :: ByteString -> Application
jsaddleAppWithJs js req sendResponse =
fromMaybe
(sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
(jsaddleAppPartialWithJs js req sendResponse)
jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
(fromMaybe (otherApp req sendResponse)
(jsaddleAppPartial req sendResponse))
jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
jsaddleAppPartial = jsaddleAppPartialWithJs $ jsaddleJs False
jsaddleAppPartialWithJs :: ByteString -> Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
jsaddleAppPartialWithJs js req sendResponse = case (W.requestMethod req, W.pathInfo req) of
("GET", []) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] js
_ -> Nothing
jsaddleJs :: Bool -> ByteString
jsaddleJs refreshOnLoad = "\
\if(typeof global !== \"undefined\") {\n\
\ global.window = global;\n\
\ global.WebSocket = require('ws');\n\
\}\n\
\\n\
\var connect = function() {\n\
\ var wsaddress = window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\");\n\
\\n\
\ var ws = new WebSocket(wsaddress);\n\
\ var syncKey = \"\";\n\
\\n\
\ ws.onopen = function(e) {\n\
\ " <> initState <> "\n\
\\n\
\ ws.onmessage = function(e) {\n\
\ var batch = JSON.parse(e.data);\n\
\ if(inCallback > 0) {\n\
\ asyncBatch = batch;\n\
\ return;\n\
\ }\n\
\ if(typeof batch === \"string\") {\n\
\ syncKey = batch;\n" <>
(if refreshOnLoad
then " var xhr = new XMLHttpRequest();\n\
\ xhr.open('POST', '/reload/'+syncKey, true);\n\
\ xhr.onreadystatechange = function() {\n\
\ if(xhr.readyState === XMLHttpRequest.DONE && xhr.status === 200)\n\
\ setTimeout(function(){window.location.reload();}, 100);\n\
\ };\n\
\ xhr.send();\n"
else "") <>
" return;\n\
\ }\n\
\\n\
\ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")
(Just (\a -> "(function(){\n\
\ var xhr = new XMLHttpRequest();\n\
\ xhr.open('POST', '/sync/'+syncKey, false);\n\
\ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\
\ xhr.send(JSON.stringify(" <> a <> "));\n\
\ return JSON.parse(xhr.response);})()")) <> "\
\ };\n\
\ };\n\
\ ws.onerror = function() {\n\
\ setTimeout(connect, 1000);\n\
\ };\n\
\}\n\
\\n\
\ " <> ghcjsHelpers <> "\
\connect();\n\
\"
debug :: Int -> JSM () -> IO ()
debug port f = do
debugWrapper $ \withRefresh registerContext ->
runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJs $ jsaddleJs True)
putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"
refreshMiddleware :: ((Response -> IO ResponseReceived) -> IO ResponseReceived) -> Middleware
refreshMiddleware refresh otherApp req sendResponse = case (W.requestMethod req, W.pathInfo req) of
("POST", ["reload", _syncKey]) -> refresh sendResponse
_ -> otherApp req sendResponse
debugWrapper :: (Middleware -> JSM () -> IO ()) -> IO ()
debugWrapper run = do
reloadMVar <- newEmptyMVar
reloadDoneMVars <- newMVar []
contexts <- newMVar []
let refresh sendResponse = do
reloadDone <- newEmptyMVar
modifyMVar_ reloadDoneMVars (return . (reloadDone:))
readMVar reloadMVar
r <- sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] ("reload" :: ByteString)
putMVar reloadDone ()
return r
start :: Int -> IO (IO Int)
start expectedConnections = do
serverDone <- newEmptyMVar
ready <- newEmptyMVar
let registerContext :: JSM ()
registerContext = do
uuid <- contextId <$> askJSM
browsersConnected <- liftIO $ modifyMVar contexts (\ctxs -> return (uuid:ctxs, length ctxs + 1))
addContext
when (browsersConnected == expectedConnections) . void . liftIO $ tryPutMVar ready ()
thread <- forkIO $
finally (run (refreshMiddleware refresh) registerContext)
(putMVar serverDone ())
_ <- forkIO $ threadDelay 10000000 >> void (tryPutMVar ready ())
when (expectedConnections /= 0) $ takeMVar ready
return $ do
putMVar reloadMVar ()
ctxs <- takeMVar contexts
mapM_ removeContext ctxs
takeMVar reloadDoneMVars >>= mapM_ takeMVar
tryTakeMVar serverDone >>= \case
Nothing -> do
killThread thread
takeMVar serverDone
Just _ -> return ()
return $ length ctxs
restarter :: MVar (Int -> IO (IO Int)) -> IO Int -> IO ()
restarter mvar stop = do
start' <- takeMVar mvar
n <- stop
start' n >>= restarter mvar
lookupStore shutdown_0 >>= \case
Nothing -> do
restartMVar <- newMVar start
void . forkIO $ restarter restartMVar (return 0)
void $ newStore restartMVar
Just shutdownStore -> do
restartMVar :: MVar (Int -> IO (IO Int)) <- readStore shutdownStore
void $ tryTakeMVar restartMVar
putMVar restartMVar start
where shutdown_0 = 0