{-# LANGUAGE RecordWildCards, CPP #-}
{-# LANGUAGE RecursiveDo #-}
module Foreign.JavaScript.EventLoop (
    eventLoop,
    runEval, callEval, debug, onDisconnect,
    newHandler, fromJSStablePtr, newJSObjectFromCoupon
    ) where

import           Control.Applicative
import           Control.Concurrent
import           Control.Concurrent.Async
import           Control.Concurrent.STM   as STM
import           Control.DeepSeq                  (deepseq)
import           Control.Exception        as E
import           Control.Monad
import qualified Data.Aeson               as JSON
import qualified Data.ByteString.Char8    as BS
import           Data.IORef
import qualified Data.Map                 as Map
import qualified Data.Text                as T
import qualified System.Mem

import Foreign.RemotePtr             as Foreign
import Foreign.JavaScript.CallBuffer
import Foreign.JavaScript.Types

rebug :: IO ()
#ifdef REBUG
rebug = System.Mem.performGC
#else
rebug :: IO ()
rebug = forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif

{-----------------------------------------------------------------------------
    Event Loop
------------------------------------------------------------------------------}
-- | Handle a single event
handleEvent :: Window -> (Coupon, Value) -> IO ()
handleEvent w :: Window
w@(Window{[Cookie]
IO ()
TVar CallBufferMode
RemotePtr ()
TMVar (String -> String)
Vendor JSPtr
Vendor (Value -> IO ())
Server
String -> IO ()
String -> IO Value
IO () -> IO ()
wJSObjects :: Window -> Vendor JSPtr
wEventHandlers :: Window -> Vendor (Value -> IO ())
wRoot :: Window -> RemotePtr ()
timestamp :: Window -> IO ()
wCallBufferMode :: Window -> TVar CallBufferMode
wCallBuffer :: Window -> TMVar (String -> String)
getCookies :: Window -> [Cookie]
getServer :: Window -> Server
wJSObjects :: Vendor JSPtr
wEventHandlers :: Vendor (Value -> IO ())
wRoot :: RemotePtr ()
onDisconnect :: IO () -> IO ()
debug :: String -> IO ()
timestamp :: IO ()
wCallBufferMode :: TVar CallBufferMode
wCallBuffer :: TMVar (String -> String)
callEval :: String -> IO Value
runEval :: String -> IO ()
getCookies :: [Cookie]
getServer :: Server
onDisconnect :: Window -> IO () -> IO ()
debug :: Window -> String -> IO ()
callEval :: Window -> String -> IO Value
runEval :: Window -> String -> IO ()
..}) (Coupon
name, Value
args) = do
    Maybe (RemotePtr (Value -> IO ()))
mhandler <- forall a. Coupon -> Vendor a -> IO (Maybe (RemotePtr a))
Foreign.lookup Coupon
name Vendor (Value -> IO ())
wEventHandlers
    case Maybe (RemotePtr (Value -> IO ()))
mhandler of
        Maybe (RemotePtr (Value -> IO ()))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just RemotePtr (Value -> IO ())
f  -> forall a b. RemotePtr a -> (Coupon -> a -> IO b) -> IO b
withRemotePtr RemotePtr (Value -> IO ())
f (\Coupon
_ Value -> IO ()
f -> Value -> IO ()
f Value
args)


type Result = Either String JSON.Value

-- | Event loop for a browser window.
-- Supports concurrent invocations of `runEval` and `callEval`.
eventLoop :: (Window -> IO void) -> EventLoop
eventLoop :: forall void. (Window -> IO void) -> EventLoop
eventLoop Window -> IO void
init Server
server [Cookie]
info Comm
comm = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ do
    -- To support concurrent FFI calls, we need three threads.
    -- A fourth thread supports 
    --
    -- The thread `multiplexer` reads from the client and
    --   sorts the messages into the appropriate queue.
    TQueue (Coupon, Value)
events      <- forall a. IO (TQueue a)
newTQueueIO
    TQueue Result
results     <- forall a. IO (TQueue a)
newTQueueIO :: IO (TQueue Result)
    -- The thread `handleCalls` executes FFI calls
    --    from the Haskell side in order.
    -- The corresponding queue records `TMVar`s in which to put the results.
    TQueue (Maybe (TMVar Result), ServerMsg)
calls       <- forall a. IO (TQueue a)
newTQueueIO :: IO (TQueue (Maybe (TMVar Result), ServerMsg))
    -- The thread `handleEvents` handles client Events in order.

    -- We only want to make an FFI call when the connection browser<->server is open
    -- Otherwise, throw an exception.
    let atomicallyIfOpen :: STM b -> IO b
atomicallyIfOpen STM b
stm = do
            Either () b
r <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
                Bool
b <- forall a. TVar a -> STM a
readTVar forall a b. (a -> b) -> a -> b
$ Comm -> TVar Bool
commOpen Comm
comm
                if Bool
b then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right STM b
stm else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left ())
            case Either () b
r of
                Right b
a -> forall (m :: * -> *) a. Monad m => a -> m a
return b
a
                Left  ()
_ -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"Foreign.JavaScript: Browser <-> Server communication broken."

    -- FFI calls are made by writing to the `calls` queue.
    let run :: ServerMsg -> IO ()
run  ServerMsg
msg = ServerMsg
msg forall a b. NFData a => a -> b -> b
`deepseq` do     -- see [ServerMsg strictness]
            forall a. STM a -> IO a
atomicallyIfOpen forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe (TMVar Result), ServerMsg)
calls (forall a. Maybe a
Nothing , ServerMsg
msg)
        call :: ServerMsg -> IO Value
