1 files changed, 50 insertions, 0 deletions

diff --git a/server/src/Control/Concurrent/Delay.hs b/server/src/Control/Concurrent/Delay.hs
new file mode 100644
index 00000000..5cc1f99a
--- /dev/null
+++ b/server/src/Control/Concurrent/Delay.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE NondecreasingIndentation #-}
+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")