-- 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
    ( FileName( )
    , fp2fn
    , fn2fp
    , fn2ps
    , ps2fn
    , niceps2fn
    , fn2niceps
    , breakOnDir
    , normPath
    , ownName
    , superName
    , movedirfilename
    , encodeWhite
    , decodeWhite
    , isParentOrEqOf
    -- * AbsolutePath
    , AbsolutePath
    , makeAbsolute
    , ioAbsolute
    , rootDirectory
    -- * AbsolutePathOrStd
    , AbsolutePathOrStd
    , makeAbsoluteOrStd
    , ioAbsoluteOrStd
    , useAbsoluteOrStd
    , stdOut
    -- * AbsoluteOrRemotePath
    , AbsoluteOrRemotePath
    , ioAbsoluteOrRemote
    , isRemote
    -- * SubPath
    , SubPath
    , makeSubPathOf
    , simpleSubPath
    , isSubPathOf
    , floatSubPath
    -- * Miscellaneous
    , sp2fn
    , FilePathOrURL(..)
    , FilePathLike(toFilePath)
    , getCurrentDirectory
    , setCurrentDirectory
    , getUniquePathName
    , doesPathExist
    -- * Check for malicious paths
    , isMaliciousPath
    , isMaliciousSubPath
    -- * Tree filtering.
    , filterFilePaths
    , 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(..)
    , AnchoredPath(..)
    , anchoredRoot
    , appendPath
    , anchorPath
    , isPrefix
    , parent, parents, catPaths, flatten, makeName, appendToName
    -- * Unsafe AnchoredPath functions.
    , floatBS, floatPath, replacePrefixPath ) where

import Prelude ()
import Darcs.Prelude

import Data.List
    ( isPrefixOf
    , isSuffixOf
    , stripPrefix
    , intersect
    , inits
    )
import Data.Char ( isSpace, chr, ord )
import Control.Exception ( tryJust, bracket_ )
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 )
import qualified System.FilePath as NativeFilePath ( takeFileName, takeDirectory )
import System.FilePath( (</>), splitDirectories, normalise, dropTrailingPathSeparator )
import System.Posix.Files ( isDirectory, getSymbolicLinkStatus )

import Darcs.Util.ByteString ( packStringToUTF8, unpackPSFromUTF8 )
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString       as B  (ByteString)

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

#include "impossible.h"


-- | FileName is an abstract type intended to facilitate the input and output of
-- unicode filenames.
newtype FileName = FN FilePath deriving ( Eq, Ord )

instance Show FileName where
   showsPrec d (FN fp) = showParen (d > appPrec) $ showString "fp2fn " . showsPrec (appPrec + 1) fp
      where appPrec = 10

instance Binary FileName where
  put (FN h) = put h
  get = FN `fmap` get

