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

Annex/LockPool/PosixOrPid.hs

@@ -1,7 +1,7 @@
 {- Wraps Utility.LockPool, making pid locks be used when git-annex is so
  - configured.
  -
- - Copyright 2015 Joey Hess <id@joeyh.name>
+ - Copyright 2015-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -31,6 +31,7 @@ import Utility.LockFile.Posix (openLockFile)
 import Utility.LockPool.STM (LockFile)
 import Utility.LockFile.LockStatus
 import Config (pidLockFile)
+import Messages (warning)
 
 import System.Posix
 
@@ -72,9 +73,8 @@ pidLock m f posixlock = debugLocks $ go =<< pidLockFile
 	go Nothing = liftIO posixlock
 	go (Just pidlock) = do
 		timeout <- annexPidLockTimeout <$> Annex.getGitConfig
-		liftIO $ do
+		liftIO $ dummyPosixLock m f
-			dummyPosixLock m f
+		Pid.waitLock timeout pidlock warning
-			Pid.waitLock timeout pidlock
 
 tryPidLock :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) -> Annex (Maybe LockHandle)
 tryPidLock m f posixlock = debugLocks $ liftIO . go =<< pidLockFile

CHANGELOG

@@ -12,6 +12,8 @@ git-annex (8.20200815) UNRELEASED; urgency=medium
   * Fix reversion in 8.20200617 that made annex.pidlock being enabled
     result in some commands stalling, particularly those needing to
     autoinit.
+  * Display a message when git-annex has to wait for a pid lock file
+    held by another process.
 
  -- Joey Hess <id@joeyh.name>  Fri, 14 Aug 2020 14:57:45 -0400
 

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
+-- After the first second waiting, runs the callback to display a message,
--- system, or on a system where the side lock cannot be taken.
+-- so the user knows why it's stalled.
-waitLock :: Seconds -> LockFile -> IO LockHandle
+waitLock :: MonadIO m => Seconds -> LockFile -> (String -> m ()) -> m LockHandle
-waitLock (Seconds timeout) lockfile = go timeout
+waitLock (Seconds timeout) lockfile displaymessage = go timeout
   where
 	go n
-		| n > 0 = maybe (threadDelaySeconds (Seconds 1) >> go (pred n)) return
+		| n > 0 = liftIO (tryLock lockfile) >>= \case
-			=<< tryLock lockfile
+			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
+			displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ lockfile
-			giveup $ "Gave up waiting for possibly stale 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)
+	setup = debugLocks $ liftIO $ atomically (pa pool file)
-	cleanup ph = debugLocks $ P.releaseLock ph
+	cleanup ph = debugLocks $ liftIO $ P.releaseLock ph
-	go ph = mkLockHandle ph =<< fa file
+	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
-waitLock timeout file = makeLockHandle P.lockPool file
+	:: (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)

doc/bugs/get_is_stuck_unless_a_clone_was_previously_explicitly___34__annex_init__34__ed/comment_7_21dbdbf7e4e889dc7c2475a0b9d4c5d7._comment

@@ -0,0 +1,7 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 7"""
+ date="2020-08-26T17:02:26Z"
+ content="""
+Added that message after the first second waiting on a pid lock.
+"""]]

doc/git-annex.mdwn

@@ -1186,14 +1186,15 @@ Like other git commands, git-annex is configured via `.git/config`.
   the other node is holding a pid lock. Caveat emptor.
 
 * `annex.pidlocktimeout`
+  
+  git-annex will wait up to this many seconds for the pid lock
+  file to go away, and will then abort if it cannot continue. Default: 300
 
   When using pid lock files, it's possible for a stale lock file to get
   left behind by previous run of git-annex that crashed or was interrupted.
   This is mostly avoided, but can occur especially when using a network
-  file system.
+  file system. This timeout prevents git-annex waiting forever in such a
-
+  situation.
-  git-annex will wait up to this many seconds for the pid lock
-  file to go away, and will then abort if it cannot continue. Default: 300
 
 * `annex.cachecreds`