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

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 qualified Data.Text                as T

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 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif

{-----------------------------------------------------------------------------
    Event Loop
------------------------------------------------------------------------------}
-- | Handle a single event
handleEvent :: Window -> (Coupon, JSON.Value) -> IO ()
handleEvent :: Window -> (Coupon, Value) -> IO ()
handleEvent Window{[Cookie]
IO ()
TVar CallBufferMode
RemotePtr ()
TMVar (String -> String)
Vendor JSPtr
Vendor (Value -> IO ())
Server
String -> IO ()
String -> IO Value
IO () -> IO ()
runEval :: Window -> String -> IO ()
callEval :: Window -> String -> IO Value
debug :: Window -> String -> IO ()
onDisconnect :: Window -> IO () -> IO ()
getServer :: Server
getCookies :: [Cookie]
runEval :: String -> IO ()
callEval :: String -> IO Value
wCallBuffer :: TMVar (String -> String)
wCallBufferMode :: TVar CallBufferMode
timestamp :: IO ()
debug :: String -> IO ()
onDisconnect :: IO () -> IO ()
wRoot :: RemotePtr ()
wEventHandlers :: Vendor (Value -> IO ())
wJSObjects :: Vendor JSPtr
getServer :: Window -> Server
getCookies :: Window -> [Cookie]
wCallBuffer :: Window -> TMVar (String -> String)
wCallBufferMode :: Window -> TVar CallBufferMode
timestamp :: Window -> IO ()
wRoot :: Window -> RemotePtr ()
wEventHandlers :: Window -> Vendor (Value -> IO ())
wJSObjects :: Window -> Vendor JSPtr
..} (Coupon
name, Value
args) = do
    Maybe (RemotePtr (Value -> IO ()))
mhandler <- Coupon
-> Vendor (Value -> IO ())
-> IO (Maybe (RemotePtr (Value -> IO ())))
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 -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just RemotePtr (Value -> IO ())
f  -> RemotePtr (Value -> IO ())
-> (Coupon -> (Value -> IO ()) -> IO ()) -> IO ()
forall a b. RemotePtr a -> (Coupon -> a -> IO b) -> IO b
withRemotePtr RemotePtr (Value -> IO ())
f (\Coupon
_ Value -> IO ()
g -> Value -> IO ()
g 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
initialize Server
server [Cookie]
info Comm
comm = IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
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      <- IO (TQueue (Coupon, Value))
forall a. IO (TQueue a)
newTQueueIO
    TQueue Result
results     <- IO (TQueue Result)
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       <- IO (TQueue (Maybe (TMVar Result), ServerMsg))
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 <- STM (Either () b) -> IO (Either () b)
forall a. STM a -> IO a
atomically (STM (Either () b) -> IO (Either () b))
-> STM (Either () b) -> IO (Either () b)
forall a b. (a -> b) -> a -> b
$ do
                Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar (TVar Bool -> STM Bool) -> TVar Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$ Comm -> TVar Bool
commOpen Comm
comm
                if Bool
b then (b -> Either () b) -> STM b -> STM (Either () b)
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either () b
forall a b. b -> Either a b
Right STM b
stm else Either () b -> STM (Either () b)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either () b
forall a b. a -> Either a b
Left ())
            case Either () b
r of
                Right b
a -> b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
a
                Left  ()
_ -> ErrorCall -> IO b
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO b) -> ErrorCall -> IO b
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 ServerMsg -> IO () -> IO ()
forall a b. NFData a => a -> b -> b
`deepseq` do     -- see [ServerMsg strictness]
            STM () -> IO ()
forall a. STM a -> IO a
atomicallyIfOpen (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (Maybe (TMVar Result), ServerMsg)
-> (Maybe (TMVar Result), ServerMsg) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe (TMVar Result), ServerMsg)
calls (Maybe (TMVar Result)
forall a. Maybe a
Nothing , ServerMsg
msg)
        call :: ServerMsg -> IO Value
call ServerMsg
msg = ServerMsg
msg ServerMsg -> IO Value -> IO Value
forall a b. NFData a => a -> b -> b
`deepseq` do     -- see [ServerMsg strictness]
            TMVar Result
