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.

4 files changed, 18 insertions, 1 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
diff --git a/debian/control b/debian/control
index 61738c4d3..00ab576bd 100644
--- a/debian/control
+++ b/debian/control
@@ -42,6 +42,7 @@ Build-Depends:
 	libghc-network-protocol-xmpp-dev (>= 0.4.3-2),
 	libghc-gnutls-dev (>= 0.1.4),
 	libghc-xml-types-dev,
+	libghc-async-dev,
 	ikiwiki,
 	perlmagick,
 	git,
diff --git a/doc/install/fromscratch.mdwn b/doc/install/fromscratch.mdwn
index 000bc8451..18759d6b4 100644
--- a/doc/install/fromscratch.mdwn
+++ b/doc/install/fromscratch.mdwn
@@ -19,6 +19,7 @@ quite a lot.
   * [edit-distance](http://hackage.haskell.org/package/edit-distance)
   * [hS3](http://hackage.haskell.org/package/hS3) (optional)
   * [SafeSemaphore](http://hackage.haskell.org/package/SafeSemaphore)
+  * [async](http://hackage.haskell.org/package/async)
 * Optional haskell stuff, used by the [[assistant]] and its webapp (edit Makefile to disable)
   * [stm](http://hackage.haskell.org/package/stm)
     (version 2.3 or newer)
diff --git a/git-annex.cabal b/git-annex.cabal
index ea6a78a04..d2ecc55ce 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -57,7 +57,7 @@ Executable git-annex
    pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP,
    base (>= 4.5 && < 4.7), monad-control, transformers-base, lifted-base,
    IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process,
-   SafeSemaphore
+   SafeSemaphore, async
   -- Need to list these because they're generated from .hsc files.
   Other-Modules: Utility.Touch Utility.Mounts
   Include-Dirs: Utility