improve period flushing

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

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)
 
 
 {-----------------------------------------------------------------------------

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

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