sync: Fix bug in direct mode that caused a file not checked into git to be deleted when merging with a remote that added a file by the same name. (Thanks, jkt)

Annex/CatFile.hs

@@ -7,6 +7,7 @@
 
 module Annex.CatFile (
 	catFile,
+	catFileDetails,
 	catObject,
 	catTree,
 	catObjectDetails,
@@ -34,6 +35,11 @@ catFile branch file = do
 	h <- catFileHandle
 	liftIO $ Git.CatFile.catFile h branch file
 
+catFileDetails :: Git.Branch -> FilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType))
+catFileDetails branch file = do
+	h <- catFileHandle
+	liftIO $ Git.CatFile.catFileDetails h branch file
+
 catObject :: Git.Ref -> Annex L.ByteString
 catObject ref = do
 	h <- catFileHandle

Annex/Direct.hs

@@ -33,6 +33,7 @@ import Utility.CopyFile
 import Annex.Perms
 import Annex.ReplaceFile
 import Annex.Exception
+import Annex.VariantFile
 
 {- Uses git ls-files to find files that need to be committed, and stages
  - them into the index. Returns True if some changes were staged. -}
@@ -142,9 +143,6 @@ addDirect file cache = do
 {- 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
@@ -193,18 +191,42 @@ mergeDirectCleanup d oldsha newsha = do
 		void $ tryIO $ removeDirectory $ parentDir f
 	
 	{- If the file is already present, with the right content for the
-	 - key, it's left alone. Otherwise, create the symlink and then
-	 - if possible, replace it with the content. -}
+	 - key, it's left alone. 
+	 -
+	 - If the file is already present, and does not exist in the
+	 - oldsha branch, preserve this local file.
+	 -
+	 - Otherwise, create the symlink and then if possible, replace it
+	 - with the content. -}
 	movein k f = unlessM (goodContent k f) $ do
+		preserveUnannexed f
 		l <- inRepo $ gitAnnexLink f k
 		replaceFile f $ makeAnnexLink l
 		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 item = liftIO $ do
