-- Copyright (C) 2007 Eric Kow
-- Copyright (C) 2010 Petr Rockai
--
-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use, copy,
-- modify, merge, publish, distribute, sublicense, and/or sell copies
-- of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:
--
-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-- SOFTWARE.

{-# LANGUAGE CPP #-}
module Darcs.Util.Path
    ( encodeWhite
    , decodeWhite
    , encodeWhiteName
    , decodeWhiteName
    -- * AbsolutePath
    , AbsolutePath
    , makeAbsolute
    , ioAbsolute
    -- * AbsolutePathOrStd
    , AbsolutePathOrStd
    , makeAbsoluteOrStd
    , ioAbsoluteOrStd
    , useAbsoluteOrStd
    , stdOut
    -- * AbsoluteOrRemotePath
    , AbsoluteOrRemotePath
    , ioAbsoluteOrRemote
    , isRemote
    -- * SubPath
    , SubPath
    , makeSubPathOf
    , simpleSubPath
    , floatSubPath
    -- * Miscellaneous
    , FilePathOrURL(..)
    , FilePathLike(toFilePath)
    , getCurrentDirectory
    , setCurrentDirectory
    , getUniquePathName
    , doesPathExist
    -- * Check for malicious paths
    , isMaliciousSubPath
    -- * Tree filtering.
    , filterPaths
    -- * AnchoredPaths: relative paths within a Tree. All paths are
    -- anchored at a certain root (this is usually the Tree root). They are
    -- represented by a list of Names (these are just strict bytestrings).
    , Name
    , name2fp
    , makeName
    , rawMakeName
    , eqAnycase
    , AnchoredPath(..)
    , anchoredRoot
    , appendPath
    , anchorPath
    , isPrefix
    , breakOnDir
    , movedirfilename
    , parent
    , parents
    , replaceParent
    , catPaths
    , flatten
    , inDarcsdir
    , displayPath
    , realPath
    , isRoot
    , darcsdirName
    -- * Unsafe AnchoredPath functions.
    , floatPath
    ) where

import Darcs.Prelude

import Data.List
    ( isPrefixOf
    , isSuffixOf
    , stripPrefix
    , intersect
    , inits
    )
import Data.Char ( isSpace, chr, ord, toLower )
import Data.Typeable ( Typeable )
import Control.Exception ( tryJust, bracket_, throw, Exception )
import Control.Monad ( when )
import System.IO.Error ( isDoesNotExistError )

import qualified Darcs.Util.Workaround as Workaround ( getCurrentDirectory )
import qualified System.Directory ( setCurrentDirectory )
import System.Directory ( doesDirectoryExist, doesFileExist )
import qualified System.FilePath.Posix as FilePath ( (</>), normalise, isRelative )
import qualified System.FilePath as NativeFilePath ( takeFileName, takeDirectory )
import System.FilePath( splitDirectories, normalise, dropTrailingPathSeparator )
import System.Posix.Files ( isDirectory, getSymbolicLinkStatus )

import Darcs.Util.ByteString ( encodeLocale, decodeLocale )
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString       as B

import Data.Binary
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.URL ( isAbsolute, isRelative, isSshNopath )


-- Utilities for use by command implementations

-- | For displaying paths to the user. It should never be used
-- for on-disk patch storage. This adds the "./" for consistency
-- with how repo paths are displayed by 'showPatch' and friends,
-- except for the root path which is displayed as plain ".".
displayPath :: AnchoredPath -> FilePath
displayPath :: AnchoredPath -> FilePath
displayPath AnchoredPath
p
  | AnchoredPath -> Bool
isRoot AnchoredPath
p = FilePath
"."
  | Bool
otherwise = FilePath -> AnchoredPath -> FilePath
anchorPath FilePath
"." AnchoredPath
p

-- | Interpret an 'AnchoredPath' as relative the current working
-- directory. Intended for IO operations in the file system.
-- Use with care!
realPath :: AnchoredPath -> FilePath
realPath :: AnchoredPath -> FilePath
realPath = FilePath -> AnchoredPath -> FilePath
anchorPath FilePath
""

-- | 'encodeWhite' translates whitespace in filenames to a darcs-specific
--   format (numerical representation according to 'ord' surrounded by
--   backslashes).  Note that backslashes are also escaped since they are used
--   in the encoding.
--
--   > encodeWhite "hello there" == "hello\32\there"
--   > encodeWhite "hello\there" == "hello\92\there"
encodeWhite :: FilePath -> String
encodeWhite :: FilePath -> FilePath
encodeWhite (Char
c:FilePath
cs) | Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' =
    Char
'\\' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: Int -> FilePath
forall a. Show a => a -> FilePath
show (Char -> Int
ord Char
c) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\\" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
encodeWhite FilePath
cs
encodeWhite (Char
c:FilePath
cs) = Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
encodeWhite FilePath
cs
encodeWhite [] = []

-- | 'decodeWhite' interprets the Darcs-specific \"encoded\" filenames
--   produced by 'encodeWhite'
--
--   > decodeWhite "hello\32\there"  == "hello there"
--   > decodeWhite "hello\92\there"  == "hello\there"
--   > decodeWhite "hello\there"   == error "malformed filename"
decodeWhite :: String -> FilePath
decodeWhite :: FilePath -> FilePath
decodeWhite FilePath
cs_ = FilePath -> FilePath -> Bool -> FilePath
go FilePath
cs_ [] Bool
False
 where go :: FilePath -> FilePath -> Bool -> FilePath
go FilePath
"" FilePath
acc Bool
True  = FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
acc -- if there was a replace, use new string
       go FilePath
"" FilePath
_   Bool
False = FilePath
cs_         -- if not, use input string
       go (Char
'\\':FilePath
cs) FilePath
acc Bool
_ =
         case (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\\') FilePath
cs of
           (FilePath
theord, Char
'\\':FilePath
rest) ->
             FilePath -> FilePath -> Bool -> FilePath
go FilePath
rest (Int -> Char
chr (FilePath -> Int
forall a. Read a => FilePath -> a
read FilePath
theord) Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
acc) Bool
True
           (FilePath, FilePath)
_ -> FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error FilePath
"malformed filename"
       go (Char
c:FilePath
cs) FilePath
acc Bool
modified = FilePath -> FilePath -> Bool -> FilePath
go FilePath
cs (Char
cChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
acc) Bool
modified

class FilePathOrURL a where
  toPath :: a -> String

class FilePathOrURL a => FilePathLike a where
  toFilePath :: a -> FilePath

-- | Paths which are relative to the local darcs repository and normalized.
-- Note: These are understood not to have the dot in front.
newtype SubPath      = SubPath FilePath deriving (SubPath -> SubPath -> Bool
(SubPath -> SubPath -> Bool)
-> (SubPath -> SubPath -> Bool) -> Eq SubPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SubPath -> SubPath -> Bool
$c/= :: SubPath -> SubPath -> Bool
== :: SubPath -> SubPath -> Bool
$c== :: SubPath -> SubPath -> Bool
Eq, Eq SubPath
Eq SubPath
-> (SubPath -> SubPath -> Ordering)
-> (SubPath -> SubPath -> Bool)
-> (SubPath -> SubPath -> Bool)
-> (SubPath -> SubPath -> Bool)
-> (SubPath -> SubPath -> Bool)
-> (SubPath -> SubPath -> SubPath)
-> (SubPath -> SubPath -> SubPath)
-> Ord SubPath
SubPath -> SubPath -> Bool
SubPath -> SubPath -> Ordering
SubPath -> SubPath -> SubPath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SubPath -> SubPath -> SubPath
$cmin :: SubPath -> SubPath -> SubPath
max :: SubPath -> SubPath -> SubPath
$cmax :: SubPath -> SubPath -> SubPath
>= :: SubPath -> SubPath -> Bool
$c>= :: SubPath -> SubPath -> Bool
> :: SubPath -> SubPath -> Bool
$c> :: SubPath -> SubPath -> Bool
<= :: SubPath -> SubPath -> Bool
$c<= :: SubPath -> SubPath -> Bool
< :: SubPath -> SubPath -> Bool
$c< :: SubPath -> SubPath -> Bool
compare :: SubPath -> SubPath -> Ordering
$ccompare :: SubPath -> SubPath -> Ordering
$cp1Ord :: Eq SubPath
Ord)

newtype AbsolutePath = AbsolutePath FilePath deriving (AbsolutePath -> AbsolutePath -> Bool
(AbsolutePath -> AbsolutePath -> Bool)
-> (AbsolutePath -> AbsolutePath -> Bool) -> Eq AbsolutePath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AbsolutePath -> AbsolutePath -> Bool
$c/= :: AbsolutePath -> AbsolutePath -> Bool
== :: AbsolutePath -> AbsolutePath -> Bool
$c== :: AbsolutePath -> AbsolutePath -> Bool
Eq, Eq AbsolutePath
Eq AbsolutePath
-> (AbsolutePath -> AbsolutePath -> Ordering)
-> (AbsolutePath -> AbsolutePath -> Bool)
-> (AbsolutePath -> AbsolutePath -> Bool)
-> (AbsolutePath -> AbsolutePath -> Bool)
-> (AbsolutePath -> AbsolutePath -> Bool)
-> (AbsolutePath -> AbsolutePath -> AbsolutePath)
-> (AbsolutePath -> AbsolutePath -> AbsolutePath)
-> Ord AbsolutePath
AbsolutePath -> AbsolutePath -> Bool
AbsolutePath -> AbsolutePath -> Ordering
AbsolutePath -> AbsolutePath -> AbsolutePath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AbsolutePath -> AbsolutePath -> AbsolutePath
$cmin :: AbsolutePath -> AbsolutePath -> AbsolutePath
max :: AbsolutePath -> AbsolutePath -> AbsolutePath
$cmax :: AbsolutePath -> AbsolutePath -> AbsolutePath
>= :: AbsolutePath -> AbsolutePath -> Bool
$c>= :: AbsolutePath -> AbsolutePath -> Bool
> :: AbsolutePath -> AbsolutePath -> Bool
$c> :: AbsolutePath -> AbsolutePath -> Bool
<= :: AbsolutePath -> AbsolutePath -> Bool
$c<= :: AbsolutePath -> AbsolutePath -> Bool
< :: AbsolutePath -> AbsolutePath -> Bool
$c< :: AbsolutePath -> AbsolutePath -> Bool
compare :: AbsolutePath -> AbsolutePath -> Ordering
$ccompare :: AbsolutePath -> AbsolutePath -> Ordering
$cp1Ord :: Eq AbsolutePath
Ord)

-- | This is for situations where a string (e.g. a command line argument)
-- may take the value \"-\" to mean stdin or stdout (which one depends on
-- context) instead of a normal file path.
data AbsolutePathOrStd = AP AbsolutePath | APStd deriving (AbsolutePathOrStd -> AbsolutePathOrStd -> Bool
(AbsolutePathOrStd -> AbsolutePathOrStd -> Bool)
-> (AbsolutePathOrStd -> AbsolutePathOrStd -> Bool)
-> Eq AbsolutePathOrStd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AbsolutePathOrStd -> AbsolutePathOrStd -> Bool
$c/= :: AbsolutePathOrStd -> AbsolutePathOrStd -> Bool
== :: AbsolutePathOrStd -> AbsolutePathOrStd -> Bool
$c== :: AbsolutePathOrStd -> AbsolutePathOrStd -> Bool
Eq, Eq AbsolutePathOrStd
Eq AbsolutePathOrStd
-> (AbsolutePathOrStd -> AbsolutePathOrStd -> Ordering)
-> (AbsolutePathOrStd -> AbsolutePathOrStd -> Bool)
-> (AbsolutePathOrStd -> AbsolutePathOrStd -> Bool)
-> (AbsolutePathOrStd -> AbsolutePathOrStd -> Bool)
-> (AbsolutePathOrStd -> AbsolutePathOrStd -> Bool)
-> (AbsolutePathOrStd -> AbsolutePathOrStd -> AbsolutePathOrStd)
-> (AbsolutePathOrStd -> AbsolutePathOrStd -> AbsolutePathOrStd)
-> Ord AbsolutePathOrStd
AbsolutePathOrStd -> AbsolutePathOrStd -> Bool
AbsolutePathOrStd -> AbsolutePathOrStd -> Ordering
AbsolutePathOrStd -> AbsolutePathOrStd -> AbsolutePathOrStd
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AbsolutePathOrStd -> AbsolutePathOrStd -> AbsolutePathOrStd
$cmin :: AbsolutePathOrStd -> AbsolutePathOrStd -> AbsolutePathOrStd
max :: AbsolutePathOrStd -> AbsolutePathOrStd -> AbsolutePathOrStd
$cmax :: AbsolutePathOrStd -> AbsolutePathOrStd -> AbsolutePathOrStd
>= :: AbsolutePathOrStd -> AbsolutePathOrStd -> Bool
$c>= :: AbsolutePathOrStd -> AbsolutePathOrStd -> Bool
> :: AbsolutePathOrStd -> AbsolutePathOrStd -> Bool
$c> :: AbsolutePathOrStd -> AbsolutePathOrStd -> Bool
<= :: AbsolutePathOrStd -> AbsolutePathOrStd -> Bool
$c<= :: AbsolutePathOrStd -> AbsolutePathOrStd -> Bool
< :: AbsolutePathOrStd -> AbsolutePathOrStd -> Bool
$c< :: AbsolutePathOrStd -> AbsolutePathOrStd -> Bool
compare :: AbsolutePathOrStd -> AbsolutePathOrStd -> Ordering
$ccompare :: AbsolutePathOrStd -> AbsolutePathOrStd -> Ordering
$cp1Ord :: Eq AbsolutePathOrStd
Ord)
data AbsoluteOrRemotePath = AbsP AbsolutePath | RmtP String deriving (AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool
(AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool)
-> (AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool)
-> Eq AbsoluteOrRemotePath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool
$c/= :: AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool
== :: AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool
$c== :: AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool
Eq, Eq AbsoluteOrRemotePath
Eq AbsoluteOrRemotePath
-> (AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Ordering)
-> (AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool)
-> (AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool)
-> (AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool)
-> (AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool)
-> (AbsoluteOrRemotePath
    -> AbsoluteOrRemotePath -> AbsoluteOrRemotePath)
-> (AbsoluteOrRemotePath
    -> AbsoluteOrRemotePath -> AbsoluteOrRemotePath)
-> Ord AbsoluteOrRemotePath
AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool
AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Ordering
AbsoluteOrRemotePath
-> AbsoluteOrRemotePath -> AbsoluteOrRemotePath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AbsoluteOrRemotePath
-> AbsoluteOrRemotePath -> AbsoluteOrRemotePath
$cmin :: AbsoluteOrRemotePath
-> AbsoluteOrRemotePath -> AbsoluteOrRemotePath
max :: AbsoluteOrRemotePath
-> AbsoluteOrRemotePath -> AbsoluteOrRemotePath
$cmax :: AbsoluteOrRemotePath
-> AbsoluteOrRemotePath -> AbsoluteOrRemotePath
>= :: AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool
$c>= :: AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool
> :: AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool
$c> :: AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool
<= :: AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool
$c<= :: AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool
< :: AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool
$c< :: AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Bool
compare :: AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Ordering
$ccompare :: AbsoluteOrRemotePath -> AbsoluteOrRemotePath -> Ordering
$cp1Ord :: Eq AbsoluteOrRemotePath
Ord)

instance FilePathOrURL AbsolutePath where
  toPath :: AbsolutePath -> FilePath
toPath (AbsolutePath FilePath
x) = FilePath
x
instance FilePathOrURL SubPath where
  toPath :: SubPath -> FilePath
toPath (SubPath FilePath
x) = FilePath
x
instance CharLike c => FilePathOrURL [c] where
  toPath :: [c] -> FilePath
toPath = [c] -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath

instance FilePathOrURL AbsoluteOrRemotePath where
  toPath :: AbsoluteOrRemotePath -> FilePath
toPath (AbsP AbsolutePath
a) = AbsolutePath -> FilePath
forall a. FilePathOrURL a => a -> FilePath
toPath AbsolutePath
a
  toPath (RmtP FilePath
r) = FilePath
r

instance FilePathLike AbsolutePath where
  toFilePath :: AbsolutePath -> FilePath
toFilePath (AbsolutePath FilePath
x) = FilePath
x
instance FilePathLike SubPath where
  toFilePath :: SubPath -> FilePath
toFilePath (SubPath FilePath
x) = FilePath
x

class CharLike c where
  toChar :: c -> Char

instance CharLike Char where
  toChar :: Char -> Char
toChar = Char -> Char
forall a. a -> a
id

instance CharLike c => FilePathLike [c] where
  toFilePath :: [c] -> FilePath
toFilePath = (c -> Char) -> [c] -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map c -> Char
forall c. CharLike c => c -> Char
toChar

-- | Make the second path relative to the first, if possible
makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath
makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath
makeSubPathOf (AbsolutePath FilePath
p1) (AbsolutePath FilePath
p2) =
 -- The slash prevents "foobar" from being treated as relative to "foo"
 if FilePath
p1 FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
p2 Bool -> Bool -> Bool
|| (FilePath
p1 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/") FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
p2
    then SubPath -> Maybe SubPath
forall a. a -> Maybe a
Just (SubPath -> Maybe SubPath) -> SubPath -> Maybe SubPath
forall a b. (a -> b) -> a -> b
$ FilePath -> SubPath
SubPath (FilePath -> SubPath) -> FilePath -> SubPath
forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
p1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) FilePath
p2
    else Maybe SubPath
forall a. Maybe a
Nothing

simpleSubPath :: FilePath -> Maybe SubPath
simpleSubPath :: FilePath -> Maybe SubPath
simpleSubPath FilePath
x | FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
x = FilePath -> Maybe SubPath
forall a. HasCallStack => FilePath -> a
error FilePath
"simpleSubPath called with empty path"
                | FilePath -> Bool
isRelative FilePath
x = SubPath -> Maybe SubPath
forall a. a -> Maybe a
Just (SubPath -> Maybe SubPath) -> SubPath -> Maybe SubPath
forall a b. (a -> b) -> a -> b
$ FilePath -> SubPath
SubPath (FilePath -> SubPath) -> FilePath -> SubPath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
FilePath.normalise (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
pathToPosix FilePath
x
                | Bool
otherwise = Maybe SubPath
forall a. Maybe a
Nothing

-- | Ensure directory exists and is not a symbolic link.
doesDirectoryReallyExist :: FilePath -> IO Bool
doesDirectoryReallyExist :: FilePath -> IO Bool
doesDirectoryReallyExist FilePath
f = do
    Either () Bool
x <- (IOError -> Maybe ()) -> IO Bool -> IO (Either () Bool)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust (\IOError
x -> if IOError -> Bool
isDoesNotExistError IOError
x then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing) (IO Bool -> IO (Either () Bool)) -> IO Bool -> IO (Either () Bool)
forall a b. (a -> b) -> a -> b
$
        FileStatus -> Bool
isDirectory (FileStatus -> Bool) -> IO FileStatus -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FileStatus
getSymbolicLinkStatus FilePath
f
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ case Either () Bool
x of
        Left () -> Bool
False
        Right Bool
y -> Bool
y

doesPathExist :: FilePath -> IO Bool
doesPathExist :: FilePath -> IO Bool
doesPathExist FilePath
p = do
   Bool
dir_exists <- FilePath -> IO Bool
doesDirectoryExist FilePath
p
   Bool
file_exists <- FilePath -> IO Bool
doesFileExist FilePath
p
   Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool
dir_exists Bool -> Bool -> Bool
|| Bool
file_exists

-- | Interpret a possibly relative path wrt the current working directory.
ioAbsolute :: FilePath -> IO AbsolutePath
ioAbsolute :: FilePath -> IO AbsolutePath
ioAbsolute FilePath
dir =
    do Bool
isdir <- FilePath -> IO Bool
doesDirectoryReallyExist FilePath
dir
       AbsolutePath
here <- IO AbsolutePath
getCurrentDirectory
       if Bool
isdir
         then IO () -> IO () -> IO AbsolutePath -> IO AbsolutePath
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (FilePath -> IO ()
forall p. FilePathLike p => p -> IO ()
setCurrentDirectory FilePath
dir)
                       (FilePath -> IO ()
forall p. FilePathLike p => p -> IO ()
setCurrentDirectory (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ AbsolutePath -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath AbsolutePath
here)
                       IO AbsolutePath
getCurrentDirectory
         else let super_dir :: FilePath
super_dir = case FilePath -> FilePath
NativeFilePath.takeDirectory FilePath
dir of
                                FilePath
"" ->  FilePath
"."
                                FilePath
d  -> FilePath
d
                  file :: FilePath
file = FilePath -> FilePath
NativeFilePath.takeFileName FilePath
dir
              in do AbsolutePath
abs_dir <- if FilePath
dir FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
super_dir
                               then AbsolutePath -> IO AbsolutePath
forall (m :: * -> *) a. Monad m => a -> m a
return (AbsolutePath -> IO AbsolutePath)
-> AbsolutePath -> IO AbsolutePath
forall a b. (a -> b) -> a -> b
$ FilePath -> AbsolutePath
AbsolutePath FilePath
dir
                               else FilePath -> IO AbsolutePath
ioAbsolute FilePath
super_dir
                    AbsolutePath -> IO AbsolutePath
forall (m :: * -> *) a. Monad m => a -> m a
return (AbsolutePath -> IO AbsolutePath)
-> AbsolutePath -> IO AbsolutePath
forall a b. (a -> b) -> a -> b
$ AbsolutePath -> FilePath -> AbsolutePath
makeAbsolute AbsolutePath
abs_dir FilePath
file

-- | Take an absolute path and a string representing a (possibly relative)
-- path and combine them into an absolute path. If the second argument is
-- already absolute, then the first argument gets ignored. This function also
-- takes care that the result is converted to Posix convention and
-- normalized. Also, parent directories (\"..\") at the front of the string
-- argument get canceled out against trailing directory parts of the
-- absolute path argument.
--
-- Regarding the last point, someone more familiar with how these functions
-- are used should verify that this is indeed necessary or at least useful.
makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath
makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath
makeAbsolute AbsolutePath
a FilePath
dir = if Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
dir) Bool -> Bool -> Bool
&& FilePath -> Bool
isAbsolute FilePath
dir
                     then FilePath -> AbsolutePath
AbsolutePath (FilePath -> FilePath
normSlashes FilePath
dir')
                     else AbsolutePath -> FilePath -> AbsolutePath
ma AbsolutePath
a FilePath
dir'
  where
    dir' :: FilePath
dir' = FilePath -> FilePath
FilePath.normalise (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
pathToPosix FilePath
dir
    -- Why do we care to reduce ".." here?
    -- Why not do this throughout the whole path, i.e. "x/y/../z" -> "x/z" ?
    ma :: AbsolutePath -> FilePath -> AbsolutePath
ma AbsolutePath
here (Char
'.':Char
'.':Char
'/':FilePath
r) = AbsolutePath -> FilePath -> AbsolutePath
ma (AbsolutePath -> AbsolutePath
takeDirectory AbsolutePath
here) FilePath
r
    ma AbsolutePath
here FilePath
".." = AbsolutePath -> AbsolutePath
takeDirectory AbsolutePath
here
    ma AbsolutePath
here FilePath
"." = AbsolutePath
here
    ma AbsolutePath
here FilePath
"" = AbsolutePath
here
    ma AbsolutePath
here FilePath
r = AbsolutePath
here AbsolutePath -> FilePath -> AbsolutePath
/- (Char
'/'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
r)

(/-) :: AbsolutePath -> String -> AbsolutePath
AbsolutePath
x /- :: AbsolutePath -> FilePath -> AbsolutePath
/- (Char
'/':FilePath
r) = AbsolutePath
x AbsolutePath -> FilePath -> AbsolutePath
/- FilePath
r
(AbsolutePath FilePath
"/") /- FilePath
r = FilePath -> AbsolutePath
AbsolutePath (Char
'/'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
simpleClean FilePath
r)
(AbsolutePath FilePath
x) /- FilePath
r = FilePath -> AbsolutePath
AbsolutePath (FilePath
xFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Char
'/'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
simpleClean FilePath
r)

-- | Convert to posix, remove trailing slashes, and (under Posix)
-- reduce multiple leading slashes to one.
simpleClean :: String -> String
simpleClean :: FilePath -> FilePath
simpleClean = FilePath -> FilePath
normSlashes (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
pathToPosix

makeAbsoluteOrStd :: AbsolutePath -> String -> AbsolutePathOrStd
makeAbsoluteOrStd :: AbsolutePath -> FilePath -> AbsolutePathOrStd
makeAbsoluteOrStd AbsolutePath
_ FilePath
"-" = AbsolutePathOrStd
APStd
makeAbsoluteOrStd AbsolutePath
a FilePath
p = AbsolutePath -> AbsolutePathOrStd
AP (AbsolutePath -> AbsolutePathOrStd)
-> AbsolutePath -> AbsolutePathOrStd
forall a b. (a -> b) -> a -> b
$ AbsolutePath -> FilePath -> AbsolutePath
makeAbsolute AbsolutePath
a FilePath
p

stdOut :: AbsolutePathOrStd
stdOut :: AbsolutePathOrStd
stdOut = AbsolutePathOrStd
APStd

ioAbsoluteOrStd :: String -> IO AbsolutePathOrStd
ioAbsoluteOrStd :: FilePath -> IO AbsolutePathOrStd
ioAbsoluteOrStd FilePath
"-" = AbsolutePathOrStd -> IO AbsolutePathOrStd
forall (m :: * -> *) a. Monad m => a -> m a
return AbsolutePathOrStd
APStd
ioAbsoluteOrStd FilePath
p = AbsolutePath -> AbsolutePathOrStd
AP (AbsolutePath -> AbsolutePathOrStd)
-> IO AbsolutePath -> IO AbsolutePathOrStd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> IO AbsolutePath
ioAbsolute FilePath
p

-- | Execute either the first or the second argument action, depending on
-- whether the given path is an 'AbsolutePath' or stdin/stdout.
useAbsoluteOrStd :: (AbsolutePath -> a) -> a -> AbsolutePathOrStd -> a
useAbsoluteOrStd :: (AbsolutePath -> a) -> a -> AbsolutePathOrStd -> a
useAbsoluteOrStd AbsolutePath -> a
_ a
f AbsolutePathOrStd
APStd = a
f
useAbsoluteOrStd AbsolutePath -> a
f a
_ (AP AbsolutePath
x) = AbsolutePath -> a
f AbsolutePath
x

ioAbsoluteOrRemote :: String -> IO AbsoluteOrRemotePath
ioAbsoluteOrRemote :: FilePath -> IO AbsoluteOrRemotePath
ioAbsoluteOrRemote FilePath
p = do
  Bool
isdir <- FilePath -> IO Bool
doesDirectoryExist FilePath
p
  if Bool -> Bool
not Bool
isdir
     then AbsoluteOrRemotePath -> IO AbsoluteOrRemotePath
forall (m :: * -> *) a. Monad m => a -> m a
return (AbsoluteOrRemotePath -> IO AbsoluteOrRemotePath)
-> AbsoluteOrRemotePath -> IO AbsoluteOrRemotePath
forall a b. (a -> b) -> a -> b
$ FilePath -> AbsoluteOrRemotePath
RmtP (FilePath -> AbsoluteOrRemotePath)
-> FilePath -> AbsoluteOrRemotePath
forall a b. (a -> b) -> a -> b
$
          case () of ()
_ | FilePath -> Bool
isSshNopath FilePath
p    -> FilePath
pFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"."
                       | FilePath
"/" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
p -> FilePath -> FilePath
forall a. [a] -> [a]
init FilePath
p
                       | Bool
otherwise          -> FilePath
p
     else AbsolutePath -> AbsoluteOrRemotePath
AbsP (AbsolutePath -> AbsoluteOrRemotePath)
-> IO AbsolutePath -> IO AbsoluteOrRemotePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> IO AbsolutePath
ioAbsolute FilePath
p

isRemote :: AbsoluteOrRemotePath -> Bool
isRemote :: AbsoluteOrRemotePath -> Bool
isRemote (RmtP FilePath
_) = Bool
True
isRemote AbsoluteOrRemotePath
_ = Bool
False

takeDirectory :: AbsolutePath -> AbsolutePath
takeDirectory :: AbsolutePath -> AbsolutePath
takeDirectory (AbsolutePath FilePath
x) =
    case FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
1 (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'/') (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
x of
    FilePath
"" -> FilePath -> AbsolutePath
AbsolutePath FilePath
"/"
    FilePath
x' -> FilePath -> AbsolutePath
AbsolutePath FilePath
x'

instance Show AbsolutePath where
 show :: AbsolutePath -> FilePath
show = FilePath -> FilePath
forall a. Show a => a -> FilePath
show (FilePath -> FilePath)
-> (AbsolutePath -> FilePath) -> AbsolutePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsolutePath -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath
instance Show SubPath where
 show :: SubPath -> FilePath
show = FilePath -> FilePath
forall a. Show a => a -> FilePath
show (FilePath -> FilePath)
-> (SubPath -> FilePath) -> SubPath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubPath -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath
instance Show AbsolutePathOrStd where
    show :: AbsolutePathOrStd -> FilePath
show (AP AbsolutePath
a) = AbsolutePath -> FilePath
forall a. Show a => a -> FilePath
show AbsolutePath
a
    show AbsolutePathOrStd
APStd = FilePath
"standard input/output"
instance Show AbsoluteOrRemotePath where
    show :: AbsoluteOrRemotePath -> FilePath
show (AbsP AbsolutePath
a) = AbsolutePath -> FilePath
forall a. Show a => a -> FilePath
show AbsolutePath
a
    show (RmtP FilePath
r) = FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
r

-- | Normalize the path separator to Posix style (slash, not backslash).
-- This only affects Windows systems.
pathToPosix :: FilePath -> FilePath
pathToPosix :: FilePath -> FilePath
pathToPosix = (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
forall a. a -> a
convert where
#ifdef WIN32
  convert '\\' = '/'
#endif
  convert :: p -> p
convert p
c = p
c

-- | Reduce multiple leading slashes to one. This only affects Posix systems.
normSlashes :: FilePath -> FilePath
#ifndef WIN32
-- multiple slashes in front are ignored under Posix
normSlashes :: FilePath -> FilePath
normSlashes (Char
'/':FilePath
p) = Char
'/' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') FilePath
p
#endif
normSlashes FilePath
p = FilePath
p

getCurrentDirectory :: IO AbsolutePath
getCurrentDirectory :: IO AbsolutePath
getCurrentDirectory = FilePath -> AbsolutePath
AbsolutePath (FilePath -> AbsolutePath) -> IO FilePath -> IO AbsolutePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO FilePath
Workaround.getCurrentDirectory

setCurrentDirectory :: FilePathLike p => p -> IO ()
setCurrentDirectory :: p -> IO ()
setCurrentDirectory = FilePath -> IO ()
System.Directory.setCurrentDirectory (FilePath -> IO ()) -> (p -> FilePath) -> p -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath

{-|
  What is a malicious path?

  A spoofed path is a malicious path.

  1. Darcs only creates explicitly relative paths (beginning with @\".\/\"@),
     so any not explicitly relative path is surely spoofed.

  2. Darcs normalizes paths so they never contain @\"\/..\/\"@, so paths with
     @\"\/..\/\"@ are surely spoofed.

  A path to a darcs repository's meta data can modify \"trusted\" patches or
  change safety defaults in that repository, so we check for paths
  containing @\"\/_darcs\/\"@ which is the entry to darcs meta data.

  To do?

  * How about get repositories?

  * Would it be worth adding a --semi-safe-paths option for allowing
    changes to certain preference files (_darcs\/prefs\/) in sub
    repositories'?

  TODO:
    Properly review the way we handle paths on Windows - it's not enough
    to just use the OS native concept of path separator. Windows often
    accepts both path separators, and repositories always use the UNIX
    separator anyway.
-}

isMaliciousSubPath :: String -> Bool
isMaliciousSubPath :: FilePath -> Bool
isMaliciousSubPath FilePath
fp =
    Bool -> Bool
not (FilePath -> Bool
FilePath.isRelative FilePath
fp) Bool -> Bool -> Bool
|| FilePath -> Bool
isGenerallyMalicious FilePath
fp

isGenerallyMalicious :: String -> Bool
isGenerallyMalicious :: FilePath -> Bool
isGenerallyMalicious FilePath
fp =
    FilePath -> [FilePath]
splitDirectories FilePath
fp [FilePath] -> [FilePath] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`contains_any` [ FilePath
"..", FilePath
darcsdir ]
 where
    contains_any :: [a] -> [a] -> Bool
contains_any [a]
a [a]
b = Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
intersect [a]
a [a]
b

-- | Iteratively tries find first non-existing path generated by
-- buildName, it feeds to buildName the number starting with -1.  When
-- it generates non-existing path and it isn't first, it displays the
-- message created with buildMsg. Usually used for generation of the
-- name like <path>_<number> when <path> already exist
-- (e.g. darcs.net_0).
getUniquePathName :: Bool -> (FilePath -> String) -> (Int -> FilePath) -> IO FilePath
getUniquePathName :: Bool -> (FilePath -> FilePath) -> (Int -> FilePath) -> IO FilePath
getUniquePathName Bool
talkative FilePath -> FilePath
buildMsg Int -> FilePath
buildName = Int -> IO FilePath
go (-Int
1)
 where
  go :: Int -> IO FilePath
  go :: Int -> IO FilePath
go Int
i = do
    Bool
exists <- FilePath -> IO Bool
doesPathExist FilePath
thename
    if Bool -> Bool
not Bool
exists
       then do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= -Int
1 Bool -> Bool -> Bool
&& Bool
talkative) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
buildMsg FilePath
thename
               FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
thename
       else Int -> IO FilePath
go (Int -> IO FilePath) -> Int -> IO FilePath
forall a b. (a -> b) -> a -> b
$ Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
    where thename :: FilePath
thename = Int -> FilePath
buildName Int
i

-------------------------------
-- AnchoredPath utilities
--

newtype Name = Name { Name -> ByteString
unName :: B.ByteString } deriving (Get Name
[Name] -> Put
Name -> Put
(Name -> Put) -> Get Name -> ([Name] -> Put) -> Binary Name
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Name] -> Put
$cputList :: [Name] -> Put
get :: Get Name
$cget :: Get Name
put :: Name -> Put
$cput :: Name -> Put
Binary, Name -> Name -> Bool
(Name -> Name -> Bool) -> (Name -> Name -> Bool) -> Eq Name
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c== :: Name -> Name -> Bool
Eq, Int -> Name -> FilePath -> FilePath
[Name] -> FilePath -> FilePath
Name -> FilePath
(Int -> Name -> FilePath -> FilePath)
-> (Name -> FilePath)
-> ([Name] -> FilePath -> FilePath)
-> Show Name
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Name] -> FilePath -> FilePath
$cshowList :: [Name] -> FilePath -> FilePath
show :: Name -> FilePath
$cshow :: Name -> FilePath
showsPrec :: Int -> Name -> FilePath -> FilePath
$cshowsPrec :: Int -> Name -> FilePath -> FilePath
Show, Eq Name
Eq Name
-> (Name -> Name -> Ordering)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Name)
-> (Name -> Name -> Name)
-> Ord Name
Name -> Name -> Bool
Name -> Name -> Ordering
Name -> Name -> Name
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Name -> Name -> Name
$cmin :: Name -> Name -> Name
max :: Name -> Name -> Name
$cmax :: Name -> Name -> Name
>= :: Name -> Name -> Bool
$c>= :: Name -> Name -> Bool
> :: Name -> Name -> Bool
$c> :: Name -> Name -> Bool
<= :: Name -> Name -> Bool
$c<= :: Name -> Name -> Bool
< :: Name -> Name -> Bool
$c< :: Name -> Name -> Bool
compare :: Name -> Name -> Ordering
$ccompare :: Name -> Name -> Ordering
$cp1Ord :: Eq Name
Ord)

-- | This is a type of "sane" file paths. These are always canonic in the sense
-- that there are no stray slashes, no ".." components and similar. They are
-- usually used to refer to a location within a Tree, but a relative filesystem
-- path works just as well. These are either constructed from individual name
-- components (using "appendPath", "catPaths" and "makeName"), or converted
-- from a FilePath ("floatPath" -- but take care when doing that).
newtype AnchoredPath = AnchoredPath [Name] deriving (Get AnchoredPath
[AnchoredPath] -> Put
AnchoredPath -> Put
(AnchoredPath -> Put)
-> Get AnchoredPath
-> ([AnchoredPath] -> Put)
-> Binary AnchoredPath
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [AnchoredPath] -> Put
$cputList :: [AnchoredPath] -> Put
get :: Get AnchoredPath
$cget :: Get AnchoredPath
put :: AnchoredPath -> Put
$cput :: AnchoredPath -> Put
Binary, AnchoredPath -> AnchoredPath -> Bool
(AnchoredPath -> AnchoredPath -> Bool)
-> (AnchoredPath -> AnchoredPath -> Bool) -> Eq AnchoredPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AnchoredPath -> AnchoredPath -> Bool
$c/= :: AnchoredPath -> AnchoredPath -> Bool
== :: AnchoredPath -> AnchoredPath -> Bool
$c== :: AnchoredPath -> AnchoredPath -> Bool
Eq, Int -> AnchoredPath -> FilePath -> FilePath
[AnchoredPath] -> FilePath -> FilePath
AnchoredPath -> FilePath
(Int -> AnchoredPath -> FilePath -> FilePath)
-> (AnchoredPath -> FilePath)
-> ([AnchoredPath] -> FilePath -> FilePath)
-> Show AnchoredPath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [AnchoredPath] -> FilePath -> FilePath
$cshowList :: [AnchoredPath] -> FilePath -> FilePath
show :: AnchoredPath -> FilePath
$cshow :: AnchoredPath -> FilePath
showsPrec :: Int -> AnchoredPath -> FilePath -> FilePath
$cshowsPrec :: Int -> AnchoredPath -> FilePath -> FilePath
Show, Eq AnchoredPath
Eq AnchoredPath
-> (AnchoredPath -> AnchoredPath -> Ordering)
-> (AnchoredPath -> AnchoredPath -> Bool)
-> (AnchoredPath -> AnchoredPath -> Bool)
-> (AnchoredPath -> AnchoredPath -> Bool)
-> (AnchoredPath -> AnchoredPath -> Bool)
-> (AnchoredPath -> AnchoredPath -> AnchoredPath)
-> (AnchoredPath -> AnchoredPath -> AnchoredPath)
-> Ord AnchoredPath
AnchoredPath -> AnchoredPath -> Bool
AnchoredPath -> AnchoredPath -> Ordering
AnchoredPath -> AnchoredPath -> AnchoredPath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AnchoredPath -> AnchoredPath -> AnchoredPath
$cmin :: AnchoredPath -> AnchoredPath -> AnchoredPath
max :: AnchoredPath -> AnchoredPath -> AnchoredPath
$cmax :: AnchoredPath -> AnchoredPath -> AnchoredPath
>= :: AnchoredPath -> AnchoredPath -> Bool
$c>= :: AnchoredPath -> AnchoredPath -> Bool
> :: AnchoredPath -> AnchoredPath -> Bool
$c> :: AnchoredPath -> AnchoredPath -> Bool
<= :: AnchoredPath -> AnchoredPath -> Bool
$c<= :: AnchoredPath -> AnchoredPath -> Bool
< :: AnchoredPath -> AnchoredPath -> Bool
$c< :: AnchoredPath -> AnchoredPath -> Bool
compare :: AnchoredPath -> AnchoredPath -> Ordering
$ccompare :: AnchoredPath -> AnchoredPath -> Ordering
$cp1Ord :: Eq AnchoredPath
Ord)

-- | Check whether a path is a prefix of another path.
isPrefix :: AnchoredPath -> AnchoredPath -> Bool
(AnchoredPath [Name]
a) isPrefix :: AnchoredPath -> AnchoredPath -> Bool
`isPrefix` (AnchoredPath [Name]
b) = [Name]
a [Name] -> [Name] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Name]
b

-- | Append an element to the end of a path.
appendPath :: AnchoredPath -> Name -> AnchoredPath
appendPath :: AnchoredPath -> Name -> AnchoredPath
appendPath (AnchoredPath [Name]
p) Name
n = [Name] -> AnchoredPath
AnchoredPath ([Name] -> AnchoredPath) -> [Name] -> AnchoredPath
forall a b. (a -> b) -> a -> b
$ [Name]
p [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
n]

-- | Catenate two paths together. Not very safe, but sometimes useful
-- (e.g. when you are representing paths relative to a different point than a
-- Tree root).
catPaths :: AnchoredPath -> AnchoredPath -> AnchoredPath
catPaths :: AnchoredPath -> AnchoredPath -> AnchoredPath
catPaths (AnchoredPath [Name]
p) (AnchoredPath [Name]
n) = [Name] -> AnchoredPath
AnchoredPath ([Name]
p [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
n)

-- | Get parent (path) of a given path. foo/bar/baz -> foo/bar
parent :: AnchoredPath -> Maybe AnchoredPath
parent :: AnchoredPath -> Maybe AnchoredPath
parent (AnchoredPath []) = Maybe AnchoredPath
forall a. Maybe a
Nothing
parent (AnchoredPath [Name]
x) = AnchoredPath -> Maybe AnchoredPath
forall a. a -> Maybe a
Just ([Name] -> AnchoredPath
AnchoredPath ([Name] -> [Name]
forall a. [a] -> [a]
init [Name]
x))

-- | List all parents of a given path. foo/bar/baz -> [.,foo, foo/bar]
parents :: AnchoredPath -> [AnchoredPath]
parents :: AnchoredPath -> [AnchoredPath]
parents (AnchoredPath []) = [] -- root has no parents
parents (AnchoredPath [Name]
xs) = ([Name] -> AnchoredPath) -> [[Name]] -> [AnchoredPath]
forall a b. (a -> b) -> [a] -> [b]
map [Name] -> AnchoredPath
AnchoredPath ([[Name]] -> [AnchoredPath]) -> [[Name]] -> [AnchoredPath]
forall a b. (a -> b) -> a -> b
$ [Name] -> [[Name]]
forall a. [a] -> [[a]]
inits ([Name] -> [[Name]]) -> [Name] -> [[Name]]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. [a] -> [a]
init [Name]
xs

-- | If the patch is under a directory, split into Right of the first component
-- (which must be a directory name) and the rest of teh path. Otherwise
-- return Left of the single component.
-- This function is *undefined* on the root path (which has no components).
breakOnDir :: AnchoredPath -> Either Name (Name, AnchoredPath)
breakOnDir :: AnchoredPath -> Either Name (Name, AnchoredPath)
breakOnDir (AnchoredPath []) = FilePath -> Either Name (Name, AnchoredPath)
forall a. HasCallStack => FilePath -> a
error FilePath
"breakOnDir called on root"
breakOnDir (AnchoredPath (Name
n:[])) = Name -> Either Name (Name, AnchoredPath)
forall a b. a -> Either a b
Left Name
n
breakOnDir (AnchoredPath (Name
n:[Name]
ns)) = (Name, AnchoredPath) -> Either Name (Name, AnchoredPath)
forall a b. b -> Either a b
Right (Name
n, [Name] -> AnchoredPath
AnchoredPath [Name]
ns)

-- | Take a "root" directory and an anchored path and produce a full
-- 'FilePath'. Moreover, you can use @anchorPath \"\"@ to get a relative
-- 'FilePath'.
anchorPath :: FilePath -> AnchoredPath -> FilePath
anchorPath :: FilePath -> AnchoredPath -> FilePath
anchorPath FilePath
dir AnchoredPath
p = FilePath
dir FilePath -> FilePath -> FilePath
FilePath.</> ByteString -> FilePath
decodeLocale (AnchoredPath -> ByteString
flatten AnchoredPath
p)
{-# INLINE anchorPath #-}

name2fp :: Name -> FilePath
name2fp :: Name -> FilePath
name2fp (Name ByteString
ps) = ByteString -> FilePath
decodeLocale ByteString
ps

-- FIXME returning "." for the root is wrong
flatten :: AnchoredPath -> BC.ByteString
flatten :: AnchoredPath -> ByteString
flatten (AnchoredPath []) = Char -> ByteString
BC.singleton Char
'.'
flatten (AnchoredPath [Name]
p) = ByteString -> [ByteString] -> ByteString
BC.intercalate (Char -> ByteString
BC.singleton Char
'/') [ByteString
n | (Name ByteString
n) <- [Name]
p]

-- | Make a 'Name' from a 'String'. If the input 'String'
-- is invalid, that is, "", ".", "..", or contains a '/', return 'Left'
-- with an error message.
makeName :: String -> Either String Name
makeName :: FilePath -> Either FilePath Name
makeName = ByteString -> Either FilePath Name
rawMakeName (ByteString -> Either FilePath Name)
-> (FilePath -> ByteString) -> FilePath -> Either FilePath Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
encodeLocale

-- | Make a 'Name' from a 'String'. If the input 'String'
-- is invalid, that is, "", ".", "..", or contains a '/', call error.
internalMakeName :: String -> Name
internalMakeName :: FilePath -> Name
internalMakeName = (FilePath -> Name)
-> (Name -> Name) -> Either FilePath Name -> Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Name
forall a. HasCallStack => FilePath -> a
error Name -> Name
forall a. a -> a
id (Either FilePath Name -> Name)
-> (FilePath -> Either FilePath Name) -> FilePath -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either FilePath Name
rawMakeName (ByteString -> Either FilePath Name)
-> (FilePath -> ByteString) -> FilePath -> Either FilePath Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
encodeLocale

-- | Take a relative FilePath and turn it into an AnchoredPath. This is a
-- partial function. Basically, by using floatPath, you are testifying that the
-- argument is a path relative to some common root -- i.e. the root of the
-- associated "Tree" object. In particular, the input path may not contain any
-- ocurrences of "." or ".." after normalising. You should sanitize any
-- FilePaths before you declare them "good" by converting into AnchoredPath
-- (using this function), especially if the FilePath come from any external
-- source (command line, file, environment, network, etc)
floatPath :: FilePath -> AnchoredPath
floatPath :: FilePath -> AnchoredPath
floatPath =
    [Name] -> AnchoredPath
AnchoredPath ([Name] -> AnchoredPath)
-> (FilePath -> [Name]) -> FilePath -> AnchoredPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Name) -> [FilePath] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Name
internalMakeName ([FilePath] -> [Name])
-> (FilePath -> [FilePath]) -> FilePath -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
sensible ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    FilePath -> [FilePath]
splitDirectories (FilePath -> [FilePath])
-> (FilePath -> FilePath) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
normalise (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
dropTrailingPathSeparator
  where
    sensible :: FilePath -> Bool
sensible FilePath
s = FilePath
s FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FilePath
"", FilePath
"."]

anchoredRoot :: AnchoredPath
anchoredRoot :: AnchoredPath
anchoredRoot = [Name] -> AnchoredPath
AnchoredPath []

-- | A view on 'AnchoredPath's.
parentChild :: AnchoredPath -> Maybe (AnchoredPath, Name)
parentChild :: AnchoredPath -> Maybe (AnchoredPath, Name)
parentChild (AnchoredPath []) = Maybe (AnchoredPath, Name)
forall a. Maybe a
Nothing
parentChild (AnchoredPath [Name]
xs) = (AnchoredPath, Name) -> Maybe (AnchoredPath, Name)
forall a. a -> Maybe a
Just ([Name] -> AnchoredPath
AnchoredPath ([Name] -> [Name]
forall a. [a] -> [a]
init [Name]
xs), [Name] -> Name
forall a. [a] -> a
last [Name]
xs)

-- | Replace the second arg's parent with the first arg.
replaceParent :: AnchoredPath -> AnchoredPath -> Maybe AnchoredPath
replaceParent :: AnchoredPath -> AnchoredPath -> Maybe AnchoredPath
replaceParent (AnchoredPath [Name]
xs) AnchoredPath
p =
  case AnchoredPath -> Maybe (AnchoredPath, Name)
parentChild AnchoredPath
p of
    Maybe (AnchoredPath, Name)
Nothing -> Maybe AnchoredPath
forall a. Maybe a
Nothing
    Just (AnchoredPath
_,Name
x) -> AnchoredPath -> Maybe AnchoredPath
forall a. a -> Maybe a
Just ([Name] -> AnchoredPath
AnchoredPath ([Name]
xs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
x]))

-- | Make a 'Name' from a 'B.ByteString'.
rawMakeName :: B.ByteString -> Either String Name
rawMakeName :: ByteString -> Either FilePath Name
rawMakeName ByteString
s
  | ByteString -> Bool
isBadName ByteString
s =
      FilePath -> Either FilePath Name
forall a b. a -> Either a b
Left (FilePath -> Either FilePath Name)
-> FilePath -> Either FilePath Name
forall a b. (a -> b) -> a -> b
$ FilePath
"'"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ByteString -> FilePath
decodeLocale ByteString
sFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"' is not a valid AnchoredPath component name"
  | Bool
otherwise = Name -> Either FilePath Name
forall a b. b -> Either a b
Right (ByteString -> Name
Name ByteString
s)

isBadName :: B.ByteString -> Bool
isBadName :: ByteString -> Bool
isBadName ByteString
n = ByteString -> Bool
hasPathSeparator ByteString
n Bool -> Bool -> Bool
|| ByteString
n ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
forbiddenNames

-- It would be nice if we could add BC.pack "_darcs" to the list, however
-- "_darcs" could be a valid file or dir name if not inside the top level
-- directory.
forbiddenNames :: [B.ByteString]
forbiddenNames :: [ByteString]
forbiddenNames = [ByteString
BC.empty, FilePath -> ByteString
BC.pack FilePath
".", FilePath -> ByteString
BC.pack FilePath
".."]

hasPathSeparator :: B.ByteString -> Bool
hasPathSeparator :: ByteString -> Bool
hasPathSeparator = Char -> ByteString -> Bool
BC.elem Char
'/'

eqAnycase :: Name -> Name -> Bool
eqAnycase :: Name -> Name -> Bool
eqAnycase (Name ByteString
a) (Name ByteString
b) = (Char -> Char) -> ByteString -> ByteString
BC.map Char -> Char
toLower ByteString
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Char) -> ByteString -> ByteString
BC.map Char -> Char
toLower ByteString
b

encodeWhiteName :: Name -> B.ByteString
encodeWhiteName :: Name -> ByteString
encodeWhiteName = FilePath -> ByteString
encodeLocale (FilePath -> ByteString)
-> (Name -> FilePath) -> Name -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
encodeWhite (FilePath -> FilePath) -> (Name -> FilePath) -> Name -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
decodeLocale (ByteString -> FilePath)
-> (Name -> ByteString) -> Name -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ByteString
unName

data CorruptPatch = CorruptPatch String deriving (CorruptPatch -> CorruptPatch -> Bool
(CorruptPatch -> CorruptPatch -> Bool)
-> (CorruptPatch -> CorruptPatch -> Bool) -> Eq CorruptPatch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CorruptPatch -> CorruptPatch -> Bool
$c/= :: CorruptPatch -> CorruptPatch -> Bool
== :: CorruptPatch -> CorruptPatch -> Bool
$c== :: CorruptPatch -> CorruptPatch -> Bool
Eq, Typeable)
instance Exception CorruptPatch
instance Show CorruptPatch where show :: CorruptPatch -> FilePath
show (CorruptPatch FilePath
s) = FilePath
s

decodeWhiteName :: B.ByteString -> Name
decodeWhiteName :: ByteString -> Name
decodeWhiteName =
  (FilePath -> Name)
-> (Name -> Name) -> Either FilePath Name -> Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (CorruptPatch -> Name
forall a e. Exception e => e -> a
throw (CorruptPatch -> Name)
-> (FilePath -> CorruptPatch) -> FilePath -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> CorruptPatch
CorruptPatch) Name -> Name
forall a. a -> a
id (Either FilePath Name -> Name)
-> (ByteString -> Either FilePath Name) -> ByteString -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  ByteString -> Either FilePath Name
rawMakeName (ByteString -> Either FilePath Name)
-> (ByteString -> ByteString) -> ByteString -> Either FilePath Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
encodeLocale (FilePath -> ByteString)
-> (ByteString -> FilePath) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
decodeWhite (FilePath -> FilePath)
-> (ByteString -> FilePath) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
decodeLocale

-- | The effect of renaming on paths.
-- The first argument is the old path, the second is the new path,
-- and the third is the possibly affected path we are interested in.
movedirfilename :: AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath
movedirfilename :: AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath
movedirfilename (AnchoredPath [Name]
old) newp :: AnchoredPath
newp@(AnchoredPath [Name]
new) orig :: AnchoredPath
orig@(AnchoredPath [Name]
path) =
  case [Name] -> [Name] -> Maybe [Name]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Name]
old [Name]
path of
    Just [] -> AnchoredPath
newp -- optimization to avoid allocation in this case
    Just [Name]
rest -> [Name] -> AnchoredPath
AnchoredPath ([Name]
new [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
rest)
    Maybe [Name]
Nothing -> AnchoredPath
orig -- old is not a prefix => no change

-- | Construct a filter from a list of AnchoredPaths, that will accept any path
-- that is either a parent or a child of any of the listed paths, and discard
-- everything else.
filterPaths :: [AnchoredPath] -> AnchoredPath -> t -> Bool
filterPaths :: [AnchoredPath] -> AnchoredPath -> t -> Bool
filterPaths [AnchoredPath]
files AnchoredPath
p t
_ = (AnchoredPath -> Bool) -> [AnchoredPath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\AnchoredPath
x -> AnchoredPath
x AnchoredPath -> AnchoredPath -> Bool
`isPrefix` AnchoredPath
p Bool -> Bool -> Bool
|| AnchoredPath
p AnchoredPath -> AnchoredPath -> Bool
`isPrefix` AnchoredPath
x) [AnchoredPath]
files


-- | Transform a SubPath into an AnchoredPath.
floatSubPath :: SubPath -> AnchoredPath
floatSubPath :: SubPath -> AnchoredPath
floatSubPath = FilePath -> AnchoredPath
floatPath (FilePath -> AnchoredPath)
-> (SubPath -> FilePath) -> SubPath -> AnchoredPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubPath -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath

-- | Is the given path in (or equal to) the _darcs metadata directory?
inDarcsdir :: AnchoredPath -> Bool
inDarcsdir :: AnchoredPath -> Bool
inDarcsdir (AnchoredPath (Name
x:[Name]
_)) | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
darcsdirName = Bool
True
inDarcsdir AnchoredPath
_ = Bool
False

darcsdirName :: Name
darcsdirName :: Name
darcsdirName = FilePath -> Name
internalMakeName FilePath
darcsdir

isRoot :: AnchoredPath -> Bool
isRoot :: AnchoredPath -> Bool
isRoot (AnchoredPath [Name]
xs) = [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
xs