{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecursiveDo #-}
-----------------------------------------------------------------------------
--
-- Module      :  Language.Javascript.JSaddle.WebSockets
-- Copyright   :  (c) Hamish Mackenzie
-- License     :  MIT
--
-- Maintainer  :  Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
--
-- |
--
-----------------------------------------------------------------------------

module Language.Javascript.JSaddle.WebSockets (
  -- * Running JSM over 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"

        -- Based on Network.WebSocket.forkPingThread
        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

-- Use this to generate this string for embedding
-- sed -e 's|\\|\\\\|g' -e 's|^|    \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
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\
    \"

-- | Start or restart the server.
-- To run this as part of every :reload use
-- > :def! reload (const $ return "::reload\nLanguage.Javascript.JSaddle.Warp.debug 3708 SomeMainModule.someMainFunction")
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