diff options
| -rw-r--r-- | Annex.hs | 2 | ||||
| -rw-r--r-- | Annex/Branch.hs | 2 | ||||
| -rw-r--r-- | Annex/Content/Direct.hs | 2 | ||||
| -rw-r--r-- | Annex/Direct.hs | 13 | ||||
| -rw-r--r-- | Command/Status.hs | 4 | ||||
| -rw-r--r-- | Git.hs | 28 | ||||
| -rw-r--r-- | Git/CheckAttr.hs | 2 | ||||
| -rw-r--r-- | Git/Command.hs | 2 | ||||
| -rw-r--r-- | Git/Construct.hs | 2 | ||||
| -rw-r--r-- | Git/FilePath.hs | 3 | ||||
| -rw-r--r-- | Git/HashObject.hs | 2 | ||||
| -rw-r--r-- | Git/LsFiles.hs | 4 | ||||
| -rw-r--r-- | Git/Repair.hs | 11 | ||||
| -rw-r--r-- | Locations.hs | 8 | ||||
| -rw-r--r-- | Test.hs | 2 | ||||
| -rw-r--r-- | Utility/Path.hs | 23 | ||||
| -rw-r--r-- | debian/changelog | 6 | ||||
| -rwxr-xr-x | standalone/windows/build.sh | 3 |
18 files changed, 83 insertions, 36 deletions
@@ -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.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/Branch.hs b/Annex/Branch.hs index c567db554..f5c490212 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -334,7 +334,7 @@ withIndex :: Annex a -> Annex a withIndex = withIndex' False withIndex' :: Bool -> Annex a -> Annex a withIndex' bootstrapping a = do - f <- fromRepo gitAnnexIndex + f <- liftIO . absPath =<< fromRepo gitAnnexIndex withIndexFile f $ do checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do unless bootstrapping create diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs index a2df9f6d3..43defdca3 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.hs b/Annex/Direct.hs index 6292f027f..710227e7e 100644 --- a/Annex/Direct.hs +++ b/Annex/Direct.hs @@ -160,8 +160,8 @@ addDirect file cache = do -} mergeDirect :: Maybe Git.Ref -> Maybe Git.Ref -> Git.Branch -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool mergeDirect startbranch oldref branch resolvemerge commitmode = exclusively $ do - reali <- fromRepo indexFile - tmpi <- fromRepo indexFileLock + reali <- liftIO . absPath =<< fromRepo indexFile + tmpi <- liftIO . absPath =<< fromRepo indexFileLock liftIO $ copyFile reali tmpi d <- fromRepo gitAnnexMergeDir @@ -198,9 +198,12 @@ stageMerge d branch commitmode = do merger <- ifM (coreSymlinks <$> Annex.getGitConfig) ( return Git.Merge.stageMerge , return $ \ref -> Git.Merge.mergeNonInteractive ref commitmode - ) - inRepo $ \g -> merger branch $ - g { location = Local { gitdir = Git.localGitDir g, worktree = Just d } } + ) + inRepo $ \g -> do + wd <- liftIO $ absPath d + gd <- liftIO $ absPath $ Git.localGitDir g + merger branch $ + g { location = Local { gitdir = gd, worktree = Just (addTrailingPathSeparator wd) } } {- Commits after a direct mode merge is complete, and after the work - tree has been updated by mergeDirectCleanup. 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 @@ -30,6 +30,8 @@ module Git ( attributes, hookPath, assertLocal, + adjustPath, + relPath, ) where import Network.URI (uriPath, uriScheme, unEscapeString) @@ -139,3 +141,29 @@ hookPath script repo = do #else isexecutable f = isExecutable . fileMode <$> getFileStatus f #endif + +{- 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 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/Construct.hs b/Git/Construct.hs index 3c6013ac1..0b926342f 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -153,7 +153,7 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir - fromAbsPath $ repoPath repo </> dir' + fromPath $ repoPath repo </> dir' {- Git remotes can have a directory that is specified relative - to the user's home directory, or that contains tilde expansions. 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/HashObject.hs b/Git/HashObject.hs index 97e1befe6..8cd35167d 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -32,7 +32,7 @@ hashObjectStop = CoProcess.stop hashFile :: HashObjectHandle -> FilePath -> IO Sha hashFile h file = CoProcess.query h send receive where - send to = hPutStrLn to file + send to = hPutStrLn to =<< absPath file receive from = getSha "hash-object" $ hGetLine from {- Injects a blob into git. Unfortunately, the current git-hash-object 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 573113883..2930b9a0c 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 5ebbbd631..02758eb05 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 (takeDirectory absfile) loc + relPathDirToFile (takeDirectory absfile) loc where whoops = error $ "unable to normalize " ++ file @@ -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 7f0349125..cc6c35485 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -124,14 +124,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 @@ -147,7 +152,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 @@ -156,7 +161,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"] @@ -185,7 +190,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 40a0a6707..df55fb468 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. * Generate shorter keys for WORM and URL, avoiding keys that are longer than used for SHA256, so as to not break on systems like Windows that have very small maximum path length limits. diff --git a/standalone/windows/build.sh b/standalone/windows/build.sh index a40151b95..09161c569 100755 --- a/standalone/windows/build.sh +++ b/standalone/windows/build.sh @@ -73,7 +73,8 @@ ghc --make Build/BuildVersion.hs Build/BuildVersion > dist/build-version # Test git-annex -# (doesn't currently work well on autobuilder, reason unknown) +# The test is run in c:/WINDOWS/Temp, because running it in the autobuilder +# directory runs afoul of Windows's short PATH_MAX. PATH="$(pwd)/dist/build/git-annex/:$PATH" export PATH mkdir -p c:/WINDOWS/Temp/git-annex-test/ |