handle sync's use of setCurrentDirectory to work with relative paths

I think this is the last problimatic setCurrentDirectory. I also audited
for extrnal commands that git-annex might run with cwd = foo, and did not
find any that were passed any FilePath that might be absolute.
This commit is contained in:
Joey Hess 2015-01-06 22:23:04 -04:00
parent 676ef32547
commit 44c9714fdf
2 changed files with 14 additions and 1 deletions

View file

@ -31,6 +31,7 @@ module Annex (
changeGitRepo, changeGitRepo,
getRemoteGitConfig, getRemoteGitConfig,
withCurrentState, withCurrentState,
changeDirectory,
) where ) where
import Common import Common
@ -300,3 +301,14 @@ withCurrentState :: Annex a -> Annex (IO a)
withCurrentState a = do withCurrentState a = do
s <- getState id s <- getState id
return $ eval s a return $ eval s a
{- It's not safe to use setCurrentDirectory in the Annex monad,
- because the git repo paths are stored relative.
- Instead, use this.
-}
changeDirectory :: FilePath -> Annex ()
changeDirectory d = do
r <- liftIO . Git.adjustPath absPath =<< gitRepo
liftIO $ setCurrentDirectory d
r' <- liftIO $ Git.relPath r
changeState $ \s -> s { repo = r' }

View file

@ -29,6 +29,7 @@ import Annex.Hook
import qualified Git.Command import qualified Git.Command
import qualified Git.LsFiles as LsFiles import qualified Git.LsFiles as LsFiles
import qualified Git.Branch import qualified Git.Branch
import qualified Git.Types as Git
import qualified Git.Ref import qualified Git.Ref
import qualified Git import qualified Git
import qualified Remote.Git import qualified Remote.Git
@ -107,7 +108,7 @@ seek rs = do
- of the repo. This also means that sync always acts on all files in the - of the repo. This also means that sync always acts on all files in the
- repository, not just on a subdirectory. -} - repository, not just on a subdirectory. -}
prepMerge :: Annex () prepMerge :: Annex ()
prepMerge = liftIO . setCurrentDirectory =<< fromRepo Git.repoPath prepMerge = Annex.changeDirectory =<< fromRepo Git.repoPath
syncBranch :: Git.Ref -> Git.Ref syncBranch :: Git.Ref -> Git.Ref
syncBranch = Git.Ref.under "refs/heads/synced" . fromDirectBranch syncBranch = Git.Ref.under "refs/heads/synced" . fromDirectBranch