call ServerMsg
msg = ServerMsg
msg forall a b. NFData a => a -> b -> b
`deepseq` do     -- see [ServerMsg strictness]
            TMVar Result
ref <- forall a. IO (TMVar a)
newEmptyTMVarIO
            forall a. STM a -> IO a
atomicallyIfOpen forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe (TMVar Result), ServerMsg)
calls (forall a. a -> Maybe a
Just TMVar Result
ref, ServerMsg
msg)
            Result
er  <- forall a. STM a -> IO a
atomicallyIfOpen forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
takeTMVar TMVar Result
ref
            case Result
er of
                Left  String
e -> forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ String -> JavaScriptException
JavaScriptException String
e
                Right Value
x -> forall (m :: * -> *) a. Monad m => a -> m a
return Value
x
        debug :: String -> IO ()
debug String
s  = String
s forall a b. NFData a => a -> b -> b
`deepseq` do       -- see [ServerMsg strictness]
            forall a. STM a -> IO a
atomicallyIfOpen forall a b. (a -> b) -> a -> b
$ Comm -> ServerMsg -> STM ()
writeServer Comm
comm forall a b. (a -> b) -> a -> b
$ String -> ServerMsg
Debug String
s

    -- We also send a separate event when the client disconnects.
    TVar (IO ())
disconnect <- forall a. a -> IO (TVar a)
newTVarIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
    -- FIXME: Make it possible to store *multiple* event handlers
    let onDisconnect :: IO () -> IO ()
onDisconnect IO ()
m = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar (IO ())
disconnect IO ()
m

    Window
w0 <- IO Window
newPartialWindow
    let w :: Window
w = Window
w0 { getServer :: Server
getServer    = Server
server
               , getCookies :: [Cookie]
getCookies   = [Cookie]
info
               , runEval :: String -> IO ()
runEval      = ServerMsg -> IO ()
run  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ServerMsg
RunEval
               , callEval :: String -> IO Value
callEval     = ServerMsg -> IO Value
call forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ServerMsg
CallEval
               , debug :: String -> IO ()
debug        = String -> IO ()
debug
               , timestamp :: IO ()
timestamp    = ServerMsg -> IO ()
run ServerMsg
Timestamp
               , onDisconnect :: IO () -> IO ()
onDisconnect = IO () -> IO ()
onDisconnect
               }

    -- The individual threads are as follows:
    --
    -- Read client messages and send them to the
    -- thread that handles events or the thread that handles FFI calls.
    let multiplexer :: IO b
