support commit.gpgsign

Support users who have set commit.gpgsign, by disabling gpg signatures for
git-annex branch commits and commits made by the assistant.

The thinking here is that a user sets commit.gpgsign intending the commits
that they manually initiate to be gpg signed. But not commits made in the
background, whether by a deamon or implicitly to the git-annex branch.
gpg signing those would be at best a waste of CPU and at worst would fail,
or flood the user with gpg passphrase prompts, or put their signature on
changes they did not directly do.

See Debian bug #753720.

Also makes all commits done by git-annex go through a few central control
points, to make such changes easier in future.

Also disables commit.gpgsign in the test suite.

This commit was sponsored by Antoine Boegli.

Annex/AutoMerge.hs

@@ -12,12 +12,12 @@ import qualified Annex.Queue
 import Annex.Direct
 import Annex.CatFile
 import Annex.Link
-import qualified Git.Command
 import qualified Git.LsFiles as LsFiles
 import qualified Git.UpdateIndex as UpdateIndex
 import qualified Git.Merge
 import qualified Git.Ref
 import qualified Git
+import qualified Git.Branch
 import Git.Types (BlobType(..))
 import Config
 import Annex.ReplaceFile
@@ -29,17 +29,17 @@ import qualified Data.Set as S
 {- Merges from a branch into the current branch
  - (which may not exist yet),
  - with automatic merge conflict resolution. -}
-autoMergeFrom :: Git.Ref -> (Maybe Git.Ref) -> Annex Bool
-autoMergeFrom branch currbranch = do
+autoMergeFrom :: Git.Ref -> (Maybe Git.Ref) -> Git.Branch.CommitMode -> Annex Bool
+autoMergeFrom branch currbranch commitmode = do
 	showOutput
 	case currbranch of
 		Nothing -> go Nothing
 		Just b -> go =<< inRepo (Git.Ref.sha b)
   where
 	go old = ifM isDirect
