Merge branch 'adjustedbranch'

5 files changed, 455 insertions, 9 deletions

diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs
new file mode 100644
index 000000000..c757eae1d
--- /dev/null
+++ b/Annex/AdjustedBranch.hs
@@ -0,0 +1,419 @@
+{- adjusted branch
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.AdjustedBranch (
+	Adjustment(..),
+	OrigBranch,
+	AdjBranch,
+	originalToAdjusted,
+	adjustedToOriginal,
+	fromAdjustedBranch,
+	getAdjustment,
+	enterAdjustedBranch,
+	adjustToCrippledFileSystem,
+	updateAdjustedBranch,
+	propigateAdjustedCommits,
+) where
+
+import Annex.Common
+import qualified Annex
+import Git
+import Git.Types
+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
+import qualified Git.LockFile
+import Annex.CatFile
+import Annex.Link
+import Annex.AutoMerge
+import Annex.Content
+import qualified Database.Keys
+
+import qualified Data.Map as M
+
+data Adjustment
+	= UnlockAdjustment
+	| LockAdjustment
+	| HideMissingAdjustment
+	| ShowMissingAdjustment
+	deriving (Show, Eq)
+
+reverseAdjustment :: Adjustment -> Adjustment
+reverseAdjustment UnlockAdjustment = LockAdjustment
+reverseAdjustment LockAdjustment = UnlockAdjustment
+reverseAdjustment HideMissingAdjustment = ShowMissingAdjustment
+reverseAdjustment ShowMissingAdjustment = HideMissingAdjustment
+
+{- How to perform various adjustments to a TreeItem. -}
+adjustTreeItem :: Adjustment -> TreeItem -> Annex (Maybe TreeItem)
+adjustTreeItem UnlockAdjustment ti@(TreeItem f m s)
+	| toBlobType m == Just SymlinkBlob = do
+		mk <- catKey s
+		case mk of
+			Just k -> do
+				Database.Keys.addAssociatedFile k f
+				Just . TreeItem f (fromBlobType FileBlob)
+					<$> hashPointerFile k
+			Nothing -> return (Just ti)
+	| otherwise = return (Just ti)
+adjustTreeItem LockAdjustment ti@(TreeItem f m s)
+	| toBlobType m /= Just SymlinkBlob = do
+		mk <- catKey s
+		case mk of
+			Just k -> do
+				absf <- inRepo $ \r -> absPath $
+					fromTopFilePath f r
+				linktarget <- calcRepo $ gitAnnexLink absf k
+				Just . TreeItem f (fromBlobType SymlinkBlob)
+					<$> hashSymlink linktarget
+			Nothing -> return (Just ti)
+	| otherwise = return (Just ti)
+adjustTreeItem HideMissingAdjustment ti@(TreeItem _ _ s) = do
+	mk <- catKey s
+	case mk of
+		Just k -> ifM (inAnnex k)
+			( return (Just ti)
+			, return Nothing
+			)
+		Nothing -> return (Just ti)
+adjustTreeItem ShowMissingAdjustment ti = return (Just ti)
+
+type OrigBranch = Branch
+type AdjBranch = Branch
+
+adjustedBranchPrefix :: String
+adjustedBranchPrefix = "refs/heads/adjusted/"
+
+serialize :: Adjustment -> String
+serialize UnlockAdjustment = "unlocked"
+serialize LockAdjustment = "locked"
+serialize HideMissingAdjustment = "present"
+serialize ShowMissingAdjustment = "showmissing"
+
+deserialize :: String -> Maybe Adjustment
+deserialize "unlocked" = Just UnlockAdjustment
+deserialize "locked" = Just UnlockAdjustment
+deserialize "present" = Just HideMissingAdjustment
+deserialize _ = Nothing
+
+originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch
+originalToAdjusted orig adj = Ref $
+	adjustedBranchPrefix ++ base ++ '(' : serialize adj ++ ")"
+  where
+	base = fromRef (Git.Ref.basename orig)
+
+adjustedToOriginal :: AdjBranch -> Maybe (Adjustment, OrigBranch)
+adjustedToOriginal b
+	| adjustedBranchPrefix `isPrefixOf` bs = do
+		let (base, as) = separate (== '(') (drop prefixlen bs)
+		adj <- deserialize (takeWhile (/= ')') as)
+		Just (adj, Git.Ref.under "refs/heads" (Ref base))
+	| otherwise = Nothing
+  where
+	bs = fromRef b
+	prefixlen = length adjustedBranchPrefix
+
+getAdjustment :: Branch -> Maybe Adjustment
+getAdjustment = fmap fst . adjustedToOriginal
+
+fromAdjustedBranch :: Branch -> OrigBranch
+fromAdjustedBranch b = maybe b snd (adjustedToOriginal b)
+
+originalBranch :: Annex (Maybe OrigBranch)
+originalBranch = fmap fromAdjustedBranch <$> inRepo Git.Branch.current
+
+{- Enter an adjusted version of current branch (or, if already in an
+ - adjusted version of a branch, changes the adjustment of the original
+ - branch).
+ -
+ - Can fail, if no branch is checked out, or perhaps if staged changes
+ - conflict with the adjusted branch.
+ -}
+enterAdjustedBranch :: Adjustment -> Annex ()
+enterAdjustedBranch adj = go =<< originalBranch
+  where
+	go (Just origbranch) = do
+		adjbranch <- preventCommits $ const $ 
+			adjustBranch adj origbranch
+		inRepo $ Git.Command.run
+			[ Param "checkout"
+			, Param $ fromRef $ Git.Ref.base $ adjbranch
+			]
+	go Nothing = error "not on any branch!"
+
+adjustToCrippledFileSystem :: Annex ()
+adjustToCrippledFileSystem = do
+	warning "Entering an adjusted branch where files are unlocked as this filesystem does not support locked files."
+	whenM (isNothing <$> originalBranch) $
+		void $ inRepo $ Git.Branch.commitCommand Git.Branch.AutomaticCommit
+			[ Param "--quiet"
+			, Param "--allow-empty"
+			, Param "-m"
+			, Param "commit before entering adjusted unlocked branch"
+			]
+	enterAdjustedBranch UnlockAdjustment
+
+adjustBranch :: Adjustment -> OrigBranch -> Annex AdjBranch
+adjustBranch adj origbranch = do
+	sha <- adjust adj origbranch
+	inRepo $ Git.Branch.update "entering adjusted branch" adjbranch sha
+	return adjbranch
+  where
+	adjbranch = originalToAdjusted origbranch adj
+
+adjust :: Adjustment -> Ref -> Annex Sha
+adjust adj orig = do
+	treesha <- adjustTree adj orig
+	commitAdjustedTree treesha orig
+
+adjustTree :: Adjustment -> Ref -> Annex Sha
+adjustTree adj orig = do
+	let toadj = adjustTreeItem adj
+	treesha <- Git.Tree.adjustTree toadj [] [] orig =<< Annex.gitRepo
+	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 :: (CommitsPrevented -> Annex a) -> Annex a
+preventCommits = bracket setup cleanup
+  where
+	setup = do
+		lck <- fromRepo indexFileLock
+		liftIO $ Git.LockFile.openLock lck
+	cleanup = liftIO . Git.LockFile.closeLock
+
+{- Commits a given adjusted tree, with the provided parent ref.
+ -
+ - This should always yield the same value, even if performed in different 
+ - clones of a repo, at different times. The commit message and other
+ - metadata is based on the parent.
+ -}
+commitAdjustedTree :: Sha -> Ref -> Annex Sha
+commitAdjustedTree treesha parent = commitAdjustedTree' treesha parent [parent]
+
+commitAdjustedTree' :: Sha -> Ref -> [Ref] -> Annex Sha
+commitAdjustedTree' treesha basis parents = go =<< catCommit basis
+  where
+	go Nothing = inRepo mkcommit
+	go (Just basiscommit) = inRepo $ commitWithMetaData
+		(commitAuthorMetaData basiscommit)
+		(commitCommitterMetaData basiscommit)
+		mkcommit
+	mkcommit = Git.Branch.commitTree Git.Branch.AutomaticCommit
+		adjustedBranchCommitMessage parents treesha
+
+adjustedBranchCommitMessage :: String
+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 = catchBoolIO $
+	join $ preventCommits $ \commitsprevented -> go commitsprevented =<< (,)
+		<$> inRepo (Git.Ref.sha tomerge)
+		<*> inRepo Git.Branch.current
+  where
+	go commitsprevented (Just mergesha, Just currbranch) =
+		ifM (inRepo $ Git.Branch.changed currbranch mergesha)
+			( do
+				void $ propigateAdjustedCommits' origbranch (adj, currbranch) commitsprevented
+				adjustedtomerge <- adjust adj mergesha
+				ifM (inRepo $ Git.Branch.changed currbranch adjustedtomerge)
+					( return $
+						-- Run after commit lock is dropped.
+						ifM (autoMergeFrom adjustedtomerge (Just currbranch) commitmode)
+							( preventCommits $ \_ ->
+								recommit currbranch mergesha =<< catCommit currbranch
+							, return False
+							)
+					, nochangestomerge
+					)
+			, nochangestomerge
+			)
+	go _ _ = return $ return False
+	nochangestomerge = return $ return True
+
+	{- A merge commit has been made on the adjusted branch.
+	 - Now, re-do it, removing the old version of the adjusted branch
+	 - from its history.
+	 -
+	 - There are two possible scenarios; either some commits
+	 - were made on top of the adjusted branch's adjusting commit,
+	 - or not. Those commits have already been propigated to the
+	 - orig branch, so we can just check if there are commits in the
+	 - orig branch that are not present in tomerge.
+	 -}
+	recommit currbranch mergedsha (Just mergecommit) =
+		ifM (inRepo $ Git.Branch.changed tomerge origbranch)
+			( remerge currbranch mergedsha mergecommit
+				=<< inRepo (Git.Ref.sha origbranch)
+			, fastforward currbranch mergedsha mergecommit
+			)
+	recommit _ _ Nothing = return False
+
+	{- Fast-forward scenario. The mergecommit is changed to a non-merge
+	 - commit, with its parent being the mergedsha. 
+	 - The orig branch can simply be pointed at the mergedsha.
+	 -}
+	fastforward currbranch mergedsha mergecommit = do
+		commitsha <- commitAdjustedTree (commitTree mergecommit) mergedsha
+		inRepo $ Git.Branch.update "fast-forward update of adjusted branch" currbranch commitsha
+		inRepo $ Git.Branch.update "updating original branch" origbranch mergedsha
+		return True
+		
+	{- True merge scenario. -}
+	remerge currbranch mergedsha mergecommit (Just origsha) = do
+	 	-- Update origbranch by reverse adjusting the mergecommit,
+		-- yielding a merge between orig and tomerge.
+		treesha <- reverseAdjustedTree origsha adj
+			-- get 1-parent commit because 
+			-- reverseAdjustedTree does not support merges
+			=<< commitAdjustedTree (commitTree mergecommit) origsha
+		revadjcommit <- inRepo $
+			Git.Branch.commitTree Git.Branch.AutomaticCommit
+				("Merge branch " ++ fromRef tomerge) [origsha, mergedsha] treesha
+		inRepo $ Git.Branch.update "updating original branch" origbranch revadjcommit
+		-- Update currbranch, reusing mergedsha, but making its
+		-- parent be the updated origbranch.
+		adjcommit <- commitAdjustedTree' (commitTree mergecommit) revadjcommit [revadjcommit]
+		inRepo $ Git.Branch.update rebaseOnTopMsg currbranch adjcommit
+		return True
+	remerge _ _ _ 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.
+ -
+ - 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) = 
+	preventCommits $ \commitsprevented -> do
+		join $ propigateAdjustedCommits' origbranch (adj, currbranch) commitsprevented
+		
+{- Returns action which will rebase the adjusted branch on top of the
+ - updated orig branch. -}
+propigateAdjustedCommits'
+	:: OrigBranch
+	-> (Adjustment, AdjBranch)
+	-> CommitsPrevented
+	-> Annex (Annex ())
+propigateAdjustedCommits' origbranch (adj, currbranch) _commitsprevented = do
+	ov <- inRepo $ Git.Ref.sha (Git.Ref.under "refs/heads" origbranch)
+	case ov of
+		Just origsha -> do
+			cv <- catCommit currbranch
+			case cv of
+				Just currcommit -> do
+					v <- newcommits >>= go origsha False
+					case v of
+						Left e -> do
+							warning e
+							return $ return ()
+						Right newparent -> return $
+							rebase currcommit newparent
+				Nothing -> return $ return ()
+		Nothing -> return $ return ()
+  where
+	newcommits = inRepo $ Git.Branch.changedCommits origbranch currbranch
+		-- Get commits oldest first, so they can be processed
+		-- in order made.
+		[Param "--reverse"]
+	go parent _ [] = do
+		inRepo $ Git.Branch.update "updating adjusted branch" origbranch parent
+		return (Right parent)
+	go parent pastadjcommit (sha:l) = do
+		mc <- catCommit sha
+		case mc of
+			Just c
+				| commitMessage c == adjustedBranchCommitMessage ->
+					go parent True l
+				| pastadjcommit -> do
+					v <- reverseAdjustedCommit parent adj (sha, c) origbranch
+					case v of
+						Left e -> return (Left e)
+						Right commit -> go commit pastadjcommit l
+			_ -> go parent pastadjcommit l
+	rebase currcommit newparent = do
+		-- Reuse the current adjusted tree,
+		-- and reparent it on top of the new
+		-- version of the origbranch.
+		commitAdjustedTree (commitTree currcommit) newparent
+			>>= inRepo . Git.Branch.update rebaseOnTopMsg currbranch
+
+rebaseOnTopMsg :: String
+rebaseOnTopMsg = "rebasing adjusted branch on top of updated original branch"
+
+{- Reverses an adjusted commit, and commit with provided commitparent,
+ - yielding a commit sha.
+ -
+ - Adjusts the tree of the commitparent, changing only the files that the
+ - commit changed, and reverse adjusting those changes.
+ -
+ - The commit message, and the author and committer metadata are
+ - copied over from the basiscommit. However, any gpg signature
+ - will be lost, and any other headers are not copied either. -}
+reverseAdjustedCommit :: Sha -> Adjustment -> (Sha, Commit) -> OrigBranch -> Annex (Either String Sha)
+reverseAdjustedCommit commitparent adj (csha, basiscommit) origbranch
+	| length (commitParent basiscommit) > 1 = return $
+		Left $ "unable to propigate merge commit " ++ show csha ++ " back to " ++ show origbranch
+	| otherwise = do
+		treesha <- reverseAdjustedTree commitparent adj csha
+		revadjcommit <- inRepo $ commitWithMetaData
+			(commitAuthorMetaData basiscommit)
+			(commitCommitterMetaData basiscommit) $
+				Git.Branch.commitTree Git.Branch.AutomaticCommit
+					(commitMessage basiscommit) [commitparent] treesha
+		return (Right revadjcommit)
+
+{- Adjusts the tree of the basis, changing only the files that the
+ - commit changed, and reverse adjusting those changes.
+ -
+ - commitDiff does not support merge commits, so the csha must not be a
+ - merge commit. -}
+reverseAdjustedTree :: Sha -> Adjustment -> Sha -> Annex Sha
+reverseAdjustedTree basis adj csha = do
+	(diff, cleanup) <- inRepo (Git.DiffTree.commitDiff csha)
+	let (adds, others) = partition (\dti -> Git.DiffTree.srcsha dti == nullSha) diff
+	let (removes, changes) = partition (\dti -> Git.DiffTree.dstsha dti == nullSha) others
+	adds' <- catMaybes <$>
+		mapM (adjustTreeItem reverseadj) (map diffTreeToTreeItem adds)
+	treesha <- Git.Tree.adjustTree
+		(propchanges changes)
+		adds'
+		(map Git.DiffTree.file removes)
+		basis
+		=<< Annex.gitRepo
+	void $ liftIO cleanup
+	return treesha
+  where
+	reverseadj = reverseAdjustment adj
+	propchanges changes ti@(TreeItem f _ _) =
+		case M.lookup f m of
+			Nothing -> return (Just ti) -- not changed
+			Just change -> adjustTreeItem reverseadj 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)
diff --git a/Annex/Direct.hs b/Annex/Direct.hs
index e85d8f447..d16692226 100644
--- a/Annex/Direct.hs
+++ b/Annex/Direct.hs
@@ -225,7 +225,7 @@ mergeDirectCommit allowff old branch commitmode = do
 	let merge_msg = d </> "MERGE_MSG"
 	let merge_mode = d </> "MERGE_MODE"
 	ifM (pure allowff <&&> canff)
