Merge from git-annex.

1 files changed, 76 insertions, 168 deletions

diff --git a/Utility/Path.hs b/Utility/Path.hs
index a8ab918..6bd407e 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -1,63 +1,59 @@
 {- path manipulation
  -
- - Copyright 2010-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
 
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Utility.Path (
 	simplifyPath,
-	absPathFrom,
 	parentDir,
 	upFrom,
 	dirContains,
-	absPath,
-	relPathCwdToFile,
-	relPathDirToFile,
-	relPathDirToFileAbs,
 	segmentPaths,
+	segmentPaths',
 	runSegmentPaths,
-	relHome,
+	runSegmentPaths',
 	inPath,
 	searchPath,
 	dotfile,
-	sanitizeFilePath,
 	splitShortExtensions,
-
-	prop_upFrom_basics,
-	prop_relPathDirToFile_basics,
-	prop_relPathDirToFile_regressionTest,
+	relPathDirToFileAbs,
 ) where
 
-import System.FilePath
+import System.FilePath.ByteString
+import qualified System.FilePath as P
+import qualified Data.ByteString as B
 import Data.List
 import Data.Maybe
-import Data.Char
 import Control.Applicative
 import Prelude
 
 import Utility.Monad
-import Utility.UserInfo
 import Utility.SystemDirectory
-import Utility.Split
+
+#ifdef mingw32_HOST_OS
+import Data.Char
 import Utility.FileSystemEncoding
+#endif
 
 {- Simplifies a path, removing any "." component, collapsing "dir/..", 
  - 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
+ - the input RawFilePaths. 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
+ - yeild the same result. Run both through normalise from System.RawFilePath
  - to ensure that.
  -}
-simplifyPath :: FilePath -> FilePath
+simplifyPath :: RawFilePath -> RawFilePath
 simplifyPath path = dropTrailingPathSeparator $ 
 	joinDrive drive $ joinPath $ norm [] $ splitPath path'
   where
@@ -72,134 +68,37 @@ simplifyPath path = dropTrailingPathSeparator $
 	  where
 		p' = dropTrailingPathSeparator p
 
-{- Makes a path absolute.
- -
- - Also simplifies it using simplifyPath.
- -
- - The first parameter is a base directory (ie, the cwd) to use if the path
- - is not already absolute, and should itsef be absolute.
- -
- - Does not attempt to deal with edge cases or ensure security with
- - untrusted inputs.
- -}
-absPathFrom :: FilePath -> FilePath -> FilePath
-absPathFrom dir path = simplifyPath (combine dir path)
-
 {- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -}
-parentDir :: FilePath -> FilePath
+parentDir :: RawFilePath -> RawFilePath
 parentDir = takeDirectory . dropTrailingPathSeparator
 
 {- Just the parent directory of a path, or Nothing if the path has no
-- parent (ie for "/" or ".") -}
-upFrom :: FilePath -> Maybe FilePath
+- parent (ie for "/" or "." or "foo") -}
+upFrom :: RawFilePath -> Maybe RawFilePath
 upFrom dir
 	| length dirs < 2 = Nothing
-	| otherwise = Just $ joinDrive drive $ intercalate s $ init dirs
+	| otherwise = Just $ joinDrive drive $
+		B.intercalate (B.singleton pathSeparator) $ init dirs
   where
 	-- on Unix, the drive will be "/" when the dir is absolute,
 	-- otherwise ""
 	(drive, path) = splitDrive dir
-	s = [pathSeparator]
-	dirs = filter (not . null) $ split s path
-
-prop_upFrom_basics :: FilePath -> Bool
-prop_upFrom_basics dir
-	| null dir = True
-	| dir == "/" = p == Nothing
-	| otherwise = p /= Just dir
-  where
-	p = upFrom dir
+	dirs = filter (not . B.null) $ B.splitWith isPathSeparator path
 
