diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs index 87d179a623..fc722c8e71 100644 --- a/Annex/CatFile.hs +++ b/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 diff --git a/Annex/Direct.hs b/Annex/Direct.hs index 4a23fcc6ca..2b43ca6805 100644 --- a/Annex/Direct.hs +++ b/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 diff --git a/Annex/VariantFile.hs b/Annex/VariantFile.hs new file mode 100644 index 0000000000..7c849c59f0 --- /dev/null +++ b/Annex/VariantFile.hs @@ -0,0 +1,45 @@ +{- git-annex .variant files for automatic merge conflict resolution + - + - Copyright 2014 Joey Hess + - + - 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 diff --git a/Command/Sync.hs b/Command/Sync.hs index 04086eab21..e8e1d345fb 100644 --- a/Command/Sync.hs +++ b/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 diff --git a/Git/CatFile.hs b/Git/CatFile.hs index c8cb76d591..c7c51b8943 100644 --- a/Git/CatFile.hs +++ 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 diff --git a/debian/changelog b/debian/changelog index 907a3d1dbc..0807c1c6d9 100644 --- a/debian/changelog +++ b/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.