-		createDirectoryIfMissing True $ parentDir f
-		void $ tryIO $ rename (d </> getTopFilePath (DiffTree.file item)) f
+	movein_raw f item = do
+		preserveUnannexed f
+		liftIO $ do
+			createDirectoryIfMissing True $ parentDir f
+			void $ tryIO $ rename (d </> getTopFilePath (DiffTree.file item)) f
+
+	{- If the file is present in the work tree, but did not exist in
+	 - the oldsha branch, preserve this local, unannexed file. -}
+	preserveUnannexed f = whenM (liftIO $ exists f) $
+		whenM (isNothing <$> catFileDetails oldsha f) $
+			liftIO $ findnewname (0 :: Int)
+	  where
+		exists = isJust <$$> catchMaybeIO . getSymbolicLinkStatus
+		findnewname n = do
+			let localf = mkVariant f 
+				("local" ++ if n > 0 then show n else "")
+			ifM (exists localf)
+				( findnewname (n+1)
+				, rename f localf
+					`catchIO` const (findnewname (n+1))
+				)
 
 {- If possible, converts a symlink in the working tree into a direct
  - mode file. If the content is not available, leaves the symlink

Annex/VariantFile.hs

@@ -0,0 +1,45 @@
+{- git-annex .variant files for automatic merge conflict resolution
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.VariantFile where
+
+import Common.Annex
+import Types.Key
+
+import Data.Hash.MD5
+
+variantMarker :: String
+variantMarker = ".variant-"
+
+mkVariant :: FilePath -> String -> FilePath
+mkVariant file variant = takeDirectory file
+	</> dropExtension (takeFileName file)
+	++ variantMarker ++ variant
+	++ takeExtension file
+
+{- The filename to use when resolving a conflicted merge of a file,
+ - that points to a key.
+ -
+ - Something derived from the key needs to be included in the filename,
+ - but rather than exposing the whole key to the user, a very weak hash
+ - is used. There is a very real, although still unlikely, chance of
+ - conflicts using this hash.
+ -
+ - In the event that there is a conflict with the filename generated
+ - for some other key, that conflict will itself be handled by the
+ - conflicted merge resolution code. That case is detected, and the full
+ - key is used in the filename.
+ -}
+variantFile :: FilePath -> Key -> FilePath
+variantFile file key
+	| doubleconflict = mkVariant file (key2file key)
+	| otherwise = mkVariant file (shortHash $ key2file key)
+  where
+	doubleconflict = variantMarker `isInfixOf` file
+
+shortHash :: String -> String
+shortHash = take 4 . md5s . md5FilePath

Command/Sync.hs

@@ -28,7 +28,6 @@ import qualified Git
 import Git.Types (BlobType(..))
 import qualified Types.Remote
 import qualified Remote.Git
-import Types.Key
 import Config
 import Annex.ReplaceFile
 import Git.FileMode
@@ -39,9 +38,9 @@ import qualified Command.Move
 import Logs.Location
 import Annex.Drop
 import Annex.UUID
+import Annex.VariantFile
 
 import qualified Data.Set as S
-import Data.Hash.MD5
 import Control.Concurrent.MVar
 
 def :: [Command]
@@ -415,7 +414,7 @@ resolveMerge' u
 	file = LsFiles.unmergedFile u
 	issymlink select = select (LsFiles.unmergedBlobType u) `elem` [Just SymlinkBlob, Nothing]
 	makelink key = do
-		let dest = mergeFile file key
+		let dest = variantFile file key
 		l <- inRepo $ gitAnnexLink dest key
 		replaceFile dest $ makeAnnexLink l
 		stageSymlink dest =<< hashSymlink l
@@ -478,34 +477,6 @@ cleanConflictCruft resolvedfs top = do
 	matchesresolved f = S.member (base f) s
 	base f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f
 
-{- The filename to use when resolving a conflicted merge of a file,
- - that points to a key.
- -
- - Something derived from the key needs to be included in the filename,
- - but rather than exposing the whole key to the user, a very weak hash
- - is used. There is a very real, although still unlikely, chance of
- - conflicts using this hash.
- -
- - In the event that there is a conflict with the filename generated
- - for some other key, that conflict will itself be handled by the
- - conflicted merge resolution code. That case is detected, and the full
- - key is used in the filename.
- -}
-mergeFile :: FilePath -> Key -> FilePath
-mergeFile file key
-	| doubleconflict = go $ key2file key
-	| otherwise = go $ shortHash $ key2file key
-  where
-	varmarker = ".variant-"
-	doubleconflict = varmarker `isInfixOf` file
-	go v = takeDirectory file
-		</> dropExtension (takeFileName file)
-		++ varmarker ++ v
-		++ takeExtension file
-		
-shortHash :: String -> String
-shortHash = take 4 . md5s . md5FilePath
-
 changed :: Remote -> Git.Ref -> Annex Bool
 changed remote b = do
 	let r = remoteBranch remote b

Git/CatFile.hs

@@ -11,6 +11,7 @@ module Git.CatFile (
 	catFileStart',
 	catFileStop,
 	catFile,
+	catFileDetails,
 	catTree,
 	catObject,
 	catObjectDetails,
@@ -52,6 +53,10 @@ catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
 catFile h branch file = catObject h $ Ref $
 	fromRef branch ++ ":" ++ toInternalGitPath file
 
+catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))
+catFileDetails h branch file = catObjectDetails h $ Ref $
+	fromRef branch ++ ":" ++ toInternalGitPath file
+
 {- Uses a running git cat-file read the content of an object.
  - Objects that do not exist will have "" returned. -}
 catObject :: CatFileHandle -> Ref -> IO L.ByteString

debian/changelog

@@ -1,5 +1,8 @@
 git-annex (5.20140228) UNRELEASED; urgency=medium
 
+  * sync: Fix bug in direct mode that caused a file not checked into git
+    to be deleted when merging with a remote that added a file by the same
+    name.
   * webapp: Now supports HTTPS.
   * webapp: No longer supports a port specified after --listen, since
     it was buggy, and that use case is better supported by setting up HTTPS.