-		( mergeDirect currbranch old branch (resolveMerge old branch)
-		, inRepo (Git.Merge.mergeNonInteractive branch)
-			<||> (resolveMerge old branch <&&> commitResolvedMerge)
+		( mergeDirect currbranch old branch (resolveMerge old branch) commitmode
+		, inRepo (Git.Merge.mergeNonInteractive branch commitmode)
+			<||> (resolveMerge old branch <&&> commitResolvedMerge commitmode)
 		)
 
 {- Resolves a conflicted merge. It's important that any conflicts be
@@ -166,10 +166,9 @@ cleanConflictCruft resolvedfs top = do
 	matchesresolved f = S.member (base f) s
 	base f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f
 	
-commitResolvedMerge :: Annex Bool
-commitResolvedMerge = inRepo $ Git.Command.runBool
-	[ Param "commit"
-	, Param "--no-verify"
+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"
 	]

Annex/Branch.hs

@@ -92,7 +92,7 @@ getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha
 		fromMaybe (error $ "failed to create " ++ fromRef name)
 			<$> branchsha
 	go False = withIndex' True $
-		inRepo $ Git.Branch.commitAlways "branch created" fullname []
+		inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit "branch created" fullname []
 	use sha = do
 		setIndexSha sha
 		return sha
@@ -252,7 +252,7 @@ commitIndex jl branchref message parents = do
 commitIndex' :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex ()
 commitIndex' jl branchref message parents = do
 	updateIndex jl branchref
-	committedref <- inRepo $ Git.Branch.commitAlways message fullname parents
+	committedref <- inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit message fullname parents
 	setIndexSha committedref
 	parentrefs <- commitparents <$> catObject committedref
 	when (racedetected branchref parentrefs) $
@@ -471,7 +471,7 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
 		Annex.Queue.flush
 		if neednewlocalbranch
 			then do
-				committedref <- inRepo $ Git.Branch.commitAlways message fullname transitionedrefs
+				committedref <- inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit message fullname transitionedrefs
 				setIndexSha committedref
 			else do
 				ref <- getBranch

Annex/Direct.hs

@@ -151,8 +151,8 @@ addDirect file cache = do
  - Then the work tree is updated to reflect the merge, and
  - finally, the merge is committed and the real index updated.
  -}
-mergeDirect :: Maybe Git.Ref -> Maybe Git.Ref -> Git.Branch -> Annex Bool -> Annex Bool
-mergeDirect startbranch oldref branch resolvemerge = do
+mergeDirect :: Maybe Git.Ref -> Maybe Git.Ref -> Git.Branch -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool
+mergeDirect startbranch oldref branch resolvemerge commitmode = do
 	-- Use the index lock file as the temp index file.
 	-- This is actually what git does when updating the index,
 	-- and so it will prevent other git processes from making
@@ -168,19 +168,19 @@ mergeDirect startbranch oldref branch resolvemerge = do
 		createDirectoryIfMissing True d
 
 	withIndexFile tmpi $ do
-		merged <- stageMerge d branch
+		merged <- stageMerge d branch commitmode
 		r <- if merged
 			then return True
 			else resolvemerge
 		mergeDirectCleanup d (fromMaybe Git.Sha.emptyTree oldref)
-		mergeDirectCommit merged startbranch branch
+		mergeDirectCommit merged startbranch branch commitmode
 		liftIO $ rename tmpi reali
 		return r
 
 {- Stage a merge into the index, avoiding changing HEAD or the current
  - branch. -}
-stageMerge :: FilePath -> Git.Branch -> Annex Bool
-stageMerge d branch = do
+stageMerge :: FilePath -> Git.Branch -> Git.Branch.CommitMode -> Annex Bool
+stageMerge d branch commitmode = do
 	-- XXX A bug in git makes stageMerge unsafe to use if the git repo
 	-- is configured with core.symlinks=false
 	-- Using mergeNonInteractive is not ideal though, since it will
@@ -190,7 +190,7 @@ stageMerge d branch = do
 	-- <http://marc.info/?l=git&m=140262402204212&w=2>
 	merger <- ifM (coreSymlinks <$> Annex.getGitConfig)
 		( return Git.Merge.stageMerge
-		, return Git.Merge.mergeNonInteractive
+		, return $ \ref -> Git.Merge.mergeNonInteractive ref commitmode
 		) 
 	inRepo $ \g -> merger branch $ 
 		g { location = Local { gitdir = Git.localGitDir g, worktree = Just d } }
@@ -198,8 +198,8 @@ stageMerge d branch = do
 {- Commits after a direct mode merge is complete, and after the work
  - tree has been updated by mergeDirectCleanup.
  -}
-mergeDirectCommit :: Bool -> Maybe Git.Ref -> Git.Branch -> Annex ()
-mergeDirectCommit allowff old branch = do
+mergeDirectCommit :: Bool -> Maybe Git.Ref -> Git.Branch -> Git.Branch.CommitMode -> Annex ()
+mergeDirectCommit allowff old branch commitmode = do
 	void preCommitDirect
 	d <- fromRepo Git.localGitDir
 	let merge_head = d </> "MERGE_HEAD"
@@ -211,7 +211,7 @@ mergeDirectCommit allowff old branch = do
 			msg <- liftIO $
 				catchDefaultIO ("merge " ++ fromRef branch) $
 					readFile merge_msg
-			void $ inRepo $ Git.Branch.commit False msg
+			void $ inRepo $ Git.Branch.commit commitmode False msg
 				Git.Ref.headRef [Git.Ref.headRef, branch]
 		)
 	liftIO $ mapM_ nukeFile [merge_head, merge_msg, merge_mode]

Annex/MakeRepo.hs

@@ -12,6 +12,7 @@ import Annex.Init
 import qualified Git.Construct
 import qualified Git.Config
 import qualified Git.Command
+import qualified Git.Branch
 import qualified Annex
 import Annex.UUID
 import Annex.Direct
@@ -50,9 +51,8 @@ initRepo True primary_assistant_repo dir desc mgroup = inDir dir $ do
 	{- Initialize the master branch, so things that expect
 	 - to have it will work, before any files are added. -}
 	unlessM (Git.Config.isBare <$> gitRepo) $
