added a runTimeout function

This adds a dep on haskell's async library, but since that's been
added to the recent haskell platform release, it should not be
much hardship to my poor long-suffering library chasing users.

1 files changed, 15 insertions, 0 deletions

diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs
index 6557398fd..5e165c9ca 100644
--- a/Utility/ThreadScheduler.hs
+++ b/Utility/ThreadScheduler.hs
@@ -11,6 +11,8 @@ module Utility.ThreadScheduler where
 import Common
 
 import Control.Concurrent
+import Control.Exception
+import Control.Concurrent.Async
 import System.Posix.Terminal
 import System.Posix.Signals
 
@@ -44,6 +46,19 @@ unboundDelay time = do
 	threadDelay $ fromInteger maxWait
 	when (maxWait /= time) $ unboundDelay (time - maxWait)
 
+{- Runs an action until a timeout is reached. If it fails to complete in
+ - time, or throws an exception, returns a Left value.
+ -
+ - Note that if the action runs an unsafe foreign call, the signal to
+ - cancel it may not arrive until the call returns. -}
+runTimeout :: Seconds -> IO a -> IO (Either SomeException a)
+runTimeout secs a = do
+	runner <- async a
+	controller <- async $ do
+		threadDelaySeconds secs
+		cancel runner
+	cancel controller `after` waitCatch runner
+
 {- Pauses the main thread, letting children run until program termination. -}
 waitForTermination :: IO ()
 waitForTermination = do