From 7bdb0cdc0d6f35d3835e57c3a34740cc98f89719 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 25 Aug 2020 14:57:25 -0400 Subject: [PATCH] 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 | 24 +++++---- Annex/Init.hs | 17 +++--- Annex/Link.hs | 2 +- Annex/Path.hs | 53 ++++++++++++++++++- CHANGELOG | 3 ++ Command/Sync.hs | 11 ++-- Upgrade.hs | 14 ++--- Utility/LockFile/PidLock.hs | 4 ++ ...y_explicitly___34__annex_init__34__ed.mdwn | 2 + 9 files changed, 97 insertions(+), 33 deletions(-) diff --git a/Annex/GitOverlay.hs b/Annex/GitOverlay.hs index 1450fc78de..2d1e889971 100644 --- a/Annex/GitOverlay.hs +++ b/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 - @@ -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 diff --git a/Annex/Init.hs b/Annex/Init.hs index 5b34af4238..4bcae34908 100644 --- a/Annex/Init.hs +++ b/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 - [ "init" - , "--autoenable" - ]) + 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 diff --git a/Annex/Link.hs b/Annex/Link.hs index 74990022ca..0cc41a8c31 100644 --- a/Annex/Link.hs +++ b/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 $ diff --git a/Annex/Path.hs b/Annex/Path.hs index 26baf908ab..c88bf7a508 100644 --- a/Annex/Path.hs +++ b/Annex/Path.hs @@ -1,15 +1,23 @@ {- git-annex program path - - - Copyright 2013 Joey Hess + - Copyright 2013-2020 Joey Hess - - 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 diff --git a/CHANGELOG b/CHANGELOG index 6b6b49d362..d816e0f53c 100644 --- a/CHANGELOG +++ b/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 Fri, 14 Aug 2020 14:57:45 -0400 diff --git a/Command/Sync.hs b/Command/Sync.hs index 0bd13e4408..abe3f6be23 100644 --- a/Command/Sync.hs +++ b/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"] - (\cp -> cp { cwd = Just (fromRawFilePath wt) }) + ( gitAnnexChildProcess ["post-receive"] + (\cp -> cp { cwd = Just (fromRawFilePath wt) }) + (\_ _ _ pid -> waitForProcess pid >>= return . \case + ExitSuccess -> True + _ -> False + ) , return True ) where diff --git a/Upgrade.hs b/Upgrade.hs index 76aac93afe..d9708a0d17 100644 --- a/Upgrade.hs +++ b/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 diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs index ae6bcc6a5d..12d4c0a5c6 100644 --- a/Utility/LockFile/PidLock.hs +++ b/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" diff --git a/doc/bugs/get_is_stuck_unless_a_clone_was_previously_explicitly___34__annex_init__34__ed.mdwn b/doc/bugs/get_is_stuck_unless_a_clone_was_previously_explicitly___34__annex_init__34__ed.mdwn index 103a623f30..10934c5bea 100644 --- a/doc/bugs/get_is_stuck_unless_a_clone_was_previously_explicitly___34__annex_init__34__ed.mdwn +++ b/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]]