{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecursiveDo #-}
module Language.Javascript.JSaddle.WebSockets (
jsaddleOr
, jsaddleApp
, jsaddleWithAppOr
, jsaddleAppWithJs
, jsaddleAppWithJsOr
, jsaddleAppPartial
, jsaddleJs
, jsaddleJs'
, debug
, debugOr
, 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 Network.Wai.Handler.WebSockets (websocketsOr)
import Network.HTTP.Types (Status(..))
import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))
import qualified Network.Wai as W
(responseLBS, requestMethod, pathInfo, modifyResponse, responseStatus)
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 qualified Data.ByteString.Lazy as LBS
(toStrict, stripPrefix)
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 (readStore, lookupStore, writeStore, Store(..))
import Language.Javascript.JSaddle (askJSM)
import Control.Monad.IO.Class (MonadIO(..))
import Language.Javascript.JSaddle.WebSockets.Compat (getTextMessageByteString)
import qualified Data.Text.Encoding as T (decodeUtf8)
jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
jsaddleOr ConnectionOptions
opts JSM ()
entryPoint Application
otherApp = do
IORef (Map Text (Results -> IO Batch))
syncHandlers <- forall a. a -> IO (IORef a)
newIORef forall k a. Map k a
M.empty
IORef (Map Text (Results -> IO ()))
asyncHandlers <- forall a. a -> IO (IORef a)
newIORef forall k a. Map k a
M.empty
let wsApp :: ServerApp
wsApp :: ServerApp
wsApp PendingConnection
pending_conn = do
Connection
conn <- PendingConnection -> IO Connection
acceptRequest PendingConnection
pending_conn
DataMessage
initMsg <- Connection -> IO DataMessage
receiveDataMessage Connection
conn
case DataMessage -> Maybe ByteString
getTextMessageByteString DataMessage
initMsg of
Just ByteString
"" -> do
rec (Results -> IO ()
processResult, Results -> IO Batch
processSyncResult, IO ()
start) <- (Batch -> IO ())
-> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
runJavaScript (forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode) forall a b. (a -> b) -> a -> b
$ do
Text
syncKey <- [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSContextRef -> Int64
contextId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadJSM m => m JSContextRef
askJSM
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map Text (Results -> IO Batch))
syncHandlers (\Map Text (Results -> IO Batch)
m -> (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
syncKey Results -> IO Batch
processSyncResult Map Text (Results -> IO Batch)
m, ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map Text (Results -> IO ()))
asyncHandlers (\Map Text (Results -> IO ())
m -> (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
syncKey Results -> IO ()
processResult Map Text (Results -> IO ())
m, ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (forall a. ToJSON a => a -> ByteString
encode Text
syncKey)
JSM ()
entryPoint
IO ()
start
Connection -> IO ()
waitTillClosed Connection
conn
Just ByteString
syncKey ->
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Method -> Text
T.decodeUtf8 forall a b. (a -> b) -> a -> b
$ ByteString -> Method
LBS.toStrict ByteString
syncKey) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef (Map Text (Results -> IO Batch))
syncHandlers forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Results -> IO Batch)
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"jsaddle missing sync message handler"
Just Results -> IO Batch
processResult ->
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$
Connection -> IO DataMessage
receiveDataMessage Connection
conn forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \DataMessage
msg -> case DataMessage -> Maybe ByteString
getTextMessageByteString DataMessage
msg of
Just ByteString
t ->
case forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
t of
Maybe Results
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"jsaddle Results decode failed : " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ByteString
t
Just Results
r -> Results -> IO Batch
processResult Results
r
Maybe ByteString
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"jsaddle WebSocket unexpected binary data"
Maybe ByteString
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"jsaddle WebSocket unexpected binary data"
waitTillClosed :: Connection -> IO ()
waitTillClosed Connection
conn = SomeException -> IO ()
ignore forall e a. Exception e => (e -> IO a) -> IO a -> IO a
`handle` Int -> IO ()
go Int
1
where
go :: Int -> IO ()
go :: Int -> IO ()
go Int
i = do
Int -> IO ()
threadDelay (Int
10 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000)
forall a. WebSocketsData a => Connection -> a -> IO ()
sendPing Connection
conn ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int
i)
Int -> IO ()
go (Int
i forall a. Num a => a -> a -> a
+ Int
1)
ignore :: SomeException -> IO ()
ignore SomeException
e = case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just AsyncException
async -> forall e a. Exception e => e -> IO a
throwIO (AsyncException
async :: AsyncException)
Maybe AsyncException
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
syncHandler :: Application
syncHandler :: Application
syncHandler Request
req Response -> IO ResponseReceived
sendResponse = case (Request -> Method
W.requestMethod Request
req, Request -> [Text]
W.pathInfo Request
req) of
(Method
"POST", [Text
"sync", Text
syncKey]) -> do
ByteString
body <- Request -> IO ByteString
lazyRequestBody Request
req
case forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
body of
Maybe Results
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"jsaddle sync message decode failed : " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ByteString
body
Just Results
result ->
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
syncKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef (Map Text (Results -> IO Batch))
syncHandlers forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Results -> IO Batch)
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"jsaddle missing sync message handler"
Just Results -> IO Batch
handler -> do
ByteString
next <- forall a. ToJSON a => a -> ByteString
encode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Results -> IO Batch
handler Results
result
Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status200 [(HeaderName
"Content-Type", Method
"application/json")] ByteString
next
(Method
method, [Text]
_) -> (Middleware
catch404 Application
otherApp) Request
req Response -> IO ResponseReceived
sendResponse
where catch404 :: Middleware
catch404 = (Response -> Response) -> Middleware
W.modifyResponse forall a b. (a -> b) -> a -> b
$ \Response
resp ->
case (Method
method, Response -> Status
W.responseStatus Response
resp) of
(Method
"GET", Status Int
404 Method
_) -> Response
indexResponse
(Method, Status)
_ -> Response
resp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ConnectionOptions -> ServerApp -> Middleware
websocketsOr ConnectionOptions
opts ServerApp
wsApp Application
syncHandler
jsaddleApp :: Application
jsaddleApp :: Application
jsaddleApp = ByteString -> Application
jsaddleAppWithJs forall a b. (a -> b) -> a -> b
$ Bool -> ByteString
jsaddleJs Bool
False
jsaddleAppWithJs :: ByteString -> Application
jsaddleAppWithJs :: ByteString -> Application
jsaddleAppWithJs ByteString
js Request
req Response -> IO ResponseReceived
sendResponse =
ByteString -> Middleware
jsaddleAppWithJsOr ByteString
js
(\Request
_ Response -> IO ResponseReceived
_ -> Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status403 [(HeaderName
"Content-Type", Method
"text/plain")] ByteString
"Forbidden")
Request
req Response -> IO ResponseReceived
sendResponse
jsaddleAppWithJsOr :: ByteString -> Application -> Application
jsaddleAppWithJsOr :: ByteString -> Middleware
jsaddleAppWithJsOr ByteString
js Application
otherApp Request
req Response -> IO ResponseReceived
sendResponse =
forall a. a -> Maybe a -> a
fromMaybe (Application
otherApp Request
req Response -> IO ResponseReceived
sendResponse)
(ByteString
-> Request
-> (Response -> IO ResponseReceived)
-> Maybe (IO ResponseReceived)
jsaddleAppPartialWithJs ByteString
js Request
req Response -> IO ResponseReceived
sendResponse)
jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
jsaddleWithAppOr ConnectionOptions
opts JSM ()
entryPoint Application
otherApp = ConnectionOptions -> JSM () -> Application -> IO Application
jsaddleOr ConnectionOptions
opts JSM ()
entryPoint forall a b. (a -> b) -> a -> b
$ \Request
req Response -> IO ResponseReceived
sendResponse ->
(forall a. a -> Maybe a -> a
fromMaybe (Application
otherApp Request
req Response -> IO ResponseReceived
sendResponse)
(Request
-> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
jsaddleAppPartial Request
req Response -> IO ResponseReceived
sendResponse))
jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
jsaddleAppPartial :: Request
-> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
jsaddleAppPartial = ByteString
-> Request
-> (Response -> IO ResponseReceived)
-> Maybe (IO ResponseReceived)
jsaddleAppPartialWithJs forall a b. (a -> b) -> a -> b
$ Bool -> ByteString
jsaddleJs Bool
False
indexResponse :: Response
indexResponse :: Response
indexResponse = Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status200 [(HeaderName
"Content-Type", Method
"text/html")] ByteString
indexHtml
jsaddleAppPartialWithJs :: ByteString -> Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
jsaddleAppPartialWithJs :: ByteString
-> Request
-> (Response -> IO ResponseReceived)
-> Maybe (IO ResponseReceived)
jsaddleAppPartialWithJs ByteString
js Request
req Response -> IO ResponseReceived
sendResponse = case (Request -> Method
W.requestMethod Request
req, Request -> [Text]
W.pathInfo Request
req) of
(Method
"GET", []) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
sendResponse Response
indexResponse
(Method
"GET", [Text
"jsaddle.js"]) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status200 [(HeaderName
"Content-Type", Method
"application/javascript")] ByteString
js
(Method, [Text])
_ -> forall a. Maybe a
Nothing
jsaddleJs :: Bool -> ByteString
jsaddleJs :: Bool -> ByteString
jsaddleJs = Maybe ByteString -> Bool -> ByteString
jsaddleJs' forall a. Maybe a
Nothing
jsaddleJs' :: Maybe ByteString -> Bool -> ByteString
jsaddleJs' :: Maybe ByteString -> Bool -> ByteString
jsaddleJs' Maybe ByteString
jsaddleUri Bool
refreshOnLoad = ByteString
"\
\if(typeof global !== \"undefined\" && typeof require === \"function\") {\n\
\ global.window = global;\n\
\ global.WebSocket = require('ws');\n\
\}\n\
\\n\
\var connect = function() {\n\
\ var wsaddress = "
forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\")"
(\ ByteString
s -> ByteString
"\"ws" forall a. Semigroup a => a -> a -> a
<> ByteString
s forall a. Semigroup a => a -> a -> a
<> ByteString
"\"")
(Maybe ByteString
jsaddleUri forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> ByteString -> Maybe ByteString
LBS.stripPrefix ByteString
"http")
forall a. Semigroup a => a -> a -> a
<> ByteString
";\n\
\\n\
\ var ws0 = new WebSocket(wsaddress);\n\
\ var syncKey = \"\";\n\
\\n\
\ ws0.onopen = function(e) {\n\
\ ws0.send(\"\");\n\
\ var initialResults = [];\n\
\ var ws = {send: function(m) {initialResults.push(m);}};\n\
\ " forall a. Semigroup a => a -> a -> a
<> ByteString
initState forall a. Semigroup a => a -> a -> a
<> ByteString
"\n\
\\n\
\ ws0.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\
\ var ws1 = new WebSocket(wsaddress);\n\
\ ws1.onopen = function(e) {\n\
\ ws1.send(syncKey);\n\
\ initialResults.forEach(function(m){ ws1.send(m); });\n\
\ initialResults = null;\n\
\ ws = ws1;\n\
\ }\n" forall a. Semigroup a => a -> a -> a
<>
(if Bool
refreshOnLoad
then ByteString
" 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 ByteString
"") forall a. Semigroup a => a -> a -> a
<>
ByteString
" return;\n\
\ }\n\
\\n\
\ " forall a. Semigroup a => a -> a -> a
<> (ByteString -> ByteString)
-> Maybe (ByteString -> ByteString) -> ByteString
runBatch (\ByteString
a -> ByteString
"ws.send(JSON.stringify(" forall a. Semigroup a => a -> a -> a
<> ByteString
a forall a. Semigroup a => a -> a -> a
<> ByteString
"));")
(forall a. a -> Maybe a
Just (\ByteString
a -> ByteString
"(function(){\n\
\ var xhr = new XMLHttpRequest();\n\
\ xhr.open('POST', '" forall a. Semigroup a => a -> a -> a
<> forall a. a -> Maybe a -> a
fromMaybe ByteString
"" Maybe ByteString
jsaddleUri forall a. Semigroup a => a -> a -> a
<> ByteString
"/sync/'+syncKey, false);\n\
\ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\
\ xhr.send(JSON.stringify(" forall a. Semigroup a => a -> a -> a
<> ByteString
a forall a. Semigroup a => a -> a -> a
<> ByteString
"));\n\
\ return JSON.parse(xhr.response);})()")) forall a. Semigroup a => a -> a -> a
<> ByteString
"\
\ };\n\
\ };\n\
\ ws0.onerror = function() {\n\
\ setTimeout(connect, 1000);\n\
\ };\n\
\}\n\
\\n\
\ " forall a. Semigroup a => a -> a -> a
<> ByteString
ghcjsHelpers forall a. Semigroup a => a -> a -> a
<> ByteString
"\
\connect();\n\
\"
debug :: Int -> JSM () -> IO ()
debug :: Int -> JSM () -> IO ()
debug Int
port JSM ()
f = do
(Middleware -> JSM () -> IO ()) -> IO ()
debugWrapper forall a b. (a -> b) -> a -> b
$ \Middleware
withRefresh JSM ()
registerContext ->
Settings -> Application -> IO ()
runSettings (Int -> Settings -> Settings
setPort Int
port (Int -> Settings -> Settings
setTimeout Int
3600 Settings
defaultSettings)) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
ConnectionOptions -> JSM () -> Application -> IO Application
jsaddleOr ConnectionOptions
defaultConnectionOptions (JSM ()
registerContext forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JSM ()
f forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JSM ()
syncPoint) (Middleware
withRefresh forall a b. (a -> b) -> a -> b
$ ByteString -> Application
jsaddleAppWithJs forall a b. (a -> b) -> a -> b
$ Bool -> ByteString
jsaddleJs Bool
True)
[Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"<a href=\"http://localhost:" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
port forall a. Semigroup a => a -> a -> a
<> [Char]
"\">run</a>"
debugOr :: Int -> JSM () -> Application -> IO ()
debugOr :: Int -> JSM () -> Application -> IO ()
debugOr Int
port JSM ()
f Application
b = do
(Middleware -> JSM () -> IO ()) -> IO ()
debugWrapper forall a b. (a -> b) -> a -> b
$ \Middleware
withRefresh JSM ()
registerContext ->
Settings -> Application -> IO ()
runSettings (Int -> Settings -> Settings
setPort Int
port (Int -> Settings -> Settings
setTimeout Int
3600 Settings
defaultSettings)) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
ConnectionOptions -> JSM () -> Application -> IO Application
jsaddleOr ConnectionOptions
defaultConnectionOptions (JSM ()
registerContext forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JSM ()
f forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JSM ()
syncPoint) (Middleware
withRefresh forall a b. (a -> b) -> a -> b
$ ByteString -> Middleware
jsaddleAppWithJsOr (Bool -> ByteString
jsaddleJs Bool
True) Application
b)
[Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"<a href=\"http://localhost:" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
port forall a. Semigroup a => a -> a -> a
<> [Char]
"\">run</a>"
refreshMiddleware :: ((Response -> IO ResponseReceived) -> IO ResponseReceived) -> Middleware
refreshMiddleware :: ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> Middleware
refreshMiddleware (Response -> IO ResponseReceived) -> IO ResponseReceived
refresh Application
otherApp Request
req Response -> IO ResponseReceived
sendResponse = case (Request -> Method
W.requestMethod Request
req, Request -> [Text]
W.pathInfo Request
req) of
(Method
"POST", [Text
"reload", Text
_syncKey]) -> (Response -> IO ResponseReceived) -> IO ResponseReceived
refresh Response -> IO ResponseReceived
sendResponse
(Method, [Text])
_ -> Application
otherApp Request
req Response -> IO ResponseReceived
sendResponse
debugWrapper :: (Middleware -> JSM () -> IO ()) -> IO ()
debugWrapper :: (Middleware -> JSM () -> IO ()) -> IO ()
debugWrapper Middleware -> JSM () -> IO ()
run = do
MVar ()
reloadMVar <- forall a. IO (MVar a)
newEmptyMVar
MVar [MVar ()]
reloadDoneMVars <- forall a. a -> IO (MVar a)
newMVar []
MVar [Int64]
contexts <- forall a. a -> IO (MVar a)
newMVar []
let refresh :: (Response -> IO b) -> IO b
refresh Response -> IO b
sendResponse = do
MVar ()
reloadDone <- forall a. IO (MVar a)
newEmptyMVar
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar [MVar ()]
reloadDoneMVars (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVar ()
reloadDoneforall a. a -> [a] -> [a]
:))
forall a. MVar a -> IO a
readMVar MVar ()
reloadMVar
b
r <- Response -> IO b
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status200 [(HeaderName
"Content-Type", Method
"application/json")] (ByteString
"reload" :: ByteString)
forall a. MVar a -> a -> IO ()
putMVar MVar ()
reloadDone ()
forall (m :: * -> *) a. Monad m => a -> m a
return b
r
start :: Int -> IO (IO Int)
start :: Int -> IO (IO Int)
start Int
expectedConnections = do
MVar ()
serverDone <- forall a. IO (MVar a)
newEmptyMVar
MVar ()
ready <- forall a. IO (MVar a)
newEmptyMVar
let registerContext :: JSM ()
registerContext :: JSM ()
registerContext = do
Int64
uuid <- JSContextRef -> Int64
contextId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadJSM m => m JSContextRef
askJSM
Int
browsersConnected <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar [Int64]
contexts (\[Int64]
ctxs -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int64
uuidforall a. a -> [a] -> [a]
:[Int64]
ctxs, forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int64]
ctxs forall a. Num a => a -> a -> a
+ Int
1))
JSM ()
addContext
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
browsersConnected forall a. Eq a => a -> a -> Bool
== Int
expectedConnections) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
ready ()
ThreadId
thread <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$
forall a b. IO a -> IO b -> IO a
finally (Middleware -> JSM () -> IO ()
run (((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> Middleware
refreshMiddleware forall {b}. (Response -> IO b) -> IO b
refresh) JSM ()
registerContext)
(forall a. MVar a -> a -> IO ()
putMVar MVar ()
serverDone ())
ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
10000000 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
ready ())
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
expectedConnections forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar ()
ready
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
forall a. MVar a -> a -> IO ()
putMVar MVar ()
reloadMVar ()
[Int64]
ctxs <- forall a. MVar a -> IO a
takeMVar MVar [Int64]
contexts
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). MonadIO m => Int64 -> m ()
removeContext [Int64]
ctxs
forall a. MVar a -> IO a
takeMVar MVar [MVar ()]
reloadDoneMVars forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. MVar a -> IO a
takeMVar
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
serverDone forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe ()
Nothing -> do
ThreadId -> IO ()
killThread ThreadId
thread
forall a. MVar a -> IO a
takeMVar MVar ()
serverDone
Just ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int64]
ctxs
restarter :: MVar (Int -> IO (IO Int)) -> IO Int -> IO ()
restarter :: MVar (Int -> IO (IO Int)) -> IO Int -> IO ()
restarter MVar (Int -> IO (IO Int))
mvar IO Int
stop = do
Int -> IO (IO Int)
start' <- forall a. MVar a -> IO a
takeMVar MVar (Int -> IO (IO Int))
mvar
Int
n <- IO Int
stop
Int -> IO (IO Int)
start' Int
n forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar (Int -> IO (IO Int)) -> IO Int -> IO ()
restarter MVar (Int -> IO (IO Int))
mvar
forall a. Word32 -> IO (Maybe (Store a))
lookupStore Word32
storeId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Store (MVar (Int -> IO (IO Int))))
Nothing -> do
MVar (Int -> IO (IO Int))
restartMVar <- forall a. a -> IO (MVar a)
newMVar Int -> IO (IO Int)
start
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ MVar (Int -> IO (IO Int)) -> IO Int -> IO ()
restarter MVar (Int -> IO (IO Int))
restartMVar (forall (m :: * -> *) a. Monad m => a -> m a
return Int
0)
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Store a -> a -> IO ()
writeStore (forall a. Word32 -> Store a
Store Word32
storeId) MVar (Int -> IO (IO Int))
restartMVar
Just Store (MVar (Int -> IO (IO Int)))
shutdownStore -> do
MVar (Int -> IO (IO Int))
restartMVar :: MVar (Int -> IO (IO Int)) <- forall a. Store a -> IO a
readStore Store (MVar (Int -> IO (IO Int)))
shutdownStore
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar (Int -> IO (IO Int))
restartMVar
forall a. MVar a -> a -> IO ()
putMVar MVar (Int -> IO (IO Int))
restartMVar Int -> IO (IO Int)
start
where storeId :: Word32
storeId = Word32
354