summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2015-01-06 15:31:24 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2015-01-06 16:19:41 -0400
commitc9f1281cdd937e9facd26741b3e42d60a9c5cf28 (patch)
treed93784c4a23a160d98fbfc40e69818c38ac06525
parent57c62d73082b6293a243f026003c697eda02b401 (diff)
Switch to using relative paths to the git repository.
This allows the git repository to be moved while git-annex is running in it, with fewer problems. On Windows, this avoids some of the problems with the absurdly small MAX_PATH of 260 bytes. In particular, git-annex repositories should work in deeper/longer directory structures than before. See http://git-annex.branchable.com/bugs/__34__git-annex:_direct:_1_failed__34___on_Windows/ There are several possible ways this change could break git-annex: 1. If it changes its working directory while it's running, that would be Bad News. Good news everyone! git-annex never does so. It would also break thread safety, so all such things were stomped out long ago. 2. parentDir "." -> "" which is not a valid path. I had to fix one instace of this, and I should probably wipe all calls to parentDir out of the git-annex code base; it was never a good idea. 3. Things like relPathDirToFile require absolute input paths, and code assumes that the git repo path is absolute and passes it to it as-is. In the case of relPathDirToFile, I converted it to not make this assumption. Currently, the test suite has 16 failures.
-rw-r--r--Annex.hs2
-rw-r--r--Annex/Content/Direct.hs2
-rw-r--r--Annex/Direct/Fixup.hs5
-rw-r--r--Command/Status.hs4
-rw-r--r--Git.hs46
-rw-r--r--Git/CheckAttr.hs2
-rw-r--r--Git/Command.hs2
-rw-r--r--Git/FilePath.hs3
-rw-r--r--Git/LsFiles.hs4
-rw-r--r--Git/Repair.hs11
-rw-r--r--Locations.hs8
-rw-r--r--Test.hs2
-rw-r--r--Utility/Path.hs23
-rw-r--r--debian/changelog6
14 files changed, 70 insertions, 50 deletions
diff --git a/Annex.hs b/Annex.hs
index 7806a9129..202c25e4f 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -187,7 +187,7 @@ newState c r = AnnexState
- Ensures the config is read, if it was not already. -}
new :: Git.Repo -> IO AnnexState
new r = do
- r' <- Git.adjustPath <$> Git.Config.read r
+ r' <- Git.Config.read =<< Git.relPath r
let c = extractGitConfig r'
newState c <$> if annexDirect c then fixupDirect r' else return r'
diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs
index d9e1535f3..c09a08f0d 100644
--- a/Annex/Content/Direct.hs
+++ b/Annex/Content/Direct.hs
@@ -114,7 +114,7 @@ addAssociatedFile key file = do
normaliseAssociatedFile :: FilePath -> Annex FilePath
normaliseAssociatedFile file = do
top <- fromRepo Git.repoPath
- liftIO $ relPathDirToFile top <$> absPath file
+ liftIO $ relPathDirToFile top file
{- Checks if a file in the tree, associated with a key, has not been modified.
-
diff --git a/Annex/Direct/Fixup.hs b/Annex/Direct/Fixup.hs
index 13485242a..73cefb134 100644
--- a/Annex/Direct/Fixup.hs
+++ b/Annex/Direct/Fixup.hs
@@ -10,16 +10,17 @@ module Annex.Direct.Fixup where
import Git.Types
import Git.Config
import qualified Git.Construct as Construct
-import Utility.Path
import Utility.SafeCommand
+import System.FilePath
+
{- Direct mode repos have core.bare=true, but are not really bare.
- Fix up the Repo to be a non-bare repo, and arrange for git commands
- run by git-annex to be passed parameters that override this setting. -}
fixupDirect :: Repo -> IO Repo
fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do
let r' = r
- { location = l { worktree = Just (parentDir d) }
+ { location = l { worktree = Just (takeDirectory d) }
, gitGlobalOpts = gitGlobalOpts r ++
[ Param "-c"
, Param $ coreBare ++ "=" ++ boolConfig False
diff --git a/Command/Status.hs b/Command/Status.hs
index 206b6a25e..578538ca7 100644
--- a/Command/Status.hs
+++ b/Command/Status.hs
@@ -28,9 +28,9 @@ start :: [FilePath] -> CommandStart
start [] = do
-- Like git status, when run without a directory, behave as if
-- given the path to the top of the repository.
- currdir <- liftIO getCurrentDirectory
top <- fromRepo Git.repoPath
- start' [relPathDirToFile currdir top]
+ d <- liftIO $ relPathCwdToFile top
+ start' [d]
start locs = start' locs
start' :: [FilePath] -> CommandStart
diff --git a/Git.hs b/Git.hs
index 032824fa7..c9750a3af 100644
--- a/Git.hs
+++ b/Git.hs
@@ -31,6 +31,7 @@ module Git (
hookPath,
assertLocal,
adjustPath,
+ relPath,
) where
import Network.URI (uriPath, uriScheme, unEscapeString)
@@ -141,25 +142,28 @@ hookPath script repo = do
isexecutable f = isExecutable . fileMode <$> getFileStatus f
#endif
-{- Adusts the path to a local Repo.
- -
- - On windows, prefixing a path with \\?\ makes it be processed as a raw
- - path (/ is not converted to \). The benefit is that such a path does
- - avoids Windows's 260 byte limitation on the entire path. -}
-adjustPath :: Repo -> Repo
-adjustPath r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = r
- { location = l
- { gitdir = adjustPath' d
- , worktree = fmap adjustPath' w
+{- Makes the path to a local Repo be relative to the cwd. -}
+relPath :: Repo -> IO Repo
+relPath = adjustPath torel
+ where
+ torel p = do
+ p' <- relPathCwdToFile p
+ if null p'
+ then return "."
+ else return p'
+
+{- Adusts the path to a local Repo using the provided function. -}
+adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo
+adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do
+ d' <- f d
+ w' <- maybe (pure Nothing) (Just <$$> f) w
+ return $ r
+ { location = l
+ { gitdir = d'
+ , worktree = w'
+ }
}
- }
-adjustPath r@(Repo { location = LocalUnknown d }) =
- r { location = LocalUnknown (adjustPath' d) }
-adjustPath r = r
-
-adjustPath' :: FilePath -> FilePath
-#if mingw32_HOST_OS
-adjustPath' d = "\\\\?\\" ++ d
-#else
-adjustPath' = id
-#endif
+adjustPath f r@(Repo { location = LocalUnknown d }) = do
+ d' <- f d
+ return $ r { location = LocalUnknown d' }
+adjustPath _ r = pure r
diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs
index bf46b938f..430154116 100644
--- a/Git/CheckAttr.hs
+++ b/Git/CheckAttr.hs
@@ -84,7 +84,7 @@ checkAttr (h, attrs, oldgit, currdir) want file = do
- so use relative filenames. -}
file'
| oldgit = absPathFrom currdir file
- | otherwise = relPathDirToFile currdir $ absPathFrom currdir file
+ | otherwise = relPathDirToFileAbs currdir $ absPathFrom currdir file
oldattrvalue attr l = end bits !! 0
where
bits = split sep l
diff --git a/Git/Command.hs b/Git/Command.hs
index c61cc9fe8..53b1d68fd 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -16,7 +16,7 @@ import qualified Utility.CoProcess as CoProcess
{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
-gitCommandLine params r@(Repo { location = l@(Local _ _ ) }) =
+gitCommandLine params r@(Repo { location = l@(Local { } ) }) =
setdir : settree ++ gitGlobalOpts r ++ params
where
setdir = Param $ "--git-dir=" ++ gitdir l
diff --git a/Git/FilePath.hs b/Git/FilePath.hs
index 42eb0812e..88f315b1c 100644
--- a/Git/FilePath.hs
+++ b/Git/FilePath.hs
@@ -39,8 +39,7 @@ fromTopFilePath p repo = absPathFrom (repoPath repo) (getTopFilePath p)
{- The input FilePath can be absolute, or relative to the CWD. -}
toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath
-toTopFilePath file repo = TopFilePath <$>
- relPathDirToFile (repoPath repo) <$> absPath file
+toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file
{- The input FilePath must already be relative to the top of the git
- repository -}
diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs
index 2aa05ba7f..8d32ba7ef 100644
--- a/Git/LsFiles.hs
+++ b/Git/LsFiles.hs
@@ -131,9 +131,9 @@ typeChanged' ps l repo = do
(fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo
-- git diff returns filenames relative to the top of the git repo;
-- convert to filenames relative to the cwd, like git ls-files.
- let top = repoPath repo
+ top <- absPath (repoPath repo)
currdir <- getCurrentDirectory
- return (map (\f -> relPathDirToFile currdir $ top </> f) fs, cleanup)
+ return (map (\f -> relPathDirToFileAbs currdir $ top </> f) fs, cleanup)
where
prefix = [Params "diff --name-only --diff-filter=T -z"]
suffix = Param "--" : (if null l then [File "."] else map File l)
diff --git a/Git/Repair.hs b/Git/Repair.hs
index 77a592b4e..bee9f2b50 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -225,10 +225,13 @@ badBranches missing r = filterM isbad =<< getAllRefs r
- Relies on packed refs being exploded before it's called.
-}
getAllRefs :: Repo -> IO [Ref]
-getAllRefs r = map toref <$> dirContentsRecursive refdir
- where
- refdir = localGitDir r </> "refs"
- toref = Ref . relPathDirToFile (localGitDir r)
+getAllRefs r = getAllRefs' (localGitDir r </> "refs")
+
+getAllRefs' :: FilePath -> IO [Ref]
+getAllRefs' refdir = do
+ let topsegs = length (splitPath refdir) - 1
+ let toref = Ref . joinPath . drop topsegs . splitPath
+ map toref <$> dirContentsRecursive refdir
explodePackedRefsFile :: Repo -> IO ()
explodePackedRefsFile r = do
diff --git a/Locations.hs b/Locations.hs
index bcf793bda..614cbdde3 100644
--- a/Locations.hs
+++ b/Locations.hs
@@ -87,8 +87,8 @@ import qualified Git
- Everything else should not end in a trailing path sepatator.
-
- Only functions (with names starting with "git") that build a path
- - based on a git repository should return an absolute path.
- - Everything else should use relative paths.
+ - based on a git repository should return full path relative to the git
+ - repository. Everything else returns path segments.
-}
{- The directory git annex uses for local state, relative to the .git
@@ -108,7 +108,7 @@ annexLocations key = map (annexLocation key) annexHashes
annexLocation :: Key -> Hasher -> FilePath
annexLocation key hasher = objectDir </> keyPath key hasher
-{- Annexed object's absolute location in a repository.
+{- Annexed object's location in a repository.
-
- When there are multiple possible locations, returns the one where the
- file is actually present.
@@ -146,7 +146,7 @@ gitAnnexLink file key r = do
currdir <- getCurrentDirectory
let absfile = fromMaybe whoops $ absNormPathUnix currdir file
loc <- gitAnnexLocation' key r False
- return $ relPathDirToFile (parentDir absfile) loc
+ relPathDirToFile (parentDir absfile) loc
where
whoops = error $ "unable to normalize " ++ file
diff --git a/Test.hs b/Test.hs
index 684da0d75..dd12997ff 100644
--- a/Test.hs
+++ b/Test.hs
@@ -79,9 +79,11 @@ import qualified Remote.Helper.Encryptable
import qualified Types.Crypto
import qualified Utility.Gpg
#endif
+import qualified Messages
main :: [String] -> IO ()
main ps = do
+ Messages.enableDebugOutput
let tests = testGroup "Tests"
-- Test both direct and indirect mode.
-- Windows is only going to use direct mode,
diff --git a/Utility/Path.hs b/Utility/Path.hs
index c3e893d16..7427bfe27 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -126,14 +126,19 @@ absPath file = do
- relPathCwdToFile "/tmp/foo/bar" == ""
-}
relPathCwdToFile :: FilePath -> IO FilePath
-relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f
+relPathCwdToFile f = do
+ c <- getCurrentDirectory
+ relPathDirToFile c f
-{- Constructs a relative path from a directory to a file.
- -
- - Both must be absolute, and cannot contain .. etc. (eg use absPath first).
+{- Constructs a relative path from a directory to a file. -}
+relPathDirToFile :: FilePath -> FilePath -> IO FilePath
+relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
+
+{- This requires the first path to be absolute, and the
+ - second path cannot contain ../ or ./
-}
-relPathDirToFile :: FilePath -> FilePath -> FilePath
-relPathDirToFile from to = join s $ dotdots ++ uncommon
+relPathDirToFileAbs :: FilePath -> FilePath -> FilePath
+relPathDirToFileAbs from to = join s $ dotdots ++ uncommon
where
s = [pathSeparator]
pfrom = split s from
@@ -149,7 +154,7 @@ prop_relPathDirToFile_basics from to
| from == to = null r
| otherwise = not (null r)
where
- r = relPathDirToFile from to
+ r = relPathDirToFileAbs from to
prop_relPathDirToFile_regressionTest :: Bool
prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
@@ -158,7 +163,7 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
- location, but it's not really the same directory.
- Code used to get this wrong. -}
same_dir_shortcurcuits_at_difference =
- relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])
+ relPathDirToFileAbs (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])
(joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
@@ -187,7 +192,7 @@ relHome :: FilePath -> IO String
relHome path = do
home <- myHomeDir
return $ if dirContains home path
- then "~/" ++ relPathDirToFile home path
+ then "~/" ++ relPathDirToFileAbs home path
else path
{- Checks if a command is available in PATH.
diff --git a/debian/changelog b/debian/changelog
index 908636f05..bc27fca85 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -12,6 +12,12 @@ git-annex (5.20141232) UNRELEASED; urgency=medium
* Check git version at runtime, rather than assuming it will be the same
as the git version used at build time when running git-checkattr and
git-branch remove.
+ * Switch to using relative paths to the git repository.
+ - This allows the git repository to be moved while git-annex is running in
+ it, with fewer problems.
+ - On Windows, this avoids some of the problems with the absurdly small
+ MAX_PATH of 260 bytes. In particular, git-annex repositories should
+ work in deeper/longer directory structures than before.
-- Joey Hess <id@joeyh.name> Fri, 02 Jan 2015 13:35:13 -0400