{-# LANGUAGE RecordWildCards, CPP #-}
{-# LANGUAGE RecursiveDo #-}
module Foreign.JavaScript.EventLoop (
eventLoop,
runEval, callEval, debug, onDisconnect,
newHandler, fromJSStablePtr,
) 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 = return ()
#endif
handleEvent w@(Window{..}) (name, args) = do
mhandler <- Foreign.lookup name wEventHandlers
case mhandler of
Nothing -> return ()
Just f -> withRemotePtr f (\_ f -> f args)
type Result = Either String JSON.Value
eventLoop :: (Window -> IO void) -> EventLoop
eventLoop init server info comm = void $ do
events <- newTQueueIO
results <- newTQueueIO :: IO (TQueue Result)
calls <- newTQueueIO :: IO (TQueue (Maybe (TMVar Result), ServerMsg))
let atomicallyIfOpen stm = do
r <- atomically $ do
b <- readTVar $ commOpen comm
if b then fmap Right stm else return (Left ())
case r of
Right a -> return a
Left _ -> throwIO $ ErrorCall "Foreign.JavaScript: Browser <-> Server communication broken."
let run msg = msg `deepseq` do
atomicallyIfOpen $ writeTQueue calls (Nothing , msg)
call msg = msg `deepseq` do
ref <- newEmptyTMVarIO
atomicallyIfOpen $ writeTQueue calls (Just ref, msg)
er <- atomicallyIfOpen $ takeTMVar ref
case er of
Left e -> E.throwIO $ JavaScriptException e
Right x -> return x
debug s = s `deepseq` do
atomicallyIfOpen $ writeServer comm $ Debug s
disconnect <- newTVarIO $ return ()
let onDisconnect m = atomically $ writeTVar disconnect m
w0 <- newPartialWindow
let w = w0 { getServer = server
, getCookies = info
, runEval = run . RunEval
, callEval = call . CallEval
, debug = debug
, timestamp = run Timestamp
, onDisconnect = onDisconnect
}
let multiplexer = forever $ atomically $ do
msg <- readClient comm
case msg of
Event x y -> writeTQueue events (x,y)
Result x -> writeTQueue results (Right x)
Exception e -> writeTQueue results (Left e)
let handleCalls = forever $ do
ref <- atomically $ do
(ref, msg) <- readTQueue calls
writeServer comm msg
return ref
atomically $
case ref of
Just ref -> do
result <- readTQueue results
putTMVar ref result
Nothing -> return ()
let handleEvents = do
me <- atomically $ do
open <- readTVar $ commOpen comm
if open
then Just <$> readTQueue events
else return Nothing
case me of
Nothing -> return ()
Just e -> do
handleEvent w e
`E.onException` commClose comm
rebug
handleEvents
let
printException :: IO a -> IO a
printException = E.handle $ \e -> do
sLog server . BS.pack $ show (e :: E.SomeException)
E.throwIO e
printException $
Foreign.withRemotePtr (wRoot w) $ \_ _ ->
withAsync multiplexer $ \_ ->
withAsync handleCalls $ \_ ->
withAsync (flushCallBufferPeriodically w) $ \_ ->
E.finally (init w >> handleEvents) $ do
putStrLn "Foreign.JavaScript: Browser window disconnected."
commClose comm
m <- atomically $ readTVar disconnect
m
flushCallBufferPeriodically :: Window -> IO ()
flushCallBufferPeriodically w =
forever $ threadDelay (flushPeriod*1000) >> flushCallBuffer w
newHandler :: Window -> ([JSON.Value] -> IO ()) -> IO HsEvent
newHandler w@(Window{..}) handler = do
coupon <- newCoupon wEventHandlers
newRemotePtr coupon (handler . parseArgs) wEventHandlers
where
fromSuccess (JSON.Success x) = x
parseArgs x = fromSuccess (JSON.fromJSON x) :: [JSON.Value]
fromJSStablePtr :: JSON.Value -> Window -> IO JSObject
fromJSStablePtr js w@(Window{..}) = do
let JSON.Success coupon = JSON.fromJSON js
mhs <- Foreign.lookup coupon wJSObjects
case mhs of
Just hs -> return hs
Nothing -> do
ptr <- newRemotePtr coupon (JSPtr coupon) wJSObjects
addFinalizer ptr $
runEval ("Haskell.freeStablePtr('" ++ T.unpack coupon ++ "')")
return ptr