Disallow ..

CHANGELOG

@@ -2,3 +2,10 @@
 
         * Rename parentAbs to simply parent.
 	* Add dirname.
+
+0.3.0:
+	* Removed Generic instance.
+
+0.4.0:
+	* Implemented stricter parsing, disabling use of "..".
+	* Made stripDir

src/Path.hs

@@ -65,6 +65,7 @@ data PathParseException
   | InvalidRelDir FilePath
   | InvalidAbsFile FilePath
   | InvalidRelFile FilePath
+  | Couldn'tStripPrefixDir FilePath FilePath
   deriving (Show,Typeable)
 instance Exception PathParseException
 
@@ -81,7 +82,10 @@ parseAbsDir :: MonadThrow m
 parseAbsDir filepath =
   if FilePath.isAbsolute filepath &&
      not (null (normalizeDir filepath)) &&
-     not (isPrefixOf "~/" filepath)
+     not (isPrefixOf "~/" filepath) &&
+     not (isSuffixOf "/.." filepath) &&
+     not (isInfixOf "/../" filepath) &&
+     not (isPrefixOf "../" filepath)
      then return (Path (normalizeDir filepath))
      else throwM (InvalidAbsDir filepath)
 
@@ -96,7 +100,11 @@ parseRelDir filepath =
   if not (FilePath.isAbsolute filepath) &&
      not (null filepath) &&
      not (isPrefixOf "~/" filepath) &&
-     not (null (normalizeDir filepath))
+     not (isPrefixOf "../" filepath) &&
+     not (isSuffixOf "/.." filepath) &&
+     not (isInfixOf "/../" filepath) &&
+     not (null (normalizeDir filepath)) &&
+     filepath /= ".."
      then return (Path (normalizeDir filepath))
      else throwM (InvalidRelDir filepath)
 
@@ -110,7 +118,11 @@ parseAbsFile filepath =
   if FilePath.isAbsolute filepath &&
      not (FilePath.hasTrailingPathSeparator filepath) &&
      not (isPrefixOf "~/" filepath) &&
-     not (null (normalizeFile filepath))
+     not (isPrefixOf "../" filepath) &&
+     not (isSuffixOf "/.." filepath) &&
+     not (isInfixOf "/../" filepath) &&
+     not (null (normalizeFile filepath)) &&
+     filepath /= ".."
      then return (Path (normalizeFile filepath))
      else throwM (InvalidAbsFile filepath)
 
@@ -121,10 +133,16 @@ parseAbsFile filepath =
 parseRelFile :: MonadThrow m
              => FilePath -> m (Path Rel File)
 parseRelFile filepath =
-  if not (FilePath.isAbsolute filepath || FilePath.hasTrailingPathSeparator filepath) &&
+  if not (FilePath.isAbsolute filepath ||
+          FilePath.hasTrailingPathSeparator filepath) &&
      not (null filepath) &&
      not (isPrefixOf "~/" filepath) &&
-     not (null (normalizeFile filepath))
+     not (isPrefixOf "../" filepath) &&
+     not (isInfixOf "/../" filepath) &&
+     not (isSuffixOf "/.." filepath) &&
+     not (isInfixOf "/../" filepath) &&
+     not (null (normalizeFile filepath)) &&
+     filepath /= ".."
      then return (Path (normalizeFile filepath))
      else throwM (InvalidRelFile filepath)
 

test/Main.hs

@@ -4,6 +4,9 @@
 
 module Main where
 
+import Control.Applicative
+import Control.Monad
+import Data.Maybe
 import Data.Monoid
 import Path
 import Path.Internal
@@ -25,6 +28,25 @@ spec =
      describe "Operations: isParentOf" operationIsParentOf
      describe "Operations: parent" operationParent
      describe "Operations: filename" operationFilename
+     describe "Restrictions" restrictions
+
+-- | Restricting the input of any tricks.
+restrictions :: Spec
+restrictions =
+  do parseFails "~/"
+     parseFails "~/foo"
+     parseFails "~/foo/bar"
+     parseFails "../"
+     parseFails ".."
+     parseFails "/.."
+     parseFails "/foo/../bar/"
+     parseFails "/foo/bar/.."
+  where parseFails x =
+          it (show x ++ " should be rejected")
+             (isNothing (void (parseAbsDir x) <|>
+                         void (parseRelDir x) <|>
+                         void (parseAbsFile x) <|>
+                         void (parseRelDir x)))
 
 -- | The 'filename' operation.
 operationFilename :: Spec