ref <- IO (TMVar Result)
forall a. IO (TMVar a)
newEmptyTMVarIO
            STM () -> IO ()
forall a. STM a -> IO a
atomicallyIfOpen (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (Maybe (TMVar Result), ServerMsg)
-> (Maybe (TMVar Result), ServerMsg) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe (TMVar Result), ServerMsg)
calls (TMVar Result -> Maybe (TMVar Result)
forall a. a -> Maybe a
Just TMVar Result
ref, ServerMsg
msg)
            Result
er  <- STM Result -> IO Result
forall a. STM a -> IO a
atomicallyIfOpen (STM Result -> IO Result) -> STM Result -> IO Result
forall a b. (a -> b) -> a -> b
$ TMVar Result -> STM Result
forall a. TMVar a -> STM a
takeTMVar TMVar Result
ref
            case Result
er of
                Left  String
e -> JavaScriptException -> IO Value
forall e a. Exception e => e -> IO a
E.throwIO (JavaScriptException -> IO Value)
-> JavaScriptException -> IO Value
forall a b. (a -> b) -> a -> b
$ String -> JavaScriptException
JavaScriptException String
e
                Right Value
x -> Value -> IO Value
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
x
        debug :: String -> IO ()
debug String
s  = String
s String -> IO () -> IO ()
forall a b. NFData a => a -> b -> b
`deepseq` do       -- see [ServerMsg strictness]
            STM () -> IO ()
forall a. STM a -> IO a
atomicallyIfOpen (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Comm -> ServerMsg -> STM ()
writeServer Comm
comm (ServerMsg -> STM ()) -> ServerMsg -> STM ()
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 <- IO () -> IO (TVar (IO ()))
forall a. a -> IO (TVar a)
newTVarIO (IO () -> IO (TVar (IO ()))) -> IO () -> IO (TVar (IO ()))
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
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 = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (IO ()) -> IO () -> STM ()
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
               , getCookies   = info
               , runEval      = run  . RunEval
               , callEval     = call . CallEval
               , debug        = debug
               , timestamp    = run Timestamp
               , onDisconnect = 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 = IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
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   -> TQueue (Coupon, Value) -> (Coupon, Value) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Coupon, Value)
events (Coupon
x,Value
y)
                Result Value
x    -> TQueue Result -> Result -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Result
results (Value -> Result
forall a b. b -> Either a b
Right Value
x)
                Exception String
e -> TQueue Result -> Result -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Result
results (String -> Result
forall a b. a -> Either a b
Left  String
e)

    -- Send FFI calls to client and collect results
    let handleCalls :: IO b
handleCalls = IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ do
            Maybe (TMVar Result)
mref <- STM (Maybe (TMVar Result)) -> IO (Maybe (TMVar Result))
forall a. STM a -> IO a
atomically (STM (Maybe (TMVar Result)) -> IO (Maybe (TMVar Result)))
-> STM (Maybe (TMVar Result)) -> IO (Maybe (TMVar Result))
forall a b. (a -> b) -> a -> b
$ do
                (Maybe (TMVar Result)
mref, ServerMsg
msg) <- TQueue (Maybe (TMVar Result), ServerMsg)
-> STM (Maybe (TMVar Result), ServerMsg)
forall a. TQueue a -> STM a
readTQueue TQueue (Maybe (TMVar Result), ServerMsg)
calls
                Comm -> ServerMsg -> STM ()
writeServer Comm
comm ServerMsg
msg
                Maybe (TMVar Result) -> STM (Maybe (TMVar Result))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TMVar Result)
mref
            STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
                case Maybe (TMVar Result)
mref of
                    Just TMVar Result
ref -> do
                        Result
result <- TQueue Result -> STM Result
forall a. TQueue a -> STM a
readTQueue TQueue Result
results
                        TMVar Result -> Result -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Result
ref Result
result
                    Maybe (TMVar Result)
