Fix bug importing from a special remote into a subdirectory more than one level deep

Which generated unusual git trees that could confuse git merge,
since they incorrectly had 2 subtrees with the same name.

Root of the bug was a) not testing that at all! but also
b) confusing graftdirs, which contains eg "foo/bar" with
non-recursively read trees, which would contain eg "bar"
when reading a subtree of "foo".

It's worth noting that Annex.Import uses graftTree, but it really
shouldn't have needed to. Eg, when importing into foo/bar from a remote,
it's enough to generate a tree of foo/bar/x, foo/bar/y, and does not
include other files that are at the top of the master branch. It uses
graftTree, so it does include the other files, as well as the foo/bar
tree. git merge will do the same thing for both trees. With that said,
switching it away from graftTree would result in another import
generating a new commit that seems to delete files that were there in a
previous commit, so it probably has to keep using graftTree since it
used it before.

diff --git a/Git/Tree.hs b/Git/Tree.hs
index ba62499ba515c04bc3cb3466344158b5f2d76345..c9534cd9a394a2d9dcbc6b5a2e824951c7ed86ac 100644 (file)
--- a/Git/Tree.hs
+++ b/Git/Tree.hs
@@ -300,43 +300,43 @@ graftTree'
        -> Repo
        -> MkTreeHandle
        -> IO Sha
-graftTree' subtree graftloc basetree repo hdl = go basetree graftdirs
+graftTree' subtree graftloc basetree repo hdl = go basetree subdirs graftdirs
   where
-       go tsha (topmostgraphdir:restgraphdirs) = do
+       go tsha (subdir:restsubdirs) (topmostgraphdir:restgraphdirs) = do
                Tree t <- getTree LsTree.LsTreeNonRecursive tsha repo
-               t' <- case partition isabovegraft t of
+               let abovegraftpoint i = gitPath i == gitPath subdir
+               t' <- case partition abovegraftpoint t of
+                       -- the graft point is not already in the tree,
+                       -- so graft it in, keeping the existing tree
+                       -- content
                        ([], _) -> do
                                graft <- graftin (topmostgraphdir:restgraphdirs)
                                return (graft:t)
-                       -- normally there can only be one matching item
-                       -- in the tree, but it's theoretically possible
-                       -- for a git tree to have multiple items with the
-                       -- same name, so process them all
                        (matching, rest) -> do
                                newshas <- forM matching $ \case
                                        RecordedSubTree tloc tsha' _
                                                | null restgraphdirs -> return $
                                                        RecordedSubTree tloc subtree []
                                                | otherwise -> do
-                                                       tsha'' <- go tsha' restgraphdirs
+                                                       tsha'' <- go tsha' restsubdirs restgraphdirs
                                                        return $ RecordedSubTree tloc tsha'' []
                                        _ -> graftin (topmostgraphdir:restgraphdirs)
                                return (newshas ++ rest)
                mkTree hdl t'
-       go _ [] = return subtree
-
-       isabovegraft i = beneathSubTree i graftloc || gitPath i == gitPath graftloc
+       go _ _ [] = return subtree
        
        graftin t = recordSubTree hdl $ graftin' t
        graftin' [] = RecordedSubTree graftloc subtree []
        graftin' (d:rest) 
                | d == graftloc = graftin' []
                | otherwise = NewSubTree d [graftin' rest]
-       
+
+       subdirs = splitDirectories $ gitPath graftloc
+
        -- For a graftloc of "foo/bar/baz", this generates
        -- ["foo", "foo/bar", "foo/bar/baz"]
        graftdirs = map (asTopFilePath . toInternalGitPath . encodeBS) $
-               mkpaths [] $ splitDirectories $ gitPath graftloc
+               mkpaths [] subdirs
        mkpaths _ [] = []
        mkpaths base (d:rest) = (joinPath base </> d) : mkpaths (base ++ [d]) rest