pass along -c options to child git-annex processes
This commit is contained in:
parent
87de360e98
commit
00526a6739
6 changed files with 27 additions and 16 deletions
17
Annex.hs
17
Annex.hs
|
@ -32,6 +32,7 @@ module Annex (
|
||||||
changeGitRepo,
|
changeGitRepo,
|
||||||
adjustGitRepo,
|
adjustGitRepo,
|
||||||
addGitConfigOverride,
|
addGitConfigOverride,
|
||||||
|
getGitConfigOverrides,
|
||||||
getRemoteGitConfig,
|
getRemoteGitConfig,
|
||||||
withCurrentState,
|
withCurrentState,
|
||||||
changeDirectory,
|
changeDirectory,
|
||||||
|
@ -110,6 +111,7 @@ data AnnexState = AnnexState
|
||||||
, repoadjustment :: (Git.Repo -> IO Git.Repo)
|
, repoadjustment :: (Git.Repo -> IO Git.Repo)
|
||||||
, gitconfig :: GitConfig
|
, gitconfig :: GitConfig
|
||||||
, gitconfigadjustment :: (GitConfig -> GitConfig)
|
, gitconfigadjustment :: (GitConfig -> GitConfig)
|
||||||
|
, gitconfigoverride :: [String]
|
||||||
, gitremotes :: Maybe [Git.Repo]
|
, gitremotes :: Maybe [Git.Repo]
|
||||||
, backend :: Maybe (BackendA Annex)
|
, backend :: Maybe (BackendA Annex)
|
||||||
, remotes :: [Types.Remote.RemoteA Annex]
|
, remotes :: [Types.Remote.RemoteA Annex]
|
||||||
|
@ -175,6 +177,7 @@ newState c r = do
|
||||||
, repoadjustment = return
|
, repoadjustment = return
|
||||||
, gitconfig = c
|
, gitconfig = c
|
||||||
, gitconfigadjustment = id
|
, gitconfigadjustment = id
|
||||||
|
, gitconfigoverride = []
|
||||||
, gitremotes = Nothing
|
, gitremotes = Nothing
|
||||||
, backend = Nothing
|
, backend = Nothing
|
||||||
, remotes = []
|
, remotes = []
|
||||||
|
@ -352,12 +355,14 @@ adjustGitRepo a = do
|
||||||
changeGitRepo =<< gitRepo
|
changeGitRepo =<< gitRepo
|
||||||
|
|
||||||
{- Adds git config setting, like "foo=bar". It will be passed with -c
|
{- Adds git config setting, like "foo=bar". It will be passed with -c
|
||||||
- to git processes. The config setting is also recorded in the repo,
|
- to git processes. The config setting is also recorded in the Repo,
|
||||||
- and the GitConfig is updated. -}
|
- and the GitConfig is updated. -}
|
||||||
addGitConfigOverride :: String -> Annex ()
|
addGitConfigOverride :: String -> Annex ()
|
||||||
addGitConfigOverride v = adjustGitRepo $ \r ->
|
addGitConfigOverride v = do
|
||||||
Git.Config.store (encodeBS' v) Git.Config.ConfigList $
|
adjustGitRepo $ \r ->
|
||||||
r { Git.gitGlobalOpts = go (Git.gitGlobalOpts r) }
|
Git.Config.store (encodeBS' v) Git.Config.ConfigList $
|
||||||
|
r { Git.gitGlobalOpts = go (Git.gitGlobalOpts r) }
|
||||||
|
changeState $ \s -> s { gitconfigoverride = v : gitconfigoverride s }
|
||||||
where
|
where
|
||||||
-- Remove any prior occurrance of the setting to avoid
|
-- Remove any prior occurrance of the setting to avoid
|
||||||
-- building up many of them when the adjustment is run repeatedly,
|
-- building up many of them when the adjustment is run repeatedly,
|
||||||
|
@ -366,6 +371,10 @@ addGitConfigOverride v = adjustGitRepo $ \r ->
|
||||||
go (Param "-c": Param v':rest) | v' == v = go rest
|
go (Param "-c": Param v':rest) | v' == v = go rest
|
||||||
go (c:rest) = c : go rest
|
go (c:rest) = c : go rest
|
||||||
|
|
||||||
|
{- Values that were passed to addGitConfigOverride. -}
|
||||||
|
getGitConfigOverrides :: Annex [String]
|
||||||
|
getGitConfigOverrides = reverse <$> getState gitconfigoverride
|
||||||
|
|
||||||
{- Changing the git Repo data also involves re-extracting its GitConfig. -}
|
{- Changing the git Repo data also involves re-extracting its GitConfig. -}
|
||||||
changeGitRepo :: Git.Repo -> Annex ()
|
changeGitRepo :: Git.Repo -> Annex ()
|
||||||
changeGitRepo r = do
|
changeGitRepo r = do
|
||||||
|
|
|
@ -383,10 +383,8 @@ fixupUnusualReposAfterInit = do
|
||||||
autoEnableSpecialRemotes :: Annex ()
|
autoEnableSpecialRemotes :: Annex ()
|
||||||
autoEnableSpecialRemotes = do
|
autoEnableSpecialRemotes = do
|
||||||
rp <- fromRawFilePath <$> fromRepo Git.repoPath
|
rp <- fromRawFilePath <$> fromRepo Git.repoPath
|
||||||
withNullHandle $ \nullh -> gitAnnexChildProcess
|
withNullHandle $ \nullh -> gitAnnexChildProcess "init"
|
||||||
[ "init"
|
[ "--autoenable" ]
|
||||||
, "--autoenable"
|
|
||||||
]
|
|
||||||
(\p -> p
|
(\p -> p
|
||||||
{ std_out = UseHandle nullh
|
{ std_out = UseHandle nullh
|
||||||
, std_err = UseHandle nullh
|
, std_err = UseHandle nullh
|
||||||
|
|
|
@ -11,6 +11,7 @@ import Annex.Common
|
||||||
import Config.Files
|
import Config.Files
|
||||||
import Utility.Env
|
import Utility.Env
|
||||||
import Annex.PidLock
|
import Annex.PidLock
|
||||||
|
import qualified Annex
|
||||||
|
|
||||||
import System.Environment (getExecutablePath)
|
import System.Environment (getExecutablePath)
|
||||||
|
|
||||||
|
@ -55,10 +56,14 @@ cannotFindProgram = do
|
||||||
- to avoid it deadlocking.
|
- to avoid it deadlocking.
|
||||||
-}
|
-}
|
||||||
gitAnnexChildProcess
|
gitAnnexChildProcess
|
||||||
:: [String]
|
:: String
|
||||||
|
-> [String]
|
||||||
-> (CreateProcess -> CreateProcess)
|
-> (CreateProcess -> CreateProcess)
|
||||||
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
|
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
|
||||||
-> Annex a
|
-> Annex a
|
||||||
gitAnnexChildProcess ps f a = do
|
gitAnnexChildProcess subcmd ps f a = do
|
||||||
cmd <- liftIO programPath
|
cmd <- liftIO programPath
|
||||||
pidLockChildProcess cmd ps f a
|
-- Pass along git config values that were set on command line
|
||||||
|
-- to the child process.
|
||||||
|
cps <- concatMap (\c -> ["-c", c]) <$> Annex.getGitConfigOverrides
|
||||||
|
pidLockChildProcess cmd (subcmd:cps++ps) f a
|
||||||
|
|
|
@ -75,7 +75,7 @@ pidLockChildProcess cmd ps f a = do
|
||||||
-
|
-
|
||||||
- This is like pidLockChildProcess, but rather than running a process
|
- This is like pidLockChildProcess, but rather than running a process
|
||||||
- itself, it runs the action with a modified Annex state that passes the
|
- itself, it runs the action with a modified Annex state that passes the
|
||||||
- necessary env var.
|
- necessary env var when running git.
|
||||||
-}
|
-}
|
||||||
runsGitAnnexChildProcessViaGit :: Annex a -> Annex a
|
runsGitAnnexChildProcessViaGit :: Annex a -> Annex a
|
||||||
#ifndef mingw32_HOST_OS
|
#ifndef mingw32_HOST_OS
|
||||||
|
|
|
@ -535,7 +535,7 @@ pushRemote o remote (Just branch, _) = do
|
||||||
postpushupdate repo = case Git.repoWorkTree repo of
|
postpushupdate repo = case Git.repoWorkTree repo of
|
||||||
Nothing -> return True
|
Nothing -> return True
|
||||||
Just wt -> ifM needemulation
|
Just wt -> ifM needemulation
|
||||||
( gitAnnexChildProcess ["post-receive"]
|
( gitAnnexChildProcess "post-receive" []
|
||||||
(\cp -> cp { cwd = Just (fromRawFilePath wt) })
|
(\cp -> cp { cwd = Just (fromRawFilePath wt) })
|
||||||
(\_ _ _ pid -> waitForProcess pid >>= return . \case
|
(\_ _ _ pid -> waitForProcess pid >>= return . \case
|
||||||
ExitSuccess -> True
|
ExitSuccess -> True
|
||||||
|
|
|
@ -103,9 +103,8 @@ upgrade automatic destversion = do
|
||||||
-- upgrading a git repo other than the current repo.
|
-- upgrading a git repo other than the current repo.
|
||||||
upgraderemote = do
|
upgraderemote = do
|
||||||
rp <- fromRawFilePath <$> fromRepo Git.repoPath
|
rp <- fromRawFilePath <$> fromRepo Git.repoPath
|
||||||
gitAnnexChildProcess
|
gitAnnexChildProcess "upgrade"
|
||||||
[ "upgrade"
|
[ "--quiet"
|
||||||
, "--quiet"
|
|
||||||
, "--autoonly"
|
, "--autoonly"
|
||||||
]
|
]
|
||||||
(\p -> p { cwd = Just rp })
|
(\p -> p { cwd = Just rp })
|
||||||
|
|
Loading…
Reference in a new issue