hasufell/hpath
1
1
Fork 0
Code Issues 8 Pull Requests Releases Wiki Activity

Switch to new layout

Browse Source
This commit is contained in:
Julian Ospald 2016-03-30 02:47:42 +02:00
parent d15e4b8ad9
commit 3c3a2d2766
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
4 changed files with 142 additions and 243 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
hpath.cabal
View File

@ -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

360
src/HPath.hs
View File

@ -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

7
src/HPath/Foreign.hsc Normal file
View File

@ -0,0 +1,7 @@
module HPath.Foreign where
#include <limits.h>
pathMax :: Int
pathMax = #{const PATH_MAX}

16
src/HPath/Internal.hs
View File

@ -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