add tweak-fetch command, for use in the tweak-fetch hook

tweak-fetch is a new git hook I have developed (not yet accepted into
git, but looking bright). Amoung other things, the hook can be used to
observe what is being fetched, notice remote git-annex branches that might
be updated, and merge them into the git-annex branch.

This will solve problems where users do a git pull, immediately followed
by a push, and it refuses to push because their git-annex branch is
diverged, and they neither ran git annex merge by hand, nor ran other
git-annex commands that auto-merge.

The tweak-fetch is written by git annex init. Of course, existing
repositories won't have it, which is ok, because git-annex still
automatically does a merge if changed branches have appeared. Indeed,
it will always need to do that check, as long as it needs to support
support git-annex branches that might be updated by other means.

Eventually though, I will want to ensure all repositories have the
tweak-fetch hook. Perhaps a minor verison upgrade to ensure it is added?

A subtlety of the hook is that when it's run, the remote tracking refs
have not yet been updated. So Annex.Branch.updateTo has to be careful to
only use the sha1 that was fetched, not the branch name. The branch
name is only used in the commit message.

The other tricky thing is that git tweak-fetch hook should *only*
output lines in a specific format, and git will be unhappy if it also
outputs status messages, etc. So those messages are sent to stderr.

Annex/Branch.hs

