commitForAdjustedBranch :: [CommandParam] -> Annex ()
commitForAdjustedBranch ps = do
cmode <- annexCommitMode <$> Annex.getGitConfig
- void $ inRepo $ Git.Branch.commitCommand cmode $
- [ Param "--quiet"
- , Param "--allow-empty"
+ let cquiet = Git.Branch.CommitQuiet True
+ void $ inRepo $ Git.Branch.commitCommand cmode cquiet $
+ [ Param "--allow-empty"
, Param "-m"
, Param "commit before entering adjusted branch"
] ++ ps
| otherwise = go fs
commitResolvedMerge :: Git.Branch.CommitMode -> Annex Bool
-commitResolvedMerge commitmode = inRepo $ Git.Branch.commitCommand commitmode
- [ Param "--no-verify"
- , Param "-m"
- , Param "git-annex automatic merge conflict fix"
- ]
+commitResolvedMerge commitmode = do
+ commitquiet <- Git.Branch.CommitQuiet <$> commandProgressDisabled
+ inRepo $ Git.Branch.commitCommand commitmode commitquiet
+ [ Param "--no-verify"
+ , Param "-m"
+ , Param "git-annex automatic merge conflict fix"
+ ]
type InodeMap = M.Map (Either FilePath InodeCacheKey) FilePath
unlessM (Git.Config.isBare <$> gitRepo) $ do
cmode <- annexCommitMode <$> Annex.getGitConfig
void $ inRepo $ Git.Branch.commitCommand cmode
- [ Param "--quiet"
- , Param "--allow-empty"
+ (Git.Branch.CommitQuiet True)
+ [ Param "--allow-empty"
, Param "-m"
, Param "created repository"
]
import qualified Git.Command
import qualified Remote
import qualified Types.Remote as Remote
+import qualified Annex
import qualified Annex.Branch
import Remote.List.Util
import Annex.UUID
pushToRemotes' :: UTCTime -> [Remote] -> Assistant [Remote]
pushToRemotes' now remotes = do
- (g, branch, u) <- liftAnnex $ do
+ (g, branch, u, ms) <- liftAnnex $ do
Annex.Branch.commit =<< Annex.Branch.commitMessage
- (,,)
+ (,,,)
<$> gitRepo
<*> getCurrentBranch
<*> getUUID
- ret <- go True branch g u remotes
+ <*> Annex.getState Annex.output
+ ret <- go ms True branch g u remotes
return ret
where
- go _ (Nothing, _) _ _ _ = return [] -- no branch, so nothing to do
- go _ _ _ _ [] = return [] -- no remotes, so nothing to do
- go shouldretry currbranch@(Just branch, _) g u rs = do
+ go _ _ (Nothing, _) _ _ _ = return [] -- no branch, so nothing to do
+ go _ _ _ _ _ [] = return [] -- no remotes, so nothing to do
+ go ms shouldretry currbranch@(Just branch, _) g u rs = do
debug ["pushing to", show rs]
- (succeeded, failed) <- parallelPush g rs (push branch)
+ (succeeded, failed) <- parallelPush g rs (push ms branch)
updatemap succeeded []
if null failed
then return []
else if shouldretry
- then retry currbranch g u failed
+ then retry ms currbranch g u failed
else fallback branch g u failed
updatemap succeeded failed = do
M.difference m (makemap succeeded)
makemap l = M.fromList $ zip l (repeat now)
- retry currbranch g u rs = do
+ retry ms currbranch g u rs = do
debug ["trying manual pull to resolve failed pushes"]
void $ manualPull currbranch rs
- go False currbranch g u rs
+ go ms False currbranch g u rs
fallback branch g u rs = do
debug ["fallback pushing to", show rs]
updatemap succeeded failed
return failed
- push branch remote = Command.Sync.pushBranch remote (Just branch)
+ push ms branch remote = Command.Sync.pushBranch remote (Just branch) ms
parallelPush :: Git.Repo -> [Remote] -> (Remote -> Git.Repo -> IO Bool)-> Assistant ([Remote], [Remote])
parallelPush g rs a = do
manualPull :: Command.Sync.CurrBranch -> [Remote] -> Assistant ([Remote], Bool)
manualPull currentbranch remotes = do
g <- liftAnnex gitRepo
+ mc <- liftAnnex Command.Sync.mergeConfig
failed <- forM remotes $ \r -> if wantpull $ Remote.gitconfig r
then do
g' <- liftAnnex $ do
<$> liftAnnex Annex.Branch.forceUpdate
forM_ remotes $ \r ->
liftAnnex $ Command.Sync.mergeRemote r
- currentbranch Command.Sync.mergeConfig def
+ currentbranch mc def
when haddiverged $
updateExportTreeFromLogAll
return (catMaybes failed, haddiverged)
]
void $ liftAnnex $ do
cmode <- annexCommitMode <$> Annex.getGitConfig
+ mc <- Command.Sync.mergeConfig
Command.Sync.merge
- currbranch Command.Sync.mergeConfig
+ currbranch
+ mc
def
cmode
changedbranch
started out as a bare repository, or had annex.crippledfilesystem
set, and was converted to a non-bare repository.
* Fix retrieval of content from borg repos accessed over ssh.
+ * sync: When --quiet is used, run git commit, push, and pull without
+ their ususual output.
+ * merge: When --quiet is used, run git merge without its usual output.
-- Joey Hess <id@joeyh.name> Wed, 14 Jul 2021 14:26:36 -0400
si = SeekInput []
mergeSyncedBranch :: CommandStart
-mergeSyncedBranch = mergeLocal mergeConfig def =<< getCurrentBranch
+mergeSyncedBranch = do
+ mc <- mergeConfig
+ mergeLocal mc def =<< getCurrentBranch
mergeBranch :: Git.Ref -> CommandStart
mergeBranch r = starting "merge" ai si $ do
currbranch <- getCurrentBranch
let o = def { notOnlyAnnexOption = True }
- next $ merge currbranch mergeConfig o Git.Branch.ManualCommit r
+ mc <- mergeConfig
+ next $ merge currbranch mc o Git.Branch.ManualCommit r
where
ai = ActionItemOther (Just (Git.fromRef r))
si = SeekInput []
updateInsteadEmulation = do
prepMerge
let o = def { notOnlyAnnexOption = True }
- mergeLocal mergeConfig o =<< getCurrentBranch
+ mc <- mergeConfig
+ mergeLocal mc o =<< getCurrentBranch
commandAction (withbranch cleanupLocal)
mapM_ (commandAction . withbranch . cleanupRemote) gitremotes
else do
+ mc <- mergeConfig
+
-- Syncing involves many actions, any of which
-- can independently fail, without preventing
-- the others from running.
-- These actions cannot be run concurrently.
mapM_ includeCommandAction $ concat
[ [ commit o ]
- , [ withbranch (mergeLocal mergeConfig o) ]
- , map (withbranch . pullRemote o mergeConfig) gitremotes
+ , [ withbranch (mergeLocal mc o) ]
+ , map (withbranch . pullRemote o mc) gitremotes
, [ mergeAnnex ]
]
content <- shouldSyncContent o
forM_ (filter isImport contentremotes) $
- withbranch . importRemote content o mergeConfig
+ withbranch . importRemote content o mc
forM_ (filter isThirdPartyPopulated contentremotes) $
pullThirdPartyPopulated o
-- avoid our push overwriting those changes.
when (syncedcontent || exportedcontent) $ do
mapM_ includeCommandAction $ concat
- [ map (withbranch . pullRemote o mergeConfig) gitremotes
+ [ map (withbranch . pullRemote o mc) gitremotes
, [ commitAnnex, mergeAnnex ]
]
prepMerge :: Annex ()
prepMerge = Annex.changeDirectory . fromRawFilePath =<< fromRepo Git.repoPath
-mergeConfig :: [Git.Merge.MergeConfig]
-mergeConfig =
- [ Git.Merge.MergeNonInteractive
- -- In several situations, unrelated histories should be merged
- -- together. This includes pairing in the assistant, merging
- -- from a remote into a newly created direct mode repo,
- -- and an initial merge from an import from a special remote.
- -- (Once direct mode is removed, this could be changed, so only
- -- the assistant and import from special remotes use it.)
- , Git.Merge.MergeUnrelatedHistories
- ]
+mergeConfig :: Annex [Git.Merge.MergeConfig]
+mergeConfig = do
+ quiet <- commandProgressDisabled
+ return $ catMaybes
+ [ Just Git.Merge.MergeNonInteractive
+ -- In several situations, unrelated histories should be
+ -- merged together. This includes pairing in the assistant,
+ -- merging from a remote into a newly created direct mode
+ -- repo, and an initial merge from an import from a special
+ -- remote. (Once direct mode is removed, this could be
+ -- changed, so only the assistant and import from special
+ -- remotes use it.)
+ , Just Git.Merge.MergeUnrelatedHistories
+ , if quiet then Just Git.Merge.MergeQuiet else Nothing
+ ]
merge :: CurrBranch -> [Git.Merge.MergeConfig] -> SyncOptions -> Git.Branch.CommitMode -> Git.Branch -> Annex Bool
merge currbranch mergeconfig o commitmode tomerge = do
Annex.Branch.commit =<< Annex.Branch.commitMessage
next $ do
showOutput
- void $ inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit
+ let cmode = Git.Branch.ManualCommit
+ cquiet <- Git.Branch.CommitQuiet <$> commandProgressDisabled
+ void $ inRepo $ Git.Branch.commitCommand cmode cquiet
[ Param "-a"
, Param "-m"
, Param commitmessage
where
fetch bs = do
repo <- Remote.getRepo remote
+ ms <- Annex.getState Annex.output
inRepoWithSshOptionsTo repo (Remote.gitconfig remote) $
- Git.Command.runBool $
- [Param "fetch", Param $ Remote.name remote]
- ++ map Param bs
+ Git.Command.runBool $ catMaybes
+ [ Just $ Param "fetch"
+ , if commandProgressDisabled' ms
+ then Just $ Param "--quiet"
+ else Nothing
+ , Just $ Param $ Remote.name remote
+ ] ++ map Param bs
wantpull = remoteAnnexPull (Remote.gitconfig remote)
ai = ActionItemOther (Just (Remote.name remote))
si = SeekInput []
starting "push" ai si $ next $ do
repo <- Remote.getRepo remote
showOutput
+ ms <- Annex.getState Annex.output
ok <- inRepoWithSshOptionsTo repo gc $
- pushBranch remote mainbranch
+ pushBranch remote mainbranch ms
if ok
then postpushupdate repo
else do
- The only difference caused by using a forced push in that case is that
- the last repository to push wins the race, rather than the first to push.
-}
-pushBranch :: Remote -> Maybe Git.Branch -> Git.Repo -> IO Bool
-pushBranch remote mbranch g = directpush `after` annexpush `after` syncpush
+pushBranch :: Remote -> Maybe Git.Branch -> MessageState -> Git.Repo -> IO Bool
+pushBranch remote mbranch ms g = directpush `after` annexpush `after` syncpush
where
syncpush = flip Git.Command.runBool g $ pushparams $ catMaybes
[ (refspec . fromAdjustedBranch) <$> mbranch
(transcript, ok) <- processTranscript' p Nothing
when (not ok && not ("denyCurrentBranch" `isInfixOf` transcript)) $
hPutStr stderr transcript
- pushparams branches =
- [ Param "push"
- , Param $ Remote.name remote
+ pushparams branches = catMaybes
+ [ Just $ Param "push"
+ , if commandProgressDisabled' ms
+ then Just $ Param "--quiet"
+ else Nothing
+ , Just $ Param $ Remote.name remote
] ++ map Param branches
refspec b = concat
[ Git.fromRef $ Git.Ref.base b
(False, True) -> findbest c rs -- worse
(False, False) -> findbest c rs -- same
+{- Should the commit avoid the usual summary output? -}
+newtype CommitQuiet = CommitQuiet Bool
+
+applyCommitQuiet :: CommitQuiet -> [CommandParam] -> [CommandParam]
+applyCommitQuiet (CommitQuiet True) ps = Param "--quiet" : ps
+applyCommitQuiet (CommitQuiet False) ps = ps
+
{- The user may have set commit.gpgsign, intending all their manual
- commits to be signed. But signing automatic/background commits could
- easily lead to unwanted gpg prompts or failures.
ps' = applyCommitMode commitmode ps
{- Commit via the usual git command. -}
-commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool
+commitCommand :: CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO Bool
commitCommand = commitCommand' runBool
-commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a
-commitCommand' runner commitmode ps = runner $
- Param "commit" : applyCommitMode commitmode ps
+commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO a
+commitCommand' runner commitmode commitquiet ps =
+ runner $ Param "commit" : ps'
+ where
+ ps' = applyCommitMode commitmode (applyCommitQuiet commitquiet ps)
{- Commits the index into the specified branch (or other ref),
- with the specified parent refs, and returns the committed sha.
- one parent, and it has the same tree that would be committed.
-
- Unlike git-commit, does not run any hooks, or examine the work tree
- - in any way.
+ - in any way, or output a summary.
-}
commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
commit commitmode allowempty message branch parentrefs repo = do
{- git merging
-
- - Copyright 2012-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
data MergeConfig
= MergeNonInteractive
- -- ^ avoids interactive merge
+ -- ^ avoids interactive merge with commit message edit
| MergeUnrelatedHistories
-- ^ avoids git's prevention of merging unrelated histories
+ | MergeQuiet
+ -- ^ avoids usual output when merging, but errors will still be
+ -- displayed
deriving (Eq)
merge :: Ref -> [MergeConfig] -> CommitMode -> Repo -> IO Bool
go [Param $ fromRef branch]
| otherwise = go [Param "--no-edit", Param $ fromRef branch]
where
- go ps = merge'' (sp ++ [Param "merge"] ++ ps ++ extraparams) mergeconfig r
+ go ps = merge'' (sp ++ [Param "merge"] ++ qp ++ ps ++ extraparams) mergeconfig r
sp
| commitmode == AutomaticCommit =
[Param "-c", Param "commit.gpgsign=false"]
| otherwise = []
+ qp
+ | MergeQuiet `notElem` mergeconfig = []
+ | otherwise = [Param "--quiet"]
merge'' :: [CommandParam] -> [MergeConfig] -> Repo -> IO Bool
merge'' ps mergeconfig r
setupConsole,
enableDebugOutput,
commandProgressDisabled,
+ commandProgressDisabled',
jsonOutputEnabled,
outputMessage,
withMessageState,
+ MessageState,
prompt,
mkPrompter,
) where
{- Should commands that normally output progress messages have that
- output disabled? -}
commandProgressDisabled :: Annex Bool
-commandProgressDisabled = withMessageState $ \s -> return $
- case outputType s of
- NormalOutput -> concurrentOutputEnabled s
- QuietOutput -> True
- JSONOutput _ -> True
- SerializedOutput _ _ -> True
+commandProgressDisabled = withMessageState $ return . commandProgressDisabled'
+
+commandProgressDisabled' :: MessageState -> Bool
+commandProgressDisabled' s = case outputType s of
+ NormalOutput -> concurrentOutputEnabled s
+ QuietOutput -> True
+ JSONOutput _ -> True
+ SerializedOutput _ _ -> True
jsonOutputEnabled :: Annex Bool
jsonOutputEnabled = withMessageState $ \s -> return $
--- /dev/null
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 1"""
+ date="2021-07-19T15:24:55Z"
+ content="""
+It's perfectly fine to file a bug report if you find something like this.
+
+Nobody seems to have wanted that before.. I've implemented it now.
+"""]]
projects / git-annex.git / commitdiff