multiplexer = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
            ClientMsg
msg <- Comm -> STM ClientMsg
readClient Comm
comm
            case ClientMsg
msg of
                Event Coupon
x Value
y   -> forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Coupon, Value)
events (Coupon
x,Value
y)
                Result Value
x    -> forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Result
results (forall a b. b -> Either a b
Right Value
x)
                Exception String
e -> forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Result
results (forall a b. a -> Either a b
Left  String
e)

    -- Send FFI calls to client and collect results
    let handleCalls :: IO b
handleCalls = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
            Maybe (TMVar Result)
ref <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
                (Maybe (TMVar Result)
ref, ServerMsg
msg) <- forall a. TQueue a -> STM a
readTQueue TQueue (Maybe (TMVar Result), ServerMsg)
calls
                Comm -> ServerMsg -> STM ()
writeServer Comm
comm ServerMsg
msg
                forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TMVar Result)
ref
            forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$
                case Maybe (TMVar Result)
ref of
                    Just TMVar Result
ref -> do
                        Result
result <- forall a. TQueue a -> STM a
readTQueue TQueue Result
results
                        forall a. TMVar a -> a -> STM ()
putTMVar TMVar Result
ref Result
result
                    Maybe (TMVar Result)
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- Receive events from client and handle them in order.
    let handleEvents :: IO ()
handleEvents = do
            Maybe (Coupon, Value)
me <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
                Bool
open <- forall a. TVar a -> STM a
readTVar forall a b. (a -> b) -> a -> b
$ Comm -> TVar Bool
commOpen Comm
comm
                if Bool
open
                    then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TQueue a -> STM a
readTQueue TQueue (Coupon, Value)
events
                    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing -- channel is closed
            case Maybe (Coupon, Value)
me of
                Maybe (Coupon, Value)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()    -- channel is closed, we're done
                Just (Coupon, Value)
e  -> do
                    Window -> (Coupon, Value) -> IO ()
handleEvent Window
w (Coupon, Value)
e
                        forall a b. IO a -> IO b -> IO a
`E.onException` Comm -> IO ()
commClose Comm
comm -- close channel in case of exception
                    IO ()
rebug
                    IO ()
handleEvents

    -- Execute an IO action, but also print any exceptions that it may throw.
    -- (The exception is rethrown.)
    let
        printException :: IO a -> IO a
        printException :: forall a. IO a -> IO a
printException = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
            Server -> ByteString -> IO ()
sLog Server
server forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (SomeException
e :: E.SomeException)
            forall e a. Exception e => e -> IO a
E.throwIO SomeException
e

    -- NOTE: Due to an issue with `snap-server` library,
    -- we print the exception ourselves.
    forall a. IO a -> IO a
printException forall a b. (a -> b) -> a -> b
$
        -- Wrap the main loop into `withRemotePtr` in order to keep the root alive.
        forall a b. RemotePtr a -> (Coupon -> a -> IO b) -> IO b
Foreign.withRemotePtr (Window -> RemotePtr ()
wRoot Window
w) forall a b. (a -> b) -> a -> b
$ \Coupon
_ ()
_ ->
        -- run `multiplexer` and `handleCalls` concurrently
        forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync forall {b}. IO b
multiplexer forall a b. (a -> b) -> a -> b
$ \Async Any
_ ->
        forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync forall {b}. IO b
handleCalls forall a b. (a -> b) -> a -> b
$ \Async Any
_ ->
        forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (Window -> IO ()
flushCallBufferPeriodically Window
w) forall a b. (a -> b) -> a -> b
$ \Async ()
_ ->
        forall a b. IO a -> IO b -> IO a
E.finally (Window -> IO void
init Window
w forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
handleEvents) forall a b. (a -> b) -> a -> b
$ do
            String -> IO ()