-{- Checks if the first FilePath is, or could be said to contain the second.
+{- Checks if the first RawFilePath is, or could be said to contain the second.
  - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
  - are all equivilant.
  -}
-dirContains :: FilePath -> FilePath -> Bool
+dirContains :: RawFilePath -> RawFilePath -> Bool
 dirContains a b = a == b
 	|| a' == b'
-	|| (addTrailingPathSeparator a') `isPrefixOf` b'
+	|| (addTrailingPathSeparator a') `B.isPrefixOf` b'
 	|| a' == "." && normalise ("." </> b') == b'
   where
 	a' = norm a
 	b' = norm b
 	norm = normalise . simplifyPath
 
-{- Converts a filename into an absolute path.
- -
- - Also simplifies it using simplifyPath.
- -
- - Unlike Directory.canonicalizePath, this does not require the path
- - already exists. -}
-absPath :: FilePath -> IO FilePath
-absPath file
-	-- Avoid unncessarily getting the current directory when the path
-	-- is already absolute. absPathFrom uses simplifyPath
-	-- so also used here for consistency.
-	| isAbsolute file = return $ simplifyPath file
-	| otherwise = do
-		cwd <- getCurrentDirectory
-		return $ absPathFrom cwd file
-
-{- Constructs a relative path from the CWD to a file.
- -
- - For example, assuming CWD is /tmp/foo/bar:
- -    relPathCwdToFile "/tmp/foo" == ".."
- -    relPathCwdToFile "/tmp/foo/bar" == "" 
- -}
-relPathCwdToFile :: FilePath -> IO FilePath
-relPathCwdToFile f = do
-	c <- getCurrentDirectory
-	relPathDirToFile c f
-
-{- Constructs a relative path from a directory to a file. -}
-relPathDirToFile :: FilePath -> FilePath -> IO FilePath
-relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
-
-{- This requires the first path to be absolute, and the
- - second path cannot contain ../ or ./
- -
- - On Windows, if the paths are on different drives,
- - a relative path is not possible and the path is simply
- - returned as-is.
- -}
-relPathDirToFileAbs :: FilePath -> FilePath -> FilePath
-relPathDirToFileAbs from to
-#ifdef mingw32_HOST_OS
-	| normdrive from /= normdrive to = to
-#endif
-	| otherwise = joinPath $ dotdots ++ uncommon
-  where
-	pfrom = sp from
-	pto = sp to
-	sp = map dropTrailingPathSeparator . splitPath . dropDrive
-	common = map fst $ takeWhile same $ zip pfrom pto
-	same (c,d) = c == d
-	uncommon = drop numcommon pto
-	dotdots = replicate (length pfrom - numcommon) ".."
-	numcommon = length common
-#ifdef mingw32_HOST_OS
-	normdrive = map toLower . takeWhile (/= ':') . takeDrive
-#endif
-
-prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
-prop_relPathDirToFile_basics from to
-	| null from || null to = True
-	| from == to = null r
-	| otherwise = not (null r)
-  where
-	r = relPathDirToFileAbs from to 
-
-prop_relPathDirToFile_regressionTest :: Bool
-prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
-  where
-	{- Two paths have the same directory component at the same
-	 - location, but it's not really the same directory.
-	 - Code used to get this wrong. -}
-	same_dir_shortcurcuits_at_difference =
-		relPathDirToFileAbs (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])
-			(joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
-				== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
-
 {- Given an original list of paths, and an expanded list derived from it,
  - which may be arbitrarily reordered, generates a list of lists, where
  - each sublist corresponds to one of the original paths.
@@ -213,30 +112,29 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
  - we stop preserving ordering at that point. Presumably a user passing
  - that many paths in doesn't care too much about order of the later ones.
  -}
-segmentPaths :: [RawFilePath] -> [RawFilePath] -> [[RawFilePath]]
-segmentPaths [] new = [new]
-segmentPaths [_] new = [new] -- optimisation
-segmentPaths (l:ls) new = found : segmentPaths ls rest
+segmentPaths :: (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[a]]
+segmentPaths = segmentPaths' (\_ r -> r)
+
+segmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[r]]
+segmentPaths' f _ [] new = [map (f Nothing) new]
+segmentPaths' f _ [i] new = [map (f (Just i)) new] -- optimisation
+segmentPaths' f c (i:is) new = 
+	map (f (Just i)) found : segmentPaths' f c is rest
   where
-	(found, rest) = if length ls < 100
-		then partition inl new
-		else break (not . inl) new
-	inl f = fromRawFilePath l `dirContains` fromRawFilePath f
+	(found, rest) = if length is < 100
+		then partition ini new
+		else break (not . ini) new
+	ini p = i `dirContains` c p
 
 {- This assumes that it's cheaper to call segmentPaths on the result,
  - than it would be to run the action separately with each path. In
  - the case of git file list commands, that assumption tends to hold.
  -}
-runSegmentPaths :: ([RawFilePath] -> IO [RawFilePath]) -> [RawFilePath] -> IO [[RawFilePath]]
-runSegmentPaths a paths = segmentPaths paths <$> a paths
+runSegmentPaths :: (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[a]]
+runSegmentPaths c a paths = segmentPaths c paths <$> a paths
 
-{- Converts paths in the home directory to use ~/ -}
-relHome :: FilePath -> IO String
-relHome path = do
-	home <- myHomeDir
-	return $ if dirContains home path
-		then "~/" ++ relPathDirToFileAbs home path
-		else path
+runSegmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[r]]
+runSegmentPaths' si c a paths = segmentPaths' si c paths <$> a paths
 
 {- Checks if a command is available in PATH.
  -
@@ -254,10 +152,10 @@ inPath command = isJust <$> searchPath command
  -}
 searchPath :: String -> IO (Maybe FilePath)
 searchPath command
