Ping now uses InterruptableDelay

1 files changed, 46 insertions, 80 deletions

diff --git a/Presence/Server.hs b/Presence/Server.hs
index 14eab06c..ff3c5d42 100644
--- a/Presence/Server.hs
+++ b/Presence/Server.hs
@@ -378,7 +378,7 @@ server = do
             expected = fromIntegral interval
         when (retry && elapsed < expected) $ do
             debugNoise $ "Waiting to retry " <> bshow addr
-            startDelay timer (round $ 1000 * (expected-elapsed))
+            void $ startDelay timer (round $ 1000 * (expected-elapsed))
         debugNoise $ "retry " <> bshow (retry,addr)
         when retry $ retryLoop
 
@@ -750,96 +750,60 @@ debugNoise str = warn str -- return ()
 data PingEvent = PingIdle | PingTimeOut
 
 data PingMachine = PingMachine
-    { pingIdle :: PingInterval
-    , pingTimeOut :: TimeOut
-    , pingDelay :: TMVar (Int,PingEvent)
+    { pingFlag :: TVar Bool
+    , pingInterruptable :: InterruptableDelay
     , pingEvent :: TMVar PingEvent
-    , pingStarted :: TMVar Bool -- True when a threadDelay is running
-    , pingThread :: ThreadId
-    , pingFlag :: TVar Bool
+    , pingStarted :: TMVar Bool
     }
 
 pingMachine :: PingInterval -> TimeOut -> IO PingMachine
 pingMachine idle timeout = do
-    me <- do
-        (delayVar,eventVar,startedVar,flag) <- atomically $ do
-            d <- newEmptyTMVar
-            e <- newEmptyTMVar
-            s <- newTMVar False
-            f <- newTVar False
-            return (d,e,s,f)
-        return PingMachine { pingIdle = idle
-                           , pingTimeOut = timeout
-                           , pingDelay = delayVar
-                           , pingEvent = eventVar
-                           , pingStarted = startedVar
-                           , pingThread = undefined
-                           , pingFlag = flag }
-    thread <- forkIO . when (pingIdle me /=0) . fix $
-      \loop -> do
-            (delay,event) <- atomically $ takeTMVar (pingDelay me)
-            when (delay /= 0) $ do
-            handle (\(ErrorCall _)-> do
-                       atomically $ do takeTMVar (pingStarted me)
-                                       putTMVar (pingStarted me) False
-                       loop)
-                   (do atomically $ do takeTMVar (pingStarted me)
-                                       putTMVar (pingStarted me) True
-                       threadDelay delay
-                       atomically $ do takeTMVar (pingStarted me)
-                                       putTMVar (pingStarted me) False
-                       atomically $ putTMVar (pingEvent me) event
-                       case event of PingTimeOut -> return ()
-                                     PingIdle    -> loop)
-
-    return me { pingThread = thread }
+    d <- interruptableDelay
+    flag <- atomically $ newTVar False
+    canceled <- atomically $ newTVar False
+    event <- atomically newEmptyTMVar
+    started <- atomically $ newEmptyTMVar
+    thread <- forkIO $ do
+        (>>=) (atomically (readTMVar started)) $ flip when $ do
+        fix $ \loop -> do
+            atomically $ writeTVar flag False
+            fin <- startDelay d (1000*idle)
+            (>>=) (atomically (readTMVar started)) $ flip when $ do
+            when (not fin) loop
+            -- Idle event
+            atomically $ do
+                tryTakeTMVar event
+                putTMVar event PingIdle
+                writeTVar flag True
+            fin <- startDelay d (1000*timeout)
+            (>>=) (atomically (readTMVar started)) $ flip when $ do
+            when (not fin) loop
+            -- Timeout event
+            atomically $ do
+                tryTakeTMVar event
+                writeTVar flag False
+                putTMVar event PingTimeOut
+    return PingMachine
+        { pingFlag = flag
+        , pingInterruptable = d
+        , pingEvent = event
+        , pingStarted = started
+        }
 
 pingCancel :: PingMachine -> IO ()
 pingCancel me = do
-    b <- atomically $ do
-            tryTakeTMVar (pingDelay me) -- no hang
-            putTMVar (pingDelay me) (0,PingTimeOut)
-            takeTMVar (pingStarted me)
-    when b $ throwTo (pingThread me) $ ErrorCall ""
-    atomically $ putTMVar (pingStarted me) b
+    atomically $ do tryTakeTMVar (pingStarted me)
+                    putTMVar (pingStarted me) False
+    interruptDelay (pingInterruptable me)
 
 pingBump :: PingMachine -> IO ()
 pingBump me = do
-    b <- atomically $ do
-            when (pingIdle me /= 0) $ do
-              e <- tryReadTMVar (pingDelay me)
-              case e of
-                  Just (0,PingTimeOut) -> return () -- canceled/fired
-                  Just _  -> retry
-                  Nothing -> putTMVar (pingDelay me)
-                                      (1000*pingIdle me,PingIdle)
-            takeTMVar (pingStarted me)
-    when b $ throwTo (pingThread me) $ ErrorCall ""
-    {-
-    utc <- getCurrentTime
-    let utc' = formatTime defaultTimeLocale "%s" utc
-    warn $ "BUMP " <> bshow utc' <> " " <> bshow (pingIdle me, pingTimeOut me)
-    -}
-    atomically $ putTMVar (pingStarted me) b
-{-
-pingBump me = do
-    b <- atomically $ do
-             when (pingIdle me /= 0) $ 
-                putTMVar (pingDelay me) (1000*pingIdle me,PingIdle)
-             readTMVar (pingStarted me)
-    when b $ throwTo (pingThread me) $ ErrorCall ""
--}
+    atomically $ do tryTakeTMVar (pingStarted me)
+                    putTMVar (pingStarted me) True
+    interruptDelay (pingInterruptable me)
 
 pingWait :: PingMachine -> STM PingEvent
-pingWait me = do
-    e <- takeTMVar (pingEvent me)
-    case e of
-        PingIdle    -> do writeTVar (pingFlag me) True
-                          putTMVar (pingDelay me)
-                                   (1000*pingTimeOut me,PingTimeOut)
-        PingTimeOut -> putTMVar (pingDelay me)
-                                (0,PingTimeOut)
-    return e
+pingWait me = takeTMVar (pingEvent me)
 
 
 data InterruptableDelay = InterruptableDelay 
@@ -851,14 +815,16 @@ interruptableDelay = do
     fmap InterruptableDelay
        $ atomically newEmptyTMVar
 
-startDelay :: InterruptableDelay -> Microseconds -> IO ()
+startDelay :: InterruptableDelay -> Microseconds -> IO Bool
 startDelay d interval = do
     thread <- myThreadId
     handle (\(ErrorCall _)-> do
-                debugNoise $ "delay interrupted" ) $ do 
+                debugNoise $ "delay interrupted"
+                return False) $ do 
         atomically $ putTMVar (delayThread d) thread
         threadDelay interval
         void . atomically $ takeTMVar (delayThread d)
+        return True
 
 interruptDelay :: InterruptableDelay -> IO ()
 interruptDelay d = do