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

Clean up, rewrite stuff

Browse Source
This commit is contained in:
Julian Ospald 2016-04-16 18:17:44 +02:00
parent 577ecf6750
commit 7e8c745e35
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
6 changed files with 280 additions and 583 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
README.md
View File

@ -16,65 +16,14 @@ decided to fork it.
## Differences to 'path' ## Differences to 'path'
I wasn't happy with the way it dealt with Dir vs File things. In his * doesn't attempt to fake IO-related types into the path, so whether a path points to a file or directory is up to your IO-code to decide... this should be a library that is used _with_ a proper IO File Type
version of the library, a `Path b Dir` always ends with a trailing * trailing path separators will be preserved if they exist, no messing with that
path separator and `Path b File` never ends with a trailing path separator. * uses safe ByteString for filepaths under the hood instead of unsafe String
* fixes broken [dirname](https://github.com/chrisdone/path/issues/18)
IMO, it is nonsensical to make a Dir vs File distinction on path level, * renames dirname/filename to basename/dirname to match the POSIX shell functions
although it first seems nice. * introduces a new `Path Fn` for safe filename guarantees and a `RelC` class
Some of the reasons are: * allows pattern matching via unidirectional PatternSynonym
* a path is just that: a path. It is completely disconnected from IO level * uses simple doctest for testing
and even if a `Dir`/`File` type theoretically allows us to say "this path * allows `~/` as relative path, because on posix level `~` is just a regular filename that does _NOT_ point to `$HOME`
ought to point to a file", there is literally zero guarantee that it will * remove TH, it sucks
hold true at runtime. So this basically gives a false feeling of a
type-safe file distinction.
* it's imprecise about Dir vs File distinction, which makes it even worse,
because a directory is also a file (just not a regular file). Add symlinks
to that and the confusion is complete.
* it makes the API oddly complicated for use cases where we basically don't
care (yet) whether something turns out to be a directory or not
Still, it comes also with a few perks:
* it simplifies some functions, because they now have guarantees whether a
path ends in a trailing path separator or not
* it may be safer for interaction with other library functions, which behave
differently depending on a trailing path separator (like probably shelly)
Not limited to, but also in order to fix my remarks without breaking any
benefits, I did:
* rename the `Dir`/`File` types to `TPS`/`NoTPS`, so it's clear we are only
giving information about trailing path separators and not actual file
types we don't know about yet
* add a `MaybeTPS` type, which does not mess with trailing path separators
and also gives no guarantees about them... then added `toNoTPS` and
`toTPS` to allow type-safe conversion
* make some functions accept more general types, so we don't unnecessarily
force paths with trailing separators for `(</>)` for example... instead
these functions now examine the paths to still have correct behavior.
This is really minor overhead. You might say now "but then I can append
filepath to filepath". Well, as I said... we don't know whether it's a
"filepath" at all.
* merge `filename` and `dirname` into `basename` and make `parent` be
`dirname`, so the function names match the name of the POSIX ones,
which do (almost) the same...
* fix a bug in `basename` (formerly `dirname`) which broke the type
guarantees
* add a pattern synonym for easier pattern matching without exporting
the internal Path constructor
## Consequences
So what does that mean? Well, it means that this library does not and
cannot make any guarantees about what a filepath is meant for or what
it might point to. And it doesn't pretend it can.
So when you strip the trailing path separator of a path that points to a
directory and then shove it into some function which expects a regular
file... then that function will very likely blow up. That's the nature of IO.
There is no type that can save you from interfacing such low-level libraries.
The filesystem is in constant change. What might have been a regular file
2 seconds ago, can now be a directory or a symlink.
That means you need a proper File type that is tied to your IO code.
This is what [hsfm](https://github.com/hasufell/hsfm) does. It currently
is not a library, maybe it will be in the future.

14
doctests.hs Normal file
View File

@ -0,0 +1,14 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Test.DocTest
import Test.HUnit
main =
doctest
[ "-isrc"
, "-XOverloadedStrings"
, "src/HPath.hs"
]

35
hpath.cabal
View File

@ -15,25 +15,30 @@ extra-source-files: README.md, CHANGELOG
library library
hs-source-dirs: src/ hs-source-dirs: src/
ghc-options: -Wall -O2 ghc-options: -Wall -O2
exposed-modules: HPath, HPath.Foreign, HPath.Internal exposed-modules: HPath, HPath.Internal
build-depends: base >= 4 && <5 build-depends: base >= 4 && <5
, HUnit
, bytestring , bytestring
, encoding
, exceptions
, deepseq , deepseq
, exceptions
, hspec
, posix-paths
, utf8-string
, word8 , word8
, template-haskell
test-suite test
type: exitcode-stdio-1.0 test-suite doctests
main-is: Main.hs type: exitcode-stdio-1.0
hs-source-dirs: test ghc-options: -threaded
build-depends: HUnit main-is: doctests.hs
, base build-depends: base
, hspec , HUnit
, mtl , bytestring
, hpath , doctest >= 0.8
, hpath
, posix-paths
source-repository head source-repository head
type: git type: git
location: https://github.com/hasufell/hpath location: https://github.com/hasufell/hpath

511
src/HPath.hs
View File

@ -10,12 +10,10 @@
-- Support for well-typed paths. -- Support for well-typed paths.
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
module HPath module HPath
@ -32,16 +30,11 @@ module HPath
,parseAbs ,parseAbs
,parseFn ,parseFn
,parseRel ,parseRel
-- * Path Constructors
,mkAbs
,mkFn
,mkRel
-- * Path Conversion -- * Path Conversion
,canonicalizePath ,canonicalizePath
,fromAbs ,fromAbs
,fromRel ,fromRel
,normalize ,normalize
,normalizeAbs
,toFilePath ,toFilePath
-- * Path Operations -- * Path Operations
,(</>) ,(</>)
@ -61,52 +54,38 @@ module HPath
,combine ,combine
,dropFileName ,dropFileName
,dropTrailingPathSeparator ,dropTrailingPathSeparator
,dropWhileEnd
,equalFilePath
,fpToString ,fpToString
,joinPath ,joinPath
,normalise ,normalise
,splitDirectories ,splitDirectories
,splitFileName ,splitFileName
,splitPath ,splitPath
,stripPrefix
,takeDirectory ,takeDirectory
,userStringToFP ,userStringToFP
-- * ByteString Query functions -- * ByteString Query functions
,hiddenFile ,hiddenFile
-- * Queries -- * Queries
,hasDot
,hasDoublePS
,hasLeadingPathSeparator
,hasParentDir ,hasParentDir
,hasTrailingPathSeparator
,isAbsolute ,isAbsolute
,isFileName ,isFileName
,isRelative ,isRelative
,isValid ,isValid
-- * String based functions -- * String based functions
,realPath
) )
where where
import Control.Exception (Exception) import Control.Exception (Exception)
import Control.Monad(void)
import Control.Monad.Catch (MonadThrow(..)) import Control.Monad.Catch (MonadThrow(..))
import Data.ByteString(ByteString) import Data.ByteString(ByteString)
import qualified Data.ByteString as B import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (fromString, toString)
import Data.Data import Data.Data
import Data.Encoding(decodeStrictByteString, encodeStrictByteString)
import Data.Encoding.UTF8(UTF8(..))
import qualified Data.List as L import qualified Data.List as L
import Data.Maybe import Data.Maybe
import Data.Word8 import Data.Word8
import Foreign.C.Error
import Foreign.C.String
import Foreign.Marshal.Alloc(allocaBytes)
import HPath.Foreign
import HPath.Internal import HPath.Internal
import Language.Haskell.TH import System.Posix.FilePath hiding ((</>))
import Safe(initDef) import System.Posix.Directory.Traversals(realpath)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -147,10 +126,24 @@ pattern Path x <- (MkPath x)
-- | Get a location for an absolute path. -- | Get a location for an absolute path. Produces a normalised path.
-- --
-- Throws: 'PathParseException' -- Throws: 'PathParseException'
-- --
-- >>> parseAbs "/abc" :: Maybe (Path Abs)
-- Just "/abc"
-- >>> parseAbs "/" :: Maybe (Path Abs)
-- Just "/"
-- >>> parseAbs "/abc/def" :: Maybe (Path Abs)
-- Just "/abc/def"
-- >>> parseAbs "/abc/def/.///" :: Maybe (Path Abs)
-- Just "/abc/def/"
-- >>> parseAbs "abc" :: Maybe (Path Abs)
-- Nothing
-- >>> parseAbs "" :: Maybe (Path Abs)
-- Nothing
-- >>> parseAbs "/abc/../foo" :: Maybe (Path Abs)
-- Nothing
parseAbs :: MonadThrow m parseAbs :: MonadThrow m
=> ByteString -> m (Path Abs) => ByteString -> m (Path Abs)
parseAbs filepath = parseAbs filepath =
@ -160,14 +153,33 @@ parseAbs filepath =
then return (MkPath $ normalise filepath) then return (MkPath $ normalise filepath)
else throwM (InvalidAbs filepath) else throwM (InvalidAbs filepath)
-- | Get a location for a relative path. Produces a normalized
-- path which always ends in a path separator. -- | Get a location for a relative path. Produces a normalised
-- path.
-- --
-- Note that @filepath@ may contain any number of @./@ but may not consist -- Note that @filepath@ may contain any number of @./@ but may not consist
-- solely of @./@. It also may not contain a single @..@ anywhere. -- solely of @./@. It also may not contain a single @..@ anywhere.
-- --
-- Throws: 'PathParseException' -- Throws: 'PathParseException'
-- --
-- >>> parseRel "abc" :: Maybe (Path Rel)
-- Just "abc"
-- >>> parseRel "def/" :: Maybe (Path Rel)
-- Just "def/"
-- >>> parseRel "abc/def" :: Maybe (Path Rel)
-- Just "abc/def"
-- >>> parseRel "abc/def/." :: Maybe (Path Rel)
-- Just "abc/def/"
-- >>> parseRel "/abc" :: Maybe (Path Rel)
-- Nothing
-- >>> parseRel "" :: Maybe (Path Rel)
-- Nothing
-- >>> parseRel "abc/../foo" :: Maybe (Path Rel)
-- Nothing
-- >>> parseRel "." :: Maybe (Path Rel)
-- Nothing
-- >>> parseRel ".." :: Maybe (Path Rel)
-- Nothing
parseRel :: MonadThrow m parseRel :: MonadThrow m
=> ByteString -> m (Path Rel) => ByteString -> m (Path Rel)
parseRel filepath = parseRel filepath =
@ -184,6 +196,26 @@ parseRel filepath =
-- --
-- Throws: 'PathParseException' -- Throws: 'PathParseException'
-- --
-- >>> parseFn "abc" :: Maybe (Path Fn)
-- Just "abc"
-- >>> parseFn "..." :: Maybe (Path Fn)
-- Just "..."
-- >>> parseFn "def/" :: Maybe (Path Fn)
-- Nothing
-- >>> parseFn "abc/def" :: Maybe (Path Fn)
-- Nothing
-- >>> parseFn "abc/def/." :: Maybe (Path Fn)
-- Nothing
-- >>> parseFn "/abc" :: Maybe (Path Fn)
-- Nothing
-- >>> parseFn "" :: Maybe (Path Fn)
-- Nothing
-- >>> parseFn "abc/../foo" :: Maybe (Path Fn)
-- Nothing
-- >>> parseFn "." :: Maybe (Path Fn)
-- Nothing
-- >>> parseFn ".." :: Maybe (Path Fn)
-- Nothing
parseFn :: MonadThrow m parseFn :: MonadThrow m
=> ByteString -> m (Path Fn) => ByteString -> m (Path Fn)
parseFn filepath = parseFn filepath =
@ -195,46 +227,10 @@ parseFn filepath =
--------------------------------------------------------------------------------
-- Constructors
-- | Make a 'Path Abs TPS'.
--
-- 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).
mkAbs :: ByteString -> Q Exp
mkAbs s =
case parseAbs s of
Left err -> error (show err)
Right (MkPath str) ->
[|MkPath $(return (LitE (StringL (show str)))) :: Path Abs|]
-- | Make a 'Path Rel TPS'.
mkRel :: ByteString -> Q Exp
mkRel s =
case parseRel s of
Left err -> error (show err)
Right (MkPath str) ->
[|MkPath $(return (LitE (StringL (show str)))) :: Path Rel|]
-- | Make a 'Path Rel TPS'.
mkFn :: ByteString -> Q Exp
mkFn s =
case parseFn s of
Left err -> error (show err)
Right (MkPath str) ->
[|MkPath $(return (LitE (StringL (show str)))) :: Path Fn|]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Path Conversion -- Path Conversion
-- | Convert to a ByteString type. -- | Convert to a ByteString type.
--
-- 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 -> ByteString toFilePath :: Path b -> ByteString
toFilePath (MkPath l) = l toFilePath (MkPath l) = l
@ -247,16 +243,10 @@ fromRel = toFilePath
normalize :: Path t -> Path t normalize :: Path t -> Path t
normalize (MkPath l) = MkPath $ normalise l normalize (MkPath l) = MkPath $ normalise l
-- | A variant for `normalize` for absolute paths which -- | May fail on `realpath`.
-- also removes occurences of '..', which may behave
-- strange for symlinks though.
normalizeAbs :: Path Abs -> Path Abs
normalizeAbs (MkPath l) = MkPath . fromJust . normaliseAbs $ l
-- | May fail on `realPath`.
canonicalizePath :: Path Abs -> IO (Path Abs) canonicalizePath :: Path Abs -> IO (Path Abs)
canonicalizePath (MkPath l) = do canonicalizePath (MkPath l) = do
nl <- realPath l nl <- realpath l
return $ MkPath nl return $ MkPath nl
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -270,22 +260,43 @@ canonicalizePath (MkPath l) = do
-- Technically, the first argument can be a path that points to a non-directory, -- 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 -- because this library is IO-agnostic and makes no assumptions about
-- file types. -- file types.
--
-- >>> (MkPath "/") </> (MkPath "file" :: Path Rel)
-- "/file"
-- >>> (MkPath "/path/to") </> (MkPath "file" :: Path Rel)
-- "/path/to/file"
-- >>> (MkPath "/") </> (MkPath "file/lal" :: Path Rel)
-- "/file/lal"
-- >>> (MkPath "/") </> (MkPath "file/" :: Path Rel)
-- "/file/"
(</>) :: RelC r => Path b -> Path r -> Path b (</>) :: RelC r => Path b -> Path r -> Path b
(</>) (MkPath a) (MkPath b) = MkPath (a' `B.append` b) (</>) (MkPath a) (MkPath b) = MkPath (a' `BS.append` b)
where where
a' = addTrailingPathSeparator a a' = if BS.last a == pathSeparator
then a
else addTrailingPathSeparator a
-- | Strip directory from path, making it relative to that directory. -- | Strip directory from path, making it relative to that directory.
-- Throws 'Couldn'tStripPrefixDir' if directory is not a parent of the path. -- Throws 'Couldn'tStripPrefixDir' if directory is not a parent of the path.
-- --
-- The bases must match. -- The bases must match.
-- --
-- >>> (MkPath "/lal/lad") `stripDir` (MkPath "/lal/lad/fad") :: Maybe (Path Rel)
-- Just "fad"
-- >>> (MkPath "lal/lad") `stripDir` (MkPath "lal/lad/fad") :: Maybe (Path Rel)
-- Just "fad"
-- >>> (MkPath "/") `stripDir` (MkPath "/") :: Maybe (Path Rel)
-- Nothing
-- >>> (MkPath "/lal/lad/fad") `stripDir` (MkPath "/lal/lad") :: Maybe (Path Rel)
-- Nothing
-- >>> (MkPath "fad") `stripDir` (MkPath "fad") :: Maybe (Path Rel)
-- Nothing
stripDir :: MonadThrow m stripDir :: MonadThrow m
=> Path b -> Path b -> m (Path Rel) => Path b -> Path b -> m (Path Rel)
stripDir (MkPath p) (MkPath l) = stripDir (MkPath p) (MkPath l) =
case stripPrefix p' l of case stripPrefix p' l of
Nothing -> throwM (Couldn'tStripPrefixTPS p' l) Nothing -> throwM (Couldn'tStripPrefixTPS p' l)
Just ok -> if B.null ok Just ok -> if BS.null ok
then throwM (Couldn'tStripPrefixTPS p' l) then throwM (Couldn'tStripPrefixTPS p' l)
else return (MkPath ok) else return (MkPath ok)
where where
@ -293,10 +304,27 @@ stripDir (MkPath p) (MkPath l) =
-- | Is p a parent of the given location? Implemented in terms of -- | Is p a parent of the given location? Implemented in terms of
-- 'stripDir'. The bases must match. -- 'stripDir'. The bases must match.
--
-- >>> (MkPath "/lal/lad") `isParentOf` (MkPath "/lal/lad/fad")
-- True
-- >>> (MkPath "lal/lad") `isParentOf` (MkPath "lal/lad/fad")
-- True
-- >>> (MkPath "/") `isParentOf` (MkPath "/")
-- False
-- >>> (MkPath "/lal/lad/fad") `isParentOf` (MkPath "/lal/lad")
-- False
-- >>> (MkPath "fad") `isParentOf` (MkPath "fad")
-- False
isParentOf :: Path b -> Path b -> Bool isParentOf :: Path b -> Path b -> Bool
isParentOf p l = isJust (stripDir p l :: Maybe (Path Rel)) isParentOf p l = isJust (stripDir p l :: Maybe (Path Rel))
-- |Get all parents of a path.
--
-- >>> getAllParents (MkPath "/abs/def/dod")
-- ["/abs/def","/abs","/"]
-- >>> getAllParents (MkPath "/")
-- []
getAllParents :: Path Abs -> [Path Abs] getAllParents :: Path Abs -> [Path Abs]
getAllParents (MkPath p) getAllParents (MkPath p)
| np == pathSeparator' = [] | np == pathSeparator' = []
@ -311,6 +339,10 @@ getAllParents (MkPath p)
-- --
-- @dirname (p \<\/> a) == dirname p@ -- @dirname (p \<\/> a) == dirname p@
-- --
-- >>> dirname (MkPath "/abc/def/dod")
-- "/abc/def"
-- >>> dirname (MkPath "/")
-- "/"
dirname :: Path Abs -> Path Abs dirname :: Path Abs -> Path Abs
dirname (MkPath fp) = MkPath (takeDirectory $ dropTrailingPathSeparator fp) dirname (MkPath fp) = MkPath (takeDirectory $ dropTrailingPathSeparator fp)
@ -322,6 +354,11 @@ dirname (MkPath fp) = MkPath (takeDirectory $ dropTrailingPathSeparator fp)
-- @basename (p \<\/> a) == basename a@ -- @basename (p \<\/> a) == basename a@
-- --
-- Throws: `PathException` if given the root path "/" -- Throws: `PathException` if given the root path "/"
--
-- >>> basename (MkPath "/abc/def/dod") :: Maybe (Path Fn)
-- Just "dod"
-- >>> basename (MkPath "/") :: Maybe (Path Fn)
-- Nothing
basename :: MonadThrow m => Path b -> m (Path Fn) basename :: MonadThrow m => Path b -> m (Path Fn)
basename (MkPath l) basename (MkPath l)
| not (isAbsolute rl) = return $ MkPath rl | not (isAbsolute rl) = return $ MkPath rl
@ -333,21 +370,31 @@ basename (MkPath l)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- ByteString Query functions -- ByteString Query functions
-- | Whether the file is a hidden file.
--
-- >>> hiddenFile (MkPath ".foo")
-- True
-- >>> hiddenFile (MkPath "..foo.bar")
-- True
-- >>> hiddenFile (MkPath "...")
-- True
-- >>> hiddenFile (MkPath "dod")
-- False
-- >>> hiddenFile (MkPath "dod.bar")
-- False
hiddenFile :: Path Fn -> Bool hiddenFile :: Path Fn -> Bool
hiddenFile (MkPath fp) hiddenFile (MkPath fp)
| fp == pathDoubleDot = False | fp == pathDoubleDot = False
| fp == pathDot' = False | fp == pathDot' = False
| otherwise = pathDot' `B.isPrefixOf` fp | otherwise = pathDot' `BS.isPrefixOf` fp
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- ByteString/Word8 constants -- ByteString/Word8 constants
pathSeparator :: Word8
pathSeparator = _slash
pathSeparator' :: ByteString pathSeparator' :: ByteString
pathSeparator' = B.singleton pathSeparator pathSeparator' = BS.singleton pathSeparator
pathDot :: Word8 pathDot :: Word8
@ -355,11 +402,11 @@ pathDot = _period
pathDot' :: ByteString pathDot' :: ByteString
pathDot' = B.singleton pathDot pathDot' = BS.singleton pathDot
pathDoubleDot :: ByteString pathDoubleDot :: ByteString
pathDoubleDot = pathDot `B.cons` pathDot' pathDoubleDot = pathDot `BS.cons` pathDot'
nullByte :: Word8 nullByte :: Word8
@ -370,228 +417,142 @@ nullByte = _nul
-- ByteString Operations -- ByteString Operations
dropWhileEnd :: (Word8 -> Bool) -> ByteString -> ByteString
dropWhileEnd p = B.reverse . B.dropWhile p . B.reverse
dropTrailingPathSeparator :: ByteString -> ByteString
dropTrailingPathSeparator filepath =
if hasTrailingPathSeparator filepath
then let filepath' = dropWhileEnd (== pathSeparator) filepath
in if B.null filepath' then B.singleton . B.last $ filepath else filepath'
else filepath
addTrailingPathSeparator :: ByteString -> ByteString
addTrailingPathSeparator filepath
| B.null filepath = filepath
| filepath == pathSeparator' = filepath
| not (hasTrailingPathSeparator filepath)
= filepath `B.append` pathSeparator'
| otherwise = filepath
-- |Normalise a file.
--
-- >>> normalise "/file/\\test////"
-- "/file/\\test/"
-- >>> normalise "/file/./test"
-- "/file/test"
-- >>> normalise "/test/file/../bob/fred/"
-- "/test/file/../bob/fred/"
-- >>> normalise "../bob/fred/"
-- "../bob/fred/"
-- >>> normalise "./bob/fred/"
-- "bob/fred/"
-- >>> normalise "./bob////.fred/./...///./..///#."
-- "bob/.fred/.../../#."
-- >>> normalise "."
-- "."
-- >>> normalise "./"
-- "./"
-- >>> normalise "./."
-- "./"
-- >>> normalise "/./"
-- "/"
-- >>> normalise "/"
-- "/"
-- >>> normalise "bob/fred/."
-- "bob/fred/"
-- >>> normalise "//home"
-- "/home"
normalise :: ByteString -> ByteString normalise :: ByteString -> ByteString
normalise filepath = result `B.append` normalise filepath =
(if addPathSeparator then pathSeparator' else B.empty) result `BS.append`
(if addPathSeparator
then BS.singleton pathSeparator
else BS.empty)
where where
(drv, pth) = splitDrive filepath result = let n = f filepath
result = joinDrive' (normaliseDrive drv) (f pth) in if BS.null n
joinDrive' d p then BS.singleton _period
| B.null d && B.null p = B.singleton pathDot else n
| otherwise = joinDrive d p addPathSeparator = isDirPath filepath &&
addPathSeparator = isDirPath pth && not (hasTrailingPathSeparator result) not (hasTrailingPathSeparator' result)
isDirPath xs = hasTrailingPathSeparator xs isDirPath xs = hasTrailingPathSeparator' xs
|| not (B.null xs) && B.last xs == pathDot || not (BS.null xs) && BS.last xs == _period
&& hasTrailingPathSeparator (B.init xs) && hasTrailingPathSeparator' (BS.init xs)
normaliseDrive p
| B.null p = B.empty
| otherwise = B.singleton pathSeparator
f = joinPath . dropDots . propSep . splitDirectories f = joinPath . dropDots . propSep . splitDirectories
propSep :: [ByteString] -> [ByteString] propSep :: [ByteString] -> [ByteString]
propSep (x:xs) propSep (x:xs)
| B.all (== pathSeparator) x = pathSeparator' : xs | BS.all (== pathSeparator) x = BS.singleton pathSeparator : xs
| otherwise = x : xs | otherwise = x : xs
propSep [] = [] propSep [] = []
dropDots = filter (pathDot' /=) dropDots :: [ByteString] -> [ByteString]
dropDots = filter (BS.singleton _period /=)
hasTrailingPathSeparator' :: RawFilePath -> Bool
hasTrailingPathSeparator' x
| BS.null x = False
| otherwise = isPathSeparator $ BS.last x
-- | A variant of `normalise` for absolute paths, which removes
-- occurences of '..'. If a non-absolute path is passed, returns Nothing.
normaliseAbs :: ByteString -> Maybe ByteString
normaliseAbs filepath
| isRelative filepath = Nothing
| otherwise =
let nfp = normalise filepath
in Just . joinPath . L.foldl' rmDbl [] . splitDirectories $ nfp
where
rmDbl x y
| x == [pathSeparator'] && y == pathDoubleDot = [pathSeparator']
| y == pathDoubleDot = initDef [] x
| otherwise = x ++ [y]
splitPath :: ByteString -> [ByteString]
splitPath filepath = [drv | drv /= B.empty] ++ f pth
where
(drv, pth) = splitDrive filepath
f p
| B.null p = []
| otherwise = (a `B.append` c) : f d
where
(a, b) = B.break (== pathSeparator) p
(c, d) = splitDrive b
joinPath :: [ByteString] -> ByteString
joinPath = foldr combine B.empty
splitDrive :: ByteString -> (ByteString, ByteString)
splitDrive = B.span (== pathSeparator)
joinDrive :: ByteString -> ByteString -> ByteString
joinDrive = combineAlways
splitDirectories :: ByteString -> [ByteString]
splitDirectories = map dropTrailingPathSeparator . splitPath
combine :: ByteString -> ByteString -> ByteString
combine d p
| hasLeadingPathSeparator p = p
| otherwise = combineAlways d p
combineAlways :: ByteString -> ByteString -> ByteString
combineAlways d p
| B.null d = p
| B.null p = d
| hasTrailingPathSeparator d = d `B.append` p
| otherwise = d `B.append` B.singleton pathSeparator `B.append` p
takeDirectory :: ByteString -> ByteString
takeDirectory = dropTrailingPathSeparator . dropFileName
dropFileName :: ByteString -> ByteString
dropFileName = fst . splitFileName
splitFileName :: ByteString -> (ByteString, ByteString)
splitFileName filepath = (if B.null dir
then pathDot `B.cons` pathSeparator'
else dir
, name)
where
(dir, name) = splitFileName_ filepath
splitFileName_ p = (drv `B.append` dir', file)
where
(drv, pth) = splitDrive p
(dir', file) = B.breakEnd (== pathSeparator) pth
stripPrefix :: ByteString -> ByteString -> Maybe ByteString
stripPrefix a b = B.pack `fmap` L.stripPrefix (B.unpack a) (B.unpack b)
-- |Uses UTF-8 decoding to convert the bytestring into a String. -- |Uses UTF-8 decoding to convert the bytestring into a String.
fpToString :: ByteString -> String fpToString :: ByteString -> String
fpToString = decodeStrictByteString UTF8 fpToString = toString
-- |Uses UTF-8 encoding to convert a user provided String into -- |Uses UTF-8 encoding to convert a user provided String into
-- a ByteString, which represents a filepath. -- a ByteString, which represents a filepath.
userStringToFP :: String -> ByteString userStringToFP :: String -> ByteString
userStringToFP = encodeStrictByteString UTF8 userStringToFP = fromString
#if MIN_VERSION_bytestring(0,10,8)
#else
stripPrefix :: ByteString -> ByteString -> Maybe ByteString
stripPrefix a b = BS.pack `fmap` L.stripPrefix (BS.unpack a) (BS.unpack b)
#endif
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- ByteString Query functions -- ByteString Query functions
-- | Helper function: check if the filepath has any parent directories in it. -- | Helper function: check if the filepath has any parent directories in it.
--
-- >>> hasParentDir "/.."
-- True
-- >>> hasParentDir "foo/bar/.."
-- True
-- >>> hasParentDir "foo/../bar/."
-- True
-- >>> hasParentDir "foo/bar"
-- False
-- >>> hasParentDir "foo"
-- False
-- >>> hasParentDir ""
-- False
-- >>> hasParentDir ".."
-- False
hasParentDir :: ByteString -> Bool hasParentDir :: ByteString -> Bool
hasParentDir filepath = hasParentDir filepath =
((pathSeparator `B.cons` pathDoubleDot) `B.isSuffixOf` filepath) || ((pathSeparator `BS.cons` pathDoubleDot) `BS.isSuffixOf` filepath) ||
((pathSeparator' `B.append` pathDoubleDot `B.append` pathSeparator') ((pathSeparator' `BS.append` pathDoubleDot `BS.append` pathSeparator')
`B.isInfixOf` filepath) || `BS.isInfixOf` filepath) ||
((pathDoubleDot `B.append` pathSeparator') `B.isPrefixOf` filepath) ((pathDoubleDot `BS.append` pathSeparator') `BS.isPrefixOf` filepath)
hasDot :: ByteString -> Bool
hasDot filepath =
((pathSeparator `B.cons` pathDot') `B.isSuffixOf` filepath) ||
((pathSeparator' `B.append` pathDot' `B.append` pathSeparator')
`B.isInfixOf` filepath) ||
((pathDot `B.cons` pathSeparator') `B.isPrefixOf` filepath)
hasDoublePS :: ByteString -> Bool
hasDoublePS filepath =
((pathSeparator `B.cons` pathSeparator') `B.isInfixOf` filepath)
hasTrailingPathSeparator :: ByteString -> Bool
hasTrailingPathSeparator filepath
| B.null filepath = False
| B.last filepath == pathSeparator = True
| otherwise = False
hasLeadingPathSeparator :: ByteString -> Bool
hasLeadingPathSeparator filepath
| B.null filepath = False
| B.head filepath == pathSeparator = True
| otherwise = False
-- | Is the given filename a valid filename?
--
-- >>> isFileName "lal"
-- True
-- >>> isFileName "."
-- True
-- >>> isFileName ".."
-- True
-- >>> isFileName ""
-- False
-- >>> isFileName "\0"
-- False
-- >>> isFileName "/random_ path:*"
-- False
isFileName :: ByteString -> Bool isFileName :: ByteString -> Bool
isFileName filepath = isFileName filepath =
not (pathSeparator' `B.isInfixOf` filepath) && not (pathSeparator' `BS.isInfixOf` filepath) &&
not (B.null filepath) && not (BS.null filepath) &&
not (nullByte `B.elem` filepath) not (nullByte `BS.elem` filepath)
isAbsolute :: ByteString -> Bool -- | Is a FilePath valid, i.e. could you create a file like it?
isAbsolute filepath
| B.null filepath = False
| B.head filepath == pathSeparator = True
| otherwise = False
isRelative :: ByteString -> Bool
isRelative = not . isAbsolute
isValid :: ByteString -> Bool
isValid filepath
| B.null filepath = False
| nullByte `B.elem` filepath = False
| otherwise = True
equalFilePath :: ByteString -> ByteString -> Bool
equalFilePath p1 p2 = f p1 == f p2
where
f x = dropTrailingPathSeparator $ normalise x
--------------------------------------------------------------------------------
-- 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) -- >>> isValid ""
realPath :: ByteString -> IO ByteString -- False
realPath inp = -- >>> isValid "\0"
allocaBytes pathMax $ \tmp -> do -- False
void $ B.useAsCString inp -- >>> isValid "/random_ path:*"
$ \cstr -> throwErrnoIfNull "realpath" -- True
$ c_realpath cstr tmp isValid :: RawFilePath -> Bool
B.packCString tmp isValid filepath
| BS.null filepath = False
| _nul `BS.elem` filepath = False
| otherwise = True

7
src/HPath/Foreign.hsc
View File

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

225
test/Main.hs
View File

@ -1,225 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
-- | Test suite.
module Main where
import Control.Applicative
import Control.Monad
import Data.Maybe
import Data.Monoid
import HPath
import HPath.Internal
import Test.Hspec
-- | Test suite entry point, returns exit failure if any test fails.
main :: IO ()
main = hspec spec
-- | Test suite.
spec :: Spec
spec =
do describe "Parsing: Path Abs Dir" parseAbsTPSSpec
describe "Parsing: Path Rel Dir" parseRelTPSSpec
describe "Parsing: Path Abs File" parseAbsNoTPSSpec
describe "Parsing: Path Rel File" parseRelNoTPSSpec
describe "Operations: (</>)" operationAppend
describe "Operations: stripDir" operationStripDir
describe "Operations: isParentOf" operationIsParentOf
describe "Operations: dirname" operationDirname
describe "Operations: basename" operationBasename
describe "Restrictions" restrictions
-- | Restricting the input of any tricks.
restrictions :: Spec
restrictions =
do parseFails "~/"
parseFails "~/foo"
parseFails "~/foo/bar"
parseFails "../"
parseFails ".."
parseFails "."
parseFails "/.."
parseFails "/foo/../bar/"
parseFails "/foo/bar/.."
where parseFails x =
it (show x ++ " should be rejected")
(isNothing (void (parseAbsTPS x) <|>
void (parseRelTPS x) <|>
void (parseAbsNoTPS x) <|>
void (parseRelNoTPS x)))
-- | The 'basename' operation.
operationBasename :: Spec
operationBasename =
do it "basename ($(mkAbsTPS parent) </> basename $(mkRelNoTPS filename)) == $(mkRelNoTPS filename)"
((basename =<< ($(mkAbsTPS "/home/hasufell/") </>)
<$> basename $(mkRelNoTPS "bar.txt")) ==
Just $(mkRelNoTPS "bar.txt"))
it "basename ($(mkRelTPS parent) </> basename $(mkRelNoTPS filename)) == $(mkRelNoTPS filename)"
((basename =<< ($(mkRelTPS "home/hasufell/") </>)
<$> basename $(mkRelNoTPS "bar.txt")) ==
Just $(mkRelNoTPS "bar.txt"))
-- | The 'dirname' operation.
operationDirname :: Spec
operationDirname =
do it "dirname (parent </> child) == parent"
(dirname ($(mkAbsTPS "/foo") </>
$(mkRelTPS "bar")) ==
$(mkAbsTPS "/foo"))
it "dirname \"\" == \"\""
(dirname $(mkAbsTPS "/") ==
$(mkAbsTPS "/"))
it "dirname (parent \"\") == \"\""
(dirname (dirname $(mkAbsTPS "/")) ==
$(mkAbsTPS "/"))
-- | The 'isParentOf' operation.
operationIsParentOf :: Spec
operationIsParentOf =
do it "isParentOf parent (parent </> child)"
(isParentOf
$(mkAbsTPS "///bar/")
($(mkAbsTPS "///bar/") </>
$(mkRelNoTPS "bar/foo.txt")))
it "isParentOf parent (parent </> child)"
(isParentOf
$(mkRelTPS "bar/")
($(mkRelTPS "bar/") </>
$(mkRelNoTPS "bob/foo.txt")))
-- | The 'stripDir' operation.
operationStripDir :: Spec
operationStripDir =
do it "stripDir parent (parent </> child) = child"
(stripDir $(mkAbsTPS "///bar/")
($(mkAbsTPS "///bar/") </>
$(mkRelNoTPS "bar/foo.txt")) ==
Just $(mkRelNoTPS "bar/foo.txt"))
it "stripDir parent (parent </> child) = child"
(stripDir $(mkRelTPS "bar/")
($(mkRelTPS "bar/") </>
$(mkRelNoTPS "bob/foo.txt")) ==
Just $(mkRelNoTPS "bob/foo.txt"))
it "stripDir parent parent = _|_"
(stripDir $(mkAbsTPS "/home/hasufell/foo")
$(mkAbsTPS "/home/hasufell/foo") ==
Nothing)
-- | The '</>' operation.
operationAppend :: Spec
operationAppend =
do it "AbsDir + RelDir = AbsDir"
($(mkAbsTPS "/home/") </>
$(mkRelTPS "hasufell") ==
$(mkAbsTPS "/home/hasufell/"))
it "AbsDir + RelFile = AbsFile"
($(mkAbsTPS "/home/") </>
$(mkRelNoTPS "hasufell/test.txt") ==
$(mkAbsNoTPS "/home/hasufell/test.txt"))
it "RelDir + RelDir = RelDir"
($(mkRelTPS "home/") </>
$(mkRelTPS "hasufell") ==
$(mkRelTPS "home/hasufell"))
it "RelDir + RelFile = RelFile"
($(mkRelTPS "home/") </>
$(mkRelNoTPS "hasufell/test.txt") ==
$(mkRelNoTPS "home/hasufell/test.txt"))
-- | Tests for the tokenizer.
parseAbsTPSSpec :: Spec
parseAbsTPSSpec =
do failing ""
failing "./"
failing "~/"
failing "foo.txt"
succeeding "/" (MkPath "/")
succeeding "//" (MkPath "/")
succeeding "///foo//bar//mu/" (MkPath "/foo/bar/mu/")
succeeding "///foo//bar////mu" (MkPath "/foo/bar/mu/")
succeeding "///foo//bar/.//mu" (MkPath "/foo/bar/mu/")
where failing x = parserTest parseAbsTPS x Nothing
succeeding x with = parserTest parseAbsTPS x (Just with)
-- | Tests for the tokenizer.
parseRelTPSSpec :: Spec
parseRelTPSSpec =
do failing ""
failing "/"
failing "//"
failing "~/"
failing "/"
failing "./"
failing "././"
failing "//"
failing "///foo//bar//mu/"
failing "///foo//bar////mu"
failing "///foo//bar/.//mu"
succeeding "..." (MkPath ".../")
succeeding "foo.bak" (MkPath "foo.bak/")
succeeding "./foo" (MkPath "foo/")
succeeding "././foo" (MkPath "foo/")
succeeding "./foo/./bar" (MkPath "foo/bar/")
succeeding "foo//bar//mu//" (MkPath "foo/bar/mu/")
succeeding "foo//bar////mu" (MkPath "foo/bar/mu/")
succeeding "foo//bar/.//mu" (MkPath "foo/bar/mu/")
where failing x = parserTest parseRelTPS x Nothing
succeeding x with = parserTest parseRelTPS x (Just with)
-- | Tests for the tokenizer.
parseAbsNoTPSSpec :: Spec
parseAbsNoTPSSpec =
do failing ""
failing "./"
failing "~/"
failing "./foo.txt"
failing "/"
failing "//"
failing "///foo//bar//mu/"
succeeding "/..." (MkPath "/...")
succeeding "/foo.txt" (MkPath "/foo.txt")
succeeding "///foo//bar////mu.txt" (MkPath "/foo/bar/mu.txt")
succeeding "///foo//bar/.//mu.txt" (MkPath "/foo/bar/mu.txt")
where failing x = parserTest parseAbsNoTPS x Nothing
succeeding x with = parserTest parseAbsNoTPS x (Just with)
-- | Tests for the tokenizer.
parseRelNoTPSSpec :: Spec
parseRelNoTPSSpec =
do failing ""
failing "/"
failing "//"
failing "~/"
failing "/"
failing "./"
failing "//"
failing "///foo//bar//mu/"
failing "///foo//bar////mu"
failing "///foo//bar/.//mu"
succeeding "..." (MkPath "...")
succeeding "foo.txt" (MkPath "foo.txt")
succeeding "./foo.txt" (MkPath "foo.txt")
succeeding "././foo.txt" (MkPath "foo.txt")
succeeding "./foo/./bar.txt" (MkPath "foo/bar.txt")
succeeding "foo//bar//mu.txt" (MkPath "foo/bar/mu.txt")
succeeding "foo//bar////mu.txt" (MkPath "foo/bar/mu.txt")
succeeding "foo//bar/.//mu.txt" (MkPath "foo/bar/mu.txt")
where failing x = parserTest parseRelNoTPS x Nothing
succeeding x with = parserTest parseRelNoTPS x (Just with)
-- | Parser test.
parserTest :: (Show a1,Show a,Eq a1)
=> (a -> Maybe a1) -> a -> Maybe a1 -> SpecWith ()
parserTest parser input expected =
it ((case expected of
Nothing -> "Failing: "
Just{} -> "Succeeding: ") <>
"Parsing " <>
show input <>
" " <>
case expected of
Nothing -> "should fail."
Just x -> "should succeed with: " <> show x)
(actual == expected)
where actual = parser input