@@ -11,6 +11,7 @@ module Annex.Branch (
 	hasSibling,
 	create,
 	update,
+	updateTo,
 	get,
 	change,
 	commit,
@@ -81,10 +82,19 @@ getBranch = maybe (hasOrigin >>= go >>= use) (return) =<< branchsha
 
 {- Ensures that the branch and index are is up-to-date; should be
  - called before data is read from it. Runs only once per git-annex run.
+ -}
+update :: Annex ()
+update = runUpdateOnce $ updateTo =<< siblingBranches
+
+{- Merges the specified Refs into the index, if they have any changes not
+ - already in it. The Branch names are only used in the commit message;
+ - it's even possible that the provided Branches have not been updated to
+ - point to the Refs yet.
  -
  - Before refs are merged into the index, it's important to first stage the
  - journal into the index. Otherwise, any changes in the journal would
  - later get staged, and might overwrite changes made during the merge.
+ - If no Refs are provided, the journal is still staged and committed.
  -
  - (It would be cleaner to handle the merge by updating the journal, not the
  - index, with changes from the branches.)
@@ -92,13 +102,13 @@ getBranch = maybe (hasOrigin >>= go >>= use) (return) =<< branchsha
  - The branch is fast-forwarded if possible, otherwise a merge commit is
  - made.
  -}
-update :: Annex ()
+updateTo :: [(Git.Ref, Git.Branch)] -> Annex ()
-update = runUpdateOnce $ do
+updateTo pairs = do
 	-- ensure branch exists, and get its current ref
 	branchref <- getBranch
 	-- check what needs updating before taking the lock
 	dirty <- journalDirty
-	(refs, branches) <- unzip <$> newerSiblings
+	(refs, branches) <- unzip <$> filterM isnewer pairs
 	if (not dirty && null refs)
 		then updateIndex branchref
 		else withIndex $ lockJournal $ do
@@ -110,7 +120,7 @@ update = runUpdateOnce $ do
 					" into " ++ show name
 			unless (null branches) $ do
 				showSideAction merge_desc
-				mergeIndex branches
+				mergeIndex refs
 			ff <- if dirty
 				then return False
 				else inRepo $ Git.Branch.fastForward fullname refs
@@ -120,8 +130,7 @@ update = runUpdateOnce $ do
 					(nub $ fullname:refs)
 			invalidateCache
 	where
-		newerSiblings = filterM isnewer =<< siblingBranches
+		isnewer (r, _) = inRepo $ Git.Branch.changed fullname r
-		isnewer (_, b) = inRepo $ Git.Branch.changed fullname b
 
 {- Gets the content of a file on the branch, or content from the journal, or
  - staged in the index.
@@ -238,7 +247,7 @@ genIndex :: Git.Repo -> IO ()
 genIndex g = Git.UnionMerge.stream_update_index g
 	[Git.UnionMerge.ls_tree fullname g]
 
-{- Merges the specified branches into the index.
+{- Merges the specified refs into the index.
  - Any changes staged in the index will be preserved. -}
 mergeIndex :: [Git.Ref] -> Annex ()
 mergeIndex branches = do

Command/TweakFetch.hs

@@ -0,0 +1,34 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.TweakFetch where
+
+import Common
+import Command
+import qualified Git.TweakFetch
+import qualified Annex.Branch
+
+def :: [Command]
+def = [command "tweak-fetch" paramNothing seek "run by git tweak-fetch hook"]
+
+seek :: [CommandSeek]
+seek = [ withNothing start]
+
+start :: CommandStart
+start = do
+	-- First, pass the hook's input through to its output, unchanged.
+	fetched <- liftIO $ Git.TweakFetch.runHook return
+
+	-- If one of the fetched refs is going to be stored on a git-annex
+	-- tracking branch, then merge in the new sha for that ref.
+	let tomerge = filter siblings fetched
+	unless (null tomerge) $ Annex.Branch.updateTo $ map topairs tomerge
+	stop
+	where
+		siblings f = suffix `isSuffixOf` (show $ Git.TweakFetch.local f)
+		suffix = "/" ++ show Annex.Branch.name
+		topairs f = (Git.TweakFetch.sha f, Git.TweakFetch.local f)

Git/TweakFetch.hs

@@ -5,7 +5,10 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Git.TweakFetch (runHook, runHookUnsafe, FetchedRef(..)) where
+module Git.TweakFetch (runHook, FetchedRef(..)) where
+
+import Data.Either (rights)
+import System.Posix.IO
 
 import Common
 import Git
@@ -26,24 +29,23 @@ data FetchedRef = FetchedRef
  - lines are passed through unchanged. -}
 type HookLine = Either String FetchedRef
 
-{- Runs the hook, allowing lines to be mutated, but never be discarded. -}
+{- Runs the hook, allowing lines to be mutated, but never be discarded.
-runHook :: (FetchedRef -> IO FetchedRef) -> IO ()
+ - Returns same FetchedRefs that are output by the hook, for further use. -}
-runHook mutate = runHook' go id
+runHook :: (FetchedRef -> IO FetchedRef) -> IO [FetchedRef]
+runHook mutate = do
+	ls <- mapM go =<< input
+	output ls
+
+	-- Nothing more should be output to stdout; only hook output
+	-- is accepted by git. Redirect stdout to stderr.
+	hFlush stdout
+	_ <- liftIO $ dupTo stdError stdOutput
+
+	return $ rights ls
 	where
 		go u@(Left _) = return u
 		go (Right r) = Right <$> catchDefaultIO (mutate r) r
 
-{- Runs the hook, allowing lines to be mutated, discarded, or produce
- - multiple output lines. -}
-runHookUnsafe :: (FetchedRef -> IO [FetchedRef]) -> IO ()
-runHookUnsafe mutate = runHook' go concat
-	where
-		go u@(Left _) = return [u]
-		go (Right r) = map Right <$> catchDefaultIO (mutate r) [r]
-
-runHook' :: (HookLine -> IO b) -> ([b] -> [HookLine]) -> IO ()
-runHook' mutate reduce = output . reduce =<< mapM mutate =<< input
-
 input :: IO [HookLine]
 input = map parseLine . lines <$> getContents
 

GitAnnex.hs

@@ -39,6 +39,7 @@ import qualified Command.DropUnused
 import qualified Command.Unlock
 import qualified Command.Lock
 import qualified Command.PreCommit
+import qualified Command.TweakFetch
 import qualified Command.Find
 import qualified Command.Whereis
 import qualified Command.Merge
@@ -73,6 +74,7 @@ cmds = concat
 	, Command.Unannex.def
 	, Command.Uninit.def
 	, Command.PreCommit.def
+	, Command.TweakFetch.def
 	, Command.Trust.def
 	, Command.Untrust.def
 	, Command.Semitrust.def

Init.hs

@@ -24,12 +24,12 @@ initialize mdescription = do
 	prepUUID
 	Annex.Branch.create
 	setVersion
-	gitPreCommitHookWrite
+	gitHooksWrite
 	u <- getUUID
 	maybe (recordUUID u) (describeUUID u) mdescription
 
 uninitialize :: Annex ()
-uninitialize = gitPreCommitHookUnWrite
+uninitialize = gitHooksUnWrite
 
 {- Will automatically initialize if there is already a git-annex
    branch from somewhere. Otherwise, require a manual init
@@ -44,37 +44,40 @@ ensureInitialized = getVersion >>= maybe needsinit checkVersion
 				then initialize Nothing
 				else error "First run: git-annex init"
 
-{- set up a git pre-commit hook, if one is not already present -}
+{- set up git hooks, if not already present -}
-gitPreCommitHookWrite :: Annex ()
+gitHooksWrite :: Annex ()
-gitPreCommitHookWrite = unlessBare $ do
+gitHooksWrite = unlessBare $ forM_ hooks $ \(hook, content) -> do
-	hook <- preCommitHook
+	file <- hookFile hook
-	exists <- liftIO $ doesFileExist hook
+	exists <- liftIO $ doesFileExist file
 	if exists
-		then warning $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring"
+		then warning $ hook ++ " hook (" ++ file ++ ") already exists, not configuring"
 		else liftIO $ do
-			viaTmp writeFile hook preCommitScript
+			viaTmp writeFile file content
-			p <- getPermissions hook
+			p <- getPermissions file
-			setPermissions hook $ p {executable = True}
+			setPermissions file $ p {executable = True}
 
-gitPreCommitHookUnWrite :: Annex ()
+gitHooksUnWrite :: Annex ()
-gitPreCommitHookUnWrite = unlessBare $ do
+gitHooksUnWrite = unlessBare $ forM_ hooks $ \(hook, content) -> do
-	hook <- preCommitHook
+	file <- hookFile hook
-	whenM (liftIO $ doesFileExist hook) $ do
+	whenM (liftIO $ doesFileExist file) $ do
-		c <- liftIO $ readFile hook
+		c <- liftIO $ readFile file
-		if c == preCommitScript
+		if c == content
-			then liftIO $ removeFile hook
+			then liftIO $ removeFile file
-			else warning $ "pre-commit hook (" ++ hook ++ 
+			else warning $ hook ++ " hook (" ++ file ++ 
 				") contents modified; not deleting." ++
 				" Edit it to remove call to git annex."
 
 unlessBare :: Annex () -> Annex ()
 unlessBare = unlessM $ fromRepo $ Git.repoIsLocalBare
 
-preCommitHook :: Annex FilePath
+hookFile :: FilePath -> Annex FilePath
-preCommitHook = (</>) <$> fromRepo Git.gitDir <*> pure "hooks/pre-commit"
+hookFile f = (</>) <$> fromRepo Git.gitDir <*> pure ("hooks/" ++ f)
 
-preCommitScript :: String
+hooks :: [(String, String)]
-preCommitScript = 
+hooks = [ ("pre-commit", hookscript "git annex pre-commit .")
-	"#!/bin/sh\n" ++
+	, ("tweak-fetch", hookscript "git annex tweak-fetch")
-	"# automatically configured by git-annex\n" ++ 
+	]
-	"git annex pre-commit .\n"
+	where
+		hookscript s = "#!/bin/sh\n" ++
+			"# automatically configured by git-annex\n" ++
+			s ++ "\n";

doc/git-annex.mdwn

@@ -344,6 +344,11 @@ subdirectories).
   This is meant to be called from git's pre-commit hook. `git annex init`
   automatically creates a pre-commit hook using this.
 
+* tweak-fetch
+
+  This is meant ot be called from git's tweak-fetch hook. `git annex init`
+  automatically creates a tweak-fetch hook using this.
+
 * fromkey key file
 
   This plumbing-level command can be used to manually set up a file