relative link fix

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 ()

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

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