1 files changed, 48 insertions, 0 deletions

diff --git a/PingMachine.hs b/PingMachine.hs
index 5cd70f95..4a1cb008 100644
--- a/PingMachine.hs
+++ b/PingMachine.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
 module PingMachine where
 
+import Control.Applicative
 import Control.Monad
 import Data.Function
 #ifdef THREAD_DEBUG
@@ -89,6 +91,52 @@ forkPingMachine label idle timeout = do
         , pingStarted       = started
         }
 
+-- | like 'forkPingMachine'  but the timeout and idle parameters can be changed dynamically
+--  Unlike 'forkPingMachine', 'forkPingMachineDynamic' always launches a thread
+--  regardless of idle value.
+forkPingMachineDynamic
+    :: String
+    -> TVar PingInterval -- ^ Milliseconds of idle before a ping is considered necessary.
+    -> TVar TimeOut      -- ^ Milliseconds after 'PingIdle' before we signal 'PingTimeOut'.
+    -> IO PingMachine
+forkPingMachineDynamic label idleV timeoutV = do
+    d <- interruptibleDelay
+    flag <- atomically $ newTVar False
+    canceled <- atomically $ newTVar False
+    event <- atomically newEmptyTMVar
+    started <- atomically $ newEmptyTMVar
+    void . forkIO $ do
+        myThreadId >>= flip labelThread ("Ping." ++ label) -- ("ping.watchdog")
+        (>>=) (atomically (readTMVar started)) $ flip when $ do
+        fix $ \loop -> do
+            atomically $ writeTVar flag False
+            (idle,timeout) <- atomically $ (,) <$> readTVar idleV <*> readTVar timeoutV
+            fin <- startDelay d (1000*idle)
+            (>>=) (atomically (readTMVar started)) $ flip when $ do
+            if (not fin) then loop
+            else do
+            -- Idle event
+            atomically $ do
+                tryTakeTMVar event
+                putTMVar event PingIdle
+                writeTVar flag True
+            fin <- startDelay d (1000*timeout)
+            (>>=) (atomically (readTMVar started)) $ flip when $ do
+            me <- myThreadId
+            if (not fin) then loop
+            else do
+            -- Timeout event
+            atomically $ do
+                tryTakeTMVar event
+                writeTVar flag False
+                putTMVar event PingTimeOut
+    return PingMachine
+        { pingFlag          = flag
+        , pingInterruptible = d
+        , pingEvent         = event
+        , pingStarted       = started
+        }
+
 -- | Terminate the watchdog thread.  Call this upon connection close.
 --
 -- You should ensure no threads are waiting on 'pingWait' because there is no