got configure working after Utility.Path ByteString conversion
Had to split out some modules because getWorkingDirectory needs unix, which is not a build-dep of configure. This commit was sponsored by Brock Spratlen on Patreon.
This commit is contained in:
Joey Hess
parent
e219aadbab
commit
d6e94a6b2e
10 changed files with 301 additions and 231 deletions
|
|
@ -39,7 +39,7 @@ fdoDesktopMenu command = genDesktopEntry
|
|||
|
||||
installIcon :: FilePath -> FilePath -> IO ()
|
||||
installIcon src dest = do
|
||||
createDirectoryIfMissing True (parentDir dest)
|
||||
createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath dest)))
|
||||
withBinaryFile src ReadMode $ \hin ->
|
||||
withBinaryFile dest WriteMode $ \hout ->
|
||||
hGetContents hin >>= hPutStr hout
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@ import Utility.FreeDesktop
|
|||
import Utility.Path
|
||||
import Utility.Monad
|
||||
import Utility.Directory
|
||||
import Utility.FileSystemEncoding
|
||||
import Config.Files
|
||||
import Utility.OSX
|
||||
import Assistant.Install.AutoStart
|
||||
|
|
@ -77,7 +78,7 @@ install command = do
|
|||
( return ()
|
||||
, do
|
||||
programfile <- inDestDir =<< programFile
|
||||
createDirectoryIfMissing True (parentDir programfile)
|
||||
createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath programfile)))
|
||||
writeFile programfile command
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -22,40 +22,6 @@ userConfigFile file = do
|
|||
autoStartFile :: IO FilePath
|
||||
autoStartFile = userConfigFile "autostart"
|
||||
|
||||
{- Returns anything listed in the autostart file (which may not exist). -}
|
||||
readAutoStartFile :: IO [FilePath]
|
||||
readAutoStartFile = do
|
||||
f <- autoStartFile
|
||||
filter valid . nub . map dropTrailingPathSeparator . lines
|
||||
<$> catchDefaultIO "" (readFile f)
|
||||
where
|
||||
-- Ignore any relative paths; some old buggy versions added eg "."
|
||||
valid = isAbsolute
|
||||
|
||||
modifyAutoStartFile :: ([FilePath] -> [FilePath]) -> IO ()
|
||||
modifyAutoStartFile func = do
|
||||
dirs <- readAutoStartFile
|
||||
let dirs' = nubBy equalFilePath $ func dirs
|
||||
when (dirs' /= dirs) $ do
|
||||
f <- autoStartFile
|
||||
createDirectoryIfMissing True (parentDir f)
|
||||
viaTmp writeFile f $ unlines dirs'
|
||||
|
||||
{- Adds a directory to the autostart file. If the directory is already
|
||||
- present, it's moved to the top, so it will be used as the default
|
||||
- when opening the webapp. -}
|
||||
addAutoStartFile :: FilePath -> IO ()
|
||||
addAutoStartFile path = do
|
||||
path' <- absPath path
|
||||
modifyAutoStartFile $ (:) path'
|
||||
|
||||
{- Removes a directory from the autostart file. -}
|
||||
removeAutoStartFile :: FilePath -> IO ()
|
||||
removeAutoStartFile path = do
|
||||
path' <- absPath path
|
||||
modifyAutoStartFile $
|
||||
filter (not . equalFilePath path')
|
||||
|
||||
{- The path to git-annex is written here; which is useful when something
|
||||
- has installed it to some awful non-PATH location. -}
|
||||
programFile :: IO FilePath
|
||||
|
|
|
|||
50
Config/Files/AutoStart.hs
Normal file
50
Config/Files/AutoStart.hs
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
{- git-annex autostart file
|
||||
-
|
||||
- Copyright 2012-2019 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-tabs #-}
|
||||
|
||||
module Config.Files.AutoStart where
|
||||
|
||||
import Common
|
||||
import Config.Files
|
||||
import Utility.Tmp
|
||||
import Utility.FreeDesktop
|
||||
import Utility.Directory.AbsRel
|
||||
|
||||
{- Returns anything listed in the autostart file (which may not exist). -}
|
||||
readAutoStartFile :: IO [FilePath]
|
||||
readAutoStartFile = do
|
||||
f <- autoStartFile
|
||||
filter valid . nub . map dropTrailingPathSeparator . lines
|
||||
<$> catchDefaultIO "" (readFile f)
|
||||
where
|
||||
-- Ignore any relative paths; some old buggy versions added eg "."
|
||||
valid = isAbsolute
|
||||
|
||||
modifyAutoStartFile :: ([FilePath] -> [FilePath]) -> IO ()
|
||||
modifyAutoStartFile func = do
|
||||
dirs <- readAutoStartFile
|
||||
let dirs' = nubBy equalFilePath $ func dirs
|
||||
when (dirs' /= dirs) $ do
|
||||
f <- autoStartFile
|
||||
createDirectoryIfMissing True (parentDir f)
|
||||
viaTmp writeFile f $ unlines dirs'
|
||||
|
||||
{- Adds a directory to the autostart file. If the directory is already
|
||||
- present, it's moved to the top, so it will be used as the default
|
||||
- when opening the webapp. -}
|
||||
addAutoStartFile :: FilePath -> IO ()
|
||||
addAutoStartFile path = do
|
||||
path' <- absPath path
|
||||
modifyAutoStartFile $ (:) path'
|
||||
|
||||
{- Removes a directory from the autostart file. -}
|
||||
removeAutoStartFile :: FilePath -> IO ()
|
||||
removeAutoStartFile path = do
|
||||
path' <- absPath path
|
||||
modifyAutoStartFile $
|
||||
filter (not . equalFilePath path')
|
||||
4
Test.hs
4
Test.hs
|
|
@ -188,8 +188,8 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" $
|
|||
, testProperty "prop_isomorphic_configEscape" Logs.Remote.prop_isomorphic_configEscape
|
||||
, testProperty "prop_parse_show_Config" Logs.Remote.prop_parse_show_Config
|
||||
, testProperty "prop_upFrom_basics" Utility.Path.prop_upFrom_basics
|
||||
, testProperty "prop_relPathDirToFile_basics" Utility.Path.prop_relPathDirToFile_basics
|
||||
, testProperty "prop_relPathDirToFile_regressionTest" Utility.Path.prop_relPathDirToFile_regressionTest
|
||||
, testProperty "prop_relPathDirToFileAbs_basics" Utility.Path.prop_relPathDirToFileAbs_basics
|
||||
, testProperty "prop_relPathDirToFileAbs_regressionTest" Utility.Path.prop_relPathDirToFileAbs_regressionTest
|
||||
, testProperty "prop_cost_sane" Config.Cost.prop_cost_sane
|
||||
, testProperty "prop_matcher_sane" Utility.Matcher.prop_matcher_sane
|
||||
, testProperty "prop_HmacSha1WithCipher_sane" Crypto.prop_HmacSha1WithCipher_sane
|
||||
|
|
|
|||
|
|
@ -18,7 +18,6 @@ import Control.Monad
|
|||
import System.FilePath
|
||||
import System.PosixCompat.Files
|
||||
import Control.Applicative
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.IfElse
|
||||
import System.IO.Unsafe (unsafeInterleaveIO)
|
||||
import System.IO.Error
|
||||
|
|
@ -30,12 +29,10 @@ import Utility.SafeCommand
|
|||
#endif
|
||||
|
||||
import Utility.SystemDirectory
|
||||
import Utility.Path
|
||||
import Utility.Tmp
|
||||
import Utility.Exception
|
||||
import Utility.Monad
|
||||
import Utility.Applicative
|
||||
import Utility.PartialPrelude
|
||||
|
||||
dirCruft :: FilePath -> Bool
|
||||
dirCruft "." = True
|
||||
|
|
@ -157,74 +154,3 @@ nukeFile file = void $ tryWhenExists go
|
|||
#else
|
||||
go = removeFile file
|
||||
#endif
|
||||
|
||||
{- Like createDirectoryIfMissing True, but it will only create
|
||||
- missing parent directories up to but not including the directory
|
||||
- in the first parameter.
|
||||
-
|
||||
- For example, createDirectoryUnder "/tmp/foo" "/tmp/foo/bar/baz"
|
||||
- will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist,
|
||||
- it will throw an exception.
|
||||
-
|
||||
- The exception thrown is the same that createDirectory throws if the
|
||||
- parent directory does not exist.
|
||||
-
|
||||
- If the second FilePath is not under the first
|
||||
- FilePath (or the same as it), it will fail with an exception
|
||||
- even if the second FilePath's parent directory already exists.
|
||||
-
|
||||
- Either or both of the FilePaths can be relative, or absolute.
|
||||
- They will be normalized as necessary.
|
||||
-
|
||||
- Note that, the second FilePath, if relative, is relative to the current
|
||||
- working directory, not to the first FilePath.
|
||||
-}
|
||||
createDirectoryUnder :: FilePath -> FilePath -> IO ()
|
||||
createDirectoryUnder topdir dir =
|
||||
createDirectoryUnder' topdir dir createDirectory
|
||||
|
||||
createDirectoryUnder'
|
||||
:: (MonadIO m, MonadCatch m)
|
||||
=> FilePath
|
||||
-> FilePath
|
||||
-> (FilePath -> m ())
|
||||
-> m ()
|
||||
createDirectoryUnder' topdir dir0 mkdir = do
|
||||
p <- liftIO $ relPathDirToFile topdir dir0
|
||||
let dirs = splitDirectories p
|
||||
-- Catch cases where the dir is not beneath the topdir.
|
||||
-- If the relative path between them starts with "..",
|
||||
-- it's not. And on Windows, if they are on different drives,
|
||||
-- the path will not be relative.
|
||||
if headMaybe dirs == Just ".." || isAbsolute p
|
||||
then liftIO $ ioError $ customerror userErrorType
|
||||
("createDirectoryFrom: not located in " ++ topdir)
|
||||
-- If dir0 is the same as the topdir, don't try to create
|
||||
-- it, but make sure it does exist.
|
||||
else if null dirs
|
||||
then liftIO $ unlessM (doesDirectoryExist topdir) $
|
||||
ioError $ customerror doesNotExistErrorType
|
||||
"createDirectoryFrom: does not exist"
|
||||
else createdirs $
|
||||
map (topdir </>) (reverse (scanl1 (</>) dirs))
|
||||
where
|
||||
customerror t s = mkIOError t s Nothing (Just dir0)
|
||||
|
||||
createdirs [] = pure ()
|
||||
createdirs (dir:[]) = createdir dir (liftIO . ioError)
|
||||
createdirs (dir:dirs) = createdir dir $ \_ -> do
|
||||
createdirs dirs
|
||||
createdir dir (liftIO . ioError)
|
||||
|
||||
-- This is the same method used by createDirectoryIfMissing,
|
||||
-- in particular the handling of errors that occur when the
|
||||
-- directory already exists. See its source for explanation
|
||||
-- of several subtleties.
|
||||
createdir dir notexisthandler = tryIO (mkdir dir) >>= \case
|
||||
Right () -> pure ()
|
||||
Left e
|
||||
| isDoesNotExistError e -> notexisthandler e
|
||||
| isAlreadyExistsError e || isPermissionError e ->
|
||||
liftIO $ unlessM (doesDirectoryExist dir) $
|
||||
ioError e
|
||||
| otherwise -> liftIO $ ioError e
|
||||
|
|
|
|||
102
Utility/Directory/Create.hs
Normal file
102
Utility/Directory/Create.hs
Normal file
|
|
@ -0,0 +1,102 @@
|
|||
{- directory creating
|
||||
-
|
||||
- Copyright 2011-2020 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# OPTIONS_GHC -fno-warn-tabs #-}
|
||||
|
||||
module Utility.Directory.Create (
|
||||
createDirectoryUnder,
|
||||
createDirectoryUnder',
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import System.FilePath
|
||||
import Control.Applicative
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.IfElse
|
||||
import System.IO.Error
|
||||
import Data.Maybe
|
||||
import Prelude
|
||||
|
||||
import Utility.SystemDirectory
|
||||
import Utility.Path.AbsRel
|
||||
import Utility.Exception
|
||||
import Utility.FileSystemEncoding
|
||||
import Utility.PartialPrelude
|
||||
|
||||
{- Like createDirectoryIfMissing True, but it will only create
|
||||
- missing parent directories up to but not including the directory
|
||||
- in the first parameter.
|
||||
-
|
||||
- For example, createDirectoryUnder "/tmp/foo" "/tmp/foo/bar/baz"
|
||||
- will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist,
|
||||
- it will throw an exception.
|
||||
-
|
||||
- The exception thrown is the same that createDirectory throws if the
|
||||
- parent directory does not exist.
|
||||
-
|
||||
- If the second FilePath is not under the first
|
||||
- FilePath (or the same as it), it will fail with an exception
|
||||
- even if the second FilePath's parent directory already exists.
|
||||
-
|
||||
- Either or both of the FilePaths can be relative, or absolute.
|
||||
- They will be normalized as necessary.
|
||||
-
|
||||
- Note that, the second FilePath, if relative, is relative to the current
|
||||
- working directory, not to the first FilePath.
|
||||
-}
|
||||
createDirectoryUnder :: FilePath -> FilePath -> IO ()
|
||||
createDirectoryUnder topdir dir =
|
||||
createDirectoryUnder' topdir dir createDirectory
|
||||
|
||||
createDirectoryUnder'
|
||||
:: (MonadIO m, MonadCatch m)
|
||||
=> FilePath
|
||||
-> FilePath
|
||||
-> (FilePath -> m ())
|
||||
-> m ()
|
||||
createDirectoryUnder' topdir dir0 mkdir = do
|
||||
p <- liftIO $ fromRawFilePath <$> relPathDirToFile
|
||||
(toRawFilePath topdir)
|
||||
(toRawFilePath dir0)
|
||||
let dirs = splitDirectories p
|
||||
-- Catch cases where the dir is not beneath the topdir.
|
||||
-- If the relative path between them starts with "..",
|
||||
-- it's not. And on Windows, if they are on different drives,
|
||||
-- the path will not be relative.
|
||||
if headMaybe dirs == Just ".." || isAbsolute p
|
||||
then liftIO $ ioError $ customerror userErrorType
|
||||
("createDirectoryFrom: not located in " ++ topdir)
|
||||
-- If dir0 is the same as the topdir, don't try to create
|
||||
-- it, but make sure it does exist.
|
||||
else if null dirs
|
||||
then liftIO $ unlessM (doesDirectoryExist topdir) $
|
||||
ioError $ customerror doesNotExistErrorType
|
||||
"createDirectoryFrom: does not exist"
|
||||
else createdirs $
|
||||
map (topdir </>) (reverse (scanl1 (</>) dirs))
|
||||
where
|
||||
customerror t s = mkIOError t s Nothing (Just dir0)
|
||||
|
||||
createdirs [] = pure ()
|
||||
createdirs (dir:[]) = createdir dir (liftIO . ioError)
|
||||
createdirs (dir:dirs) = createdir dir $ \_ -> do
|
||||
createdirs dirs
|
||||
createdir dir (liftIO . ioError)
|
||||
|
||||
-- This is the same method used by createDirectoryIfMissing,
|
||||
-- in particular the handling of errors that occur when the
|
||||
-- directory already exists. See its source for explanation
|
||||
-- of several subtleties.
|
||||
createdir dir notexisthandler = tryIO (mkdir dir) >>= \case
|
||||
Right () -> pure ()
|
||||
Left e
|
||||
| isDoesNotExistError e -> notexisthandler e
|
||||
| isAlreadyExistsError e || isPermissionError e ->
|
||||
liftIO $ unlessM (doesDirectoryExist dir) $
|
||||
ioError e
|
||||
| otherwise -> liftIO $ ioError e
|
||||
167
Utility/Path.hs
167
Utility/Path.hs
|
|
@ -11,27 +11,22 @@
|
|||
|
||||
module Utility.Path (
|
||||
simplifyPath,
|
||||
absPathFrom,
|
||||
parentDir,
|
||||
upFrom,
|
||||
dirContains,
|
||||
absPath,
|
||||
relPathCwdToFile,
|
||||
relPathDirToFile,
|
||||
relPathDirToFileAbs,
|
||||
segmentPaths,
|
||||
segmentPaths',
|
||||
runSegmentPaths,
|
||||
runSegmentPaths',
|
||||
relHome,
|
||||
inPath,
|
||||
searchPath,
|
||||
dotfile,
|
||||
splitShortExtensions,
|
||||
relPathDirToFileAbs,
|
||||
|
||||
prop_upFrom_basics,
|
||||
prop_relPathDirToFile_basics,
|
||||
prop_relPathDirToFile_regressionTest,
|
||||
prop_relPathDirToFileAbs_basics,
|
||||
prop_relPathDirToFileAbs_regressionTest,
|
||||
) where
|
||||
|
||||
import System.FilePath.ByteString
|
||||
|
|
@ -39,11 +34,6 @@ import qualified System.FilePath as P
|
|||
import qualified Data.ByteString as B
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
#ifdef mingw32_HOST_OS
|
||||
import Data.Char
|
||||
#else
|
||||
import System.Posix.Directory.ByteString (getWorkingDirectory)
|
||||
#endif
|
||||
import Control.Applicative
|
||||
import Prelude
|
||||
|
||||
|
|
@ -80,19 +70,6 @@ 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 :: RawFilePath -> RawFilePath -> RawFilePath
|
||||
absPathFrom dir path = simplifyPath (combine dir path)
|
||||
|
||||
{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -}
|
||||
parentDir :: RawFilePath -> RawFilePath
|
||||
parentDir = takeDirectory . dropTrailingPathSeparator
|
||||
|
|
@ -132,90 +109,6 @@ dirContains a b = a == b
|
|||
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 :: 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
|
||||
|
||||
{- 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
|
||||
|
||||
prop_relPathDirToFile_basics :: RawFilePath -> RawFilePath -> Bool
|
||||
prop_relPathDirToFile_basics from to
|
||||
| B.null from || B.null to = True
|
||||
| from == to = B.null r
|
||||
| otherwise = not (B.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 `B.cons` "tmp", "r", "lll", "xxx", "yyy", "18"])
|
||||
(joinPath [pathSeparator `B.cons` "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.
|
||||
|
|
@ -253,15 +146,6 @@ runSegmentPaths c a paths = segmentPaths c paths <$> a paths
|
|||
runSegmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[r]]
|
||||
runSegmentPaths' si c a paths = segmentPaths' si c paths <$> a paths
|
||||
|
||||
{- 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
|
||||
|
||||
{- Checks if a command is available in PATH.
|
||||
-
|
||||
- The command may be fully-qualified, in which case, this succeeds as
|
||||
|
|
@ -314,3 +198,48 @@ splitShortExtensions' maxextension = go []
|
|||
where
|
||||
(base, ext) = splitExtension f
|
||||
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
|
||||
|
||||
prop_relPathDirToFileAbs_basics :: RawFilePath -> RawFilePath -> Bool
|
||||
prop_relPathDirToFileAbs_basics from to
|
||||
| B.null from || B.null to = True
|
||||
| from == to = B.null r
|
||||
| otherwise = not (B.null r)
|
||||
where
|
||||
r = relPathDirToFileAbs from to
|
||||
|
||||
prop_relPathDirToFileAbs_regressionTest :: Bool
|
||||
prop_relPathDirToFileAbs_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 `B.cons` "tmp", "r", "lll", "xxx", "yyy", "18"])
|
||||
(joinPath [pathSeparator `B.cons` "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
|
||||
== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
|
||||
|
|
|
|||
93
Utility/Path/AbsRel.hs
Normal file
93
Utility/Path/AbsRel.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -817,6 +817,7 @@ Executable git-annex
|
|||
Config
|
||||
Config.Cost
|
||||
Config.Files
|
||||
Config.Files.AutoStart
|
||||
Config.DynamicConfig
|
||||
Config.GitConfig
|
||||
Config.Smudge
|
||||
|
|
@ -1055,6 +1056,7 @@ Executable git-annex
|
|||
Utility.DirWatcher
|
||||
Utility.DirWatcher.Types
|
||||
Utility.Directory
|
||||
Utility.Directory.Create
|
||||
Utility.Directory.Stream
|
||||
Utility.DiskFree
|
||||
Utility.Dot
|
||||
|
|
@ -1094,6 +1096,7 @@ Executable git-annex
|
|||
Utility.PID
|
||||
Utility.PartialPrelude
|
||||
Utility.Path
|
||||
Utility.Path.AbsRel
|
||||
Utility.Path.Max
|
||||
Utility.Percentage
|
||||
Utility.Process
|
||||
|
|
|
|||
Loading…
Reference in a new issue