refactor out Annex.PidLock
This commit is contained in:
Joey Hess
parent
6547bfe324
commit
b24ba92231
5 changed files with 131 additions and 101 deletions
|
|
@ -134,69 +134,3 @@ withAltRepo modrepo unmodrepo a = do
|
|||
, Annex.repoqueue = Just q
|
||||
}
|
||||
either E.throw return v
|
||||
|
||||
{- 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
|
||||
- is run with the Annex monad modified so git commands are run with
|
||||
- an env var set, which prevents child git annex processes from
|
||||
- trying to take the pid lock themselves.
|
||||
-
|
||||
- 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.
|
||||
-
|
||||
- When git-annex runs its child process directly, gitAnnexChildProcess is
|
||||
- used instead of this.
|
||||
-}
|
||||
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
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ import Git.FilePath
|
|||
import Git.Config
|
||||
import Annex.HashObject
|
||||
import Annex.InodeSentinal
|
||||
import Annex.GitOverlay
|
||||
import Annex.PidLock
|
||||
import Utility.FileMode
|
||||
import Utility.InodeCache
|
||||
import Utility.Tmp.Dir
|
||||
|
|
|
|||
|
|
@ -5,19 +5,12 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Annex.Path where
|
||||
|
||||
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 Annex.PidLock
|
||||
|
||||
import System.Environment (getExecutablePath)
|
||||
|
||||
|
|
@ -68,29 +61,4 @@ gitAnnexChildProcess
|
|||
-> 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
|
||||
pidLockChildProcess cmd ps f a
|
||||
|
|
|
|||
127
Annex/PidLock.hs
Normal file
127
Annex/PidLock.hs
Normal file
|
|
@ -0,0 +1,127 @@
|
|||
{- 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 Annex.GitOverlay
|
||||
import Git
|
||||
import Git.Env
|
||||
#ifndef mingw32_HOST_OS
|
||||
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
|
||||
-> [String]
|
||||
-> (CreateProcess -> CreateProcess)
|
||||
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
|
||||
-> Annex a
|
||||
pidLockChildProcess cmd ps f a = do
|
||||
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
|
||||
|
||||
{- 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.
|
||||
-}
|
||||
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
|
||||
|
|
@ -675,6 +675,7 @@ Executable git-annex
|
|||
Annex.NumCopies
|
||||
Annex.Path
|
||||
Annex.Perms
|
||||
Annex.PidLock
|
||||
Annex.Queue
|
||||
Annex.ReplaceFile
|
||||
Annex.RemoteTrackingBranch
|
||||
|
|
|
|||
Loading…
Reference in a new issue