-		void $ inRepo $ Git.Command.runBool
-			[ Param "commit"
-			, Param "--quiet"
+		void $ inRepo $ Git.Branch.commitCommand Git.Branch.AutomaticCommit
+			[ Param "--quiet"
 			, Param "--allow-empty"
 			, Param "-m"
 			, Param "created repository"

Annex/View.hs

@@ -433,7 +433,7 @@ genViewBranch :: View -> Annex () -> Annex Git.Branch
 genViewBranch view a = withIndex $ do
 	a
 	let branch = branchView view
-	void $ inRepo $ Git.Branch.commit True (fromRef branch) branch []
+	void $ inRepo $ Git.Branch.commit Git.Branch.AutomaticCommit True (fromRef branch) branch []
 	return branch
 
 {- Runs an action using the view index file.

Assistant/Threads/Committer.hs

@@ -221,7 +221,7 @@ commitStaged = do
 	case v of
 		Left _ -> return False
 		Right _ -> do
-			ok <- Command.Sync.commitStaged ""
+			ok <- Command.Sync.commitStaged Git.Branch.AutomaticCommit ""
 			when ok $
 				Command.Sync.updateSyncBranch =<< inRepo Git.Branch.current
 			return ok

Assistant/Threads/Merger.hs

@@ -83,7 +83,7 @@ onChange file
 				[ "merging", Git.fromRef changedbranch
 				, "into", Git.fromRef current
 				]
-			void $ liftAnnex  $ autoMergeFrom changedbranch (Just current)
+			void $ liftAnnex  $ autoMergeFrom changedbranch (Just current) Git.Branch.AutomaticCommit
 	mergecurrent _ = noop
 
 	handleDesynced = case fromTaggedBranch changedbranch of

Command/Direct.hs

@@ -12,8 +12,8 @@ import Control.Exception.Extensible
 import Common.Annex
 import Command
 import qualified Git
-import qualified Git.Command
 import qualified Git.LsFiles
+import qualified Git.Branch
 import Config
 import Annex.Direct
 import Annex.Exception
@@ -33,9 +33,8 @@ perform :: CommandPerform
 perform = do
 	showStart "commit" ""
 	showOutput
-	_ <- inRepo $ Git.Command.runBool
-		[ Param "commit"
-		, Param "-a"
+	_ <- inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit
+		[ Param "-a"
 		, Param "-m"
 		, Param "commit before switching to direct mode"
 		]

Command/Indirect.hs

@@ -12,7 +12,7 @@ import Control.Exception.Extensible
 import Common.Annex
 import Command
 import qualified Git
-import qualified Git.Command
+import qualified Git.Branch
 import qualified Git.LsFiles
 import Git.FileMode
 import Config
@@ -49,9 +49,8 @@ perform = do
 	showStart "commit" ""
 	whenM stageDirect $ do
 		showOutput
-		void $ inRepo $ Git.Command.runBool
-			[ Param "commit"
-			, Param "-m"
+		void $ inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit
+			[ Param "-m"
 			, Param "commit before switching to indirect mode"
 			]
 	showEndOk

Command/Sync.hs

@@ -127,14 +127,12 @@ commit = next $ next $ ifM isDirect
 		showStart "commit" ""
 		void stageDirect
 		void preCommitDirect
-		commitStaged commitmessage
+		commitStaged Git.Branch.ManualCommit commitmessage
 	, do
 		showStart "commit" ""
 		Annex.Branch.commit "update"
-		-- Commit will fail when the tree is clean, so ignore failure.
-		_ <- inRepo $ tryIO . Git.Command.runQuiet
-			[ Param "commit"
-			, Param "-a"
+		inRepo $ Git.Branch.commitQuiet Git.Branch.ManualCommit
+			[ Param "-a"
 			, Param "-m"
 			, Param commitmessage
 			]
@@ -143,14 +141,14 @@ commit = next $ next $ ifM isDirect
   where
 	commitmessage = "git-annex automatic sync"
 
-commitStaged :: String -> Annex Bool
-commitStaged commitmessage = go =<< inRepo Git.Branch.currentUnsafe
+commitStaged :: Git.Branch.CommitMode -> String -> Annex Bool
+commitStaged commitmode commitmessage = go =<< inRepo Git.Branch.currentUnsafe
   where
 	go Nothing = return False
 	go (Just branch) = do
 		runAnnexHook preCommitAnnexHook
 		parent <- inRepo $ Git.Ref.sha branch
-		void $ inRepo $ Git.Branch.commit False commitmessage branch
+		void $ inRepo $ Git.Branch.commit commitmode False commitmessage branch
 			(maybeToList parent)
 		return True
 
@@ -169,7 +167,7 @@ mergeLocal (Just branch) = go =<< needmerge
 	go False = stop
 	go True = do
 		showStart "merge" $ Git.Ref.describe syncbranch
-		next $ next $ autoMergeFrom syncbranch (Just branch)
+		next $ next $ autoMergeFrom syncbranch (Just branch) Git.Branch.ManualCommit
 
 pushLocal :: Maybe Git.Ref -> CommandStart
 pushLocal b = do
@@ -221,7 +219,7 @@ mergeRemote remote b = case b of
 	Just thisbranch ->
 		and <$> (mapM (merge (Just thisbranch)) =<< tomerge (branchlist b))
   where
-	merge thisbranch = flip autoMergeFrom thisbranch . remoteBranch remote
+	merge thisbranch br = autoMergeFrom (remoteBranch remote br) thisbranch Git.Branch.ManualCommit
 	tomerge = filterM (changed remote)
 	branchlist Nothing = []
 	branchlist (Just branch) = [branch, syncBranch branch]

Command/Unannex.hs

@@ -16,6 +16,7 @@ import qualified Annex
 import Annex.Content
 import Annex.Content.Direct
 import qualified Git.Command
+import qualified Git.Branch
 import qualified Git.Ref
 import qualified Git.DiffTree as DiffTree
 import Utility.CopyFile
@@ -45,9 +46,8 @@ wrapUnannex a = ifM isDirect
 		)
 	)
   where
-	commit = inRepo $ Git.Command.run
-		[ Param "commit"
-		, Param "-q"
+	commit = inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit
+		[ Param "-q"
 		, Param "--allow-empty"
 		, Param "--no-verify"
 		, Param "-m", Param "content removed from git annex"

Git/Branch.hs

@@ -103,6 +103,28 @@ fastForward branch (first:rest) repo =
 			(False, True) -> findbest c rs -- worse
 			(False, False) -> findbest c rs -- same
 
+{- The user may have set commit.gpgsign, indending all their manual
+ - commits to be signed. But signing automatic/background commits could
+ - easily lead to unwanted gpg prompts or failures.
+ -}
+data CommitMode = ManualCommit | AutomaticCommit
+	deriving (Eq)
+
+{- Commit via the usual git command. -}
+commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool
+commitCommand = commitCommand' runBool
+
+{- Commit will fail when the tree is clean. This suppresses that error. -}
+commitQuiet :: CommitMode -> [CommandParam] -> Repo -> IO ()
+commitQuiet commitmode ps = void . tryIO . commitCommand' runQuiet commitmode ps
+
+commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a
+commitCommand' runner commitmode ps = runner (Param "commit" : ps')
+  where
+	ps'
+		| commitmode == AutomaticCommit = Param "--no-gpg-sign" : ps
+		| otherwise = ps
+
 {- Commits the index into the specified branch (or other ref), 
  - with the specified parent refs, and returns the committed sha.
  -
@@ -112,8 +134,8 @@ fastForward branch (first:rest) repo =
  - Unlike git-commit, does not run any hooks, or examine the work tree
  - in any way.
  -}
-commit :: Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
-commit allowempty message branch parentrefs repo = do
+commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
+commit commitmode allowempty message branch parentrefs repo = do
 	tree <- getSha "write-tree" $
 		pipeReadStrict [Param "write-tree"] repo
 	ifM (cancommit tree)
@@ -126,16 +148,18 @@ commit allowempty message branch parentrefs repo = do
 		, return Nothing
 		)
   where
-	ps = concatMap (\r -> ["-p", fromRef r]) parentrefs
+	ps = 
+		(if commitmode == AutomaticCommit then ["--no-gpg-sign"] else [])
+		++ concatMap (\r -> ["-p", fromRef r]) parentrefs
 	cancommit tree
 		| allowempty = return True
 		| otherwise = case parentrefs of
 			[p] -> maybe False (tree /=) <$> Git.Ref.tree p repo
 			_ -> return True
 
-commitAlways :: String -> Branch -> [Ref] -> Repo -> IO Sha
-commitAlways message branch parentrefs repo = fromJust
-	<$> commit True message branch parentrefs repo
+commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha
+commitAlways commitmode message branch parentrefs repo = fromJust
+	<$> commit commitmode True message branch parentrefs repo
 
 {- A leading + makes git-push force pushing a branch. -}
 forcePush :: String -> String

Git/Merge.hs

@@ -11,14 +11,19 @@ import Common
 import Git
 import Git.Command
 import Git.BuildVersion
+import Git.Branch (CommitMode(..))
 
 {- Avoids recent git's interactive merge. -}
-mergeNonInteractive :: Ref -> Repo -> IO Bool
-mergeNonInteractive branch
+mergeNonInteractive :: Ref -> CommitMode -> Repo -> IO Bool
+mergeNonInteractive branch commitmode
 	| older "1.7.7.6" = merge [Param $ fromRef branch]
-	| otherwise = merge [Param "--no-edit", Param $ fromRef branch]
+	| otherwise = merge $ [Param "--no-edit", Param $ fromRef branch]
   where
-	merge ps = runBool $ Param "merge" : ps
+	merge ps = runBool $ cp ++ [Param "merge"] ++ ps
+	cp
+		| commitmode == AutomaticCommit =
+			[Param "-c", Param "commit.gpgsign=false"]
+		| otherwise = []
 
 {- Stage the merge into the index, but do not commit it.-}
 stageMerge :: Ref -> Repo -> IO Bool

Test.hs

@@ -1406,9 +1406,9 @@ clonerepo testenv old new bare = do
 	ensuretmpdir
 	let b = if bare then " --bare" else ""
 	boolSystem "git" [Params ("clone -q" ++ b), File old, File new] @? "git clone failed"
+	configrepo testenv new
 	indir testenv new $
 		git_annex testenv "init" ["-q", new] @? "git annex init failed"
-	configrepo testenv new
 	unless bare $
 		indir testenv new $
 			handleforcedirect testenv
@@ -1416,8 +1416,11 @@ clonerepo testenv old new bare = do
 
 configrepo :: TestEnv -> FilePath -> IO ()
 configrepo testenv dir = indir testenv dir $ do
+	-- ensure git is set up to let commits happen
 	boolSystem "git" [Params "config user.name", Param "Test User"] @? "git config failed"
 	boolSystem "git" [Params "config user.email test@example.com"] @? "git config failed"
+	-- avoid signed commits by test suite
+	boolSystem "git" [Params "config commit.gpgsign false"] @? "git config failed"
 
 handleforcedirect :: TestEnv -> IO ()
 handleforcedirect testenv = when (M.lookup "FORCEDIRECT" testenv == Just "1") $

debian/changelog

@@ -14,6 +14,8 @@ git-annex (5.20140614) UNRELEASED; urgency=medium
   * importfeed: When annex.genmetadata is set, metadata from the feed
     is added to files that are imported from it.
   * Android: patch git to avoid fchmod, which fails on /sdcard.
+  * Support users who have set commit.gpgsign, by disabling gpg signatures
+    for git-annex branch commits and commits made by the assistant.
 
  -- Joey Hess <joeyh@debian.org>  Mon, 16 Jun 2014 11:28:42 -0400