74c1e0660b
git -c was already propagated via environment, but need this for consistency. Also, notice it does not use gitAnnexChildProcess to run the transferrer. So nothing is done about avoid it taking the pid lock. It's possible that the caller is already doing something that took the pid lock, and if so, the transferrer will certianly fail, since it needs to take the pid lock too. This may prevent combining annex.stalldetection with annex.pidlock, but I have not verified it's really a problem. If it was, it seems git-annex would have to take the pid lock when starting a transferrer, and hold it until shutdown, or would need to take pid lock when starting to use a transferrer, and hold it until done with a transfer and then drop it. The latter would require starting the transferrer with pid locking disabled for the child process, so assumes that the transferrer does not do anyting that needs locking when not running a transfer.
127 lines
3.7 KiB
Haskell
127 lines
3.7 KiB
Haskell
{- Pid locking support.
|
|
-
|
|
- Copyright 2014-2020 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Annex.PidLock where
|
|
|
|
import Annex.Common
|
|
import Git
|
|
#ifndef mingw32_HOST_OS
|
|
import Git.Env
|
|
import Annex.GitOverlay
|
|
import qualified Utility.LockFile.PidLock as PidF
|
|
import qualified Utility.LockPool.PidLock as PidP
|
|
import Utility.LockPool (dropLock)
|
|
import Utility.Env
|
|
import Config
|
|
#endif
|
|
|
|
{- When pid locking is in use, this tries to take the pid lock (unless
|
|
- the process already has it), and if successful, holds it while
|
|
- running the child process. The child process is run with an env var
|
|
- set, which prevents it from trying to take the pid lock itself.
|
|
-
|
|
- This way, any locking the parent does will not get in the way of
|
|
- 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.
|
|
-
|
|
- If another process is already holding the pid lock, the child process
|
|
- is still run, but without setting the env var, so it can try to take the
|
|
- pid lock itself, and fail however is appropriate for it in that
|
|
- situation.
|
|
-}
|
|
pidLockChildProcess
|
|
:: FilePath
|
|
-> [CommandParam]
|
|
-> (CreateProcess -> CreateProcess)
|
|
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
|
|
-> Annex a
|
|
pidLockChildProcess cmd ps f a = do
|
|
let p = f (proc cmd (toCommand 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
|
|
liftIO gonopidlock
|
|
#endif
|
|
|
|
{- Wrap around actions that may run a git-annex child process via a git
|
|
- command.
|
|
-
|
|
- This is like pidLockChildProcess, but rather than running a process
|
|
- itself, it runs the action with a modified Annex state that passes the
|
|
- necessary env var when running git.
|
|
-}
|
|
runsGitAnnexChildProcessViaGit :: Annex a -> Annex a
|
|
#ifndef mingw32_HOST_OS
|
|
runsGitAnnexChildProcessViaGit a = pidLockFile >>= \case
|
|
Nothing -> a
|
|
Just pidlock -> bracket (setup pidlock) cleanup (go pidlock)
|
|
where
|
|
setup pidlock = liftIO $ PidP.tryLock pidlock
|
|
|
|
cleanup (Just h) = liftIO $ dropLock h
|
|
cleanup Nothing = return ()
|
|
|
|
go _ Nothing = a
|
|
go pidlock (Just _h) = do
|
|
v <- liftIO $ PidF.pidLockEnv pidlock
|
|
let addenv g = do
|
|
g' <- liftIO $ addGitEnv g v PidF.pidLockEnvValue
|
|
return (g', ())
|
|
let rmenv oldg g
|
|
| any (\(k, _) -> k == v) (fromMaybe [] (Git.gitEnv oldg)) = g
|
|
| otherwise =
|
|
let e' = case Git.gitEnv g of
|
|
Just e -> Just (delEntry v e)
|
|
Nothing -> Nothing
|
|
in g { Git.gitEnv = e' }
|
|
withAltRepo addenv rmenv (const a)
|
|
#else
|
|
runsGitAnnexChildProcessViaGit a = a
|
|
#endif
|
|
|
|
runsGitAnnexChildProcessViaGit' :: Git.Repo -> (Git.Repo -> IO a) -> Annex a
|
|
#ifndef mingw32_HOST_OS
|
|
runsGitAnnexChildProcessViaGit' r a = pidLockFile >>= \case
|
|
Nothing -> liftIO $ a r
|
|
Just pidlock -> liftIO $ bracket (setup pidlock) cleanup (go pidlock)
|
|
where
|
|
setup pidlock = PidP.tryLock pidlock
|
|
|
|
cleanup (Just h) = dropLock h
|
|
cleanup Nothing = return ()
|
|
|
|
go _ Nothing = a r
|
|
go pidlock (Just _h) = do
|
|
v <- PidF.pidLockEnv pidlock
|
|
r' <- addGitEnv r v PidF.pidLockEnvValue
|
|
a r'
|
|
#else
|
|
runsGitAnnexChildProcessViaGit' r a = liftIO $ a r
|
|
#endif
|