-	| isAbsolute command = check command
-	| otherwise = getSearchPath >>= getM indir
+	| P.isAbsolute command = check command
+	| otherwise = P.getSearchPath >>= getM indir
   where
-	indir d = check $ d </> command
+	indir d = check $ d P.</> command
 	check f = firstM doesFileExist
 #ifdef mingw32_HOST_OS
 		[f, f ++ ".exe"]
@@ -267,42 +165,52 @@ searchPath command
 
 {- Checks if a filename is a unix dotfile. All files inside dotdirs
  - count as dotfiles. -}
-dotfile :: FilePath -> Bool
+dotfile :: RawFilePath -> Bool
 dotfile file
 	| f == "." = False
 	| f == ".." = False
 	| f == "" = False
-	| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)
+	| otherwise = "." `B.isPrefixOf` f || dotfile (takeDirectory file)
   where
 	f = takeFileName file
 
-{- Given a string that we'd like to use as the basis for FilePath, but that
- - was provided by a third party and is not to be trusted, returns the closest
- - sane FilePath.
- -
- - All spaces and punctuation and other wacky stuff are replaced
- - with '_', except for '.'
- - "../" will thus turn into ".._", which is safe.
- -}
-sanitizeFilePath :: String -> FilePath
-sanitizeFilePath = map sanitize
-  where
-	sanitize c
-		| c == '.' = c
-		| isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_'
-		| otherwise = c
-
-{- Similar to splitExtensions, but knows that some things in FilePaths
+{- Similar to splitExtensions, but knows that some things in RawFilePaths
  - after a dot are too long to be extensions. -}
-splitShortExtensions :: FilePath -> (FilePath, [String])
+splitShortExtensions :: RawFilePath -> (RawFilePath, [B.ByteString])
 splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg"
-splitShortExtensions' :: Int -> FilePath -> (FilePath, [String])
+splitShortExtensions' :: Int -> RawFilePath -> (RawFilePath, [B.ByteString])
 splitShortExtensions' maxextension = go []
   where
 	go c f
-		| len > 0 && len <= maxextension && not (null base) = 
+		| len > 0 && len <= maxextension && not (B.null base) = 
 			go (ext:c) base
 		| otherwise = (f, c)
 	  where
 		(base, ext) = splitExtension f
-		len = length ext
+		len = B.length ext
+
+{- This requires the first path to be absolute, and the
+ - second path cannot contain ../ or ./
+ -
+ - On Windows, if the paths are on different drives,
+ - a relative path is not possible and the path is simply
+ - returned as-is.
+ -}
+relPathDirToFileAbs :: RawFilePath -> RawFilePath -> RawFilePath
+relPathDirToFileAbs from to
+#ifdef mingw32_HOST_OS
+	| normdrive from /= normdrive to = to
+#endif
+	| otherwise = joinPath $ dotdots ++ uncommon
+  where
+	pfrom = sp from
+	pto = sp to
+	sp = map dropTrailingPathSeparator . splitPath . dropDrive
+	common = map fst $ takeWhile same $ zip pfrom pto
+	same (c,d) = c == d
+	uncommon = drop numcommon pto
+	dotdots = replicate (length pfrom - numcommon) ".."
+	numcommon = length common
+#ifdef mingw32_HOST_OS
+	normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive
+#endif