Merge from git-annex.

1 files changed, 93 insertions, 0 deletions

diff --git a/Utility/Path/AbsRel.hs b/Utility/Path/AbsRel.hs
new file mode 100644
index 0000000..0026bd6
--- /dev/null
+++ b/Utility/Path/AbsRel.hs
@@ -0,0 +1,93 @@
+{- absolute and relative path manipulation
+ -
+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Path.AbsRel (
+	absPathFrom,
+	absPath,
+	relPathCwdToFile,
+	relPathDirToFile,
+	relPathDirToFileAbs,
+	relHome,
+) where
+
+import System.FilePath.ByteString
+#ifdef mingw32_HOST_OS
+import System.Directory (getCurrentDirectory)
+#else
+import System.Posix.Directory.ByteString (getWorkingDirectory)
+#endif
+import Control.Applicative
+import Prelude
+
+import Utility.Path
+import Utility.UserInfo
+import Utility.FileSystemEncoding
+
+{- 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 :: RawFilePath -> RawFilePath -> RawFilePath
+absPathFrom dir path = simplifyPath (combine dir path)
+
+{- Converts a filename into an absolute path.
+ -
+ - Also simplifies it using simplifyPath.
+ -
+ - Unlike Directory.canonicalizePath, this does not require the path
+ - already exists. -}
+absPath :: RawFilePath -> IO RawFilePath
+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
+#ifdef mingw32_HOST_OS
+		cwd <- toRawFilePath <$> getCurrentDirectory
+#else
+		cwd <- getWorkingDirectory
+#endif
+		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 :: RawFilePath -> IO RawFilePath
+relPathCwdToFile f = do
+#ifdef mingw32_HOST_OS
+	c <- toRawFilePath <$> getCurrentDirectory
+#else
+	c <- getWorkingDirectory
+#endif
+	relPathDirToFile c f
+
+{- Constructs a relative path from a directory to a file. -}
+relPathDirToFile :: RawFilePath -> RawFilePath -> IO RawFilePath
+relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
+
+{- Converts paths in the home directory to use ~/ -}
+relHome :: FilePath -> IO String
+relHome path = do
+	let path' = toRawFilePath path
+	home <- toRawFilePath <$> myHomeDir
+	return $ if dirContains home path'
+		then fromRawFilePath ("~/" <> relPathDirToFileAbs home path')
+		else path