From 31bd6c174826b066ffd547cfc4c4770431d8f3a3 Mon Sep 17 00:00:00 2001 From: Wesley Sales Massuda Date: Sun, 27 Aug 2017 22:39:58 -0300 Subject: [PATCH] improve period flushing --- src/Foreign/JavaScript/CallBuffer.hs | 9 +++++++++ src/Foreign/JavaScript/EventLoop.hs | 23 ++++++++++++++++++++--- src/Foreign/JavaScript/Types.hs | 17 ++++++++++++----- threepenny-gui.cabal | 1 + 4 files changed, 42 insertions(+), 8 deletions(-) diff --git a/src/Foreign/JavaScript/CallBuffer.hs b/src/Foreign/JavaScript/CallBuffer.hs index be367527..217b33cf 100644 --- a/src/Foreign/JavaScript/CallBuffer.hs +++ b/src/Foreign/JavaScript/CallBuffer.hs @@ -5,6 +5,8 @@ import Control.Concurrent import Control.Concurrent.STM as STM import Control.Monad +import GHC.Conc +import Data.Time import Foreign.JavaScript.Types {----------------------------------------------------------------------------- @@ -27,6 +29,7 @@ flushCallBuffer w@Window{..} = do code' <- atomically $ do code <- readTVar wCallBuffer writeTVar wCallBuffer id + tryTakeTMVar wCallBufferStats return code let code = code' "" unless (null code) $ @@ -44,6 +47,12 @@ bufferRunEval w@Window{..} code = do _ -> do msg <- readTVar wCallBuffer writeTVar wCallBuffer (msg . (\s -> ";" ++ code ++ s)) + case mode of + FlushPeriodically{..}-> do + t0 <- unsafeIOToSTM getCurrentTime + v <- tryTakeTMVar wCallBufferStats + putTMVar wCallBufferStats (maybe t0 (const t0) v) + i -> return () return Nothing case action of Nothing -> return () diff --git a/src/Foreign/JavaScript/EventLoop.hs b/src/Foreign/JavaScript/EventLoop.hs index ecd2758a..d0c76867 100644 --- a/src/Foreign/JavaScript/EventLoop.hs +++ b/src/Foreign/JavaScript/EventLoop.hs @@ -23,6 +23,8 @@ import qualified System.Mem import Foreign.RemotePtr as Foreign import Foreign.JavaScript.CallBuffer import Foreign.JavaScript.Types +import Data.Time +import GHC.Conc rebug :: IO () #ifdef REBUG @@ -49,7 +51,7 @@ type Result = Either String JSON.Value eventLoop :: (Window -> IO void) -> (Server -> Comm -> IO ()) eventLoop init server comm = void $ do -- To support concurrent FFI calls, we need three threads. - -- A fourth thread supports + -- A fourth thread supports -- -- The thread `multiplexer` reads from the client and -- sorts the messages into the appropriate queue. @@ -165,8 +167,23 @@ eventLoop init server comm = void $ do -- | Thread that periodically flushes the call buffer flushCallBufferPeriodically :: Window -> IO () -flushCallBufferPeriodically w = - forever $ threadDelay (flushPeriod*1000) >> flushCallBuffer w +flushCallBufferPeriodically w@Window{..} = forever $ do + b <- atomically $ do + tl <- takeTMVar wCallBufferStats + FlushPeriodically max_flush_delay <- readTVar wCallBufferMode + tc <- unsafeIOToSTM getCurrentTime + let delta = diffUTCTime tc tl * 1000 + if delta > fromIntegral max_flush_delay + then return (Right (max_flush_delay - ceiling delta)) + else do + putTMVar wCallBufferStats tl + return $ Left max_flush_delay + case b of + Right delta -> do + flushCallBuffer w + threadDelay (delta*1000) + Left delta -> + threadDelay (delta*1000) {----------------------------------------------------------------------------- diff --git a/src/Foreign/JavaScript/Types.hs b/src/Foreign/JavaScript/Types.hs index ca782c7b..87df047a 100644 --- a/src/Foreign/JavaScript/Types.hs +++ b/src/Foreign/JavaScript/Types.hs @@ -16,6 +16,7 @@ import Data.String import Data.Text import Data.Typeable import System.IO (stderr) +import Data.Time import Foreign.RemotePtr @@ -29,7 +30,7 @@ import Foreign.RemotePtr This is a record type which has the following fields: -* @jsPort :: Maybe Int@ +* @jsPort :: Maybe Int@ Port number. @Nothing@ means that the port number is read from the environment variable @PORT@. @@ -67,7 +68,7 @@ This is a record type which has the following fields: -} data Config = Config - { jsPort :: Maybe Int + { jsPort :: Maybe Int , jsAddr :: Maybe ByteString , jsCustomHTML :: Maybe FilePath , jsStatic :: Maybe FilePath @@ -251,10 +252,11 @@ data CallBufferMode -- to simplify usage. Users may choose 'BufferRun' instead if they want more control -- over flushing the buffer. | FlushPeriodically + { max_buffer_timeout :: Int + } -- ^ The same as 'BufferRun', except that the buffer will also be flushed -- every 300ms. -flushPeriod = 300 :: Int -- | Representation of a browser window. data Window = Window @@ -265,6 +267,7 @@ data Window = Window , wCallBuffer :: TVar (String -> String) , wCallBufferMode :: TVar CallBufferMode + , wCallBufferStats :: TMVar UTCTime , timestamp :: IO () -- ^ Print a timestamp and the time difference to the previous one @@ -278,13 +281,17 @@ data Window = Window , wJSObjects :: Vendor JSPtr } +defaultBufferFlushConfig :: CallBufferMode +defaultBufferFlushConfig = FlushPeriodically 25 + newPartialWindow :: IO Window newPartialWindow = do ptr <- newRemotePtr "" () =<< newVendor b1 <- newTVarIO id - b2 <- newTVarIO NoBuffering + b2 <- newTVarIO FlushOften + b3 <- newEmptyTMVarIO let nop = const $ return () - Window undefined nop undefined b1 b2 (return ()) nop nop ptr <$> newVendor <*> newVendor + Window undefined nop undefined b1 b2 b3 (return ()) nop nop ptr <$> newVendor <*> newVendor -- | For the purpose of controlling garbage collection, -- every 'Window' as an associated 'RemotePtr' that is alive diff --git a/threepenny-gui.cabal b/threepenny-gui.cabal index 7545d8e8..3c9e6ad0 100644 --- a/threepenny-gui.cabal +++ b/threepenny-gui.cabal @@ -119,6 +119,7 @@ Library ,file-embed == 0.0.10 ,hashable >= 1.1.0 && < 1.3 ,safe == 0.3.* + ,time >= 1.6.1 && < 1.9 ,snap-server >= 0.9.0 && < 1.1 ,snap-core >= 0.9.0 && < 1.1 ,stm >= 2.2 && < 2.5