1 {-# OPTIONS_GHC -cpp #-}
    2 {-# LANGUAGE CPP #-}
    3 
    4 -- Copyright (C) 2007 Eric Kow
    5 --
    6 -- This program is free software; you can redistribute it and/or modify
    7 -- it under the terms of the GNU General Public License as published by
    8 -- the Free Software Foundation; either version 2, or (at your option)
    9 -- any later version.
   10 --
   11 -- This program is distributed in the hope that it will be useful,
   12 -- but WITHOUT ANY WARRANTY; without even the implied warranty of
   13 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   14 -- GNU General Public License for more details.
   15 --
   16 -- You should have received a copy of the GNU General Public License
   17 -- along with this program; see the file COPYING.  If not, write to
   18 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   19 -- Boston, MA 02110-1301, USA.
   20 
   21 -- | Various abstractions for dealing with paths.
   22 module Darcs.RepoPath (
   23   -- * AbsolutePath
   24   AbsolutePath,
   25   makeAbsolute,
   26   ioAbsolute,
   27   rootDirectory,
   28   -- * AbsolutePathOrStd
   29   AbsolutePathOrStd,
   30   makeAbsoluteOrStd,
   31   ioAbsoluteOrStd,
   32   useAbsoluteOrStd,
   33   -- * AbsoluteOrRemotePath
   34   AbsoluteOrRemotePath,
   35   ioAbsoluteOrRemote,
   36   isRemote,
   37   -- * SubPath
   38   SubPath,
   39   makeSubPathOf,
   40   simpleSubPath,
   41   -- * Miscellaneous
   42   sp2fn,
   43   FilePathOrURL(..),
   44   FilePathLike(toFilePath),
   45   getCurrentDirectory,
   46   setCurrentDirectory
   47 ) where
   48 
   49 import Data.List ( isPrefixOf, isSuffixOf )
   50 import Control.Exception ( bracket )
   51 
   52 import Darcs.URL ( is_absolute, is_relative, is_ssh_nopath )
   53 import qualified Workaround ( getCurrentDirectory )
   54 import qualified System.Directory ( setCurrentDirectory )
   55 import System.Directory ( doesDirectoryExist )
   56 import qualified System.FilePath.Posix as FilePath ( normalise )
   57 import qualified System.FilePath as NativeFilePath ( takeFileName, takeDirectory )
   58 import qualified Darcs.Patch.FileName as PatchFileName ( FileName, fp2fn, fn2fp )
   59 #include "impossible.h"
   60 
   61 class FilePathOrURL a where
   62  {-# INLINE toPath #-}
   63  toPath :: a -> String
   64 
   65 class FilePathOrURL a => FilePathLike a where
   66  {-# INLINE toFilePath #-}
   67  toFilePath :: a -> FilePath
   68 
   69 -- | Paths which are relative to the local darcs repository and normalized.
   70 -- Note: These are understood not to have the dot in front.
   71 newtype SubPath      = SubPath FilePath deriving (Eq, Ord)
   72 
   73 newtype AbsolutePath = AbsolutePath FilePath deriving (Eq, Ord)
   74 
   75 -- | This is for situations where a string (e.g. a command line argument)
   76 -- may take the value \"-\" to mean stdin or stdout (which one depends on
   77 -- context) instead of a normal file path.
   78 data AbsolutePathOrStd = AP AbsolutePath | APStd deriving (Eq, Ord)
   79 data AbsoluteOrRemotePath = AbsP AbsolutePath | RmtP String deriving (Eq, Ord)
   80 
   81 instance FilePathOrURL AbsolutePath where
   82  toPath (AbsolutePath x) = x
   83 instance FilePathOrURL SubPath where
   84  toPath (SubPath x) = x
   85 instance CharLike c => FilePathOrURL [c] where
   86  toPath = toFilePath
   87 
   88 instance FilePathOrURL AbsoluteOrRemotePath where
   89  toPath (AbsP a) = toPath a
   90  toPath (RmtP r) = r
   91 
   92 instance FilePathOrURL PatchFileName.FileName where
   93     toPath = PatchFileName.fn2fp
   94 instance FilePathLike PatchFileName.FileName where
   95     toFilePath = PatchFileName.fn2fp
   96 
   97 instance FilePathLike AbsolutePath where
   98  toFilePath (AbsolutePath x) = x
   99 instance FilePathLike SubPath where
  100  toFilePath (SubPath x) = x
  101 
  102 class CharLike c where
  103     toChar :: c -> Char
  104     fromChar :: Char -> c
  105 instance CharLike Char where
  106     toChar = id
  107     fromChar = id
  108 
  109 instance CharLike c => FilePathLike [c] where
  110     toFilePath = map toChar
  111 
  112 -- | Make the second path relative to the first, if possible
  113 makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath
  114 makeSubPathOf (AbsolutePath p1) (AbsolutePath p2) =
  115  -- The slash prevents "foobar" from being treated as relative to "foo"
  116  if p1 == p2 || (p1 ++ "/") `isPrefixOf` p2
  117     then Just $ SubPath $ drop (length p1 + 1) p2
  118     else Nothing
  119 
  120 simpleSubPath :: FilePath -> Maybe SubPath
  121 simpleSubPath x | null x = bug "simpleSubPath called with empty path"                                                                                                  
  122                 | is_relative x = Just $ SubPath $ FilePath.normalise $ pathToPosix x
  123                 | otherwise = Nothing
  124 
  125 -- | Interpret a possibly relative path wrt the current working directory.
  126 ioAbsolute :: FilePath -> IO AbsolutePath
  127 ioAbsolute dir =
  128     do isdir <- doesDirectoryExist dir
  129        here <- getCurrentDirectory
  130        if isdir
  131          then bracket (setCurrentDirectory dir)
  132                       (const $ setCurrentDirectory $ toFilePath here)
  133                       (const getCurrentDirectory)
  134          else let super_dir = case NativeFilePath.takeDirectory dir of
  135                                 "" ->  "."
  136                                 d  -> d
  137                   file = NativeFilePath.takeFileName dir
  138               in do abs_dir <- if dir == super_dir
  139                                then return $ AbsolutePath dir
  140                                else ioAbsolute super_dir
  141                     return $ makeAbsolute abs_dir file
  142 
  143 -- | Take an absolute path and a string representing a (possibly relative)
  144 -- path and combine them into an absolute path. If the second argument is
  145 -- already absolute, then the first argument gets ignored. This function also
  146 -- takes care that the result is converted to Posix convention and
  147 -- normalized. Also, parent directories (\"..\") at the front of the string
  148 -- argument get canceled out against trailing directory parts of the
  149 -- absolute path argument.
  150 --
  151 -- Regarding the last point, someone more familiar with how these functions
  152 -- are used should verify that this is indeed necessary or at least useful.
  153 makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath
  154 makeAbsolute a dir = if not (null dir) && is_absolute dir
  155                      then AbsolutePath (norm_slashes dir')
  156                      else ma a dir'
  157   where
  158     dir' = FilePath.normalise $ pathToPosix dir
  159     -- Why do we care to reduce ".." here?
  160     -- Why not do this throughout the whole path, i.e. "x/y/../z" -> "x/z" ?
  161     ma here ('.':'.':'/':r) = ma (takeDirectory here) r
  162     ma here ".." = takeDirectory here
  163     ma here "." = here
  164     ma here "" = here
  165     ma here r = here /- ('/':r)
  166 
  167 (/-) :: AbsolutePath -> String -> AbsolutePath
  168 x /- ('/':r) = x /- r
  169 (AbsolutePath "/") /- r = AbsolutePath ('/':simpleClean r)
  170 (AbsolutePath x) /- r = AbsolutePath (x++'/':simpleClean r)
  171 
  172 -- | Convert to posix, remove trailing slashes, and (under Posix)
  173 -- reduce multiple leading slashes to one.
  174 simpleClean :: String -> String
  175 simpleClean = norm_slashes . reverse . dropWhile (=='/') . reverse . pathToPosix
  176 
  177 -- | The root directory as an absolute path.
  178 rootDirectory :: AbsolutePath
  179 rootDirectory = AbsolutePath "/"
  180 
  181 makeAbsoluteOrStd :: AbsolutePath -> String -> AbsolutePathOrStd
  182 makeAbsoluteOrStd _ "-" = APStd
  183 makeAbsoluteOrStd a p = AP $ makeAbsolute a p
  184 
  185 ioAbsoluteOrStd :: String -> IO AbsolutePathOrStd
  186 ioAbsoluteOrStd "-" = return APStd
  187 ioAbsoluteOrStd p = AP `fmap` ioAbsolute p
  188 
  189 -- | Execute either the first or the second argument action, depending on
  190 -- whether the given path is an 'AbsolutePath' or stdin/stdout.
  191 useAbsoluteOrStd :: (AbsolutePath -> IO a) -> IO a -> AbsolutePathOrStd -> IO a
  192 useAbsoluteOrStd _ f APStd = f
  193 useAbsoluteOrStd f _ (AP x) = f x
  194 
  195 ioAbsoluteOrRemote :: String -> IO AbsoluteOrRemotePath
  196 ioAbsoluteOrRemote p = do
  197   isdir <- doesDirectoryExist p
  198   if not isdir
  199      then return $ RmtP $
  200           case () of _ | is_ssh_nopath p    -> p++"."
  201                        | "/" `isSuffixOf` p -> init p
  202                        | otherwise          -> p
  203      else AbsP `fmap` ioAbsolute p
  204 
  205 isRemote :: AbsoluteOrRemotePath -> Bool
  206 isRemote (RmtP _) = True
  207 isRemote _ = False
  208 
  209 takeDirectory :: AbsolutePath -> AbsolutePath
  210 takeDirectory (AbsolutePath x) =
  211     case reverse $ drop 1 $ dropWhile (/='/') $ reverse x of
  212     "" -> AbsolutePath "/"
  213     x' -> AbsolutePath x'
  214 
  215 instance Show AbsolutePath where
  216  show = show . toFilePath
  217 instance Show SubPath where
  218  show = show . toFilePath
  219 instance Show AbsolutePathOrStd where
  220     show (AP a) = show a
  221     show APStd = "standard input/output"
  222 instance Show AbsoluteOrRemotePath where
  223     show (AbsP a) = show a
  224     show (RmtP r) = show r
  225 
  226 -- | Normalize the path separator to Posix style (slash, not backslash).
  227 -- This only affects Windows systems.
  228 pathToPosix :: FilePath -> FilePath
  229 pathToPosix = map convert where
  230 #ifdef WIN32
  231   convert '\\' = '/'
  232 #endif
  233   convert c = c
  234 
  235 -- | Reduce multiple leading slashes to one. This only affects Posix systems.
  236 norm_slashes :: FilePath -> FilePath
  237 #ifndef WIN32
  238 -- multiple slashes in front are ignored under Posix
  239 norm_slashes ('/':p) = '/' : dropWhile (== '/') p
  240 #endif
  241 norm_slashes p = p
  242 
  243 getCurrentDirectory :: IO AbsolutePath
  244 getCurrentDirectory = AbsolutePath `fmap` Workaround.getCurrentDirectory
  245 
  246 setCurrentDirectory :: FilePathLike p => p -> IO ()
  247 setCurrentDirectory = System.Directory.setCurrentDirectory . toFilePath
  248 
  249 {-# INLINE sp2fn #-}
  250 sp2fn :: SubPath -> PatchFileName.FileName
  251 sp2fn = PatchFileName.fp2fn . toFilePath