-		( inRepo $ Git.Branch.update Git.Ref.headRef branch -- fast forward
+		( inRepo $ Git.Branch.update "merge" Git.Ref.headRef branch -- fast forward
 		, do
 			msg <- liftIO $
 				catchDefaultIO ("merge " ++ fromRef branch) $
@@ -462,7 +462,7 @@ switchHEAD = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
   where
 	switch orighead = do
 		let newhead = directBranch orighead
-		maybe noop (inRepo . Git.Branch.update newhead)
+		maybe noop (inRepo . Git.Branch.update "entering direct mode" newhead)
 			=<< inRepo (Git.Ref.sha orighead)
 		inRepo $ Git.Branch.checkout newhead
 
@@ -475,7 +475,7 @@ switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
 		case v of
 			Just headsha
 				| orighead /= currhead -> do
-					inRepo $ Git.Branch.update orighead headsha
+					inRepo $ Git.Branch.update "leaving direct mode" orighead headsha
 					inRepo $ Git.Branch.checkout orighead
 					inRepo $ Git.Branch.delete currhead
 			_ -> inRepo $ Git.Branch.checkout orighead
diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs
index b80f0e1e0..1bf1db146 100644
--- a/Annex/Ingest.hs
+++ b/Annex/Ingest.hs
@@ -35,6 +35,8 @@ import Logs.Location
 import qualified Annex
 import qualified Annex.Queue
 import qualified Database.Keys
+import qualified Git
+import qualified Git.Branch
 import Config
 import Utility.InodeCache
 import Annex.ReplaceFile
@@ -43,6 +45,7 @@ import Utility.CopyFile
 import Utility.Touch
 import Git.FilePath
 import Annex.InodeSentinal
+import Annex.AdjustedBranch
 
 import Control.Exception (IOException)
 
@@ -309,15 +312,32 @@ forceParams = ifM (Annex.getState Annex.force)
 	)
 
 {- Whether a file should be added unlocked or not. Default is to not,
- - unless symlinks are not supported. annex.addunlocked can override that. -}
+ - unless symlinks are not supported. annex.addunlocked can override that.
+ - Also, when in an adjusted unlocked branch, always add files unlocked.
+ -}
 addUnlocked :: Annex Bool
 addUnlocked = isDirect <||>
 	(versionSupportsUnlockedPointers <&&>
 	 ((not . coreSymlinks <$> Annex.getGitConfig) <||>
-	  (annexAddUnlocked <$> Annex.getGitConfig)
+	  (annexAddUnlocked <$> Annex.getGitConfig) <||>
+	  (maybe False (\b -> getAdjustment b == Just UnlockAdjustment) <$> cachedCurrentBranch)
 	 )
 	)
 
