diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,5 @@ +0.5.9: + * Lifted ~ restriction from parser https://github.com/chrisdone/path/issues/19 0.5.8 * Add Aeson instances. diff --git a/path.cabal b/path.cabal --- a/path.cabal +++ b/path.cabal @@ -1,7 +1,7 @@ name: path -version: 0.5.8 +version: 0.5.9 synopsis: Support for well-typed paths -description: Support for will-typed paths. +description: Support for well-typed paths. license: BSD3 license-file: LICENSE author: Chris Done @@ -18,7 +18,7 @@ exposed-modules: Path, Path.Internal build-depends: base >= 4 && <5 , exceptions - , filepath + , filepath < 1.2.0.1 || >= 1.3 , template-haskell , deepseq , aeson @@ -30,6 +30,7 @@ build-depends: HUnit , aeson , base + , bytestring , hspec , mtl , path diff --git a/src/Path.hs b/src/Path.hs --- a/src/Path.hs +++ b/src/Path.hs @@ -9,6 +9,7 @@ -- -- Support for well-typed paths. +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} @@ -65,7 +66,10 @@ -- | An absolute path. data Abs deriving (Typeable) --- | A relative path; one without a root. +-- | A relative path; one without a root. Note that a @.@ as well as any path +-- starting with a @..@ is not a valid relative path. In other words, a +-- relative path is always strictly under the directory tree to which it is +-- relative. data Rel deriving (Typeable) -- | A file path. @@ -112,63 +116,72 @@ -------------------------------------------------------------------------------- -- Parsers --- | Get a location for an absolute directory. Produces a normalized --- path which always ends in a path separator. +-- | Convert an absolute 'FilePath' to a normalized absolute dir 'Path'. -- --- Throws: 'PathParseException' +-- Throws: 'PathParseException' when the supplied path: -- +-- * is not an absolute path +-- * contains a @..@ anywhere in the path +-- * is not a valid path (See 'System.FilePath.isValid') +-- parseAbsDir :: MonadThrow m => FilePath -> m (Path Abs Dir) parseAbsDir filepath = if FilePath.isAbsolute filepath && - not (null (normalizeDir filepath)) && - not ("~/" `isPrefixOf` filepath) && not (hasParentDir filepath) && FilePath.isValid filepath then return (Path (normalizeDir filepath)) else throwM (InvalidAbsDir filepath) --- | Get a location for a relative directory. Produces a normalized --- path which always ends in a path separator. +-- | Convert a relative 'FilePath' to a normalized relative dir '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' when the supplied path: -- --- Throws: 'PathParseException' +-- * is not a relative path +-- * is any of @""@, @.@ or @..@ +-- * contains @..@ anywhere in the path +-- * is not a valid path (See 'System.FilePath.isValid') -- parseRelDir :: MonadThrow m => FilePath -> m (Path Rel Dir) parseRelDir filepath = if not (FilePath.isAbsolute filepath) && - not (null filepath) && - not ("~/" `isPrefixOf` filepath) && not (hasParentDir filepath) && - not (null (normalizeDir filepath)) && - filepath /= "." && filepath /= ".." && + not (null filepath) && + filepath /= "." && (normalizeFilePath filepath) /= curDirNormalizedFP && + filepath /= ".." && FilePath.isValid filepath then return (Path (normalizeDir filepath)) else throwM (InvalidRelDir filepath) --- | Get a location for an absolute file. +-- | Convert an absolute 'FilePath' to a normalized absolute file 'Path'. -- --- Throws: 'PathParseException' +-- Throws: 'PathParseException' when the supplied path: -- +-- * is not an absolute path +-- * has a trailing path separator +-- * contains @..@ anywhere in the path +-- * is not a valid path (See 'System.FilePath.isValid') +-- parseAbsFile :: MonadThrow m => FilePath -> m (Path Abs File) parseAbsFile filepath = if FilePath.isAbsolute filepath && not (FilePath.hasTrailingPathSeparator filepath) && - not ("~/" `isPrefixOf` filepath) && not (hasParentDir filepath) && - not (null (normalizeFile filepath)) && FilePath.isValid filepath - then return (Path (normalizeFile filepath)) + then return (Path (normalizeFilePath filepath)) else throwM (InvalidAbsFile filepath) --- | Get a location for a relative file. +-- | Convert a relative 'FilePath' to a normalized relative file 'Path'. -- --- Note that @filepath@ may contain any number of @./@ but may not contain a single @..@ anywhere. +-- Throws: 'PathParseException' when the supplied path: -- --- Throws: 'PathParseException' +-- * is not a relative path +-- * has a trailing path separator +-- * is @""@, @.@ or @..@ +-- * contains @..@ anywhere in the path +-- * is not a valid path (See 'System.FilePath.isValid') -- parseRelFile :: MonadThrow m => FilePath -> m (Path Rel File) @@ -176,12 +189,10 @@ if not (FilePath.isAbsolute filepath || FilePath.hasTrailingPathSeparator filepath) && not (null filepath) && - not ("~/" `isPrefixOf` filepath) && not (hasParentDir filepath) && - not (null (normalizeFile filepath)) && filepath /= "." && filepath /= ".." && FilePath.isValid filepath - then return (Path (normalizeFile filepath)) + then return (Path (normalizeFilePath filepath)) else throwM (InvalidRelFile filepath) -- | Helper function: check if the filepath has any parent directories in it. @@ -320,6 +331,13 @@ -- | Is p a parent of the given location? Implemented in terms of -- 'stripDir'. The bases must match. +-- +-- The following properties hold: +-- +-- @not (x `isParentOf` x)@ +-- +-- @x `isParentOf` (x \<\/\> y)@ +-- isParentOf :: Path b Dir -> Path b t -> Bool isParentOf p l = isJust (stripDir p l) @@ -346,7 +364,7 @@ -- filename :: Path b File -> Path Rel File filename (Path l) = - Path (normalizeFile (FilePath.takeFileName l)) + Path (FilePath.takeFileName l) -- | Extract the last directory name of a path. -- @@ -361,18 +379,21 @@ -------------------------------------------------------------------------------- -- Internal functions +curDirNormalizedFP :: FilePath +curDirNormalizedFP = '.' : [FilePath.pathSeparator] + -- | Internal use for normalizing a directory. normalizeDir :: FilePath -> FilePath -normalizeDir = - clean . FilePath.addTrailingPathSeparator . FilePath.normalise - where clean "./" = "" - clean ('/':'/':xs) = clean ('/':xs) - clean x = x +normalizeDir = FilePath.addTrailingPathSeparator . normalizeFilePath --- | Internal use for normalizing a fileectory. -normalizeFile :: FilePath -> FilePath -normalizeFile = - clean . FilePath.normalise - where clean "./" = "" - clean ('/':'/':xs) = clean ('/':xs) - clean x = x +normalizeFilePath :: FilePath -> FilePath +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) || MIN_VERSION_filepath(1,4,0) +normalizeFilePath = FilePath.normalise +#else +normalizeFilePath = normalizeLeadingSeparators . FilePath.normalise + where + sep = FilePath.pathSeparator + normalizeLeadingSeparators (x1:x2:xs) | x1 == sep && x2 == sep + = normalizeLeadingSeparators (sep:xs) + normalizeLeadingSeparators x = x +#endif diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -- | Test suite. @@ -8,6 +7,7 @@ import Control.Applicative import Control.Monad import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Maybe import Path import Path.Internal @@ -35,9 +35,12 @@ -- | Restricting the input of any tricks. restrictions :: Spec restrictions = - do parseFails "~/" - parseFails "~/foo" - parseFails "~/foo/bar" + do -- These ~ related ones below are now lifted: + -- https://github.com/chrisdone/path/issues/19 + parseSucceeds "~/" (Path "~/") + parseSucceeds "~/foo" (Path "~/foo/") + parseSucceeds "~/foo/bar" (Path "~/foo/bar/") + -- parseFails "../" parseFails ".." parseFails "." @@ -50,6 +53,8 @@ void (parseRelDir x) <|> void (parseAbsFile x) <|> void (parseRelFile x))) + parseSucceeds x with = + parserTest parseRelDir x (Just with) -- | The 'filename' operation. operationFilename :: Spec @@ -134,7 +139,6 @@ parseAbsDirSpec = do failing "" failing "./" - failing "~/" failing "foo.txt" succeeding "/" (Path "/") succeeding "//" (Path "/") @@ -150,7 +154,7 @@ do failing "" failing "/" failing "//" - failing "~/" + succeeding "~/" (Path "~/") -- https://github.com/chrisdone/path/issues/19 failing "/" failing "./" failing "././" @@ -223,15 +227,18 @@ case expected of Nothing -> "should fail." Just x -> "should succeed with: " ++ show x) - (actual == expected) + (actual `shouldBe` expected) where actual = parser input -- | Tests for the 'ToJSON' and 'FromJSON' instances +-- +-- Can't use overloaded strings due to some weird issue with bytestring-0.9.2.1 / ghc-7.4.2: +-- https://travis-ci.org/sjakobi/path/jobs/138399072#L989 aesonInstances :: Spec aesonInstances = do it "Decoding \"[\"/foo/bar\"]\" as a [Path Abs Dir] should succeed." $ - eitherDecode "[\"/foo/bar\"]" `shouldBe` Right [Path "/foo/bar/" :: Path Abs Dir] + eitherDecode (LBS.pack "[\"/foo/bar\"]") `shouldBe` Right [Path "/foo/bar/" :: Path Abs Dir] it "Decoding \"[\"/foo/bar\"]\" as a [Path Rel Dir] should fail." $ - decode "[\"/foo/bar\"]" `shouldBe` (Nothing :: Maybe [Path Rel Dir]) + decode (LBS.pack "[\"/foo/bar\"]") `shouldBe` (Nothing :: Maybe [Path Rel Dir]) it "Encoding \"[\"/foo/bar/mu.txt\"]\" should succeed." $ - encode [Path "/foo/bar/mu.txt" :: Path Abs File] `shouldBe` "[\"/foo/bar/mu.txt\"]" + encode [Path "/foo/bar/mu.txt" :: Path Abs File] `shouldBe` (LBS.pack "[\"/foo/bar/mu.txt\"]")