git-annex/Annex/AutoMerge.hs

{- git-annex automatic merge conflict resolution
 -
 - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.AutoMerge (autoMergeFrom) where

import Common.Annex
import qualified Annex.Queue
import Annex.Direct
import Annex.CatFile
import Annex.Link
import qualified Git.LsFiles as LsFiles
import qualified Git.UpdateIndex as UpdateIndex
import qualified Git.Merge
import qualified Git.Ref
import qualified Git
import qualified Git.Branch
import Git.Types (BlobType(..))
import Config
import Annex.ReplaceFile
import Git.FileMode
import Annex.VariantFile

import qualified Data.Set as S

{- Merges from a branch into the current branch
 - (which may not exist yet),
 - with automatic merge conflict resolution.
 -
 - Callers should use Git.Branch.changed first, to make sure that
 - there are changed from the current branch to the branch being merged in.
 -}
autoMergeFrom :: Git.Ref -> (Maybe Git.Ref) -> Git.Branch.CommitMode -> Annex Bool
autoMergeFrom branch currbranch commitmode = do
	showOutput
	case currbranch of
		Nothing -> go Nothing
		Just b -> go =<< inRepo (Git.Ref.sha b)
  where
	go old = ifM isDirect
		( mergeDirect currbranch old branch (resolveMerge old branch) commitmode
		, inRepo (Git.Merge.mergeNonInteractive branch commitmode)
			<||> (resolveMerge old branch <&&> commitResolvedMerge commitmode)
		)

{- Resolves a conflicted merge. It's important that any conflicts be
 - resolved in a way that itself avoids later merge conflicts, since
 - multiple repositories may be doing this concurrently.
 -
 - Only merge conflicts where at least one side is an annexed file
 - is resolved.
 -
 - This uses the Keys pointed to by the files to construct new
 - filenames. So when both sides modified annexed file foo, 
 - it will be deleted, and replaced with files foo.variant-A and
 - foo.variant-B.
 -
 - On the other hand, when one side deleted foo, and the other modified it,
 - it will be deleted, and the modified version stored as file
 - foo.variant-A (or B).
 -
 - It's also possible that one side has foo as an annexed file, and
 - the other as a directory or non-annexed file. The annexed file
 - is renamed to resolve the merge, and the other object is preserved as-is.
 -
 - In indirect mode, the merge is resolved in the work tree and files
 - staged, to clean up from a conflicted merge that was run in the work
 - tree.
 -
 - In direct mode, the work tree is not touched here; files are staged to
 - the index, and written to the gitAnnexMergeDir, for later handling by
 - the direct mode merge code.
 -}
resolveMerge :: Maybe Git.Ref -> Git.Ref -> Annex Bool
resolveMerge us them = do
	top <- fromRepo Git.repoPath
	(fs, cleanup) <- inRepo (LsFiles.unmerged [top])
	mergedfs <- catMaybes <$> mapM (resolveMerge' us them) fs
	let merged = not (null mergedfs)
	void $ liftIO cleanup

	unlessM isDirect $ do
		(deleted, cleanup2) <- inRepo (LsFiles.deleted [top])
		unless (null deleted) $
			Annex.Queue.addCommand "rm" [Params "--quiet -f --"] deleted
		void $ liftIO cleanup2

	when merged $ do
		unlessM isDirect $
			cleanConflictCruft mergedfs top
		Annex.Queue.flush
		showLongNote "Merge conflict was automatically resolved; you may want to examine the result."
	return merged

resolveMerge' :: Maybe Git.Ref -> Git.Ref -> LsFiles.Unmerged -> Annex (Maybe FilePath)
resolveMerge' Nothing _ _ = return Nothing
resolveMerge' (Just us) them u = do
	kus <- getkey LsFiles.valUs LsFiles.valUs 
	kthem <- getkey LsFiles.valThem LsFiles.valThem
	case (kus, kthem) of
		-- Both sides of conflict are annexed files
		(Just keyUs, Just keyThem)
			| keyUs /= keyThem -> resolveby $ do
				makelink keyUs
				makelink keyThem
			| otherwise -> resolveby $
				makelink keyUs
		-- Our side is annexed file, other side is not.
		(Just keyUs, Nothing) -> resolveby $ do
			graftin them file LsFiles.valThem LsFiles.valThem
			makelink keyUs
		-- Our side is not annexed file, other side is.
		(Nothing, Just keyThem) -> resolveby $ do
			graftin us file LsFiles.valUs LsFiles.valUs
			makelink keyThem
		-- Neither side is annexed file; cannot resolve.
		(Nothing, Nothing) -> return Nothing
  where
	file = LsFiles.unmergedFile u

	getkey select select'
		| select (LsFiles.unmergedBlobType u) == Just SymlinkBlob =
			case select' (LsFiles.unmergedSha u) of
				Nothing -> return Nothing
				Just sha -> catKey sha symLinkMode
		| otherwise = return Nothing
	
	makelink key = do
		let dest = variantFile file key
		l <- inRepo $ gitAnnexLink dest key
		replacewithlink dest l
		stageSymlink dest =<< hashSymlink l

	replacewithlink file link = ifM isDirect
		( do
			d <- fromRepo gitAnnexMergeDir
			replaceFile (d </> file) $ makeGitLink link
		, replaceFile file $ makeGitLink link
		)

	{- Stage a graft of a directory or file from a branch.
	 -
	 - When there is a conflicted merge where one side is a directory
	 - or file, and the other side is a symlink, git merge always
	 - updates the work tree to contain the non-symlink. So, the
	 - directory or file will already be in the work tree correctly,
	 - and they just need to be staged into place. Do so by copying the
	 - index. (Note that this is also better than calling git-add
	 - because on a crippled filesystem, it preserves any symlink
	 - bits.)
	 -
	 - It's also possible for the branch to have a symlink in it,
	 - which is not a git-annex symlink. In this special case,
	 - git merge does not update the work tree to contain the symlink
	 - from the branch, so we have to do so manually.
	 -}
	graftin b item select select' = do
		Annex.Queue.addUpdateIndex
			=<< fromRepo (UpdateIndex.lsSubTree b item)
		when (select (LsFiles.unmergedBlobType u) == Just SymlinkBlob) $
			case select' (LsFiles.unmergedSha u) of
				Nothing -> noop
				Just sha -> do
					link <- catLink True sha
					replacewithlink item link
		
	resolveby a = do
		{- Remove conflicted file from index so merge can be resolved. -}
		Annex.Queue.addCommand "rm" [Params "--quiet -f --cached --"] [file]
		void a
		return (Just file)

{- git-merge moves conflicting files away to files
 - named something like f~HEAD or f~branch, but the
 - exact name chosen can vary. Once the conflict is resolved,
 - this cruft can be deleted. To avoid deleting legitimate
 - files that look like this, only delete files that are
 - A) not staged in git and B) look like git-annex symlinks.
 -}
cleanConflictCruft :: [FilePath] -> FilePath -> Annex ()
cleanConflictCruft resolvedfs top = do
	(fs, cleanup) <- inRepo $ LsFiles.notInRepo False [top]
	mapM_ clean fs
	void $ liftIO cleanup
  where
	clean f
		| matchesresolved f = whenM (isJust <$> isAnnexLink f) $
			liftIO $ nukeFile f
		| otherwise = noop
	s = S.fromList resolvedfs
	matchesresolved f = S.member (base f) s
	base f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f
	
commitResolvedMerge :: Git.Branch.CommitMode -> Annex Bool
commitResolvedMerge commitmode = inRepo $ Git.Branch.commitCommand commitmode
	[ Param "--no-verify"
	, Param "-m"
	, Param "git-annex automatic merge conflict fix"
	]