working toward adjusted commit propigation

Annex/AdjustedBranch.hs

@@ -9,6 +9,7 @@ module Annex.AdjustedBranch (
 	Adjustment(..),
 	OrigBranch,
 	AdjBranch,
+	originalToAdjusted,
 	adjustedToOriginal,
 	fromAdjustedBranch,
 	enterAdjustedBranch,
@@ -18,13 +19,16 @@ module Annex.AdjustedBranch (
 
 import Annex.Common
 import qualified Annex
+import Git
 import Git.Types
 import qualified Git.Branch
 import qualified Git.Ref
 import qualified Git.Command
-import Git.Tree
+import qualified Git.Tree
+import Git.Tree (TreeItem(..))
 import Git.Env
 import Git.Index
+import Git.FilePath
 import qualified Git.LockFile
 import Annex.CatFile
 import Annex.Link
@@ -35,8 +39,10 @@ import qualified Database.Keys
 data Adjustment = UnlockAdjustment
 	deriving (Show)
 
-adjustTreeItem :: Adjustment -> HashObjectHandle -> TreeItem -> Annex (Maybe TreeItem)
+data Direction = Forward | Reverse
-adjustTreeItem UnlockAdjustment h ti@(TreeItem f m s)
+
+adjustTreeItem :: Adjustment -> Direction -> HashObjectHandle -> TreeItem -> Annex (Maybe TreeItem)
+adjustTreeItem UnlockAdjustment Forward h ti@(TreeItem f m s)
 	| toBlobType m == Just SymlinkBlob = do
 		mk <- catKey s
 		case mk of
@@ -46,6 +52,20 @@ adjustTreeItem UnlockAdjustment h ti@(TreeItem f m s)
 					<$> hashPointerFile' h k
 			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
+			Just k -> do
+				absf <- inRepo $ \r -> absPath $
+					repoPath r <> fromTopFilePath f r
+				linktarget <- calcRepo $ gitAnnexLink absf k
+				Just . TreeItem f (fromBlobType SymlinkBlob)
+					<$> hashSymlink' h linktarget
+			Nothing -> return (Just ti)
+	| otherwise = return (Just ti)
 
 type OrigBranch = Branch
 type AdjBranch = Branch
@@ -92,28 +112,34 @@ enterAdjustedBranch :: Adjustment -> Annex ()
 enterAdjustedBranch adj = go =<< originalBranch
   where
 	go (Just origbranch) = do
-		adjbranch <- preventCommits $ adjustBranch adj origbranch
+		adjbranch <- preventCommits $ adjustBranch adj Forward origbranch
 		inRepo $ Git.Command.run
 			[ Param "checkout"
 			, Param $ fromRef $ Git.Ref.base $ adjbranch
 			]
 	go Nothing = error "not on any branch!"
 
-adjustBranch :: Adjustment -> OrigBranch -> Annex AdjBranch
+adjustBranch :: Adjustment -> Direction -> OrigBranch -> Annex AdjBranch
-adjustBranch adj origbranch = do
+adjustBranch adj direction origbranch = do
-	sha <- adjust adj origbranch
+	sha <- adjust adj direction origbranch
 	inRepo $ Git.Branch.update adjbranch sha
 	return adjbranch
   where
 	adjbranch = originalToAdjusted origbranch adj
 
-adjust :: Adjustment -> Ref -> Annex Sha
+adjust :: Adjustment -> Direction -> Ref -> Annex Sha
-adjust adj orig = do
+adjust adj direction orig = do
-	h <- inRepo hashObjectStart
+	treesha <- adjustTree adj direction orig
-	treesha <- adjustTree (adjustTreeItem adj h) orig =<< Annex.gitRepo
-	liftIO $ hashObjectStop h
 	commitAdjustedTree treesha orig
 
+adjustTree :: Adjustment -> Direction -> Ref -> Annex Sha
+adjustTree adj direction orig = do
+	h <- inRepo hashObjectStart
+	treesha <- Git.Tree.adjustTree (adjustTreeItem adj direction h) orig
+		=<< Annex.gitRepo
+	liftIO $ hashObjectStop h
+	return treesha
+
 {- Locks git's index file, preventing git from making a commit, merge, 
  - or otherwise changing the HEAD ref while the action is run.
  -
@@ -141,8 +167,11 @@ commitAdjustedTree treesha parent = go =<< catCommit parent
 		(commitAuthorMetaData parentcommit)
 		(commitCommitterMetaData parentcommit)
 		mkcommit
-	mkcommit = Git.Branch.commitTree
+	mkcommit = Git.Branch.commitTree Git.Branch.AutomaticCommit
-		Git.Branch.AutomaticCommit "adjusted branch" [parent] treesha
+		adjustedBranchCommitMessage [parent] treesha
+
+adjustedBranchCommitMessage :: String
+adjustedBranchCommitMessage = "git-annex adjusted branch"
 
 {- Update the currently checked out adjusted branch, merging the provided
  - branch into it. -}
@@ -154,8 +183,8 @@ updateAdjustedBranch tomerge (origbranch, adj) commitmode =
   where
 	go (Just mergesha, Just currbranch) = ifM (inRepo $ Git.Branch.changed currbranch mergesha)
 		( do
-			propigateAdjustedCommits origbranch adj
+			propigateAdjustedCommits origbranch (adj, currbranch)
-			adjustedtomerge <- adjust adj mergesha
+			adjustedtomerge <- adjust adj Forward mergesha
 			ifM (inRepo $ Git.Branch.changed currbranch adjustedtomerge)
 				( ifM (autoMergeFrom adjustedtomerge (Just currbranch) commitmode)
 					( recommit currbranch mergesha =<< catCommit currbranch
@@ -176,11 +205,51 @@ updateAdjustedBranch tomerge (origbranch, adj) commitmode =
 	recommit currbranch parent (Just commit) = do
 		commitsha <- commitAdjustedTree (commitTree commit) parent
 		inRepo $ Git.Branch.update currbranch commitsha
-		propigateAdjustedCommits origbranch adj
+		propigateAdjustedCommits origbranch (adj, currbranch)
 		return True
 	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. -}
+ - been propigated to the orig branch, and propigate them.
-propigateAdjustedCommits :: OrigBranch -> Adjustment -> Annex ()
+ -
-propigateAdjustedCommits originbranch adj = return () -- TODO
+ - After propigating the commits back to the orig banch,
+ - rebase the adjusted branch on top of the updated orig branch.
+ -}
+propigateAdjustedCommits :: OrigBranch -> (Adjustment, AdjBranch) -> Annex ()
+propigateAdjustedCommits origbranch (adj, currbranch) = do
+	v <- inRepo $ Git.Ref.sha (Git.Ref.under "refs/heads/" origbranch)
+	case v of
+		Just origsha -> go origsha False =<< newcommits
+		Nothing -> return ()
+  where
+	newcommits = inRepo $ Git.Branch.changedCommits origbranch currbranch
+		-- Get commits oldest first, so they can be processed
+		-- in order made.
+		[Param "--reverse"]
+	go newhead _ [] = do
+		inRepo $ Git.Branch.update origbranch newhead
+		-- TODO rebase adjusted branch
+	go parent pastadjcommit (sha:l) = do
+		mc <- catCommit sha
+		case mc of
+			Just c
+				| commitMessage c == adjustedBranchCommitMessage ->
+					go parent True l
+				| pastadjcommit -> do
+					commit <- reverseAdjustedCommit parent adj c
+					go commit pastadjcommit l
+			_ -> go parent pastadjcommit l
+
+{- Reverses an adjusted commit, yielding a commit sha.
+ -
+ - 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 parent adj c = do
+	treesha <- adjustTree adj Reverse (commitTree c)
+	inRepo $ commitWithMetaData
+		(commitAuthorMetaData c)
+		(commitCommitterMetaData c) $
+		Git.Branch.commitTree Git.Branch.AutomaticCommit
+			(commitMessage c) [parent] treesha

Command/Sync.hs

@@ -267,21 +267,20 @@ pushLocal b = do
 
 updateSyncBranch :: CurrBranch -> Annex ()
 updateSyncBranch (Nothing, _) = noop
-updateSyncBranch (Just branch, _) = do
+updateSyncBranch (Just branch, madj) = do
 	-- When in an adjusted branch, propigate any changes to it back to
 	-- the original branch.
-	branch' <- case adjustedToOriginal branch of
+	case madj of
-		Just (adj, origbranch) -> do
+		Just adj -> propigateAdjustedCommits branch
-			propigateAdjustedCommits origbranch adj
+			(adj, originalToAdjusted branch adj)
-			return origbranch
+		Nothing -> return ()
-		Nothing -> return branch
 	-- Update the sync branch to match the new state of the branch
-	inRepo $ updateBranch (syncBranch branch') branch'
+	inRepo $ updateBranch (syncBranch branch) branch
 	-- In direct mode, we're operating on some special direct mode
 	-- branch, rather than the intended branch, so update the intended
 	-- branch.
 	whenM isDirect $
-		inRepo $ updateBranch (fromDirectBranch branch') branch'
+		inRepo $ updateBranch (fromDirectBranch branch) branch
 
 updateBranch :: Git.Branch -> Git.Branch -> Git.Repo -> IO ()
 updateBranch syncbranch updateto g = 

Git/Branch.hs

@@ -48,15 +48,25 @@ currentUnsafe r = parse . firstLine
 changed :: Branch -> Branch -> Repo -> IO Bool
 changed origbranch newbranch repo
 	| origbranch == newbranch = return False
-	| otherwise = not . null <$> diffs
+	| otherwise = not . null
+		<$> changed' origbranch newbranch [Param "-n1"] repo
   where
-	diffs = pipeReadStrict
+
+changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String
+changed' origbranch newbranch extraps repo = pipeReadStrict ps repo
+  where
+	ps =
 		[ Param "log"
 		, Param (fromRef origbranch ++ ".." ++ fromRef newbranch)
-		, Param "-n1"
 		, Param "--pretty=%H"
-		] repo
+		] ++ extraps
 
+{- Lists commits that are in the second branch and not in the first branch. -}
+changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha]
+changedCommits origbranch newbranch extraps repo = 
+	catMaybes . map extractSha . lines
+		<$> changed' origbranch newbranch extraps repo
+	
 {- Check if it's possible to fast-forward from the old
  - ref to the new ref.
  -

doc/design/adjusted_branches.mdwn

@@ -351,3 +351,5 @@ like this, at its most simple:
 * Entering an adjusted branch can race with commits to the current branch,
   and so the assistant should not be running, or at least should have
   commits disabled when entering it.
+* When the adjusted branch unlocks files, behave as if annex.addunlocked is
+  set, so git annex add will add files unlocked.