putStrLn String
"Foreign.JavaScript: Browser window disconnected."
            -- close communication channel if still necessary
            Comm -> IO ()
commClose Comm
comm
            -- trigger the `disconnect` event
            -- FIXME: Asynchronous exceptions should not be masked during the disconnect handler
            IO ()
m <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> STM a
readTVar TVar (IO ())
disconnect
            IO ()
m

-- | Thread that periodically flushes the call buffer
flushCallBufferPeriodically :: Window -> IO ()
flushCallBufferPeriodically :: Window -> IO ()
flushCallBufferPeriodically Window
w =
    forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int
flushPeriodforall a. Num a => a -> a -> a
*Int
1000) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Window -> IO ()
flushCallBuffer Window
w


{-----------------------------------------------------------------------------
    Exports, Imports and garbage collection
------------------------------------------------------------------------------}
-- | Turn a Haskell function into an event handler.
newHandler :: Window -> ([JSON.Value] -> IO ()) -> IO HsEvent
newHandler :: Window -> ([Value] -> IO ()) -> IO (RemotePtr (Value -> IO ()))
newHandler w :: Window
w@(Window{[Cookie]
IO ()
TVar CallBufferMode
RemotePtr ()
TMVar (String -> String)
Vendor JSPtr
Vendor (Value -> IO ())
Server
String -> IO ()
String -> IO Value
IO () -> IO ()
wJSObjects :: Vendor JSPtr
wEventHandlers :: Vendor (Value -> IO ())
wRoot :: RemotePtr ()
onDisconnect :: IO () -> IO ()
debug :: String -> IO ()
timestamp :: IO ()
wCallBufferMode :: TVar CallBufferMode
wCallBuffer :: TMVar (String -> String)
callEval :: String -> IO Value
runEval :: String -> IO ()
getCookies :: [Cookie]
getServer :: Server
wJSObjects :: Window -> Vendor JSPtr
wEventHandlers :: Window -> Vendor (Value -> IO ())
wRoot :: Window -> RemotePtr ()
timestamp :: Window -> IO ()
wCallBufferMode :: Window -> TVar CallBufferMode
wCallBuffer :: Window -> TMVar (String -> String)
getCookies :: Window -> [Cookie]
getServer :: Window -> Server
onDisconnect :: Window -> IO () -> IO ()
debug :: Window -> String -> IO ()
callEval :: Window -> String -> IO Value
runEval :: Window -> String -> IO ()
..}) [Value] -> IO ()
handler = do
    Coupon
coupon <- forall a. Vendor a -> IO Coupon
newCoupon Vendor (Value -> IO ())
wEventHandlers
    forall a. Coupon -> a -> Vendor a -> IO (RemotePtr a)
newRemotePtr Coupon
coupon ([Value] -> IO ()
handler forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [Value]
parseArgs) Vendor (Value -> IO ())
wEventHandlers
    where
    fromSuccess :: Result a -> a
fromSuccess (JSON.Success a
x) = a
x
    -- parse a genuine JavaScript array
    parseArgs :: Value -> [Value]
parseArgs Value
x = forall {a}. Result a -> a
fromSuccess (forall a. FromJSON a => Value -> Result a
JSON.fromJSON Value
x) :: [JSON.Value]
    -- parse a JavaScript arguments object
    -- parseArgs x = Map.elems (fromSuccess (JSON.fromJSON x) :: Map.Map String JSON.Value)


