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.

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'
 

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.
  -

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

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

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.
+{- Makes the path to a local Repo be relative to the cwd. -}
- -
+relPath :: Repo -> IO Repo
- - On windows, prefixing a path with \\?\ makes it be processed as a raw
+relPath = adjustPath torel
- - path (/ is not converted to \). The benefit is that such a path does
+  where
- - avoids Windows's 260 byte limitation on the entire path. -}
+	torel p = do
-adjustPath :: Repo -> Repo
+		p' <- relPathCwdToFile p
-adjustPath r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = r
+		if null p'
-	{ location = l 
+			then return "."
-		{ gitdir = adjustPath' d
+			else return p'
-		, worktree = fmap adjustPath' w
-		}
-	}
-adjustPath r@(Repo { location = LocalUnknown d }) = 
-	r { location = LocalUnknown (adjustPath' d) }
-adjustPath r = r
 
-adjustPath' :: FilePath -> FilePath
+{- Adusts the path to a local Repo using the provided function. -}
-#if mingw32_HOST_OS
+adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo
-adjustPath' d = "\\\\?\\" ++ d
+adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do
-#else
+	d' <- f d
-adjustPath' = id
+	w' <- maybe (pure Nothing) (Just <$$> f) w
-#endif
+	return $ r 
+		{ location = l 
+			{ gitdir = d'
+			, worktree = w'
+			}
+		}
+adjustPath f r@(Repo { location = LocalUnknown d }) = do
+	d' <- f d
+	return $ r { location = LocalUnknown d' }
+adjustPath _ r = pure r

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

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

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 <$>
+toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file
-	relPathDirToFile (repoPath repo) <$> absPath file
 
 {- The input FilePath must already be relative to the top of the git
  - repository -}

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)

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
+getAllRefs r = getAllRefs' (localGitDir r </> "refs")
-  where
+
-	refdir = localGitDir r </> "refs"
+getAllRefs' :: FilePath -> IO [Ref]
-	toref = Ref . relPathDirToFile (localGitDir r)
+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

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.
+ - based on a git repository should return full path relative to the git
- - Everything else should use relative paths.
+ - 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
 

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,

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.
+{- Constructs a relative path from a directory to a file. -}
- -
+relPathDirToFile :: FilePath -> FilePath -> IO FilePath
- - Both must be absolute, and cannot contain .. etc. (eg use absPath first).
+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
+relPathDirToFileAbs :: FilePath -> FilePath -> FilePath
-relPathDirToFile from to = join s $ dotdots ++ uncommon
+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.

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