add gitAnnexChildProcess and use instead of incorrect use of runsGitAnnexChildProcess

Fixes reversion in 8.20200617 that made annex.pidlock being enabled result
in some commands stalling, particularly those needing to autoinit.

Renamed runsGitAnnexChildProcess to make clearer where it should be
used.

Arguably, it would be better to have a way to make any process git-annex
runs have the env var set. But then it would need to take the pid lock
when running any and all processes, and that would be a problem when
git-annex runs two processes concurrently. So, I'm left doing it ad-hoc
in places where git-annex really does run a child process, directly
or indirectly via a particular git command.

Annex/GitOverlay.hs

@@ -1,4 +1,4 @@
-{- Temporarily changing the files git uses.
+{- Temporarily changing how git-annex runs git commands.
  -
  - Copyright 2014-2020 Joey Hess <id@joeyh.name>
  -
@@ -135,7 +135,8 @@ withAltRepo modrepo unmodrepo a = do
 		}
 	either E.throw return v
 
-{- Wrap around actions that may run a git-annex child process.
+{- Wrap around actions that may run a git-annex child process via a git
+ - command.
  -
  - When pid locking is in use, this tries to take the pid lock, and if
  - successful, holds it while running the child process. The action
@@ -147,10 +148,13 @@ withAltRepo modrepo unmodrepo a = do
  - the child. The child is assumed to not do any locking that conflicts
  - with the parent, but if it did happen to do that, it would be noticed
  - when git-annex is used without pid locking.
+ -
+ - When git-annex runs its child process directly, gitAnnexChildProcess is
+ - used instead of this.
  -}
-runsGitAnnexChildProcess :: Annex a -> Annex a
+runsGitAnnexChildProcessViaGit :: Annex a -> Annex a
 #ifndef mingw32_HOST_OS
-runsGitAnnexChildProcess a = pidLockFile >>= \case
+runsGitAnnexChildProcessViaGit a = pidLockFile >>= \case
 	Nothing -> a
 	Just pidlock -> bracket (setup pidlock) cleanup (go pidlock)
   where
@@ -163,7 +167,7 @@ runsGitAnnexChildProcess a = pidLockFile >>= \case
 	go pidlock (Just _h) = do
 		v <- liftIO $ PidF.pidLockEnv pidlock
 		let addenv g = do
-			g' <- liftIO $ addGitEnv g v "1"
+			g' <- liftIO $ addGitEnv g v PidF.pidLockEnvValue
 			return (g', ())
 		let rmenv oldg g
 			| any (\(k, _) -> k == v) (fromMaybe [] (Git.gitEnv oldg)) = g
@@ -174,12 +178,12 @@ runsGitAnnexChildProcess a = pidLockFile >>= \case
 				in g { Git.gitEnv = e' }
 		withAltRepo addenv rmenv (const a)
 #else
-runsGitAnnexChildProcess a = a
+runsGitAnnexChildProcessViaGit a = a
 #endif
 
-runsGitAnnexChildProcess' :: Git.Repo -> (Git.Repo -> IO a) -> Annex a
+runsGitAnnexChildProcessViaGit' :: Git.Repo -> (Git.Repo -> IO a) -> Annex a
 #ifndef mingw32_HOST_OS
-runsGitAnnexChildProcess' r a = pidLockFile >>= \case
+runsGitAnnexChildProcessViaGit' r a = pidLockFile >>= \case
 	Nothing -> liftIO $ a r
 	Just pidlock -> liftIO $ bracket (setup pidlock) cleanup (go pidlock)
   where
@@ -191,8 +195,8 @@ runsGitAnnexChildProcess' r a = pidLockFile >>= \case
 	go _ Nothing = a r
 	go pidlock (Just _h) = do
 		v <- PidF.pidLockEnv pidlock
-		r' <- addGitEnv r v "1"
+		r' <- addGitEnv r v PidF.pidLockEnvValue
 		a r'
 #else
-runsGitAnnexChildProcess' r a = liftIO $ a r
+runsGitAnnexChildProcessViaGit' r a = liftIO $ a r
 #endif

Annex/Init.hs

@@ -37,7 +37,6 @@ import Annex.UUID
 import Annex.WorkTree
 import Annex.Fixup
 import Annex.Path
-import Annex.GitOverlay
 import Config
 import Config.Files
 import Config.Smudge
@@ -327,18 +326,18 @@ fixupUnusualReposAfterInit = do
  - The enabling is done in a child process to avoid it using stdio.
  -}
 autoEnableSpecialRemotes :: Annex ()
-autoEnableSpecialRemotes = runsGitAnnexChildProcess $ do
+autoEnableSpecialRemotes = do
 	rp <- fromRawFilePath <$> fromRepo Git.repoPath
-	cmd <- liftIO programPath
-	liftIO $ withNullHandle $ \nullh -> do
-		let p = (proc cmd 
+	withNullHandle $ \nullh -> gitAnnexChildProcess
 		[ "init"
 		, "--autoenable"
-			])
+		]
+		(\p -> p
 			{ std_out = UseHandle nullh
 			, std_err = UseHandle nullh
 			, std_in = UseHandle nullh
 			, cwd = Just rp
 			}
-		withCreateProcess p $ \_ _ _ pid -> void $ waitForProcess pid
+		)
+		(\_ _ _ pid -> void $ waitForProcess pid)
 	remotesChanged

Annex/Link.hs

@@ -218,7 +218,7 @@ restagePointerFile (Restage True) f orig = withTSDelta $ \tsd ->
 					[ Param "-c"
 					, Param $ "core.safecrlf=" ++ boolConfig False
 					] }
-				runsGitAnnexChildProcess' r'' $ \r''' ->
+				runsGitAnnexChildProcessViaGit' r'' $ \r''' ->
 					liftIO $ Git.UpdateIndex.refreshIndex r''' $ \feed ->
 						forM_ l $ \(f', checkunmodified) ->
 							whenM checkunmodified $

Annex/Path.hs

@@ -1,15 +1,23 @@
 {- git-annex program path
  -
- - Copyright 2013 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Annex.Path where
 
-import Common
+import Annex.Common
 import Config.Files
 import Utility.Env
+#ifndef mingw32_HOST_OS
+import qualified Utility.LockFile.PidLock as PidF
+import qualified Utility.LockPool.PidLock as PidP
+import Utility.LockPool (dropLock)
+import Config
+#endif
 
 import System.Environment (getExecutablePath)
 
@@ -45,3 +53,44 @@ cannotFindProgram :: IO a
 cannotFindProgram = do
 	f <- programFile
 	giveup $ "cannot find git-annex program in PATH or in " ++ f
+
+{- Runs a git-annex child process.
+ -
+ - Like runsGitAnnexChildProcessViaGit, when pid locking is in use,
+ - this takes the pid lock, while running it, and sets an env var
+ - that prevents the child process trying to take the pid lock,
+ - to avoid it deadlocking.
+ -}
+gitAnnexChildProcess
+	:: [String]
+	-> (CreateProcess -> CreateProcess)
+	-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
+	-> Annex a
+gitAnnexChildProcess ps f a = do
+	cmd <- liftIO programPath
+	let p = f (proc cmd ps)
+	let gonopidlock = withCreateProcess p a
+#ifndef mingw32_HOST_OS
+	pidLockFile >>= liftIO . \case
+		Nothing -> gonopidlock
+		Just pidlock -> bracket
+			(setup pidlock)
+			cleanup
+			(go gonopidlock p pidlock)
+  where
+  	setup pidlock = PidP.tryLock pidlock
+
+	cleanup (Just h) = dropLock h
+	cleanup Nothing = return ()
+
+	go gonopidlock _ _ Nothing = gonopidlock
+	go _ p pidlock (Just _h) = do
+		v <- PidF.pidLockEnv pidlock
+		baseenv <- case env p of
+			Nothing -> getEnvironment
+			Just baseenv -> pure baseenv
+		let p' = p { env = Just ((v, PidF.pidLockEnvValue) : baseenv) }
+		withCreateProcess p' a
+#else
+	gonopidlock
+#endif

CHANGELOG

@@ -9,6 +9,9 @@ git-annex (8.20200815) UNRELEASED; urgency=medium
   * stack.yaml: Updated to lts-16.10.
   * Fix reversion in 7.20190322 that made addurl --file not be honored
     when youtube-dl was used to download media.
+  * Fix reversion in 8.20200617 that made annex.pidlock being enabled
+    result in some commands stalling, particularly those needing to
+    autoinit.
 
  -- Joey Hess <id@joeyh.name>  Fri, 14 Aug 2020 14:57:45 -0400
 

Command/Sync.hs

@@ -65,7 +65,6 @@ import Annex.UpdateInstead
 import Annex.Export
 import Annex.TaggedPush
 import Annex.CurrentBranch
-import Annex.GitOverlay
 import qualified Database.Export as Export
 import Utility.Bloom
 import Utility.OptParse
@@ -515,10 +514,12 @@ pushRemote o remote (Just branch, _) = do
 	postpushupdate repo = case Git.repoWorkTree repo of
 		Nothing -> return True
 		Just wt -> ifM needemulation
-			( runsGitAnnexChildProcess $ liftIO $ do
-				p <- programPath
-				boolSystem' p [Param "post-receive"]
+			( gitAnnexChildProcess ["post-receive"]
 				(\cp -> cp { cwd = Just (fromRawFilePath wt) })
+				(\_ _ _ pid -> waitForProcess pid >>= return . \case
+					ExitSuccess -> True
+					_ -> False
+				)
 			, return True
 			)
 	  where

Upgrade.hs

@@ -15,7 +15,6 @@ import qualified Git
 import Config
 import Annex.Path
 import Annex.Version
-import Annex.GitOverlay
 import Types.RepoVersion
 #ifndef mingw32_HOST_OS
 import qualified Upgrade.V0
@@ -104,13 +103,16 @@ upgrade automatic destversion = do
 	-- upgrading a git repo other than the current repo.
 	upgraderemote = do
 		rp <- fromRawFilePath <$> fromRepo Git.repoPath
-		cmd <- liftIO programPath
-		runsGitAnnexChildProcess $ liftIO $ boolSystem' cmd
-			[ Param "upgrade"
-			, Param "--quiet"
-			, Param "--autoonly"
+		gitAnnexChildProcess
+			[ "upgrade"
+			, "--quiet"
+			, "--autoonly"
 			]
 			(\p -> p { cwd = Just rp })
+			(\_ _ _ pid -> waitForProcess pid >>= return . \case
+				ExitSuccess -> True
+				_ -> False
+			)
 
 upgradingRemote :: Annex Bool
 upgradingRemote = isJust <$> fromRepo Git.remoteName

Utility/LockFile/PidLock.hs

@@ -15,6 +15,7 @@ module Utility.LockFile.PidLock (
 	checkLocked,
 	checkSaneLock,
 	pidLockEnv,
+	pidLockEnvValue,
 ) where
 
 import Utility.PartialPrelude
@@ -293,3 +294,6 @@ pidLockEnv :: FilePath -> IO String
 pidLockEnv lockfile = do
 	abslockfile <- absPath lockfile
 	return $ "PIDLOCK_" ++ filter legalInEnvVar abslockfile
+
+pidLockEnvValue :: String
+pidLockEnvValue = "1"

doc/bugs/get_is_stuck_unless_a_clone_was_previously_explicitly___34__annex_init__34__ed.mdwn

@@ -74,3 +74,5 @@ done.
 
 [[!meta author=yoh]]
 [[!tag projects/datalad]]
+
+> [[fixed|done]] --[[Joey]]