eliminating absNormPath

git-annex has been using MissingH's `abdNormPath` forever, but that's
unmaintained and possibly buggy, and doesn't work on Windows. I've been
wanting to get rid of it for some time, and finally did today, writing a
`simplifyPath` that does the things git-annex needs and will work with all
the Windows filename craziness, and takes advantage of the more modern
System.FilePath to be quite a simple peice of code. A QuickCheck test found
no important divergences from absNormPath. A good first step to making
git-annex not depend on MissingH at all.

And it fixed some weird behaviors on Windows like
`git annex add ..\subdir\file` not working.

Note that absNormPathUnix has been left alone for now.

1 files changed, 37 insertions, 25 deletions

diff --git a/Utility/Path.hs b/Utility/Path.hs
index 27f39d3e5..2bcd110d8 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -1,6 +1,6 @@
 {- path manipulation
  -
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -28,22 +28,42 @@ import qualified "MissingH" System.Path as MissingH
 import Utility.Monad
 import Utility.UserInfo
 
-{- Makes a path absolute if it's not already.
+{- Simplifies a path, removing any ".." or ".", and removing the trailing
+ - path separator.
+ -
+ - On Windows, preserves whichever style of path separator might be used in
+ - the input FilePaths. This is done because some programs in Windows
+ - demand a particular path separator -- and which one actually varies!
+ -
+ - This does not guarantee that two paths that refer to the same location,
+ - and are both relative to the same location (or both absolute) will
+ - yeild the same result. Run both through normalise from System.FilePath
+ - to ensure that.
+ -}
+simplifyPath :: FilePath -> FilePath
+simplifyPath path = dropTrailingPathSeparator $ 
+	joinDrive drive $ joinPath $ norm [] $ splitPath path'
+  where
+	(drive, path') = splitDrive path
+
+	norm c [] = reverse c
+	norm c (p:ps)
+		| p' == ".." = norm (drop 1 c) ps
+		| p' == "." = norm c ps
+		| otherwise = norm (p:c) ps
+	  where
+		p' = dropTrailingPathSeparator p
+
+{- Makes a path absolute.
+ -
  - The first parameter is a base directory (ie, the cwd) to use if the path
  - is not already absolute.
  -
- - On Unix, collapses and normalizes ".." etc in the path. May return Nothing
- - if the path cannot be normalized.
- -
- - MissingH's absNormPath does not work on Windows, so on Windows
- - no normalization is done.
+ - Does not attempt to deal with edge cases or ensure security with
+ - untrusted inputs.
  -}
-absNormPath :: FilePath -> FilePath -> Maybe FilePath
-#ifndef mingw32_HOST_OS
-absNormPath dir path = MissingH.absNormPath dir path
-#else
-absNormPath dir path = Just $ combine dir path
-#endif
+absPathFrom :: FilePath -> FilePath -> FilePath
+absPathFrom dir path = simplifyPath (combine dir path)
 
 {- On Windows, this converts the paths to unix-style, in order to run
  - MissingH's absNormPath on them. Resulting path will use / separators. -}
@@ -55,7 +75,6 @@ absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos
   where
 	fromdos = replace "\\" "/"
 	todos = replace "/" "\\"
-
 #endif
 
 {- Returns the parent directory of a path.
@@ -85,13 +104,13 @@ prop_parentDir_basics dir
  - are all equivilant.
  -}
 dirContains :: FilePath -> FilePath -> Bool
-dirContains a b = a == b || a' == b' || (a'++[pathSeparator]) `isPrefixOf` b'
+dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b'
   where
-	norm p = fromMaybe "" $ absNormPath p "."
 	a' = norm a
 	b' = norm b
+	norm = normalise . simplifyPath
 
-{- Converts a filename into a normalized, absolute path.
+{- Converts a filename into an absolute path.
  -
  - Unlike Directory.canonicalizePath, this does not require the path
  - already exists. -}
@@ -100,13 +119,6 @@ absPath file = do
 	cwd <- getCurrentDirectory
 	return $ absPathFrom cwd file
 
-{- Converts a filename into a normalized, absolute path
- - from the specified cwd. -}
-absPathFrom :: FilePath -> FilePath -> FilePath
-absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file
-  where
-	bad = error $ "unable to normalize " ++ file
-
 {- Constructs a relative path from the CWD to a file.
  -
  - For example, assuming CWD is /tmp/foo/bar:
@@ -118,7 +130,7 @@ relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f
 
 {- Constructs a relative path from a directory to a file.
  -
- - Both must be absolute, and normalized (eg with absNormpath).
+ - Both must be absolute, and cannot contain .. etc. (eg use absPath first).
  -}
 relPathDirToFile :: FilePath -> FilePath -> FilePath
 relPathDirToFile from to = join s $ dotdots ++ uncommon