add timeout for pid lock waiting

2 files changed, 16 insertions, 12 deletions

diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs
index e968f1861..ac1df253d 100644
--- a/Utility/LockFile/PidLock.hs
+++ b/Utility/LockFile/PidLock.hs
@@ -25,6 +25,7 @@ import Utility.Monad
 import Utility.Path
 import Utility.FileMode
 import Utility.LockFile.LockStatus
+import Utility.ThreadScheduler
 import qualified Utility.LockFile.Posix as Posix
 
 import System.IO
@@ -101,7 +102,7 @@ tryLock lockfile = trySideLock lockfile $ \sidelock -> do
 				Just pl | isJust sidelock && hn == lockingHost pl -> do
 					-- Since we have the sidelock,
 					-- and are on the same host that
-					-- the pidlock was take on,
+					-- the pidlock was taken on,
 					-- we know that the pidlock is
 					-- stale, and can take it over.
 					rename tmp lockfile
@@ -113,13 +114,17 @@ tryLock lockfile = trySideLock lockfile $ \sidelock -> do
 --
 -- Uses a 1 second wait-loop.
 --
--- May wait forever if the lock file is stale and is on a network file
+-- May wait untie timeout if the lock file is stale and is on a network file
 -- system, or on a system where the side lock cannot be taken.
-waitLock :: LockFile -> IO LockHandle
-waitLock lockfile = go
+waitLock :: Seconds -> LockFile -> IO LockHandle
+waitLock (Seconds timeout) lockfile = go timeout
   where
-	go = maybe (threadDelaySeconds (Seconds 1) >> go) return
-		=<< tryLock lockfile
+	go n
+		| n > 0 = maybe (threadDelaySeconds (Seconds 1) >> go (pred n)) return
+			=<< tryLock lockfile
+		| otherwise = do
+			hPutStrLn stderr $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ lockfile
+			error $ "Gave up waiting for possibly stale pid lock file " ++ lockfile
 
 dropLock :: LockHandle -> IO ()
 dropLock (LockHandle lockfile fd plh) = do
diff --git a/Utility/LockPool/PidLock.hs b/Utility/LockPool/PidLock.hs
index dc796b961..dca353fdf 100644
--- a/Utility/LockPool/PidLock.hs
+++ b/Utility/LockPool/PidLock.hs
@@ -22,6 +22,7 @@ import Utility.LockFile.LockStatus
 import qualified Utility.LockPool.STM as P
 import Utility.LockPool.STM (LockFile, LockMode(..))
 import Utility.LockPool.LockHandle
+import Utility.ThreadScheduler
 
 import System.IO
 import System.Posix
@@ -29,13 +30,11 @@ import Data.Maybe
 import Control.Applicative
 import Prelude
 
--- Takes a pid lock, blocking until the lock is available.
---
--- May block forever on stale locks, see PidLock documentation for details.
-waitLock :: LockFile -> IO LockHandle
-waitLock file = makeLockHandle
+-- Takes a pid lock, blocking until the lock is available or the timeout.
+waitLock :: Seconds -> LockFile -> IO LockHandle
+waitLock timeout file = makeLockHandle
 	(P.waitTakeLock P.lockPool file LockExclusive)
-	(mk <$> F.waitLock file)
+	(mk <$> F.waitLock timeout file)
 
 -- Tries to take a pid lock, but does not block.
 tryLock :: LockFile -> IO (Maybe LockHandle)