{-# INLINE fp2fn #-}
fp2fn :: FilePath -> FileName
fp2fn = FN

{-# INLINE fn2fp #-}
fn2fp :: FileName -> FilePath
fn2fp (FN fp) = fp

{-# INLINE niceps2fn #-}
niceps2fn :: B.ByteString -> FileName
niceps2fn = FN . decodeWhite . BC.unpack

{-# INLINE fn2niceps #-}
fn2niceps :: FileName -> B.ByteString
fn2niceps (FN fp) = BC.pack $ encodeWhite fp

{-# INLINE fn2ps #-}
fn2ps :: FileName -> B.ByteString
fn2ps (FN fp) = packStringToUTF8 $ encodeWhite fp

{-# INLINE ps2fn #-}
ps2fn :: B.ByteString -> FileName
ps2fn ps = FN $ decodeWhite $ unpackPSFromUTF8 ps

{-# INLINE sp2fn #-}
sp2fn :: SubPath -> FileName
sp2fn = fp2fn . toFilePath

-- | '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 (c:cs) | isSpace c || c == '\\' =
    '\\' : show (ord c) ++ "\\" ++ encodeWhite cs
encodeWhite (c:cs) = c : encodeWhite 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 cs_ = go cs_ [] False
 where go "" acc True  = reverse acc -- if there was a replace, use new string
       go "" _   False = cs_         -- if not, use input string
       go ('\\':cs) acc _ =
         case break (=='\\') cs of
           (theord, '\\':rest) ->
             go rest (chr (read theord) :acc) True
           _ -> error "malformed filename"
       go (c:cs) acc modified = go cs (c:acc) modified

ownName :: FileName -> FileName
ownName (FN f) =  case breakLast '/' f of Nothing -> FN f
                                          Just (_,f') -> FN f'
superName :: FileName -> FileName
superName fn = case normPath fn of
                FN f -> case breakLast '/' f of
                        Nothing -> FN "."
                        Just (d,_) -> FN d
breakOnDir :: FileName -> Maybe (FileName,FileName)
breakOnDir (FN p) = case breakFirst '/' p of
                      Nothing -> Nothing
                      Just (d,f) | d == "." -> breakOnDir $ FN f
                                 | otherwise -> Just (FN d, FN f)

-- | convert a path string into a sequence of directories strings
--   "/", "." and ".." are generally interpreted as expected.
--   Behaviour with too many '..' is to leave them.
--
--   Examples:
--     Splitting:
--       "aa/bb/cc"       -> ["aa","bb","cc"]
--     Ignoring "." and extra "/":
--       "aa/./bb"        -> ["aa","bb"]
--       "aa//bb"         -> ["aa","bb"]
--       "/aa/bb/"        -> ["aa","bb"]
--     Handling "..":
--       "aa/../bb/cc"    -> ["bb","cc"]
--       "aa/bb/../../cc" -> ["cc"]
--       "aa/../bb/../cc" -> ["cc"]
--       "../cc"          -> ["..","cc"]
normPath :: FileName -> FileName
normPath (FN p) = FN $ norm p

norm :: String -> String
norm ('.':'/':s) = norm s
norm ('/':s)     = norm s
norm "."         = ""
norm s = go s [] False
 where go "" _   False = s           -- no modification
       go "" acc True  = reverse acc
       go ('/':r)         acc _ | sep r = go r acc True
       go ('/':'.':r)     acc _ | sep r = go r acc True
       go ('/':'.':'.':r) acc _ | sep r = go r (doDotDot acc) True
       go (c:s') acc changed = go s' (c:acc) changed
       -- remove last path or add "/.." if impossible
       doDotDot ""                       = ".."
       doDotDot acc@('.':'.':r) | sep r  = '.':'.':'/':acc
       doDotDot acc = let a' = dropWhile (/='/') acc in -- eat dir
                       if null a' then "" else tail a'
       -- check if is a path separator
       sep ('/':_) = True
       sep []      = True -- end of string is considered separator
       sep _       = False

breakFirst :: Char -> String -> Maybe (String,String)
breakFirst c = bf []
    where bf a (r:rs) | r == c = Just (reverse a,rs)
                      | otherwise = bf (r:a) rs
          bf _ [] = Nothing
breakLast :: Char -> String -> Maybe (String,String)
breakLast c l = case breakFirst c (reverse l) of
                Nothing -> Nothing
                Just (a,b) -> Just (reverse b, reverse a)

isParentOrEqOf :: FileName -> FileName -> Bool
isParentOrEqOf fn1 fn2 = case stripPrefix (fn2fp fn1) (fn2fp fn2) of
    Just ('/' : _) -> True
    Just [] -> True
    _ -> False

movedirfilename :: FileName -> FileName -> FileName -> FileName
movedirfilename old new name =
    if name' == old'
        then new
        else case stripPrefix old' name' of
            Just rest@('/':_) -> fp2fn $ "./" ++ new' ++ rest
            _ -> name
        where old' = fn2fp $ normPath old
              new' = fn2fp $ normPath new
              name' = fn2fp $ normPath name


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 (Eq, Ord)

newtype AbsolutePath = AbsolutePath FilePath deriving (Eq, 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 (Eq, Ord)
data AbsoluteOrRemotePath = AbsP AbsolutePath | RmtP String deriving (Eq, Ord)

instance FilePathOrURL AbsolutePath where
  toPath (AbsolutePath x) = x
instance FilePathOrURL SubPath where
  toPath (SubPath x) = x
instance CharLike c => FilePathOrURL [c] where
  toPath = toFilePath

instance FilePathOrURL AbsoluteOrRemotePath where
  toPath (AbsP a) = toPath a
  toPath (RmtP r) = r

instance FilePathOrURL FileName where
  toPath = fn2fp
instance FilePathLike FileName where
  toFilePath = fn2fp

instance FilePathLike AbsolutePath where
  toFilePath (AbsolutePath x) = x
instance FilePathLike SubPath where
  toFilePath (SubPath x) = x

class CharLike c where
  toChar :: c -> Char

instance CharLike Char where
  toChar = id

instance CharLike c => FilePathLike [c] where
  toFilePath = map toChar

-- | Make the second path relative to the first, if possible
makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath
makeSubPathOf (AbsolutePath p1) (AbsolutePath p2) =
 -- The slash prevents "foobar" from being treated as relative to "foo"
 if p1 == p2 || (p1 ++ "/") `isPrefixOf` p2
    then Just $ SubPath $ drop (length p1 + 1) p2
    else Nothing

simpleSubPath :: FilePath -> Maybe SubPath
simpleSubPath x | null x = bug "simpleSubPath called with empty path"
                | isRelative x = Just $ SubPath $ FilePath.normalise $ pathToPosix x
                | otherwise = Nothing

isSubPathOf :: SubPath -> SubPath -> Bool
isSubPathOf (SubPath p1) (SubPath p2) =
    p1 == "" || p1 == p2 || (p1 ++ "/") `isPrefixOf` p2

-- | Ensure directory exists and is not a symbolic link.
doesDirectoryReallyExist :: FilePath -> IO Bool
doesDirectoryReallyExist f = do
    x <- tryJust (\x -> if isDoesNotExistError x then Just () else Nothing) $
        isDirectory <$> getSymbolicLinkStatus f
    return $ case x of
        Left () -> False
        Right y -> y

doesPathExist :: FilePath -> IO Bool
doesPathExist p = do
   dir_exists <- doesDirectoryExist p
   file_exists <- doesFileExist p
   return $ dir_exists || file_exists

-- | Interpret a possibly relative path wrt the current working directory.
ioAbsolute :: FilePath -> IO AbsolutePath
ioAbsolute dir =
    do isdir <- doesDirectoryReallyExist dir
       here <- getCurrentDirectory
       if isdir
         then bracket_ (setCurrentDirectory dir)
                       (setCurrentDirectory $ toFilePath here)
                       getCurrentDirectory
         else let super_dir = case NativeFilePath.takeDirectory dir of
                                "" ->  "."
                                d  -> d
                  file = NativeFilePath.takeFileName dir
              in do abs_dir <- if dir == super_dir
                               then return $ AbsolutePath dir
                               else ioAbsolute super_dir
                    return $ makeAbsolute abs_dir 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 a dir = if not (null dir) && isAbsolute dir
                     then AbsolutePath (normSlashes dir')
                     else ma a dir'
  where
    dir' = FilePath.normalise $ pathToPosix dir
    -- Why do we care to reduce ".." here?
    -- Why not do this throughout the whole path, i.e. "x/y/../z" -> "x/z" ?
    ma here ('.':'.':'/':r) = ma (takeDirectory here) r
    ma here ".." = takeDirectory here
    ma here "." = here
    ma here "" = here
    ma here r = here /- ('/':r)

(/-) :: AbsolutePath -> String -> AbsolutePath
x /- ('/':r) = x /- r
(AbsolutePath "/") /- r = AbsolutePath ('/':simpleClean r)
(AbsolutePath x) /- r = AbsolutePath (x++'/':simpleClean r)

-- | Convert to posix, remove trailing slashes, and (under Posix)
-- reduce multiple leading slashes to one.
simpleClean :: String -> String
simpleClean = normSlashes . reverse . dropWhile (=='/') . reverse . pathToPosix

-- | The root directory as an absolute path.
rootDirectory :: AbsolutePath
rootDirectory = AbsolutePath "/"

makeAbsoluteOrStd :: AbsolutePath -> String -> AbsolutePathOrStd
makeAbsoluteOrStd _ "-" = APStd
makeAbsoluteOrStd a p = AP $ makeAbsolute a p

stdOut :: AbsolutePathOrStd
stdOut = APStd

ioAbsoluteOrStd :: String -> IO AbsolutePathOrStd
ioAbsoluteOrStd "-" = return APStd
ioAbsoluteOrStd p = AP `fmap` ioAbsolute 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 _ f APStd = f
useAbsoluteOrStd f _ (AP x) = f x

ioAbsoluteOrRemote :: String -> IO AbsoluteOrRemotePath
ioAbsoluteOrRemote p = do
  isdir <- doesDirectoryExist p
  if not isdir
     then return $ RmtP $
          case () of _ | isSshNopath p    -> p++"."
                       | "/" `isSuffixOf` p -> init p
                       | otherwise          -> p
     else AbsP `fmap` ioAbsolute p

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

takeDirectory :: AbsolutePath -> AbsolutePath
takeDirectory (AbsolutePath x) =
    case reverse $ drop 1 $ dropWhile (/='/') $ reverse x of
    "" -> AbsolutePath "/"
    x' -> AbsolutePath x'

instance Show AbsolutePath where
 show = show . toFilePath
instance Show SubPath where
 show = show . toFilePath
instance Show AbsolutePathOrStd where
    show (AP a) = show a
    show APStd = "standard input/output"
instance Show AbsoluteOrRemotePath where
    show (AbsP a) = show a
    show (RmtP r) = show r

-- | Normalize the path separator to Posix style (slash, not backslash).
-- This only affects Windows systems.
pathToPosix :: FilePath -> FilePath
pathToPosix = map convert where
#ifdef WIN32
  convert '\\' = '/'
#endif
  convert c = 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 ('/':p) = '/' : dropWhile (== '/') p
#endif
normSlashes p = p

getCurrentDirectory :: IO AbsolutePath
getCurrentDirectory = AbsolutePath `fmap` Workaround.getCurrentDirectory

setCurrentDirectory :: FilePathLike p => p -> IO ()
setCurrentDirectory = System.Directory.setCurrentDirectory . 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'?
-}
isMaliciousPath :: String -> Bool
isMaliciousPath fp =
    not (isExplicitlyRelative fp) || isGenerallyMalicious fp

-- | Warning : this is less rigorous than isMaliciousPath
--   but it's to allow for subpath representations that
--   don't start with ./
isMaliciousSubPath :: String -> Bool
isMaliciousSubPath fp =
    not (isRelative fp) || isGenerallyMalicious fp

isGenerallyMalicious :: String -> Bool
isGenerallyMalicious fp =
    splitDirectories fp `contains_any` [ "..", darcsdir ]
 where
    contains_any a b = not . null $ intersect a b


isExplicitlyRelative :: String -> Bool
isExplicitlyRelative ('.':'/':_) = True  -- begins with "./"
isExplicitlyRelative _ = False

-- | 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 files p _ = any (\x -> x `isPrefix` p || p `isPrefix` x) files


-- | Same as 'filterPath', but for ordinary 'FilePath's (as opposed to
-- AnchoredPath).
filterFilePaths :: [FilePath]
                -> AnchoredPath
                -> t
                -> Bool
filterFilePaths = filterPaths . map floatPath

-- | 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 talkative buildMsg buildName = go (-1)
 where
  go :: Int -> IO FilePath
  go i = do
    exists <- doesPathExist thename
    if not exists
       then do when (i /= -1 && talkative) $ putStrLn $ buildMsg thename
               return thename
       else go $ i+1
    where thename = buildName i

-- | Transform a SubPath into an AnchoredPath.
floatSubPath :: SubPath -> AnchoredPath
floatSubPath = floatPath . fn2fp . sp2fn
 
-------------------------------
-- AnchoredPath utilities
--

newtype Name = Name BC.ByteString  deriving (Eq, Show, 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) or .
newtype AnchoredPath = AnchoredPath [Name] deriving (Eq, Show, Ord)

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

-- | Append an element to the end of a path.
appendPath :: AnchoredPath -> Name -> AnchoredPath
appendPath (AnchoredPath p) n =
    case n of
      (Name s) | s == BC.empty -> AnchoredPath p
               | s == BC.pack "." -> AnchoredPath p
               | otherwise -> AnchoredPath $ p ++ [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 p) (AnchoredPath n) = AnchoredPath $ p ++ n

-- | Get parent (path) of a given path. foo/bar/baz -> foo/bar
parent :: AnchoredPath -> AnchoredPath
parent (AnchoredPath x) = AnchoredPath (init x)

-- | List all parents of a given path. foo/bar/baz -> [foo, foo/bar]
parents :: AnchoredPath -> [AnchoredPath]
parents (AnchoredPath x) = map AnchoredPath . init . inits $ x

-- | 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 dir p = dir </> BC.unpack (flatten p)
{-# INLINE anchorPath #-}

-- | Unsafe. Only ever use on bytestrings that came from flatten on a
-- pre-existing AnchoredPath.
floatBS :: BC.ByteString -> AnchoredPath
floatBS = AnchoredPath . map Name . takeWhile (not . BC.null) . BC.split '/'

flatten :: AnchoredPath -> BC.ByteString
flatten (AnchoredPath []) = BC.singleton '.'
flatten (AnchoredPath p) = BC.intercalate (BC.singleton '/')
                                           [ n | (Name n) <- p ]

makeName :: String -> Name
makeName ".." = error ".. is not a valid AnchoredPath component name"
makeName n | '/' `elem` n = error "/ may not occur in a valid AnchoredPath component name"
           | otherwise = Name $ BC.pack n

-- | Take a relative FilePath and turn it into an AnchoredPath. The operation
-- is (relatively) unsafe. 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. Also, there are certain invariants about
-- AnchoredPath that this function tries hard to preserve, but probably cannot
-- guarantee (i.e. this is a best-effort thing). You should sanitize any
-- FilePaths before you declare them "good" by converting into AnchoredPath
-- (using this function).
floatPath :: FilePath -> AnchoredPath
floatPath = make . splitDirectories . normalise . dropTrailingPathSeparator
  where make ["."] = AnchoredPath []
        make x = AnchoredPath $ map (Name . BC.pack) x


anchoredRoot :: AnchoredPath
anchoredRoot = AnchoredPath []

-- | Take a prefix path, the changed prefix path, and a path to change.
-- Assumes the prefix path is a valid prefix. If prefix is wrong return
-- AnchoredPath [].
replacePrefixPath :: AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath
replacePrefixPath (AnchoredPath []) b c = catPaths b c
replacePrefixPath (AnchoredPath (r:p)) b (AnchoredPath (r':p'))
    | r == r' = replacePrefixPath (AnchoredPath p) b (AnchoredPath p')
    | otherwise = AnchoredPath []
replacePrefixPath _ _ _ = AnchoredPath []

-- | Append a ByteString to the last Name of an AnchoredPath.
appendToName :: AnchoredPath -> String -> AnchoredPath
appendToName (AnchoredPath p) s = AnchoredPath (init p++[Name finalname])
    where suffix = BC.pack s
          finalname | suffix `elem` (BC.tails lastname) = lastname
                    | otherwise = BC.append lastname suffix
          lastname = case last p of
                        Name name -> name