add timeout for pid lock waiting

diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs
index e968f18618684ece2e31b7512d636f989860ef33..ac1df253d66c8054f696bc849569a706e99a93ae 100644 (file)
--- 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 dc796b961d483ae4a83d19b552cebf985849d4a4..dca353fdf09ee8dc94ef08aabb210a86b2a5c822 100644 (file)
--- 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)