improve propigation of commits from adjusted branches

Only reverse adjust the changes in the commit, which means that adjustments
do not need to be generally cleanly reversable.

For example, an adjustment can unlock all locked files, but does not need
to worry about files that were originally unlocked when reversing, because
it will only ever be run on files that have been changed. So, it's ok
if it locks all files when reversed, or even leaves all files as-is when
reversed.

Annex/AdjustedBranch.hs

@@ -1,4 +1,4 @@
-{- adjusted version of main branch
+{- adjusted branch
  -
  - Copyright 2016 Joey Hess <id@joeyh.name>
  -
@@ -25,7 +25,9 @@ import qualified Git.Branch
 import qualified Git.Ref
 import qualified Git.Command
 import qualified Git.Tree
+import qualified Git.DiffTree
 import Git.Tree (TreeItem(..))
+import Git.Sha
 import Git.Env
 import Git.Index
 import Git.FilePath
@@ -36,11 +38,14 @@ import Git.HashObject
 import Annex.AutoMerge
 import qualified Database.Keys
 
+import qualified Data.Map as M
+
 data Adjustment = UnlockAdjustment
 	deriving (Show)
 
 data Direction = Forward | Reverse
 
+{- How to perform various adjustments to a TreeItem. -}
 adjustTreeItem :: Adjustment -> Direction -> HashObjectHandle -> TreeItem -> Annex (Maybe TreeItem)
 adjustTreeItem UnlockAdjustment Forward h ti@(TreeItem f m s)
 	| toBlobType m == Just SymlinkBlob = do
@@ -53,8 +58,6 @@ adjustTreeItem UnlockAdjustment Forward h ti@(TreeItem f m s)
 			Nothing -> return (Just ti)
 	| otherwise = return (Just ti)
 adjustTreeItem UnlockAdjustment Reverse h ti@(TreeItem f m s)
-	-- XXX does not remember when files were originally unlocked; locks
-	-- everything
 	| toBlobType m /= Just SymlinkBlob = do
 		mk <- catKey s
 		case mk of
@@ -114,7 +117,8 @@ enterAdjustedBranch :: Adjustment -> Annex ()
 enterAdjustedBranch adj = go =<< originalBranch
   where
 	go (Just origbranch) = do
-		adjbranch <- preventCommits $ adjustBranch adj Forward origbranch
+		adjbranch <- preventCommits $ const $ 
+			adjustBranch adj Forward origbranch
 		inRepo $ Git.Command.run
 			[ Param "checkout"
 			, Param $ fromRef $ Git.Ref.base $ adjbranch
@@ -137,23 +141,25 @@ adjust adj direction orig = do
 adjustTree :: Adjustment -> Direction -> Ref -> Annex Sha
 adjustTree adj direction orig = do
 	h <- inRepo hashObjectStart
-	treesha <- Git.Tree.adjustTree (adjustTreeItem adj direction h) orig
+	let toadj = adjustTreeItem adj direction h
-		=<< Annex.gitRepo
+	treesha <- Git.Tree.adjustTree toadj [] orig =<< Annex.gitRepo
 	liftIO $ hashObjectStop h
 	return treesha
 
+type CommitsPrevented = Git.LockFile.LockHandle
+
 {- Locks git's index file, preventing git from making a commit, merge, 
  - or otherwise changing the HEAD ref while the action is run.
  -
  - Throws an IO exception if the index file is already locked.
  -}
-preventCommits :: Annex a -> Annex a
+preventCommits :: (CommitsPrevented -> Annex a) -> Annex a
-preventCommits = bracket setup cleanup . const
+preventCommits = bracket setup cleanup
   where
 	setup = do
 		lck <- fromRepo indexFileLock
 		liftIO $ Git.LockFile.openLock lck
-	cleanup lckhandle = liftIO $ Git.LockFile.closeLock lckhandle
+	cleanup = liftIO . Git.LockFile.closeLock
 
 {- Commits a given adjusted tree, with the provided parent ref.
  -
@@ -178,25 +184,29 @@ adjustedBranchCommitMessage = "git-annex adjusted branch"
 {- Update the currently checked out adjusted branch, merging the provided
  - branch into it. -}
 updateAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> Git.Branch.CommitMode -> Annex Bool
-updateAdjustedBranch tomerge (origbranch, adj) commitmode = 
+updateAdjustedBranch tomerge (origbranch, adj) commitmode = catchBoolIO $ do
-	catchBoolIO $ preventCommits $ go =<< (,)
+	preventCommits $ \commitsprevented -> go commitsprevented =<< (,)
 		<$> inRepo (Git.Ref.sha tomerge)
 		<*> inRepo Git.Branch.current
   where
-	go (Just mergesha, Just currbranch) = ifM (inRepo $ Git.Branch.changed currbranch mergesha)
+	go commitsprevented (Just mergesha, Just currbranch) =
+		ifM (inRepo $ Git.Branch.changed currbranch mergesha)
 			( do
-			propigateAdjustedCommits origbranch (adj, currbranch)
+				propigateAdjustedCommits' origbranch (adj, currbranch) commitsprevented
 				adjustedtomerge <- adjust adj Forward mergesha
 				ifM (inRepo $ Git.Branch.changed currbranch adjustedtomerge)
-				( ifM (autoMergeFrom adjustedtomerge (Just currbranch) commitmode)
+					( do
-					( recommit currbranch mergesha =<< catCommit currbranch
+						liftIO $ Git.LockFile.closeLock commitsprevented
+						ifM (autoMergeFrom adjustedtomerge (Just currbranch) commitmode)
+							( preventCommits $ \commitsprevented' ->
+								recommit commitsprevented' currbranch mergesha =<< catCommit currbranch
 							, return False
 							)
 					, return True -- no changes to merge
 					)
 			, return True -- no changes to merge
 			)
-	go _ = return False
+	go _ _ = return False
 	{- Once a merge commit has been made, re-do it, removing
 	 - the old version of the adjusted branch as a parent, and
 	 - making the only parent be the branch that was merged in.
@@ -204,12 +214,12 @@ updateAdjustedBranch tomerge (origbranch, adj) commitmode =
 	 - Doing this ensures that the same commit Sha is
 	 - always arrived at for a given commit from the merged in branch.
 	 -}
-	recommit currbranch parent (Just commit) = do
+	recommit commitsprevented currbranch parent (Just commit) = do
 		commitsha <- commitAdjustedTree (commitTree commit) parent
 		inRepo $ Git.Branch.update currbranch commitsha
-		propigateAdjustedCommits origbranch (adj, currbranch)
+		propigateAdjustedCommits' origbranch (adj, currbranch) commitsprevented
 		return True
-	recommit _ _ Nothing = return False
+	recommit _ _ _ Nothing = return False
 
 {- Check for any commits present on the adjusted branch that have not yet
  - been propigated to the orig branch, and propigate them.
@@ -218,16 +228,26 @@ updateAdjustedBranch tomerge (origbranch, adj) commitmode =
  - rebase the adjusted branch on top of the updated orig branch.
  -}
 propigateAdjustedCommits :: OrigBranch -> (Adjustment, AdjBranch) -> Annex ()
-propigateAdjustedCommits origbranch (adj, currbranch) = do
+propigateAdjustedCommits origbranch (adj, currbranch) = 
+	preventCommits $ propigateAdjustedCommits' origbranch (adj, currbranch)
+
+propigateAdjustedCommits' :: OrigBranch -> (Adjustment, AdjBranch) -> CommitsPrevented -> Annex ()
+propigateAdjustedCommits' origbranch (adj, currbranch) _commitsprevented = do
 	ov <- inRepo $ Git.Ref.sha (Git.Ref.under "refs/heads" origbranch)
 	case ov of
-		Just origsha -> preventCommits $ do
+		Just origsha -> do
 			cv <- catCommit currbranch
 			case cv of
-				Just currcommit -> 
+				Just currcommit -> do
-					newcommits 
+					h <- inRepo hashObjectStart
-						>>= go origsha False
+					v <- newcommits >>= go h origsha False
-						>>= rebase currcommit
+					liftIO $ hashObjectStop h
+					case v of
+						Left e -> do
+							warning e
+							return ()
+						Right newparent ->
+							rebase currcommit newparent
 				Nothing -> return ()
 		Nothing -> return ()
   where
@@ -235,19 +255,21 @@ propigateAdjustedCommits origbranch (adj, currbranch) = do
 		-- Get commits oldest first, so they can be processed
 		-- in order made.
 		[Param "--reverse"]
-	go parent _ [] = do
+	go _ parent _ [] = do
 		inRepo $ Git.Branch.update origbranch parent
-		return parent
+		return (Right parent)
-	go parent pastadjcommit (sha:l) = do
+	go h parent pastadjcommit (sha:l) = do
 		mc <- catCommit sha
 		case mc of
 			Just c
 				| commitMessage c == adjustedBranchCommitMessage ->
-					go parent True l
+					go h parent True l
 				| pastadjcommit -> do
-					commit <- reverseAdjustedCommit parent adj c
+					v <- reverseAdjustedCommit h parent adj (sha, c) origbranch
-					go commit pastadjcommit l
+					case v of
-			_ -> go parent pastadjcommit l
+						Left e -> return (Left e)
+						Right commit -> go h commit pastadjcommit l
+			_ -> go h parent pastadjcommit l
 	rebase currcommit newparent = do
 		-- Reuse the current adjusted tree,
 		-- and reparent it on top of the new
@@ -255,16 +277,46 @@ propigateAdjustedCommits origbranch (adj, currbranch) = do
 		commitAdjustedTree (commitTree currcommit) newparent
 			>>= inRepo . Git.Branch.update currbranch
 
-{- Reverses an adjusted commit, yielding a commit sha.
+{- Reverses an adjusted commit, and commit on top of the provided newparent,
+ - yielding a commit sha.
+ -
+ - Adjust the tree of the newparent, changing only the files that the
+ - commit changed, and reverse adjusting those changes.
  -
  - Note that the commit message, and the author and committer metadata are
  - copied over. However, any gpg signature will be lost, and any other
  - headers are not copied either. -}
-reverseAdjustedCommit :: Sha -> Adjustment -> Commit -> Annex Sha
+reverseAdjustedCommit :: HashObjectHandle -> Sha -> Adjustment -> (Sha, Commit) -> OrigBranch -> Annex (Either String Sha)
-reverseAdjustedCommit parent adj c = do
+reverseAdjustedCommit h newparent adj (csha, c) origbranch
-	treesha <- adjustTree adj Reverse (commitTree c)
+	-- commitDiff does not support merge commits
-	inRepo $ commitWithMetaData
+	| length (commitParent c) > 1 = return $
+		Left $ "unable to propigate merge commit " ++ show csha ++ " back to " ++ show origbranch
+	| otherwise = do
+		(diff, cleanup) <- inRepo (Git.DiffTree.commitDiff csha)
+		let (adds, changes) = partition (\dti -> Git.DiffTree.srcsha dti == nullSha) diff
+		adds' <- catMaybes <$>
+			mapM (adjustTreeItem adj Reverse h) (map diffTreeToTreeItem adds)
+		treesha <- Git.Tree.adjustTree (propchanges changes)
+			adds' newparent
+			=<< Annex.gitRepo
+		void $ liftIO cleanup
+		revadjcommit <- inRepo $ commitWithMetaData
 			(commitAuthorMetaData c)
 			(commitCommitterMetaData c) $
 				Git.Branch.commitTree Git.Branch.AutomaticCommit
-			(commitMessage c) [parent] treesha
+					(commitMessage c) [newparent] treesha
+		return (Right revadjcommit)
+  where
+	propchanges changes ti@(TreeItem f _ _) =
+		case M.lookup f m of
+			Nothing -> return (Just ti) -- not changed
+			Just change -> adjustTreeItem adj Reverse h change
+	  where
+		m = M.fromList $ map (\i@(TreeItem f' _ _) -> (f', i)) $
+			map diffTreeToTreeItem changes
+
+diffTreeToTreeItem :: Git.DiffTree.DiffTreeItem -> TreeItem
+diffTreeToTreeItem dti = TreeItem
+	(Git.DiffTree.file dti)
+	(Git.DiffTree.dstmode dti)
+	(Git.DiffTree.dstsha dti)

Git/FilePath.hs

@@ -31,7 +31,7 @@ import qualified System.FilePath.Posix
 
 {- A FilePath, relative to the top of the git repository. -}
 newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }
-	deriving (Show, Eq)
+	deriving (Show, Eq, Ord)
 
 {- Path to a TopFilePath, within the provided git repo. -}
 fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath

Git/Tree.hs

@@ -107,7 +107,7 @@ mkTreeOutput fm ot s f = concat
 	]
 
 data TreeItem = TreeItem TopFilePath FileMode Sha
-	deriving (Eq)
+	deriving (Show, Eq)
 
 treeItemToTreeContent :: TreeItem -> TreeContent
 treeItemToTreeContent (TreeItem f m s) = TreeBlob f m s
@@ -122,7 +122,7 @@ adjustTree :: (MonadIO m, MonadMask m) => (TreeItem -> m (Maybe TreeItem)) -> [T
 adjustTree adjusttreeitem addtreeitems r repo = withMkTreeHandle repo $ \h -> do
 	(l, cleanup) <- liftIO $ lsTreeWithObjects r repo
 	(l', _, _) <- go h False [] inTopTree l
-	sha <- liftIO $ mkTree h l'
+	sha <- liftIO $ mkTree h (map treeItemToTreeContent addedtotop ++ l')
 	void $ liftIO cleanup
 	return sha
   where
@@ -149,6 +149,7 @@ adjustTree adjusttreeitem addtreeitems r repo = withMkTreeHandle repo $ \h -> do
 				go h modified' (subtree : c) intree is'
 			_ -> error ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"")
 		| otherwise = return (c, wasmodified, i:is)
+	addedtotop = filter (\(TreeItem f _ _) -> inTopTree' f) addtreeitems
 
 {- Assumes the list is ordered, with tree objects coming right before their
  - contents. -}
@@ -176,7 +177,10 @@ extractTree l = case go [] inTopTree l of
 type InTree = LsTree.TreeItem -> Bool
 
 inTopTree :: InTree
-inTopTree = notElem '/' . getTopFilePath . LsTree.file
+inTopTree = inTopTree' . LsTree.file
+
+inTopTree' :: TopFilePath -> Bool
+inTopTree' f = takeDirectory (getTopFilePath f) == "."
 
 beneathSubTree :: LsTree.TreeItem -> InTree
 beneathSubTree t =

doc/design/adjusted_branches.mdwn

@@ -67,7 +67,7 @@ and updates the branches. And/or `git-annex sync` could do it.
 
 There may be multiple commits made to the adjusted branch before any get
 applied back to the original branch. This is handled by reverse filtering
-one at a time and rebasing the others on top.
+commits one at a time and rebasing the others on top.
 
 	master           adjusted/master
 	A