{-# 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 <- Map Text (Results -> IO Batch)
-> IO (IORef (Map Text (Results -> IO Batch)))
forall a. a -> IO (IORef a)
newIORef Map Text (Results -> IO Batch)
forall k a. Map k a
M.empty
IORef (Map Text (Results -> IO ()))
asyncHandlers <- Map Text (Results -> IO ())
-> IO (IORef (Map Text (Results -> IO ())))
forall a. a -> IO (IORef a)
newIORef Map Text (Results -> IO ())
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 (Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (ByteString -> IO ()) -> (Batch -> ByteString) -> Batch -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Batch -> ByteString
forall a. ToJSON a => a -> ByteString
encode) (JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ()))
-> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
forall a b. (a -> b) -> a -> b
$ do
Text
syncKey <- String -> Text
T.pack (String -> Text)
-> (JSContextRef -> String) -> JSContextRef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> String
forall a. Show a => a -> String
show (Int64 -> String)
-> (JSContextRef -> Int64) -> JSContextRef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSContextRef -> Int64
contextId (JSContextRef -> Text) -> JSM JSContextRef -> JSM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSM JSContextRef
forall (m :: * -> *). MonadJSM m => m JSContextRef
askJSM
IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ IORef (Map Text (Results -> IO Batch))
-> (Map Text (Results -> IO Batch)
-> (Map Text (Results -> IO Batch), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map Text (Results -> IO Batch))
syncHandlers (\Map Text (Results -> IO Batch)
m -> (Text
-> (Results -> IO Batch)
-> Map Text (Results -> IO Batch)
-> Map Text (Results -> IO Batch)
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, ()))
IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ IORef (Map Text (Results -> IO ()))
-> (Map Text (Results -> IO ())
-> (Map Text (Results -> IO ()), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map Text (Results -> IO ()))
asyncHandlers (\Map Text (Results -> IO ())
m -> (Text
-> (Results -> IO ())
-> Map Text (Results -> IO ())
-> Map Text (Results -> IO ())
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, ()))
IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (Text -> ByteString
forall a. ToJSON a => a -> ByteString
encode Text
syncKey)
JSM ()
entryPoint
IO ()
start
Connection -> IO ()
waitTillClosed Connection
conn
Just ByteString
syncKey ->
Text
-> Map Text (Results -> IO Batch) -> Maybe (Results -> IO Batch)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
syncKey) (Map Text (Results -> IO Batch) -> Maybe (Results -> IO Batch))
-> IO (Map Text (Results -> IO Batch))
-> IO (Maybe (Results -> IO Batch))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map Text (Results -> IO Batch))
-> IO (Map Text (Results -> IO Batch))
forall a. IORef a -> IO a
readIORef IORef (Map Text (Results -> IO Batch))
syncHandlers IO (Maybe (Results -> IO Batch))
-> (Maybe (Results -> IO Batch) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Results -> IO Batch)
Nothing -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"jsaddle missing sync message handler"
Just Results -> IO Batch
processResult ->
IO Batch -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO Batch -> IO ()) -> IO Batch -> IO ()
forall a b. (a -> b) -> a -> b
$
Connection -> IO DataMessage
receiveDataMessage Connection
conn IO DataMessage -> (DataMessage -> IO Batch) -> IO Batch
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 ByteString -> Maybe Results
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
t of
Maybe Results
Nothing -> String -> IO Batch
forall a. HasCallStack => String -> a
error (String -> IO Batch) -> String -> IO Batch
forall a b. (a -> b) -> a -> b
$ String
"jsaddle Results decode failed : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
t
Just Results
r -> Results -> IO Batch
processResult Results
r
Maybe ByteString
_ -> String -> IO Batch
forall a. HasCallStack => String -> a
error String
"jsaddle WebSocket unexpected binary data"
Maybe ByteString
_ -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"jsaddle WebSocket unexpected binary data"
waitTillClosed :: Connection -> IO ()
waitTillClosed Connection
conn = SomeException -> IO ()
ignore (SomeException -> IO ()) -> IO () -> IO ()
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)
Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendPing Connection
conn (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i)
Int -> IO ()
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
ignore :: SomeException -> IO ()
ignore SomeException
e = case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just AsyncException
async -> AsyncException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (AsyncException
async :: AsyncException)
Maybe AsyncException
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
syncHandler :: Application
syncHandler :: Application
syncHandler Request
req Response -> IO ResponseReceived
sendResponse = case (Request -> ByteString
W.requestMethod Request
req, Request -> [Text]
W.pathInfo Request
req) of
(ByteString
"POST", [Text
"sync", Text
syncKey]) -> do
ByteString
body <- Request -> IO ByteString
lazyRequestBody Request
req
case ByteString -> Maybe Results
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
body of
Maybe Results
Nothing -> String -> IO ResponseReceived
forall a. HasCallStack => String -> a
error (String -> IO ResponseReceived) -> String -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ String
"jsaddle sync message decode failed : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
body
Just Results
result ->
Text
-> Map Text (Results -> IO Batch) -> Maybe (Results -> IO Batch)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
syncKey (Map Text (Results -> IO Batch) -> Maybe (Results -> IO Batch))
-> IO (Map Text (Results -> IO Batch))
-> IO (Maybe (Results -> IO Batch))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map Text (Results -> IO Batch))
-> IO (Map Text (Results -> IO Batch))
forall a. IORef a -> IO a
readIORef IORef (Map Text (Results -> IO Batch))
syncHandlers IO (Maybe (Results -> IO Batch))
-> (Maybe (Results -> IO Batch) -> IO ResponseReceived)
-> IO ResponseReceived
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Results -> IO Batch)
Nothing -> String -> IO ResponseReceived
forall a. HasCallStack => String -> a
error String
"jsaddle missing sync message handler"
Just Results -> IO Batch
handler -> do
ByteString
next <- Batch -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Batch -> ByteString) -> IO Batch -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Results -> IO Batch
handler Results
result
Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status200 [(HeaderName
"Content-Type", ByteString
"application/json")] ByteString
next
(ByteString
method, [Text]
_) -> (Middleware
catch404 Application
otherApp) Request
req Response -> IO ResponseReceived
sendResponse
where catch404 :: Middleware
catch404 = (Response -> Response) -> Middleware
W.modifyResponse ((Response -> Response) -> Middleware)
-> (Response -> Response) -> Middleware
forall a b. (a -> b) -> a -> b
$ \Response
resp ->
case (ByteString
method, Response -> Status
W.responseStatus Response
resp) of
(ByteString
"GET", Status Int
404 ByteString
_) -> Response
indexResponse
(ByteString, Status)
_ -> Response
resp
Application -> IO Application
forall (m :: * -> *) a. Monad m => a -> m a
return (Application -> IO Application) -> Application -> IO Application
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 (ByteString -> Application) -> ByteString -> Application
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 (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status403 [(HeaderName
"Content-Type", ByteString
"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 =
IO ResponseReceived
-> Maybe (IO ResponseReceived) -> IO ResponseReceived
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 (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ \Request
req Response -> IO ResponseReceived
sendResponse ->
(IO ResponseReceived
-> Maybe (IO ResponseReceived) -> IO ResponseReceived
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 (ByteString
-> Request
-> (Response -> IO ResponseReceived)
-> Maybe (IO ResponseReceived))
-> ByteString
-> Request
-> (Response -> IO ResponseReceived)
-> Maybe (IO ResponseReceived)
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", ByteString
"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 -> ByteString
W.requestMethod Request
req, Request -> [Text]
W.pathInfo Request
req) of
(ByteString
"GET", []) -> IO ResponseReceived -> Maybe (IO ResponseReceived)
forall a. a -> Maybe a
Just (IO ResponseReceived -> Maybe (IO ResponseReceived))
-> IO ResponseReceived -> Maybe (IO ResponseReceived)
forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
sendResponse Response
indexResponse
(ByteString
"GET", [Text
"jsaddle.js"]) -> IO ResponseReceived -> Maybe (IO ResponseReceived)
forall a. a -> Maybe a
Just (IO ResponseReceived -> Maybe (IO ResponseReceived))
-> IO ResponseReceived -> Maybe (IO ResponseReceived)
forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status200 [(HeaderName
"Content-Type", ByteString
"application/javascript")] ByteString
js
(ByteString, [Text])
_ -> Maybe (IO ResponseReceived)
forall a. Maybe a
Nothing
jsaddleJs :: Bool -> ByteString
jsaddleJs :: Bool -> ByteString
jsaddleJs = Maybe ByteString -> Bool -> ByteString
jsaddleJs' Maybe ByteString
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 = "
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
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" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
s ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\"")
(Maybe ByteString
jsaddleUri Maybe ByteString
-> (ByteString -> Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> ByteString -> Maybe ByteString
LBS.stripPrefix ByteString
"http")
ByteString -> ByteString -> ByteString
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\
\ " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
initState ByteString -> ByteString -> ByteString
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" ByteString -> ByteString -> ByteString
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
"") ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
ByteString
" return;\n\
\ }\n\
\\n\
\ " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (ByteString -> ByteString)
-> Maybe (ByteString -> ByteString) -> ByteString
runBatch (\ByteString
a -> ByteString
"ws.send(JSON.stringify(" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
a ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"));")
((ByteString -> ByteString) -> Maybe (ByteString -> ByteString)
forall a. a -> Maybe a
Just (\ByteString
a -> ByteString
"(function(){\n\
\ var xhr = new XMLHttpRequest();\n\
\ xhr.open('POST', '" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" Maybe ByteString
jsaddleUri ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/sync/'+syncKey, false);\n\
\ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\
\ xhr.send(JSON.stringify(" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
a ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"));\n\
\ return JSON.parse(xhr.response);})()")) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\
\ };\n\
\ };\n\
\ ws0.onerror = function() {\n\
\ setTimeout(connect, 1000);\n\
\ };\n\
\}\n\
\\n\
\ " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
ghcjsHelpers ByteString -> ByteString -> ByteString
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 ((Middleware -> JSM () -> IO ()) -> IO ())
-> (Middleware -> JSM () -> IO ()) -> IO ()
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)) (Application -> IO ()) -> IO Application -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
ConnectionOptions -> JSM () -> Application -> IO Application
jsaddleOr ConnectionOptions
defaultConnectionOptions (JSM ()
registerContext JSM () -> JSM () -> JSM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JSM ()
f JSM () -> JSM () -> JSM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JSM ()
syncPoint) (Middleware
withRefresh Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ ByteString -> Application
jsaddleAppWithJs (ByteString -> Application) -> ByteString -> Application
forall a b. (a -> b) -> a -> b
$ Bool -> ByteString
jsaddleJs Bool
True)
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"<a href=\"http://localhost:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
port String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\">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 ((Middleware -> JSM () -> IO ()) -> IO ())
-> (Middleware -> JSM () -> IO ()) -> IO ()
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)) (Application -> IO ()) -> IO Application -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
ConnectionOptions -> JSM () -> Application -> IO Application
jsaddleOr ConnectionOptions
defaultConnectionOptions (JSM ()
registerContext JSM () -> JSM () -> JSM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JSM ()
f JSM () -> JSM () -> JSM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JSM ()
syncPoint) (Middleware
withRefresh Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ ByteString -> Middleware
jsaddleAppWithJsOr (Bool -> ByteString
jsaddleJs Bool
True) Application
b)
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"<a href=\"http://localhost:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
port String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\">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 -> ByteString
W.requestMethod Request
req, Request -> [Text]
W.pathInfo Request
req) of
(ByteString
"POST", [Text
"reload", Text
_syncKey]) -> (Response -> IO ResponseReceived) -> IO ResponseReceived
refresh Response -> IO ResponseReceived
sendResponse
(ByteString, [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 <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
MVar [MVar ()]
reloadDoneMVars <- [MVar ()] -> IO (MVar [MVar ()])
forall a. a -> IO (MVar a)
newMVar []
MVar [Int64]
contexts <- [Int64] -> IO (MVar [Int64])
forall a. a -> IO (MVar a)
newMVar []
let refresh :: (Response -> IO b) -> IO b
refresh Response -> IO b
sendResponse = do
MVar ()
reloadDone <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
MVar [MVar ()] -> ([MVar ()] -> IO [MVar ()]) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar [MVar ()]
reloadDoneMVars ([MVar ()] -> IO [MVar ()]
forall (m :: * -> *) a. Monad m => a -> m a
return ([MVar ()] -> IO [MVar ()])
-> ([MVar ()] -> [MVar ()]) -> [MVar ()] -> IO [MVar ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVar ()
reloadDoneMVar () -> [MVar ()] -> [MVar ()]
forall a. a -> [a] -> [a]
:))
MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
reloadMVar
b
r <- Response -> IO b
sendResponse (Response -> IO b) -> Response -> IO b
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status200 [(HeaderName
"Content-Type", ByteString
"application/json")] (ByteString
"reload" :: ByteString)
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
reloadDone ()
b -> IO b
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 <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
MVar ()
ready <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
let registerContext :: JSM ()
registerContext :: JSM ()
registerContext = do
Int64
uuid <- JSContextRef -> Int64
contextId (JSContextRef -> Int64) -> JSM JSContextRef -> JSM Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSM JSContextRef
forall (m :: * -> *). MonadJSM m => m JSContextRef
askJSM
Int
browsersConnected <- IO Int -> JSM Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> JSM Int) -> IO Int -> JSM Int
forall a b. (a -> b) -> a -> b
$ MVar [Int64] -> ([Int64] -> IO ([Int64], Int)) -> IO Int
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar [Int64]
contexts (\[Int64]
ctxs -> ([Int64], Int) -> IO ([Int64], Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64
uuidInt64 -> [Int64] -> [Int64]
forall a. a -> [a] -> [a]
:[Int64]
ctxs, [Int64] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int64]
ctxs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
JSM ()
addContext
Bool -> JSM () -> JSM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
browsersConnected Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
expectedConnections) (JSM () -> JSM ()) -> (IO Bool -> JSM ()) -> IO Bool -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSM Bool -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM Bool -> JSM ()) -> (IO Bool -> JSM Bool) -> IO Bool -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Bool -> JSM Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> JSM ()) -> IO Bool -> JSM ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
ready ()
ThreadId
thread <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally (Middleware -> JSM () -> IO ()
run (((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> Middleware
refreshMiddleware (Response -> IO ResponseReceived) -> IO ResponseReceived
forall b. (Response -> IO b) -> IO b
refresh) JSM ()
registerContext)
(MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
serverDone ())
ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
10000000 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
ready ())
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
expectedConnections Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
ready
IO Int -> IO (IO Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO Int -> IO (IO Int)) -> IO Int -> IO (IO Int)
forall a b. (a -> b) -> a -> b
$ do
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
reloadMVar ()
[Int64]
ctxs <- MVar [Int64] -> IO [Int64]
forall a. MVar a -> IO a
takeMVar MVar [Int64]
contexts
(Int64 -> IO ()) -> [Int64] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int64 -> IO ()
forall (m :: * -> *). MonadIO m => Int64 -> m ()
removeContext [Int64]
ctxs
MVar [MVar ()] -> IO [MVar ()]
forall a. MVar a -> IO a
takeMVar MVar [MVar ()]
reloadDoneMVars IO [MVar ()] -> ([MVar ()] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (MVar () -> IO ()) -> [MVar ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar
MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
serverDone IO (Maybe ()) -> (Maybe () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe ()
Nothing -> do
ThreadId -> IO ()
killThread ThreadId
thread
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
serverDone
Just ()
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ [Int64] -> Int
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' <- MVar (Int -> IO (IO Int)) -> IO (Int -> IO (IO Int))
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 IO (IO Int) -> (IO Int -> IO ()) -> IO ()
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
Word32 -> IO (Maybe (Store (MVar (Int -> IO (IO Int)))))
forall a. Word32 -> IO (Maybe (Store a))
lookupStore Word32
storeId IO (Maybe (Store (MVar (Int -> IO (IO Int)))))
-> (Maybe (Store (MVar (Int -> IO (IO Int)))) -> IO ()) -> IO ()
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 <- (Int -> IO (IO Int)) -> IO (MVar (Int -> IO (IO Int)))
forall a. a -> IO (MVar a)
newMVar Int -> IO (IO Int)
start
IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar (Int -> IO (IO Int)) -> IO Int -> IO ()
restarter MVar (Int -> IO (IO Int))
restartMVar (Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0)
IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Store (MVar (Int -> IO (IO Int)))
-> MVar (Int -> IO (IO Int)) -> IO ()
forall a. Store a -> a -> IO ()
writeStore (Word32 -> Store (MVar (Int -> IO (IO Int)))
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)) <- Store (MVar (Int -> IO (IO Int))) -> IO (MVar (Int -> IO (IO Int)))
forall a. Store a -> IO a
readStore Store (MVar (Int -> IO (IO Int)))
shutdownStore
IO (Maybe (Int -> IO (IO Int))) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (Int -> IO (IO Int))) -> IO ())
-> IO (Maybe (Int -> IO (IO Int))) -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar (Int -> IO (IO Int)) -> IO (Maybe (Int -> IO (IO Int)))
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar (Int -> IO (IO Int))
restartMVar
MVar (Int -> IO (IO Int)) -> (Int -> IO (IO Int)) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int -> IO (IO Int))
restartMVar Int -> IO (IO Int)
start
where storeId :: Word32
storeId = Word32
354