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.
This commit is contained in:
Joey Hess 2020-08-25 14:57:25 -04:00
parent 6b0532e532
commit 7bdb0cdc0d
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
9 changed files with 97 additions and 33 deletions

View file

@ -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