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,
|
||||
adjustGitRepo,
|
||||
addGitConfigOverride,
|
||||
getGitConfigOverrides,
|
||||
getRemoteGitConfig,
|
||||
withCurrentState,
|
||||
changeDirectory,
|
||||
|
@ -110,6 +111,7 @@ data AnnexState = AnnexState
|
|||
, repoadjustment :: (Git.Repo -> IO Git.Repo)
|
||||
, gitconfig :: GitConfig
|
||||
, gitconfigadjustment :: (GitConfig -> GitConfig)
|
||||
, gitconfigoverride :: [String]
|
||||
, gitremotes :: Maybe [Git.Repo]
|
||||
, backend :: Maybe (BackendA Annex)
|
||||
, remotes :: [Types.Remote.RemoteA Annex]
|
||||
|
@ -175,6 +177,7 @@ newState c r = do
|
|||
, repoadjustment = return
|
||||
, gitconfig = c
|
||||
, gitconfigadjustment = id
|
||||
, gitconfigoverride = []
|
||||
, gitremotes = Nothing
|
||||
, backend = Nothing
|
||||
, remotes = []
|
||||
|
@ -352,12 +355,14 @@ adjustGitRepo a = do
|
|||
changeGitRepo =<< gitRepo
|
||||
|
||||
{- 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. -}
|
||||
addGitConfigOverride :: String -> Annex ()
|
||||
addGitConfigOverride v = adjustGitRepo $ \r ->
|
||||
Git.Config.store (encodeBS' v) Git.Config.ConfigList $
|
||||
r { Git.gitGlobalOpts = go (Git.gitGlobalOpts r) }
|
||||
addGitConfigOverride v = do
|
||||
adjustGitRepo $ \r ->
|
||||
Git.Config.store (encodeBS' v) Git.Config.ConfigList $
|
||||
r { Git.gitGlobalOpts = go (Git.gitGlobalOpts r) }
|
||||
changeState $ \s -> s { gitconfigoverride = v : gitconfigoverride s }
|
||||
where
|
||||
-- Remove any prior occurrance of the setting to avoid
|
||||
-- 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 (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. -}
|
||||
changeGitRepo :: Git.Repo -> Annex ()
|
||||
changeGitRepo r = do
|
||||
|
|
|
@ -383,10 +383,8 @@ fixupUnusualReposAfterInit = do
|
|||
autoEnableSpecialRemotes :: Annex ()
|
||||
autoEnableSpecialRemotes = do
|
||||
rp <- fromRawFilePath <$> fromRepo Git.repoPath
|
||||
withNullHandle $ \nullh -> gitAnnexChildProcess
|
||||
[ "init"
|
||||
, "--autoenable"
|
||||
]
|
||||
withNullHandle $ \nullh -> gitAnnexChildProcess "init"
|
||||
[ "--autoenable" ]
|
||||
(\p -> p
|
||||
{ std_out = UseHandle nullh
|
||||
, std_err = UseHandle nullh
|
||||
|
|
|
@ -11,6 +11,7 @@ import Annex.Common
|
|||
import Config.Files
|
||||
import Utility.Env
|
||||
import Annex.PidLock
|
||||
import qualified Annex
|
||||
|
||||
import System.Environment (getExecutablePath)
|
||||
|
||||
|
@ -55,10 +56,14 @@ cannotFindProgram = do
|
|||
- to avoid it deadlocking.
|
||||
-}
|
||||
gitAnnexChildProcess
|
||||
:: [String]
|
||||
:: String
|
||||
-> [String]
|
||||
-> (CreateProcess -> CreateProcess)
|
||||
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
|
||||
-> Annex a
|
||||
gitAnnexChildProcess ps f a = do
|
||||
gitAnnexChildProcess subcmd ps f a = do
|
||||
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
|
||||
- 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
|
||||
#ifndef mingw32_HOST_OS
|
||||
|
|
|
@ -535,7 +535,7 @@ pushRemote o remote (Just branch, _) = do
|
|||
postpushupdate repo = case Git.repoWorkTree repo of
|
||||
Nothing -> return True
|
||||
Just wt -> ifM needemulation
|
||||
( gitAnnexChildProcess ["post-receive"]
|
||||
( gitAnnexChildProcess "post-receive" []
|
||||
(\cp -> cp { cwd = Just (fromRawFilePath wt) })
|
||||
(\_ _ _ pid -> waitForProcess pid >>= return . \case
|
||||
ExitSuccess -> True
|
||||
|
|
|
@ -103,9 +103,8 @@ upgrade automatic destversion = do
|
|||
-- upgrading a git repo other than the current repo.
|
||||
upgraderemote = do
|
||||
rp <- fromRawFilePath <$> fromRepo Git.repoPath
|
||||
gitAnnexChildProcess
|
||||
[ "upgrade"
|
||||
, "--quiet"
|
||||
gitAnnexChildProcess "upgrade"
|
||||
[ "--quiet"
|
||||
, "--autoonly"
|
||||
]
|
||||
(\p -> p { cwd = Just rp })
|
||||
|
|
Loading…
Reference in a new issue