+cachedCurrentBranch :: Annex (Maybe Git.Branch)
+cachedCurrentBranch = maybe cache (return . Just)
+	=<< Annex.getState Annex.cachedcurrentbranch
+  where
+	cache :: Annex (Maybe Git.Branch)
+	cache = do
+		mb <- inRepo Git.Branch.currentUnsafe
+		case mb of
+			Nothing -> return Nothing
+			Just b -> do
+				Annex.changeState $ \s ->
+					s { Annex.cachedcurrentbranch = Just b }
+				return (Just b)
+
 {- Adds a file to the work tree for the key, and stages it in the index.
  - The content of the key may be provided in a temp file, which will be
  - moved into place. -}
diff --git a/Annex/Init.hs b/Annex/Init.hs
index 7501d9b8f..99f8ece2c 100644
--- a/Annex/Init.hs
+++ b/Annex/Init.hs
@@ -33,6 +33,7 @@ import Annex.UUID
 import Annex.Link
 import Config
 import Annex.Direct
+import Annex.AdjustedBranch
 import Annex.Environment
 import Annex.Hook
 import Annex.InodeSentinal
@@ -92,10 +93,13 @@ initialize' mversion = do
 	whenM versionSupportsUnlockedPointers $ do
 		configureSmudgeFilter
 		Database.Keys.scanAssociatedFiles
-	ifM (crippledFileSystem <&&> (not <$> isBare) <&&> (not <$> versionSupportsUnlockedPointers))
-		( do
-			enableDirectMode
-			setDirect True
+	ifM (crippledFileSystem <&&> (not <$> isBare))
+		( ifM versionSupportsUnlockedPointers
+			( adjustToCrippledFileSystem
+			, do
+				enableDirectMode
+				setDirect True
+			)
 		-- Handle case where this repo was cloned from a
 		-- direct mode repo
 		, unlessM isBare
diff --git a/Annex/Version.hs b/Annex/Version.hs
index f294f8cd3..b5f038c0d 100644
--- a/Annex/Version.hs
+++ b/Annex/Version.hs
@@ -52,6 +52,9 @@ versionSupportsUnlockedPointers = go <$> getVersion
 	go (Just "6") = True
 	go _ = False
 
+versionSupportsAdjustedBranch :: Annex Bool
+versionSupportsAdjustedBranch = versionSupportsUnlockedPointers
+
 setVersion :: Version -> Annex ()
 setVersion = setConfig versionField