From a45c6f8173910364b69d77c1765cd7afd1431028 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 7 Feb 2014 17:10:51 -0400 Subject: 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. --- Test.hs | 4 ---- Utility/Path.hs | 62 ++++++++++++++++++++++++++++++++++----------------------- 2 files changed, 37 insertions(+), 29 deletions(-) diff --git a/Test.hs b/Test.hs index 0fba72eb2..7cbf6dbfd 100644 --- a/Test.hs +++ b/Test.hs @@ -1071,14 +1071,10 @@ test_add_subdirs env = intmpclonerepo env $ do l <- annexeval $ encodeW8 . L.unpack <$> Annex.CatFile.catObject (Git.Types.Ref "HEAD:dir/foo") "../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l) -#ifndef mingw32_HOST_OS - {- This does not work on Windows, for whatever reason. -} createDirectory "dir2" writeFile ("dir2" "foo") $ content annexedfile setCurrentDirectory "dir" git_annex env "add" [".." "dir2"] @? "add of ../subdir failed" -#endif - -- This is equivilant to running git-annex, but it's all run in-process -- (when the OS allows) so test coverage collection works. 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 + - Copyright 2010-2014 Joey Hess - - 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 -- cgit v1.2.3