diff --git a/hpath.cabal b/hpath.cabal index 931d811..a51f737 100644 --- a/hpath.cabal +++ b/hpath.cabal @@ -15,7 +15,7 @@ extra-source-files: README.md, CHANGELOG library hs-source-dirs: src/ ghc-options: -Wall -O2 - exposed-modules: HPath, HPath.Internal + exposed-modules: HPath, HPath.Foreign, HPath.Internal build-depends: base >= 4 && <5 , exceptions , filepath diff --git a/src/HPath.hs b/src/HPath.hs index 74ab325..818a973 100644 --- a/src/HPath.hs +++ b/src/HPath.hs @@ -13,33 +13,27 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_HADDOCK ignore-exports #-} module HPath ( -- * Types Abs - ,NoTPS ,Path ,Rel - ,TPS + ,Fn -- * PatternSynonyms/ViewPatterns ,pattern Path -- * Parsing ,PathParseException - ,parseAbsMaybeTPS - ,parseAbsNoTPS - ,parseAbsTPS - ,parseRelMaybeTPS - ,parseRelNoTPS - ,parseRelTPS + ,parseAbs + ,parseFn + ,parseRel -- * Constructors - ,mkAbsMaybeTPS - ,mkAbsNoTPS - ,mkAbsTPS - ,mkRelMaybeTPS - ,mkRelNoTPS - ,mkRelTPS + ,mkAbs + ,mkFn + ,mkRel -- * Operations ,() ,basename @@ -47,24 +41,32 @@ module HPath ,isParentOf ,stripDir -- * Conversion - ,fromAbsMaybeTPS - ,fromAbsNoTPS - ,fromAbsTPS - ,fromRelMaybeTPS - ,fromRelNoTPS - ,fromRelTPS + ,canonicalizePath + ,fromAbs + ,fromRel + ,normalize ,toFilePath - ,toNoTPS - ,toTPS + -- * Queries + ,hasDot + ,hasDoublePS + ,hasParentDir + ,isFileName + -- * String based functions + ,realPath ) where import Control.Exception (Exception) +import Control.Monad(void) import Control.Monad.Catch (MonadThrow(..)) import Data.Data import Data.List import Data.Maybe +import Foreign.C.Error +import Foreign.C.String +import Foreign.Marshal.Alloc(allocaBytes) import Language.Haskell.TH +import HPath.Foreign import HPath.Internal import qualified System.FilePath as FilePath @@ -77,29 +79,21 @@ data Abs deriving (Typeable) -- | A relative path; one without a root. data Rel deriving (Typeable) --- | A path without trailing separator. -data NoTPS deriving (Typeable) - --- | A path with trailing separator. -data TPS deriving (Typeable) - --- | A path without any guarantee about whether it ends in a --- trailing path separators. Use `toTPS` and `toNoTPS` --- if that guarantee is required. -data MaybeTPS deriving (Typeable) +-- | A filename, without any '/'. +data Fn deriving (Typeable) -- | Exception when parsing a location. data PathParseException - = InvalidAbsTPS FilePath - | InvalidRelTPS FilePath - | InvalidAbsNoTPS FilePath - | InvalidRelNoTPS FilePath - | InvalidAbsMaybeTPS FilePath - | InvalidRelMaybeTPS FilePath + = InvalidAbs FilePath + | InvalidRel FilePath + | InvalidFn FilePath | Couldn'tStripPrefixTPS FilePath FilePath deriving (Show,Typeable) instance Exception PathParseException +instance RelC Rel +instance RelC Fn + -------------------------------------------------------------------------------- -- PatternSynonyms @@ -108,21 +102,18 @@ pattern Path x <- (MkPath x) -------------------------------------------------------------------------------- -- Parsers --- | Get a location for an absolute path. Produces a normalized --- path which always ends in a path separator. +-- | Get a location for an absolute path. -- -- Throws: 'PathParseException' -- -parseAbsTPS :: MonadThrow m - => FilePath -> m (Path Abs TPS) -parseAbsTPS filepath = +parseAbs :: MonadThrow m + => FilePath -> m (Path Abs) +parseAbs filepath = if FilePath.isAbsolute filepath && - not (null (normalizeTPS filepath)) && - not ("~/" `isPrefixOf` filepath) && - not (hasParentDir filepath) && + not (null filepath) && FilePath.isValid filepath - then return (MkPath (normalizeTPS filepath)) - else throwM (InvalidAbsTPS filepath) + then return (MkPath filepath) + else throwM (InvalidAbs filepath) -- | Get a location for a relative path. Produces a normalized -- path which always ends in a path separator. @@ -132,107 +123,24 @@ parseAbsTPS filepath = -- -- Throws: 'PathParseException' -- -parseRelTPS :: MonadThrow m - => FilePath -> m (Path Rel TPS) -parseRelTPS filepath = +parseRel :: MonadThrow m + => FilePath -> m (Path Rel) +parseRel filepath = if not (FilePath.isAbsolute filepath) && not (null filepath) && - not ("~/" `isPrefixOf` filepath) && - not (hasParentDir filepath) && - not (null (normalizeTPS filepath)) && - filepath /= "." && filepath /= ".." && FilePath.isValid filepath - then return (MkPath (normalizeTPS filepath)) - else throwM (InvalidRelTPS filepath) + then return (MkPath filepath) + else throwM (InvalidRel filepath) --- | Get a location for an absolute path, which must not end with a trailing --- path separator. --- --- Throws: 'PathParseException' --- -parseAbsNoTPS :: MonadThrow m - => FilePath -> m (Path Abs NoTPS) -parseAbsNoTPS filepath = - if FilePath.isAbsolute filepath && - not (FilePath.hasTrailingPathSeparator filepath) && - not ("~/" `isPrefixOf` filepath) && - not (hasParentDir filepath) && - not (null (normalizeNoTPS filepath)) && - FilePath.isValid filepath - then return (MkPath (normalizeNoTPS filepath)) - else throwM (InvalidAbsNoTPS filepath) - --- | Get a location for a relative path, which must not end with a trailing --- path separator. --- --- Note that @filepath@ may contain any number of @./@ but may not contain a --- single @..@ anywhere. --- --- Throws: 'PathParseException' --- -parseRelNoTPS :: MonadThrow m - => FilePath -> m (Path Rel NoTPS) -parseRelNoTPS filepath = - if not (FilePath.isAbsolute filepath || - FilePath.hasTrailingPathSeparator filepath) && - not (null filepath) && - not ("~/" `isPrefixOf` filepath) && - not (hasParentDir filepath) && - not (null (normalizeNoTPS filepath)) && - filepath /= "." && filepath /= ".." && - FilePath.isValid filepath - then return (MkPath (normalizeNoTPS filepath)) - else throwM (InvalidRelNoTPS filepath) - --- | Get a location for an absolute path that may or may not end in a trailing --- path separator. Use `toTPS` and `toNoTPS` if that guarantee is required. --- --- Throws: 'PathParseException' --- -parseAbsMaybeTPS :: MonadThrow m - => FilePath -> m (Path Abs MaybeTPS) -parseAbsMaybeTPS filepath = - if FilePath.isAbsolute filepath && - not ("~/" `isPrefixOf` filepath) && - not (hasParentDir filepath) && - not (null (normalizeNoTPS filepath)) && - FilePath.isValid filepath - then return (MkPath (normalizeNoTPS filepath)) - else throwM (InvalidAbsMaybeTPS filepath) - --- | Get a location for a relative path that may or may not end in a trailing --- path separator. Use `toTPS` and `toNoTPS` if that guarantee is required. --- --- Note that @filepath@ may contain any number of @./@ but may not contain a --- single @..@ anywhere. --- --- Throws: 'PathParseException' --- -parseRelMaybeTPS :: MonadThrow m - => FilePath -> m (Path Rel MaybeTPS) -parseRelMaybeTPS filepath = +parseFn :: MonadThrow m + => FilePath -> m (Path Fn) +parseFn filepath = if not (FilePath.isAbsolute filepath) && not (null filepath) && - not ("~/" `isPrefixOf` filepath) && - not (hasParentDir filepath) && - not (null (normalizeNoTPS filepath)) && - filepath /= "." && filepath /= ".." && + isFileName filepath && FilePath.isValid filepath - then return (MkPath (normalizeNoTPS filepath)) - else throwM (InvalidRelMaybeTPS filepath) - --- | Helper function: check if the filepath has any parent directories in it. --- This handles the logic of checking for different path separators on Windows. -hasParentDir :: FilePath -> Bool -hasParentDir filepath' = - ("/.." `isSuffixOf` filepath) || - ("/../" `isInfixOf` filepath) || - ("../" `isPrefixOf` filepath) - where - filepath = - case FilePath.pathSeparator of - '/' -> filepath' - x -> map (\y -> if x == y then '/' else y) filepath' + then return (MkPath filepath) + else throwM (InvalidFn filepath) -------------------------------------------------------------------------------- -- Constructors @@ -242,56 +150,28 @@ hasParentDir filepath' = -- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@) -- may compile on your platform, but it may not compile on another -- platform (Windows). -mkAbsTPS :: FilePath -> Q Exp -mkAbsTPS s = - case parseAbsTPS s of +mkAbs :: FilePath -> Q Exp +mkAbs s = + case parseAbs s of Left err -> error (show err) Right (MkPath str) -> - [|MkPath $(return (LitE (StringL str))) :: Path Abs TPS|] + [|MkPath $(return (LitE (StringL str))) :: Path Abs|] -- | Make a 'Path Rel TPS'. -mkRelTPS :: FilePath -> Q Exp -mkRelTPS s = - case parseRelTPS s of +mkRel :: FilePath -> Q Exp +mkRel s = + case parseRel s of Left err -> error (show err) Right (MkPath str) -> - [|MkPath $(return (LitE (StringL str))) :: Path Rel TPS|] + [|MkPath $(return (LitE (StringL str))) :: Path Rel|] --- | Make a 'Path Abs NoTPS'. --- --- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@) --- may compile on your platform, but it may not compile on another --- platform (Windows). -mkAbsNoTPS :: FilePath -> Q Exp -mkAbsNoTPS s = - case parseAbsNoTPS s of +-- | Make a 'Path Rel TPS'. +mkFn :: FilePath -> Q Exp +mkFn s = + case parseFn s of Left err -> error (show err) Right (MkPath str) -> - [|MkPath $(return (LitE (StringL str))) :: Path Abs NoTPS|] - --- | Make a 'Path Rel NoTPS'. -mkRelNoTPS :: FilePath -> Q Exp -mkRelNoTPS s = - case parseRelNoTPS s of - Left err -> error (show err) - Right (MkPath str) -> - [|MkPath $(return (LitE (StringL str))) :: Path Rel NoTPS|] - --- | Make a 'Path Rel MaybeTPS'. -mkAbsMaybeTPS :: FilePath -> Q Exp -mkAbsMaybeTPS s = - case parseAbsMaybeTPS s of - Left err -> error (show err) - Right (MkPath str) -> - [|MkPath $(return (LitE (StringL str))) :: Path Abs MaybeTPS|] - --- | Make a 'Path Rel MaybeTPS'. -mkRelMaybeTPS :: FilePath -> Q Exp -mkRelMaybeTPS s = - case parseRelMaybeTPS s of - Left err -> error (show err) - Right (MkPath str) -> - [|MkPath $(return (LitE (StringL str))) :: Path Rel MaybeTPS|] + [|MkPath $(return (LitE (StringL str))) :: Path Fn|] -------------------------------------------------------------------------------- -- Conversion @@ -301,32 +181,23 @@ mkRelMaybeTPS s = -- All TPS data types have a trailing slash, so if you want no trailing -- slash, you can use 'System.FilePath.dropTrailingPathSeparator' from -- the filepath package. -toFilePath :: Path b t -> FilePath +toFilePath :: Path b -> FilePath toFilePath (MkPath l) = l -fromAbsTPS :: Path Abs TPS -> FilePath -fromAbsTPS = toFilePath +fromAbs :: Path Abs -> FilePath +fromAbs = toFilePath -fromRelTPS :: Path Rel TPS -> FilePath -fromRelTPS = toFilePath +fromRel :: RelC r => Path r -> FilePath +fromRel = toFilePath -fromAbsNoTPS :: Path Abs NoTPS -> FilePath -fromAbsNoTPS = toFilePath +normalize :: Path t -> Path t +normalize (MkPath l) = MkPath $ FilePath.normalise l -fromRelNoTPS :: Path Rel NoTPS -> FilePath -fromRelNoTPS = toFilePath - -fromAbsMaybeTPS :: Path Abs MaybeTPS -> FilePath -fromAbsMaybeTPS = toFilePath - -fromRelMaybeTPS :: Path Rel MaybeTPS -> FilePath -fromRelMaybeTPS = toFilePath - -toTPS :: Path b MaybeTPS -> Path b TPS -toTPS (MkPath l) = MkPath (FilePath.addTrailingPathSeparator l) - -toNoTPS :: Path b MaybeTPS -> Path b NoTPS -toNoTPS (MkPath l) = MkPath (FilePath.dropTrailingPathSeparator l) +-- | May fail on `realPath`. +canonicalizePath :: Path Abs -> IO (Path Abs) +canonicalizePath (MkPath l) = do + nl <- realPath l + return $ MkPath nl -------------------------------------------------------------------------------- -- Operations @@ -339,7 +210,7 @@ toNoTPS (MkPath l) = MkPath (FilePath.dropTrailingPathSeparator l) -- Technically, the first argument can be a path that points to a non-directory, -- because this library is IO-agnostic and makes no assumptions about -- file types. -() :: Path b t1 -> Path Rel t2 -> Path b t2 +() :: RelC r => Path b -> Path r -> Path b () (MkPath a) (MkPath b) = MkPath (a' ++ b) where a' = FilePath.addTrailingPathSeparator a @@ -350,7 +221,7 @@ toNoTPS (MkPath l) = MkPath (FilePath.dropTrailingPathSeparator l) -- The bases must match. -- stripDir :: MonadThrow m - => Path b t1 -> Path b t2 -> m (Path Rel t2) + => Path b -> Path b -> m (Path Rel) stripDir (MkPath p) (MkPath l) = case stripPrefix p' l of Nothing -> throwM (Couldn'tStripPrefixTPS p' l) @@ -361,9 +232,8 @@ stripDir (MkPath p) (MkPath l) = -- | Is p a parent of the given location? Implemented in terms of -- 'stripDir'. The bases must match. -isParentOf :: Path b t1 -> Path b t2 -> Bool -isParentOf p l = - isJust (stripDir p l) +isParentOf :: Path b -> Path b -> Bool +isParentOf p l = isJust (stripDir p l :: Maybe (Path Rel)) -- | Extract the directory name of a path. -- @@ -371,45 +241,63 @@ isParentOf p l = -- -- @dirname (p \<\/> a) == dirname p@ -- -dirname :: Path Abs t -> Path Abs TPS -dirname (MkPath fp) = MkPath (normalizeTPS (FilePath.takeDirectory $ FilePath.dropTrailingPathSeparator fp)) +dirname :: Path Abs -> Path Abs +dirname (MkPath fp) = MkPath (FilePath.takeDirectory $ FilePath.dropTrailingPathSeparator fp) -- | Extract the file part of a path. -- --- Throws InvalidRelTPS if it's passed e.g. '/', because there is no --- basename for that and it would break the `Path Rel t` type. -- -- The following properties hold: -- -- @basename (p \<\/> a) == basename a@ -- -basename :: MonadThrow m => Path b t -> m (Path Rel t) +-- Except when "/" is passed in which case the filename "." is returned. +basename :: Path b -> Path Fn basename (MkPath l) - | not (FilePath.isAbsolute rl) = return $ MkPath rl - | otherwise = throwM (InvalidRelTPS rl) + | not (FilePath.isAbsolute rl) = MkPath rl + | otherwise = MkPath "." where - rl = case FilePath.hasTrailingPathSeparator l of - True -> last (FilePath.splitPath l) - False -> normalizeNoTPS (FilePath.takeFileName l) + rl = last . FilePath.splitPath . FilePath.dropTrailingPathSeparator $ l -------------------------------------------------------------------------------- --- Internal functions +-- Query functions --- | Internal use for normalizing a path while always adding --- a trailing path separator. -normalizeTPS :: FilePath -> FilePath -normalizeTPS = - clean . FilePath.addTrailingPathSeparator . FilePath.normalise - where clean "./" = "" - clean ('/':'/':xs) = clean ('/':xs) - clean x = x +-- | Helper function: check if the filepath has any parent directories in it. +hasParentDir :: FilePath -> Bool +hasParentDir filepath = + ("/.." `isSuffixOf` filepath) || + ("/../" `isInfixOf` filepath) || + ("../" `isPrefixOf` filepath) --- | Internal use for normalizing a path without adding or removing --- a trailing path separator. -normalizeNoTPS :: FilePath -> FilePath -normalizeNoTPS = - clean . FilePath.normalise - where clean "./" = "" - clean ('/':'/':xs) = clean ('/':xs) - clean x = x +hasDot :: FilePath -> Bool +hasDot filepath = + ("/." `isSuffixOf` filepath) || + ("/./" `isInfixOf` filepath) || + ("./" `isPrefixOf` filepath) + +hasDoublePS :: FilePath -> Bool +hasDoublePS filepath = + ("//" `isInfixOf` filepath) + +isFileName :: FilePath -> Bool +isFileName filepath = + not ("/" `isInfixOf` filepath) + + +-------------------------------------------------------------------------------- +-- String based path functions + +foreign import ccall "realpath" + c_realpath :: CString -> CString -> IO CString + +-- | return the canonicalized absolute pathname +-- +-- like canonicalizePath, but uses realpath(3) +realPath :: String -> IO String +realPath inp = do + allocaBytes pathMax $ \tmp -> do + void $ withCString inp + $ \cstr -> throwErrnoIfNull "realpath" + $ c_realpath cstr tmp + peekCAString tmp diff --git a/src/HPath/Foreign.hsc b/src/HPath/Foreign.hsc new file mode 100644 index 0000000..71639cd --- /dev/null +++ b/src/HPath/Foreign.hsc @@ -0,0 +1,7 @@ +module HPath.Foreign where + +#include + +pathMax :: Int +pathMax = #{const PATH_MAX} + diff --git a/src/HPath/Internal.hs b/src/HPath/Internal.hs index 995a04e..592684a 100644 --- a/src/HPath/Internal.hs +++ b/src/HPath/Internal.hs @@ -3,7 +3,8 @@ -- | Internal types and functions. module HPath.Internal - (Path(..)) + (Path(..) + ,RelC) where import Control.DeepSeq (NFData (..)) @@ -18,7 +19,7 @@ import Data.Data -- -- There are no duplicate -- path separators @\/\/@, no @..@, no @.\/@, no @~\/@, etc. -data Path b t = MkPath FilePath +data Path b = MkPath FilePath deriving (Typeable) -- | String equality. @@ -26,7 +27,7 @@ data Path b t = MkPath FilePath -- The following property holds: -- -- @show x == show y ≡ x == y@ -instance Eq (Path b t) where +instance Eq (Path b) where (==) (MkPath x) (MkPath y) = x == y -- | String ordering. @@ -34,7 +35,7 @@ instance Eq (Path b t) where -- The following property holds: -- -- @show x \`compare\` show y ≡ x \`compare\` y@ -instance Ord (Path b t) where +instance Ord (Path b) where compare (MkPath x) (MkPath y) = compare x y -- | Same as 'Path.toFilePath'. @@ -42,9 +43,12 @@ instance Ord (Path b t) where -- The following property holds: -- -- @x == y ≡ show x == show y@ -instance Show (Path b t) where +instance Show (Path b) where show (MkPath x) = show x -instance NFData (Path b t) where +instance NFData (Path b) where rnf (MkPath x) = rnf x + +class RelC m +