From d6dc5ae72b8fd18c8d2e4f72c59dc6f93d635bc7 Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Wed, 4 Dec 2019 17:50:44 -0500
Subject: InterruptibleDelay.hs -> src/Control/Concurrent/Delay.hs

---
 dht/src/Control/Concurrent/Delay.hs | 49 +++++++++++++++++++++++++++++++++++++
 1 file changed, 49 insertions(+)
 create mode 100644 dht/src/Control/Concurrent/Delay.hs

(limited to 'dht/src/Control/Concurrent/Delay.hs')

diff --git a/dht/src/Control/Concurrent/Delay.hs b/dht/src/Control/Concurrent/Delay.hs
new file mode 100644
index 00000000..67dcd451
--- /dev/null
+++ b/dht/src/Control/Concurrent/Delay.hs
@@ -0,0 +1,49 @@
+module Control.Concurrent.Delay where
+
+import Control.Concurrent
+import Control.Monad
+import Control.Exception ({-evaluate,-}handle,finally,throwIO)
+import Data.Time.Clock (NominalDiffTime)
+import System.IO.Error
+
+type Microseconds = Int
+
+microseconds :: NominalDiffTime -> Microseconds
+microseconds d = round $ 1000000 * d
+
+data InterruptibleDelay = InterruptibleDelay
+        { delayThread :: MVar ThreadId
+        }
+
+interruptibleDelay :: IO InterruptibleDelay
+interruptibleDelay = do
+    fmap InterruptibleDelay newEmptyMVar
+
+-- | Delay for the given number of microseconds and return 'True' if the delay
+-- is not interrupted.
+--
+-- Note: If a thread is already waiting on the given 'InterruptibleDelay'
+-- object, then this will block until it becomes available and only then start
+-- the delay timer.
+startDelay :: InterruptibleDelay -> Microseconds -> IO Bool
+startDelay d interval = do
+    thread <- myThreadId
+    handle (\e -> do when (not $ isUserError e) (throwIO e)
+                     return False) $ do
+        putMVar (delayThread d) thread
+        threadDelay interval
+        void $ takeMVar (delayThread d)
+        return True
+     -- The following cleanup shouldn't be necessary, but I'm paranoid.
+     `finally` tryTakeMVar (delayThread d)
+
+  where debugNoise str = return ()
+
+-- | Signal the thread waiting on the given 'InterruptibleDelay' object to
+-- continue even though the timeout has not elapsed. If no thread is waiting,
+-- then this is a no-op.
+interruptDelay :: InterruptibleDelay -> IO ()
+interruptDelay d = do
+    mthread <- tryTakeMVar (delayThread d)
+    forM_ mthread $ \thread -> do
+    throwTo thread (userError "Interrupted delay")
-- 
cgit v1.2.3