Display a message when git-annex has to wait for a pid lock file held by another process

Utility/LockFile/PidLock.hs

@@ -38,6 +38,8 @@ import System.Posix.IO
 import System.Posix.Types
 import System.Posix.Files
 import System.Posix.Process
+import Control.Monad
+import Control.Monad.IO.Class (liftIO, MonadIO)
 import Data.Maybe
 import Data.List
 import Network.BSD
@@ -240,19 +242,24 @@ checkInsaneLustre dest = do
 
 -- | Waits as necessary to take a lock.
 --
--- Uses a 1 second wait-loop.
+-- Uses a 1 second wait-loop, retrying until a timeout.
 --
--- May wait until 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 :: Seconds -> LockFile -> IO LockHandle
-waitLock (Seconds timeout) lockfile = go timeout
+-- After the first second waiting, runs the callback to display a message,
+-- so the user knows why it's stalled.
+waitLock :: MonadIO m => Seconds -> LockFile -> (String -> m ()) -> m LockHandle
+waitLock (Seconds timeout) lockfile displaymessage = go timeout
   where
 	go n
-		| n > 0 = maybe (threadDelaySeconds (Seconds 1) >> go (pred n)) return
-			=<< tryLock lockfile
+		| n > 0 = liftIO (tryLock lockfile) >>= \case
+			Nothing -> do
+				when (n == pred timeout) $
+					displaymessage $ "waiting for pid lock file " ++ lockfile ++ " which is held by another process (or may be stale)"
+				liftIO $ threadDelaySeconds (Seconds 1)
+				go (pred n)
+			Just lckh -> return lckh
 		| otherwise = do
-			hPutStrLn stderr $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ lockfile
-			giveup $ "Gave up waiting for possibly stale pid lock file " ++ lockfile
+			displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ lockfile
+			giveup $ "Gave up waiting for pid lock file " ++ lockfile
 
 dropLock :: LockHandle -> IO ()
 dropLock (LockHandle lockfile _ sidelock) = do

Utility/LockPool/LockHandle.hs

@@ -1,6 +1,6 @@
 {- Handles for lock pools.
  -
- - Copyright 2015 Joey Hess <id@joeyh.name>
+ - Copyright 2015-2020 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
@@ -23,7 +23,8 @@ import Utility.LockPool.STM (LockFile)
 import Utility.DebugLocks
 
 import Control.Concurrent.STM
-import Control.Exception
+import Control.Monad.Catch
+import Control.Monad.IO.Class (liftIO, MonadIO)
 import Control.Applicative
 import Prelude
 
@@ -47,27 +48,39 @@ checkSaneLock lockfile (LockHandle _ flo) = fCheckSaneLock flo lockfile
 -- Take a lock, by first updating the lock pool, and then taking the file
 -- lock. If taking the file lock fails for any reason, take care to
 -- release the lock in the lock pool.
-makeLockHandle :: P.LockPool -> LockFile -> (P.LockPool -> LockFile -> STM P.LockHandle) -> (LockFile -> IO FileLockOps) -> IO LockHandle
+makeLockHandle
+	:: (MonadIO m, MonadMask m)
+	=> P.LockPool
+	-> LockFile
+	-> (P.LockPool -> LockFile -> STM P.LockHandle)
+	-> (LockFile -> m FileLockOps)
+	-> m LockHandle
 makeLockHandle pool file pa fa = bracketOnError setup cleanup go
   where
-	setup = debugLocks $ atomically (pa pool file)
-	cleanup ph = debugLocks $ P.releaseLock ph
-	go ph = mkLockHandle ph =<< fa file
+	setup = debugLocks $ liftIO $ atomically (pa pool file)
+	cleanup ph = debugLocks $ liftIO $ P.releaseLock ph
+	go ph = liftIO . mkLockHandle ph =<< fa file
 
-tryMakeLockHandle :: P.LockPool -> LockFile -> (P.LockPool -> LockFile -> STM (Maybe P.LockHandle)) -> (LockFile -> IO (Maybe FileLockOps)) -> IO (Maybe LockHandle)
+tryMakeLockHandle
+	:: (MonadIO m, MonadMask m)
+	=> P.LockPool
+	-> LockFile
+	-> (P.LockPool -> LockFile -> STM (Maybe P.LockHandle))
+	-> (LockFile -> m (Maybe FileLockOps))
+	-> m (Maybe LockHandle)
 tryMakeLockHandle pool file pa fa = bracketOnError setup cleanup go
   where
-	setup = atomically (pa pool file)
+	setup = liftIO $ atomically (pa pool file)
 	cleanup Nothing = return ()
-	cleanup (Just ph) = P.releaseLock ph
+	cleanup (Just ph) = liftIO $ P.releaseLock ph
 	go Nothing = return Nothing
 	go (Just ph) = do
 		mfo <- fa file
 		case mfo of
 			Nothing -> do
-				cleanup (Just ph)
+				liftIO $ cleanup (Just ph)
 				return Nothing
-			Just fo -> Just <$> mkLockHandle ph fo
+			Just fo -> liftIO $ Just <$> mkLockHandle ph fo
 
 mkLockHandle :: P.LockHandle -> FileLockOps -> IO LockHandle
 mkLockHandle ph fo = do

Utility/LockPool/PidLock.hs

@@ -1,6 +1,6 @@
 {- Pid locks, using lock pools.
  -
- - Copyright 2015 Joey Hess <id@joeyh.name>
+ - Copyright 2015-2020 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
@@ -27,16 +27,23 @@ import Utility.ThreadScheduler
 import System.IO
 import System.Posix
 import Data.Maybe
+import Control.Monad.Catch
+import Control.Monad.IO.Class
 import Control.Applicative
 import Prelude
 
 -- Takes a pid lock, blocking until the lock is available or the timeout.
-waitLock :: Seconds -> LockFile -> IO LockHandle
-waitLock timeout file = makeLockHandle P.lockPool file
+waitLock
+	:: (MonadIO m, MonadMask m)
+	=> Seconds
+	-> LockFile
+	-> (String -> m ())
+	-> m LockHandle
+waitLock timeout file displaymessage = makeLockHandle P.lockPool file
 	-- LockShared for STM lock, because a pid lock can be the top-level
 	-- lock with various other STM level locks gated behind it.
 	(\p f -> P.waitTakeLock p f LockShared)
-	(\f -> mk <$> F.waitLock timeout f)
+	(\f -> mk <$> F.waitLock timeout f displaymessage)
 
 -- Tries to take a pid lock, but does not block.
 tryLock :: LockFile -> IO (Maybe LockHandle)