diff options
| -rw-r--r-- | Commands.hs | 25 | ||||
| -rw-r--r-- | Locations.hs | 5 | ||||
| -rw-r--r-- | Utility.hs | 48 |
3 files changed, 61 insertions, 17 deletions
diff --git a/Commands.hs b/Commands.hs index aed3a19d3..a403a5a48 100644 --- a/Commands.hs +++ b/Commands.hs @@ -6,6 +6,7 @@ import System.Console.GetOpt import Control.Monad.State (liftIO) import System.Posix.Files import System.Directory +import System.Path import Data.String.Utils import List import IO @@ -66,13 +67,14 @@ defaultCmd file = do addCmd :: FilePath -> Annex () addCmd file = inBackend file err $ do liftIO $ checkLegal file - stored <- Backend.storeFileKey file g <- Annex.gitRepo + link <- liftIO $ calcGitLink file g + stored <- Backend.storeFileKey file case (stored) of Nothing -> error $ "no backend could store: " ++ file Just (key, backend) -> do logStatus key ValuePresent - liftIO $ setup g key + liftIO $ setup g key link where err = error $ "already annexed " ++ file checkLegal file = do @@ -80,24 +82,21 @@ addCmd file = inBackend file err $ do if ((isSymbolicLink s) || (not $ isRegularFile s)) then error $ "not a regular file: " ++ file else return () - setup g key = do + calcGitLink file g = do + cwd <- getCurrentDirectory + let absfile = case (absNormPath cwd file) of + Just f -> f + Nothing -> error $ "unable to normalize " ++ file + return $ relPathDirToDir (parentDir absfile) (Git.workTree g) + setup g key link = do let dest = annexLocation g key let reldest = annexLocationRelative g key createDirectoryIfMissing True (parentDir dest) renameFile file dest - createSymbolicLink ((linkTarget file) ++ reldest) file + createSymbolicLink (link ++ reldest) file Git.run g ["add", file] Git.run g ["commit", "-m", ("git-annex annexed " ++ file), file] - linkTarget file = - -- relies on file being relative to the top of the - -- git repo; just replace each subdirectory with ".." - if (subdirs > 0) - then (join "/" $ take subdirs $ repeat "..") ++ "/" - else "" - where - subdirs = (length $ split "/" file) - 1 - {- Inverse of addCmd. -} unannexCmd :: FilePath -> Annex () diff --git a/Locations.hs b/Locations.hs index 960a8938d..733e74553 100644 --- a/Locations.hs +++ b/Locations.hs @@ -31,10 +31,9 @@ annexLocation :: Git.Repo -> Key -> FilePath annexLocation r key = (Git.workTree r) ++ "/" ++ (annexLocationRelative r key) -{- Annexed file's location relative to the gitWorkTree -} +{- Annexed file's location relative to git's working tree. -} annexLocationRelative :: Git.Repo -> Key -> FilePath -annexLocationRelative r key = - Git.dir r ++ "/annex/" ++ (keyFile key) +annexLocationRelative r key = Git.dir r ++ "/annex/" ++ (keyFile key) {- Converts a key into a filename fragment. - diff --git a/Utility.hs b/Utility.hs index 349dd9355..a8324815e 100644 --- a/Utility.hs +++ b/Utility.hs @@ -4,12 +4,16 @@ module Utility ( withFileLocked, hGetContentsStrict, - parentDir + parentDir, + relPathCwdToDir, + relPathDirToDir, ) where import System.IO import System.Posix.IO import Data.String.Utils +import System.Path +import System.Directory {- Let's just say that Haskell makes reading/writing a file with - file locking excessively difficult. -} @@ -39,3 +43,45 @@ parentDir dir = where dirs = filter (\x -> length x > 0) $ split "/" dir absolute = if ((dir !! 0) == '/') then "/" else "" + +{- Constructs a relative path from the CWD to a directory. + - + - For example, assuming CWD is /tmp/foo/bar: + - relPathCwdToDir "/tmp/foo" == "../" + - relPathCwdToDir "/tmp/foo/bar" == "" + - relPathCwdToDir "/tmp/foo/bar" == "" + -} +relPathCwdToDir :: FilePath -> IO FilePath +relPathCwdToDir dir = do + cwd <- getCurrentDirectory + let absdir = abs cwd dir + return $ relPathDirToDir cwd absdir + where + -- absolute, normalized form of the directory + abs cwd dir = + case (absNormPath cwd dir) of + Just d -> d + Nothing -> error $ "unable to normalize " ++ dir + +{- Constructs a relative path from one directory to another. + - + - Both directories must be absolute, and normalized (eg with absNormpath). + - + - The path will end with "/", unless it is empty. + - -} +relPathDirToDir :: FilePath -> FilePath -> FilePath +relPathDirToDir from to = + if (0 < length path) + then if (endswith "/" path) + then path + else path ++ "/" + else "" + where + pfrom = split "/" from + pto = split "/" to + common = map fst $ filter same $ zip pfrom pto + same (c,d) = c == d + uncommon = drop numcommon pto + dotdots = take ((length pfrom) - numcommon) $ repeat ".." + numcommon = length $ common + path = join "/" $ dotdots ++ uncommon |