-- | Retrieve 'JSObject' associated with a JavaScript stable pointer.
fromJSStablePtr :: JSON.Value -> Window -> IO JSObject
fromJSStablePtr :: Value -> Window -> IO JSObject
fromJSStablePtr Value
js w :: Window
w@(Window{[Cookie]
IO ()
TVar CallBufferMode
RemotePtr ()
TMVar (String -> String)
Vendor JSPtr
Vendor (Value -> IO ())
Server
String -> IO ()
String -> IO Value
IO () -> IO ()
wJSObjects :: Vendor JSPtr
wEventHandlers :: Vendor (Value -> IO ())
wRoot :: RemotePtr ()
onDisconnect :: IO () -> IO ()
debug :: String -> IO ()
timestamp :: IO ()
wCallBufferMode :: TVar CallBufferMode
wCallBuffer :: TMVar (String -> String)
callEval :: String -> IO Value
runEval :: String -> IO ()
getCookies :: [Cookie]
getServer :: Server
wJSObjects :: Window -> Vendor JSPtr
wEventHandlers :: Window -> Vendor (Value -> IO ())
wRoot :: Window -> RemotePtr ()
timestamp :: Window -> IO ()
wCallBufferMode :: Window -> TVar CallBufferMode
wCallBuffer :: Window -> TMVar (String -> String)
getCookies :: Window -> [Cookie]
getServer :: Window -> Server
onDisconnect :: Window -> IO () -> IO ()
debug :: Window -> String -> IO ()
callEval :: Window -> String -> IO Value
runEval :: Window -> String -> IO ()
..}) = do
    let JSON.Success Coupon
coupon = forall a. FromJSON a => Value -> Result a
JSON.fromJSON Value
js
    Maybe JSObject
mhs <- forall a. Coupon -> Vendor a -> IO (Maybe (RemotePtr a))
Foreign.lookup Coupon
coupon Vendor JSPtr
wJSObjects
    case Maybe JSObject
mhs of
        Just JSObject
hs -> forall (m :: * -> *) a. Monad m => a -> m a
return JSObject
hs
        Maybe JSObject
Nothing -> Window -> Coupon -> IO JSObject
newJSObjectFromCoupon Window
w Coupon
coupon

-- | Create a new JSObject by registering a new coupon.
newJSObjectFromCoupon :: Window -> Foreign.Coupon -> IO JSObject
newJSObjectFromCoupon :: Window -> Coupon -> IO JSObject
newJSObjectFromCoupon w :: Window
w@(Window{[Cookie]
IO ()
TVar CallBufferMode
RemotePtr ()
TMVar (String -> String)
Vendor JSPtr
Vendor (Value -> IO ())
Server
String -> IO ()
String -> IO Value
IO () -> IO ()
wJSObjects :: Vendor JSPtr
wEventHandlers :: Vendor (Value -> IO ())
wRoot :: RemotePtr ()
onDisconnect :: IO () -> IO ()
debug :: String -> IO ()
timestamp :: IO ()
wCallBufferMode :: TVar CallBufferMode
wCallBuffer :: TMVar (String -> String)
callEval :: String -> IO Value
runEval :: String -> IO ()
getCookies :: [Cookie]
getServer :: Server
wJSObjects :: Window -> Vendor JSPtr
wEventHandlers :: Window -> Vendor (Value -> IO ())
wRoot :: Window -> RemotePtr ()
timestamp :: Window -> IO ()
wCallBufferMode :: Window -> TVar CallBufferMode
wCallBuffer :: Window -> TMVar (String -> String)
getCookies :: Window -> [Cookie]
getServer :: Window -> Server
onDisconnect :: Window -> IO () -> IO ()
debug :: Window -> String -> IO ()
callEval :: Window -> String -> IO Value
runEval :: Window -> String -> IO ()
..}) Coupon
coupon = do
    JSObject
ptr <- forall a. Coupon -> a -> Vendor a -> IO (RemotePtr a)
newRemotePtr Coupon
coupon (Coupon -> JSPtr
JSPtr Coupon
coupon) Vendor JSPtr
wJSObjects
    forall a. RemotePtr a -> IO () -> IO ()
addFinalizer JSObject
ptr forall a b. (a -> b) -> a -> b
$
        Window -> String -> IO ()
bufferRunEval Window
w (String
"Haskell.freeStablePtr('" forall a. [a] -> [a] -> [a]
++ Coupon -> String
T.unpack Coupon
coupon forall a. [a] -> [a] -> [a]
++ String
"')")
    forall (m :: * -> *) a. Monad m => a -> m a
return JSObject
ptr