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