diff options
| -rw-r--r-- | Command/Fsck.hs | 9 | ||||
| -rw-r--r-- | Command/Move.hs | 8 | ||||
| -rw-r--r-- | Content.hs | 16 | ||||
| -rw-r--r-- | GitRepo.hs | 35 | ||||
| -rw-r--r-- | debian/changelog | 2 |
5 files changed, 43 insertions, 27 deletions
diff --git a/Command/Fsck.hs b/Command/Fsck.hs index bedb9fb99..20ef2c808 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -64,11 +64,11 @@ verifyLocationLog key file = do case (present, u `elem` uuids) of (True, False) -> do - fix g u ValuePresent + fix u ValuePresent -- There is no data loss, so do not fail. return True (False, True) -> do - fix g u ValueMissing + fix u ValueMissing warning $ "** Based on the location log, " ++ file ++ "\n** was expected to be present, " ++ @@ -77,7 +77,6 @@ verifyLocationLog key file = do _ -> return True where - fix g u s = do + fix u s = do showNote "fixing location log" - _ <- liftIO $ logChange g key u s - return () + logStatusFor u key s diff --git a/Command/Move.hs b/Command/Move.hs index e5e78d249..476bf866a 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -7,19 +7,15 @@ module Command.Move where -import Control.Monad.State (liftIO) - import Command import qualified Command.Drop import qualified Annex -import qualified AnnexQueue import LocationLog import Types import Content import qualified Remote import UUID import Messages -import Utility command :: [Command] command = [repoCommand "move" paramPath seek @@ -57,10 +53,8 @@ showAction False file = showStart "copy" file - for bare repos. -} remoteHasKey :: Remote.Remote Annex -> Key -> Bool -> Annex () remoteHasKey remote key present = do - g <- Annex.gitRepo let remoteuuid = Remote.uuid remote - logfile <- liftIO $ logChange g key remoteuuid status - AnnexQueue.add "add" [Param "--"] logfile + logStatusFor remoteuuid key status where status = if present then ValuePresent else ValueMissing diff --git a/Content.hs b/Content.hs index 576eecb31..bf9456221 100644 --- a/Content.hs +++ b/Content.hs @@ -9,6 +9,7 @@ module Content ( inAnnex, calcGitLink, logStatus, + logStatusFor, getViaTmp, getViaTmpUnchecked, checkDiskSpace, @@ -61,7 +62,8 @@ calcGitLink file key = do return $ relPathDirToFile (parentDir absfile) (Git.workTree g) </> ".git" </> annexLocation key -{- Updates the LocationLog when a key's presence changes. +{- Updates the LocationLog when a key's presence changes in the current + - repository. - - Note that the LocationLog is not updated in bare repositories. - Operations that change a bare repository should be done from @@ -70,10 +72,18 @@ calcGitLink file key = do logStatus :: Key -> LogStatus -> Annex () logStatus key status = do g <- Annex.gitRepo + u <- getUUID g + logStatusFor u key status + +{- Updates the LocationLog when a key's presence changes in a repository + - identified by UUID. -} +logStatusFor :: UUID -> Key -> LogStatus -> Annex () +logStatusFor u key status = do + g <- Annex.gitRepo unless (Git.repoIsLocalBare g) $ do - u <- getUUID g logfile <- liftIO $ logChange g key u status - AnnexQueue.add "add" [Param "--"] logfile + rellogfile <- liftIO $ Git.workTreeFile g logfile + AnnexQueue.add "add" [Param "--"] rellogfile {- Runs an action, passing it a temporary filename to download, - and if the action succeeds, moves the temp file into diff --git a/GitRepo.hs b/GitRepo.hs index 3e177cf1b..2bf320eda 100644 --- a/GitRepo.hs +++ b/GitRepo.hs @@ -21,8 +21,8 @@ module GitRepo ( repoDescribe, repoLocation, workTree, + workTreeFile, gitDir, - relative, urlPath, urlHost, urlPort, @@ -59,7 +59,7 @@ module GitRepo ( prop_idempotent_deencode ) where -import Control.Monad (unless, when) +import Control.Monad (unless) import System.Directory import System.FilePath import System.Posix.Directory @@ -236,27 +236,38 @@ workTree r@(Repo { location = Url _ }) = urlPath r workTree (Repo { location = Dir d }) = d workTree Repo { location = Unknown } = undefined -{- Given a relative or absolute filename in a repository, calculates the - - name to use to refer to the file relative to a git repository's top. - - This is the same form displayed and used by git. -} -relative :: Repo -> FilePath -> IO FilePath -relative repo@(Repo { location = Dir d }) file = do +{- Given a relative or absolute filename inside a git repository's + - workTree, calculates the name to use to refer to that file to git. + - + - This is complicated because the best choice can vary depending on + - whether the cwd is in a subdirectory of the git repository, or not. + - + - For example, when adding a file "/tmp/repo/foo", it's best to refer + - to it as "foo" if the cwd is outside the repository entirely + - (this avoids a gotcha with using the full path name when /tmp/repo + - is itself a symlink). But, if the cwd is "/tmp/repo/subdir", + - it's best to refer to "../foo". + -} +workTreeFile :: Repo -> FilePath -> IO FilePath +workTreeFile repo@(Repo { location = Dir d }) file = do cwd <- getCurrentDirectory let file' = absfile cwd - let len = length absrepo - when (take len file' /= absrepo) $ + unless (inrepo file') $ error $ file ++ " is not located inside git repository " ++ absrepo - return $ drop (length absrepo) file' + if (inrepo $ addTrailingPathSeparator cwd) + then return $ relPathDirToFile cwd file' + else return $ drop (length absrepo) file' where -- normalize both repo and file, so that repo -- will be substring of file absrepo = case (absNormPath "/" d) of - Just f -> f ++ "/" + Just f -> addTrailingPathSeparator f Nothing -> error $ "bad repo" ++ repoDescribe repo absfile c = case (secureAbsNormPath c file) of Just f -> f Nothing -> file -relative repo _ = assertLocal repo $ error "internal" + inrepo f = absrepo `isPrefixOf` f +workTreeFile repo _ = assertLocal repo $ error "internal" {- Path of an URL repo. -} urlPath :: Repo -> String diff --git a/debian/changelog b/debian/changelog index 872277d0f..c6dfb1ff3 100644 --- a/debian/changelog +++ b/debian/changelog @@ -4,6 +4,8 @@ git-annex (0.20110421) UNRELEASED; urgency=low * Remove testpack from build depends, as it is not available on all architectures. The test suite will not be run if it cannot be compiled. + * Avoid using absolute paths when staging location log, as that can + confuse git when a remote's path contains a symlink. Closes: #621386 -- Joey Hess <joeyh@debian.org> Thu, 21 Apr 2011 16:35:27 -0400 |