Nothing  -> () -> STM ()
forall a. a -> STM a
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 <- STM (Maybe (Coupon, Value)) -> IO (Maybe (Coupon, Value))
forall a. STM a -> IO a
atomically (STM (Maybe (Coupon, Value)) -> IO (Maybe (Coupon, Value)))
-> STM (Maybe (Coupon, Value)) -> IO (Maybe (Coupon, Value))
forall a b. (a -> b) -> a -> b
$ do
                Bool
open <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar (TVar Bool -> STM Bool) -> TVar Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$ Comm -> TVar Bool
commOpen Comm
comm
                if Bool
open
                    then (Coupon, Value) -> Maybe (Coupon, Value)
forall a. a -> Maybe a
Just ((Coupon, Value) -> Maybe (Coupon, Value))
-> STM (Coupon, Value) -> STM (Maybe (Coupon, Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TQueue (Coupon, Value) -> STM (Coupon, Value)
forall a. TQueue a -> STM a
readTQueue TQueue (Coupon, Value)
events
                    else Maybe (Coupon, Value) -> STM (Maybe (Coupon, Value))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Coupon, Value)
forall a. Maybe a
Nothing -- channel is closed
            case Maybe (Coupon, Value)
me of
                Maybe (Coupon, Value)
Nothing -> () -> IO ()
forall a. a -> IO a
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
                        IO () -> IO () -> IO ()
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 = (SomeException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle ((SomeException -> IO a) -> IO a -> IO a)
-> (SomeException -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
            Server -> ByteString -> IO ()
sLog Server
server (ByteString -> IO ()) -> (String -> ByteString) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.pack (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: E.SomeException)
            SomeException -> IO a
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.
    IO () -> IO ()
forall a. IO a -> IO a
printException (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        -- Wrap the main loop into `withRemotePtr` in order to keep the root alive.
        RemotePtr () -> (Coupon -> () -> IO ()) -> IO ()
forall a b. RemotePtr a -> (Coupon -> a -> IO b) -> IO b
Foreign.withRemotePtr (Window -> RemotePtr ()
wRoot Window
w) ((Coupon -> () -> IO ()) -> IO ())
-> (Coupon -> () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Coupon
_ ()
_ ->
        -- run `multiplexer` and `handleCalls` concurrently
        IO Any -> (Async Any -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO Any
forall {b}. IO b
multiplexer ((Async Any -> IO ()) -> IO ()) -> (Async Any -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async Any
_ ->
        IO Any -> (Async Any -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO Any
forall {b}. IO b
handleCalls ((Async Any -> IO ()) -> IO ()) -> (Async Any -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async Any
_ ->
        IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (Window -> IO ()
flushCallBufferPeriodically Window
w) ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
_ ->
        IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
E.finally (Window -> IO void
initialize Window
w IO void -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
handleEvents) (IO () -> IO ()) -> IO () -> IO ()
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 <- STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ TVar (IO ()) -> STM (IO ())
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 =
    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int
flushPeriodInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
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 Window{[Cookie]
IO ()
TVar CallBufferMode
RemotePtr ()
TMVar (String -> String)
Vendor JSPtr
Vendor (Value -> IO ())
Server
String -> IO ()
String -> IO Value
IO () -> IO ()
runEval :: Window -> String -> IO ()
callEval :: Window -> String -> IO Value
debug :: Window -> String -> IO ()
onDisconnect :: Window -> IO () -> IO ()
getServer :: Window -> Server
getCookies :: Window -> [Cookie]
wCallBuffer :: Window -> TMVar (String -> String)
wCallBufferMode :: Window -> TVar CallBufferMode
timestamp :: Window -> IO ()
wRoot :: Window -> RemotePtr ()
wEventHandlers :: Window -> Vendor (Value -> IO ())
wJSObjects :: Window -> Vendor JSPtr
getServer :: Server
getCookies :: [Cookie]
runEval :: String -> IO ()
callEval :: String -> IO Value
wCallBuffer :: TMVar (String -> String)
wCallBufferMode :: TVar CallBufferMode
timestamp :: IO ()
debug :: String -> IO ()
onDisconnect :: IO () -> IO ()
wRoot :: RemotePtr ()
wEventHandlers :: Vendor (Value -> IO ())
wJSObjects :: Vendor JSPtr
..} [Value] -> IO ()
handler = do
    Coupon
coupon <- Vendor (Value -> IO ()) -> IO Coupon
forall a. Vendor a -> IO Coupon
newCoupon Vendor (Value -> IO ())
wEventHandlers
    Coupon
-> (Value -> IO ())
-> Vendor (Value -> IO ())
-> IO (RemotePtr (Value -> IO ()))
forall a. Coupon -> a -> Vendor a -> IO (RemotePtr a)
newRemotePtr Coupon
coupon ([Value] -> IO ()
handler ([Value] -> IO ()) -> (Value -> [Value]) -> Value -> IO ()
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 = Result [Value] -> [Value]
forall {a}. Result a -> a
fromSuccess (Value -> Result [Value]
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 ()
runEval :: Window -> String -> IO ()
callEval :: Window -> String -> IO Value
debug :: Window -> String -> IO ()
onDisconnect :: Window -> IO () -> IO ()
getServer :: Window -> Server
getCookies :: Window -> [Cookie]
wCallBuffer :: Window -> TMVar (String -> String)
wCallBufferMode :: Window -> TVar CallBufferMode
timestamp :: Window -> IO ()
wRoot :: Window -> RemotePtr ()
wEventHandlers :: Window -> Vendor (Value -> IO ())
wJSObjects :: Window -> Vendor JSPtr
getServer :: Server
getCookies :: [Cookie]
runEval :: String -> IO ()
callEval :: String -> IO Value
wCallBuffer :: TMVar (String -> String)
wCallBufferMode :: TVar CallBufferMode
timestamp :: IO ()
debug :: String -> IO ()
onDisconnect :: IO () -> IO ()
wRoot :: RemotePtr ()
wEventHandlers :: Vendor (Value -> IO ())
wJSObjects :: Vendor JSPtr
..}) = do
    let JSON.Success Coupon
coupon = Value -> Result Coupon
forall a. FromJSON a => Value -> Result a
JSON.fromJSON Value
js
    Maybe JSObject
mhs <- Coupon -> Vendor JSPtr -> IO (Maybe JSObject)
forall a. Coupon -> Vendor a -> IO (Maybe (RemotePtr a))
Foreign.lookup Coupon
coupon Vendor JSPtr
wJSObjects
    case Maybe JSObject
mhs of
        Just JSObject
hs -> JSObject -> IO JSObject
forall a. a -> IO a
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 ()
runEval :: Window -> String -> IO ()
callEval :: Window -> String -> IO Value
debug :: Window -> String -> IO ()
onDisconnect :: Window -> IO () -> IO ()
getServer :: Window -> Server
getCookies :: Window -> [Cookie]
wCallBuffer :: Window -> TMVar (String -> String)
wCallBufferMode :: Window -> TVar CallBufferMode
timestamp :: Window -> IO ()
wRoot :: Window -> RemotePtr ()
wEventHandlers :: Window -> Vendor (Value -> IO ())
wJSObjects :: Window -> Vendor JSPtr
getServer :: Server
getCookies :: [Cookie]
runEval :: String -> IO ()
callEval :: String -> IO Value
wCallBuffer :: TMVar (String -> String)
wCallBufferMode :: TVar CallBufferMode
timestamp :: IO ()
debug :: String -> IO ()
onDisconnect :: IO () -> IO ()
wRoot :: RemotePtr ()
wEventHandlers :: Vendor (Value -> IO ())
wJSObjects :: Vendor JSPtr
..}) Coupon
coupon = do
    JSObject
ptr <- Coupon -> JSPtr -> Vendor JSPtr -> IO JSObject
forall a. Coupon -> a -> Vendor a -> IO (RemotePtr a)
newRemotePtr Coupon
coupon (Coupon -> JSPtr
JSPtr Coupon
coupon) Vendor JSPtr
wJSObjects
    JSObject -> IO () -> IO ()
forall a. RemotePtr a -> IO () -> IO ()
addFinalizer JSObject
ptr (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Window -> String -> IO ()
bufferRunEval Window
w (String
"Haskell.freeStablePtr('" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Coupon -> String
T.unpack Coupon
coupon String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"')")
    JSObject -> IO JSObject
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JSObject
ptr