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:
parent
6b0532e532
commit
7bdb0cdc0d
9 changed files with 97 additions and 33 deletions
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue