diff options
Diffstat (limited to 'PingMachine.hs')
-rw-r--r-- | PingMachine.hs | 7 |
1 files changed, 4 insertions, 3 deletions
diff --git a/PingMachine.hs b/PingMachine.hs index b714d71e..5cd70f95 100644 --- a/PingMachine.hs +++ b/PingMachine.hs | |||
@@ -48,17 +48,18 @@ data PingMachine = PingMachine | |||
48 | -- 'pingFlag' is difficult to use properly because it is up to the caller to | 48 | -- 'pingFlag' is difficult to use properly because it is up to the caller to |
49 | -- remember that the ping is already in progress. | 49 | -- remember that the ping is already in progress. |
50 | forkPingMachine | 50 | forkPingMachine |
51 | :: PingInterval -- ^ Milliseconds of idle before a ping is considered necessary. | 51 | :: String |
52 | -> PingInterval -- ^ Milliseconds of idle before a ping is considered necessary. | ||
52 | -> TimeOut -- ^ Milliseconds after 'PingIdle' before we signal 'PingTimeOut'. | 53 | -> TimeOut -- ^ Milliseconds after 'PingIdle' before we signal 'PingTimeOut'. |
53 | -> IO PingMachine | 54 | -> IO PingMachine |
54 | forkPingMachine idle timeout = do | 55 | forkPingMachine label idle timeout = do |
55 | d <- interruptibleDelay | 56 | d <- interruptibleDelay |
56 | flag <- atomically $ newTVar False | 57 | flag <- atomically $ newTVar False |
57 | canceled <- atomically $ newTVar False | 58 | canceled <- atomically $ newTVar False |
58 | event <- atomically newEmptyTMVar | 59 | event <- atomically newEmptyTMVar |
59 | started <- atomically $ newEmptyTMVar | 60 | started <- atomically $ newEmptyTMVar |
60 | when (idle/=0) $ void . forkIO $ do | 61 | when (idle/=0) $ void . forkIO $ do |
61 | myThreadId >>= flip labelThread ("ping.watchdog") | 62 | myThreadId >>= flip labelThread ("Ping." ++ label) -- ("ping.watchdog") |
62 | (>>=) (atomically (readTMVar started)) $ flip when $ do | 63 | (>>=) (atomically (readTMVar started)) $ flip when $ do |
63 | fix $ \loop -> do | 64 | fix $ \loop -> do |
64 | atomically $ writeTVar flag False | 65 | atomically $ writeTVar flag False |