From 7e8c745e359710c01b8af42727e54dace1416901 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 16 Apr 2016 18:17:44 +0200 Subject: [PATCH] Clean up, rewrite stuff --- README.md | 71 +----- doctests.hs | 14 ++ hpath.cabal | 35 +-- src/HPath.hs | 511 +++++++++++++++++++----------------------- src/HPath/Foreign.hsc | 7 - test/Main.hs | 225 ------------------- 6 files changed, 280 insertions(+), 583 deletions(-) create mode 100644 doctests.hs delete mode 100644 src/HPath/Foreign.hsc delete mode 100644 test/Main.hs diff --git a/README.md b/README.md index b4997e4..7717cef 100644 --- a/README.md +++ b/README.md @@ -16,65 +16,14 @@ decided to fork it. ## Differences to 'path' -I wasn't happy with the way it dealt with Dir vs File things. In his -version of the library, a `Path b Dir` always ends with a trailing -path separator and `Path b File` never ends with a trailing path separator. - -IMO, it is nonsensical to make a Dir vs File distinction on path level, -although it first seems nice. -Some of the reasons are: -* a path is just that: a path. It is completely disconnected from IO level - and even if a `Dir`/`File` type theoretically allows us to say "this path - ought to point to a file", there is literally zero guarantee that it will - 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. +* 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 +* trailing path separators will be preserved if they exist, no messing with that +* uses safe ByteString for filepaths under the hood instead of unsafe String +* fixes broken [dirname](https://github.com/chrisdone/path/issues/18) +* renames dirname/filename to basename/dirname to match the POSIX shell functions +* introduces a new `Path Fn` for safe filename guarantees and a `RelC` class +* allows pattern matching via unidirectional PatternSynonym +* uses simple doctest for testing +* allows `~/` as relative path, because on posix level `~` is just a regular filename that does _NOT_ point to `$HOME` +* remove TH, it sucks diff --git a/doctests.hs b/doctests.hs new file mode 100644 index 0000000..d7d8316 --- /dev/null +++ b/doctests.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Test.DocTest +import Test.HUnit + +main = + doctest + [ "-isrc" + , "-XOverloadedStrings" + , "src/HPath.hs" + ] + diff --git a/hpath.cabal b/hpath.cabal index 02b4b58..585ee9b 100644 --- a/hpath.cabal +++ b/hpath.cabal @@ -15,25 +15,30 @@ extra-source-files: README.md, CHANGELOG library hs-source-dirs: src/ ghc-options: -Wall -O2 - exposed-modules: HPath, HPath.Foreign, HPath.Internal + exposed-modules: HPath, HPath.Internal build-depends: base >= 4 && <5 + , HUnit , bytestring - , encoding - , exceptions , deepseq + , exceptions + , hspec + , posix-paths + , utf8-string , word8 - , template-haskell -test-suite test - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test - build-depends: HUnit - , base - , hspec - , mtl - , hpath + +test-suite doctests + type: exitcode-stdio-1.0 + ghc-options: -threaded + main-is: doctests.hs + build-depends: base + , HUnit + , bytestring + , doctest >= 0.8 + , hpath + , posix-paths source-repository head - type: git - location: https://github.com/hasufell/hpath + type: git + location: https://github.com/hasufell/hpath + diff --git a/src/HPath.hs b/src/HPath.hs index 8c68695..330ea88 100644 --- a/src/HPath.hs +++ b/src/HPath.hs @@ -10,12 +10,10 @@ -- Support for well-typed paths. - -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_HADDOCK ignore-exports #-} module HPath @@ -32,16 +30,11 @@ module HPath ,parseAbs ,parseFn ,parseRel - -- * Path Constructors - ,mkAbs - ,mkFn - ,mkRel -- * Path Conversion ,canonicalizePath ,fromAbs ,fromRel ,normalize - ,normalizeAbs ,toFilePath -- * Path Operations ,() @@ -61,52 +54,38 @@ module HPath ,combine ,dropFileName ,dropTrailingPathSeparator - ,dropWhileEnd - ,equalFilePath ,fpToString ,joinPath ,normalise ,splitDirectories ,splitFileName ,splitPath - ,stripPrefix ,takeDirectory ,userStringToFP -- * ByteString Query functions ,hiddenFile -- * Queries - ,hasDot - ,hasDoublePS - ,hasLeadingPathSeparator ,hasParentDir - ,hasTrailingPathSeparator ,isAbsolute ,isFileName ,isRelative ,isValid -- * String based functions - ,realPath ) where import Control.Exception (Exception) -import Control.Monad(void) import Control.Monad.Catch (MonadThrow(..)) 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.Encoding(decodeStrictByteString, encodeStrictByteString) -import Data.Encoding.UTF8(UTF8(..)) import qualified Data.List as L import Data.Maybe import Data.Word8 -import Foreign.C.Error -import Foreign.C.String -import Foreign.Marshal.Alloc(allocaBytes) -import HPath.Foreign import HPath.Internal -import Language.Haskell.TH -import Safe(initDef) +import System.Posix.FilePath hiding (()) +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' -- +-- >>> 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 => ByteString -> m (Path Abs) parseAbs filepath = @@ -160,14 +153,33 @@ parseAbs filepath = then return (MkPath $ normalise 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 -- solely of @./@. It also may not contain a single @..@ anywhere. -- -- 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 => ByteString -> m (Path Rel) parseRel filepath = @@ -184,6 +196,26 @@ parseRel filepath = -- -- 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 => ByteString -> m (Path Fn) 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 -- | 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 (MkPath l) = l @@ -247,16 +243,10 @@ fromRel = toFilePath normalize :: Path t -> Path t normalize (MkPath l) = MkPath $ normalise l --- | A variant for `normalize` for absolute paths which --- 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`. +-- | May fail on `realpath`. canonicalizePath :: Path Abs -> IO (Path Abs) canonicalizePath (MkPath l) = do - nl <- realPath l + nl <- realpath l 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, -- because this library is IO-agnostic and makes no assumptions about -- 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 -() (MkPath a) (MkPath b) = MkPath (a' `B.append` b) +() (MkPath a) (MkPath b) = MkPath (a' `BS.append` b) 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. -- Throws 'Couldn'tStripPrefixDir' if directory is not a parent of the path. -- -- 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 => Path b -> Path b -> m (Path Rel) stripDir (MkPath p) (MkPath l) = case stripPrefix p' l of Nothing -> throwM (Couldn'tStripPrefixTPS p' l) - Just ok -> if B.null ok + Just ok -> if BS.null ok then throwM (Couldn'tStripPrefixTPS p' l) else return (MkPath ok) where @@ -293,10 +304,27 @@ stripDir (MkPath p) (MkPath l) = -- | Is p a parent of the given location? Implemented in terms of -- '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 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 (MkPath p) | np == pathSeparator' = [] @@ -311,6 +339,10 @@ getAllParents (MkPath p) -- -- @dirname (p \<\/> a) == dirname p@ -- +-- >>> dirname (MkPath "/abc/def/dod") +-- "/abc/def" +-- >>> dirname (MkPath "/") +-- "/" dirname :: Path Abs -> Path Abs dirname (MkPath fp) = MkPath (takeDirectory $ dropTrailingPathSeparator fp) @@ -322,6 +354,11 @@ dirname (MkPath fp) = MkPath (takeDirectory $ dropTrailingPathSeparator fp) -- @basename (p \<\/> a) == basename a@ -- -- 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 (MkPath l) | not (isAbsolute rl) = return $ MkPath rl @@ -333,21 +370,31 @@ basename (MkPath l) -------------------------------------------------------------------------------- -- 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 (MkPath fp) | fp == pathDoubleDot = False | fp == pathDot' = False - | otherwise = pathDot' `B.isPrefixOf` fp + | otherwise = pathDot' `BS.isPrefixOf` fp -------------------------------------------------------------------------------- -- ByteString/Word8 constants -pathSeparator :: Word8 -pathSeparator = _slash - pathSeparator' :: ByteString -pathSeparator' = B.singleton pathSeparator +pathSeparator' = BS.singleton pathSeparator pathDot :: Word8 @@ -355,11 +402,11 @@ pathDot = _period pathDot' :: ByteString -pathDot' = B.singleton pathDot +pathDot' = BS.singleton pathDot pathDoubleDot :: ByteString -pathDoubleDot = pathDot `B.cons` pathDot' +pathDoubleDot = pathDot `BS.cons` pathDot' nullByte :: Word8 @@ -370,228 +417,142 @@ nullByte = _nul -- 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 filepath = result `B.append` - (if addPathSeparator then pathSeparator' else B.empty) +normalise filepath = + result `BS.append` + (if addPathSeparator + then BS.singleton pathSeparator + else BS.empty) where - (drv, pth) = splitDrive filepath - result = joinDrive' (normaliseDrive drv) (f pth) - joinDrive' d p - | B.null d && B.null p = B.singleton pathDot - | otherwise = joinDrive d p - addPathSeparator = isDirPath pth && not (hasTrailingPathSeparator result) - isDirPath xs = hasTrailingPathSeparator xs - || not (B.null xs) && B.last xs == pathDot - && hasTrailingPathSeparator (B.init xs) - normaliseDrive p - | B.null p = B.empty - | otherwise = B.singleton pathSeparator + result = let n = f filepath + in if BS.null n + then BS.singleton _period + else n + addPathSeparator = isDirPath filepath && + not (hasTrailingPathSeparator' result) + isDirPath xs = hasTrailingPathSeparator' xs + || not (BS.null xs) && BS.last xs == _period + && hasTrailingPathSeparator' (BS.init xs) f = joinPath . dropDots . propSep . splitDirectories propSep :: [ByteString] -> [ByteString] propSep (x:xs) - | B.all (== pathSeparator) x = pathSeparator' : xs - | otherwise = x : xs + | BS.all (== pathSeparator) x = BS.singleton pathSeparator : xs + | otherwise = x : xs 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. fpToString :: ByteString -> String -fpToString = decodeStrictByteString UTF8 +fpToString = toString -- |Uses UTF-8 encoding to convert a user provided String into -- a ByteString, which represents a filepath. 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 -- | 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 filepath = - ((pathSeparator `B.cons` pathDoubleDot) `B.isSuffixOf` filepath) || - ((pathSeparator' `B.append` pathDoubleDot `B.append` pathSeparator') - `B.isInfixOf` filepath) || - ((pathDoubleDot `B.append` pathSeparator') `B.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 + ((pathSeparator `BS.cons` pathDoubleDot) `BS.isSuffixOf` filepath) || + ((pathSeparator' `BS.append` pathDoubleDot `BS.append` pathSeparator') + `BS.isInfixOf` filepath) || + ((pathDoubleDot `BS.append` pathSeparator') `BS.isPrefixOf` filepath) +-- | 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 filepath = - not (pathSeparator' `B.isInfixOf` filepath) && - not (B.null filepath) && - not (nullByte `B.elem` filepath) + not (pathSeparator' `BS.isInfixOf` filepath) && + not (BS.null filepath) && + not (nullByte `BS.elem` filepath) -isAbsolute :: ByteString -> Bool -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 +-- | Is a FilePath valid, i.e. could you create a file like it? -- --- like canonicalizePath, but uses realpath(3) -realPath :: ByteString -> IO ByteString -realPath inp = - allocaBytes pathMax $ \tmp -> do - void $ B.useAsCString inp - $ \cstr -> throwErrnoIfNull "realpath" - $ c_realpath cstr tmp - B.packCString tmp +-- >>> isValid "" +-- False +-- >>> isValid "\0" +-- False +-- >>> isValid "/random_ path:*" +-- True +isValid :: RawFilePath -> Bool +isValid filepath + | BS.null filepath = False + | _nul `BS.elem` filepath = False + | otherwise = True diff --git a/src/HPath/Foreign.hsc b/src/HPath/Foreign.hsc deleted file mode 100644 index 71639cd..0000000 --- a/src/HPath/Foreign.hsc +++ /dev/null @@ -1,7 +0,0 @@ -module HPath.Foreign where - -#include - -pathMax :: Int -pathMax = #{const PATH_MAX} - diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 index 851c080..0000000 --- a/test/Main.hs +++ /dev/null @@ -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