{-# 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 <- 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"

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

-- 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 = "
      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\
    \"

-- | 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 ((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