direct mode merging works!

Automatic merge resoltion code needs to be fixed to preserve objects from
direct mode files.

Annex/Content/Direct.hs

@@ -9,7 +9,6 @@ module Annex.Content.Direct (
 	associatedFiles,
 	removeAssociatedFile,
 	addAssociatedFile,
-	updateAssociatedFiles,
 	goodContent,
 	updateCache,
 	recordedCache,
@@ -23,11 +22,7 @@ module Annex.Content.Direct (
 
 import Common.Annex
 import qualified Git
-import qualified Git.DiffTree as DiffTree
-import Git.Sha
-import Annex.CatFile
 import Utility.TempFile
-import Utility.FileMode
 import Logs.Location
 
 import System.Posix.Types
@@ -70,23 +65,6 @@ addAssociatedFile key file = changeAssociatedFiles key $ \files ->
 		then files
 		else file:files
 
-{- Uses git diff-tree to find files changed between two tree Shas, and
- - updates the associated file mappings, efficiently. -}
-updateAssociatedFiles :: Git.Sha -> Git.Sha -> Annex ()
-updateAssociatedFiles oldsha newsha = do
-	(items, cleanup) <- inRepo $ DiffTree.diffTree oldsha newsha
-	forM_ items update
-	void $ liftIO $ cleanup
-  where
-	update item = do
-		go DiffTree.dstsha DiffTree.dstmode addAssociatedFile
-		go DiffTree.srcsha DiffTree.srcmode removeAssociatedFile
-	  where
-		go getsha getmode a =
-			when (getsha item /= nullSha && isSymLink (getmode item)) $ do
-				key <- catKey (getsha item)
-				maybe noop (\k -> void $ a k $ DiffTree.file item) key
-
 {- Checks if a file in the tree, associated with a key, has not been modified.
  -
  - To avoid needing to fsck the file's content, which can involve an

Annex/Direct.hs

@@ -12,9 +12,13 @@ import qualified Git
 import qualified Git.LsFiles
 import qualified Git.UpdateIndex
 import qualified Git.HashObject
-import qualified Annex.Queue
+import qualified Git.Merge
+import qualified Git.DiffTree as DiffTree
+import Git.Sha
 import Git.Types
 import Annex.CatFile
+import Utility.FileMode
+import qualified Annex.Queue
 import Logs.Location
 import Backend
 import Types.KeySource
@@ -103,3 +107,93 @@ addDirect file cache = do
 			showEndFail
 			return False
 		)
+
+{- In direct mode, git merge would usually refuse to do anything, since it
+ - sees present direct mode files as type changed files. To avoid this,
+ - merge is run with the work tree set to a temp directory.
+ -
+ - This should only be used once any changes to the real working tree have
+ - already been committed, because it overwrites files in the working tree.
+ -}
+mergeDirect :: FilePath -> Git.Ref -> Git.Repo -> IO Bool
+mergeDirect d branch g = do
+	createDirectoryIfMissing True d
+	let g' = g { location = Local { gitdir = Git.localGitDir g, worktree = Just d } }
+	Git.Merge.mergeNonInteractive branch g'
+
+{- Cleans up after a direct mode merge. The merge must have been committed,
+ - and the commit sha passed in, along with the old sha of the tree
+ - before the merge. Uses git diff-tree to find files that changed between
+ - the two shas, and applies those changes to the work tree.
+ -}
+mergeDirectCleanup :: FilePath -> Git.Ref -> Git.Ref -> Annex ()
+mergeDirectCleanup d oldsha newsha = do
+	(items, cleanup) <- inRepo $ DiffTree.diffTreeRecursive oldsha newsha
+	forM_ items updated
+	void $ liftIO $ cleanup
+	liftIO $ removeDirectoryRecursive d
+  where
+	updated item = do
+		go DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
+		go DiffTree.dstsha DiffTree.dstmode movein movein_raw
+	  where
+		go getsha getmode a araw
+			| getsha item == nullSha = noop
+			| isSymLink (getmode item) =
+				maybe (araw f) (\k -> void $ a k f)
+					=<< catKey (getsha item)
+			| otherwise = araw f
+		f = DiffTree.file item
+
+	{- Any content that was present in direct mode and whose file is to
+	 - be modified or deleted by the merge is first moved to
+	 - .git/annex/objects, unless there are other associated files for
+	 - the content. No content is ever lost due to a direct mode merge. -}
+	moveout k f = do
+		locs <- removeAssociatedFile k f
+		when (null locs) $ do
+			r <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus f
+			case r of
+				Just s
+					| not (isSymbolicLink s) ->
+						moveAnnex k f
+				_ -> noop
+		moveout_raw f
+
+	{- Files deleted by the merge are removed from the work tree.
+	 - Empty work tree directories are removed, per git behavior. -}
+	moveout_raw f = liftIO $ do
+		nukeFile f
+		void $ catchMaybeIO $ removeDirectory $ parentDir f
+	
+	{- Key symlinks are replaced with their content, if it's available. -}
+	movein k f = do
+		movein_raw f
+		maybe noop id =<< toDirect k f
+	
+	{- Any new, modified, or renamed files were written to the temp
+	 - directory by the merge, and are moved to the real work tree. -}
+	movein_raw f = liftIO $ do
+		createDirectoryIfMissing True $ parentDir f
+		rename (d </> f) f
+
+{- If possible, returns an action that will convert a symlink in the
+ - working tree into a direct mode file. -}
+toDirect :: Key -> FilePath -> Annex (Maybe (Annex ()))
+toDirect k f = do
+	loc <- inRepo $ gitAnnexLocation k
+	createContentDir loc -- thaws directory too
+	locs <- filter (/= f) <$> addAssociatedFile k f
+	case locs of
+		[] -> ifM (liftIO $ doesFileExist loc)
+			( return $ Just $ do
+				{- Move content from annex to direct file. -}
+				updateCache k loc
+				thawContent loc
+				liftIO $ replaceFile f $ moveFile loc
+			, return Nothing
+			)
+		(loc':_) -> return $ Just $ do
+			{- Another direct file has the content, so
+			 - hard link to it. -}
+			liftIO $ replaceFile f $ createLink loc'

Command/Direct.hs

@@ -13,8 +13,7 @@ import qualified Git
 import qualified Git.Command
 import qualified Git.LsFiles
 import Config
-import Annex.Content
-import Annex.Content.Direct
+import Annex.Direct
 
 def :: [Command]
 def = [command "direct" paramNothing seek "switch repository to direct mode"]
@@ -41,25 +40,13 @@ perform = do
 	void $ liftIO clean
 	next cleanup
   where
-	{- Walk tree from top and move all present objects to the
-	 - files that link to them, while updating direct mode mappings. -}
 	go = whenAnnexed $ \f (k, _) -> do
-		loc <- inRepo $ gitAnnexLocation k
-		createContentDir loc -- thaws directory too
-		locs <- filter (/= f) <$> addAssociatedFile k f
-		case locs of
-			[] -> whenM (liftIO $ doesFileExist loc) $ do
-				{- Move content from annex to direct file. -}
+		r <- toDirect k f
+		case r of
+			Nothing -> noop
+			Just a -> do
 				showStart "direct" f
-				updateCache k loc
-				thawContent loc
-				liftIO $ replaceFile f $ moveFile loc
-				showEndOk
-			(loc':_) -> do
-				{- Another direct file has the content, so
-				 - hard link to it. -}
-				showStart "direct" f
-				liftIO $ replaceFile f $ createLink loc'
+				a
 				showEndOk
 		return Nothing
 

Command/Sync.hs

@@ -15,7 +15,6 @@ import qualified Annex
 import qualified Annex.Branch
 import qualified Annex.Queue
 import Annex.Content
-import Annex.Content.Direct
 import Annex.Direct
 import Annex.CatFile
 import qualified Git.Command
@@ -179,31 +178,30 @@ mergeAnnex = do
 	void $ Annex.Branch.forceUpdate
 	stop
 
-{- Merges from a branch into the current branch.
- -
- - In direct mode, updates associated files mappings for the files that
- - were changed by the merge. -}
+{- Merges from a branch into the current branch. -}
 mergeFrom :: Git.Ref -> Annex Bool
-mergeFrom branch = ifM isDirect
+mergeFrom branch = do
+	showOutput
+	ifM isDirect
 		( maybe go godirect =<< inRepo Git.Branch.current
 		, go
 		)
   where
-	go = do
-		showOutput
-		ok <- inRepo $ Git.Merge.mergeNonInteractive branch
-		if ok
-			then return ok
-			else resolveMerge
+	go = runmerge $ inRepo $ Git.Merge.mergeNonInteractive branch
 	godirect currbranch = do
 		old <- inRepo $ Git.Ref.sha currbranch
-		r <- go
+		d <- fromRepo gitAnnexMergeDir
+		r <- runmerge $ inRepo $ mergeDirect d branch
 		new <- inRepo $ Git.Ref.sha currbranch
 		case (old, new) of
-			(Just oldsha, Just newsha) -> do
-				updateAssociatedFiles oldsha newsha
+			(Just oldsha, Just newsha) ->
+				mergeDirectCleanup d oldsha newsha
 			_ -> noop
 		return r
+	runmerge a = ifM (a)
+		( return True
+		, resolveMerge
+		)
 
 {- Resolves a conflicted merge. It's important that any conflicts be
  - resolved in a way that itself avoids later merge conflicts, since

Git/DiffTree.hs

@@ -8,6 +8,7 @@
 module Git.DiffTree (
 	DiffTreeItem(..),
 	diffTree,
+	diffTreeRecursive,
 	parseDiffTree
 ) where
 
@@ -31,9 +32,19 @@ data DiffTreeItem = DiffTreeItem
 
 {- Diffs two tree Refs. -}
 diffTree :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)
-diffTree src dst repo = do
-	(diff, cleanup) <- pipeNullSplit [Params "diff-tree -z --raw --no-renames -l0", Param (show src), Param (show dst)] repo
+diffTree = diffTree' []
+
+{- Diffs two tree Refs, recursing into sub-trees -}
+diffTreeRecursive :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)
+diffTreeRecursive = diffTree' [Param "-r"]
+
+diffTree' :: [CommandParam] -> Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)
+diffTree' params src dst repo = do
+	(diff, cleanup) <- pipeNullSplit ps repo
 	return (parseDiffTree diff, cleanup)
+  where
+	ps = Params "diff-tree -z --raw --no-renames -l0" : params ++
+		[Param (show src), Param (show dst)]
 
 {- Parses diff-tree output. -}
 parseDiffTree :: [String] -> [DiffTreeItem]

Locations.hs

@@ -25,6 +25,7 @@ module Locations (
 	gitAnnexFsckState,
 	gitAnnexTransferDir,
 	gitAnnexCredsDir,
+	gitAnnexMergeDir,
 	gitAnnexJournalDir,
 	gitAnnexJournalLock,
 	gitAnnexIndex,
@@ -161,6 +162,10 @@ gitAnnexFsckState r = gitAnnexDir r </> "fsckstate"
 gitAnnexCredsDir :: Git.Repo -> FilePath
 gitAnnexCredsDir r = addTrailingPathSeparator $ gitAnnexDir r </> "creds"
 
+{- .git/annex/merge/ is used for direct mode merges. -}
+gitAnnexMergeDir :: Git.Repo -> FilePath
+gitAnnexMergeDir r = addTrailingPathSeparator $ gitAnnexDir r </> "merge"
+
 {- .git/annex/transfer/ is used to record keys currently
  - being transferred, and other transfer bookkeeping info. -}
 gitAnnexTransferDir :: Git.Repo -> FilePath