adjusted branches, proof of concept

"git annex adjust" may be a temporary interface, but works for a proof of
concept.

It is pretty fast at creating the adjusted branch. The main overhead is
injecting pointer files. It might be worth optimising that by reusing the
symlink target as the pointer file content. When I tried to do that,
the problem was that the clean filter doesn't use that same format, and so
git thought files had changed. Could be dealt with, perhaps make the clean
filter use symlink format for pointer files when on an adjusted branch?

But the real overhead is in checking out the branch, when git runs the
smudge filter once per file. That is perhaps too slow to be usable,
although it may only affect initial checkout of the branch, and not
updates. TBD.

Annex/AdjustedBranch.hs

@@ -0,0 +1,102 @@
+{- adjusted version of main branch
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.AdjustedBranch where
+
+import Annex.Common
+import qualified Annex
+import Git.Types
+import qualified Git.Branch
+import qualified Git.Ref
+import qualified Git.Command
+import Git.Tree
+import Git.Env
+import Annex.CatFile
+import Annex.Link
+import Git.HashObject
+
+data Adjustment = UnlockAdjustment
+	deriving (Show)
+
+adjustTreeItem :: Adjustment -> HashObjectHandle -> TreeItem -> Annex (Maybe TreeItem)
+adjustTreeItem UnlockAdjustment h ti@(TreeItem f m s)
+	| toBlobType m == Just SymlinkBlob = do
+		mk <- catKey s
+		case mk of
+			Just k -> Just . TreeItem f (fromBlobType FileBlob)
+				<$> hashPointerFile' h k
+			Nothing -> return (Just ti)
+	| otherwise = return (Just ti)
+
+type OrigBranch = Branch
+type AdjBranch = Branch
+
+adjustedBranchPrefix :: String
+adjustedBranchPrefix = "refs/heads/adjusted/"
+
+originalToAdjusted :: OrigBranch -> AdjBranch
+originalToAdjusted orig = Ref $ adjustedBranchPrefix ++ takeFileName (fromRef orig)
+
+adjustedToOriginal :: AdjBranch -> Maybe (OrigBranch)
+adjustedToOriginal b
+	| adjustedBranchPrefix `isPrefixOf` bs =
+		Just $ Ref $ drop prefixlen bs
+	| otherwise = Nothing
+  where
+	bs = fromRef b
+	prefixlen = length adjustedBranchPrefix
+
+originalBranch :: Annex (Maybe OrigBranch)
+originalBranch = fmap getorig <$> inRepo Git.Branch.current
+  where
+	getorig currbranch = fromMaybe currbranch (adjustedToOriginal currbranch)
+
+{- 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 <- adjustBranch adj 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 adj origbranch = do
+	h <- inRepo hashObjectStart
+	treesha <- adjustTree (adjustTreeItem adj h) origbranch =<< Annex.gitRepo
+	liftIO $ hashObjectStop h
+	commitsha <- commitAdjustedTree treesha origbranch
+	inRepo $ Git.Branch.update adjbranch commitsha
+	return adjbranch
+  where
+	adjbranch = originalToAdjusted origbranch
+
+{- 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 = go =<< catCommit parent
+  where
+	go Nothing = inRepo mkcommit
+	go (Just parentcommit) = inRepo $ commitWithMetaData
+		(commitAuthorMetaData parentcommit)
+		(commitCommitterMetaData parentcommit)
+		mkcommit
+	mkcommit = Git.Branch.commitTree
+		Git.Branch.AutomaticCommit "adjusted branch" [parent] treesha

CmdLine/GitAnnex.hs

@@ -38,6 +38,7 @@ import qualified Command.SetPresentKey
 import qualified Command.ReadPresentKey
 import qualified Command.CheckPresentKey
 import qualified Command.ReKey
+import qualified Command.Adjust
 import qualified Command.MetaData
 import qualified Command.View
 import qualified Command.VAdd
@@ -174,6 +175,7 @@ cmds testoptparser testrunner =
 	, Command.ReadPresentKey.cmd
 	, Command.CheckPresentKey.cmd
 	, Command.ReKey.cmd
+	, Command.Adjust.cmd
 	, Command.MetaData.cmd
 	, Command.View.cmd
 	, Command.VAdd.cmd

Command/Adjust.hs

@@ -0,0 +1,25 @@
+{- git-annex command
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Adjust where
+
+import Command
+import Annex.AdjustedBranch
+
+cmd :: Command
+cmd = notBareRepo $ notDirect $
+	command "adjust" SectionSetup "adjust branch"
+		paramNothing (withParams seek)
+
+seek :: CmdParams -> CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start [] = do
+	enterAdjustedBranch UnlockAdjustment
+	next $ next $ return True
+start _ = error "Unknown parameter"