aboutsummaryrefslogtreecommitdiff
path: root/src/CabalHelper
diff options
context:
space:
mode:
authorDaniel Gröber <dxld@darkboxed.org>2019-07-29 21:53:57 +0200
committerDaniel Gröber (dxld) <dxld@darkboxed.org>2019-09-17 17:48:26 +0200
commit1b05d896884a8c02306f73f82658e7c6f3825fff (patch)
tree27b329f6b547b23d54b5a810c93f94557a992983 /src/CabalHelper
parent4ea02d3a8a6aec056e58eb1c15e12e0835041549 (diff)
Fix RelativePath invariants
Two things were broken here: - I forgot to encode the invariant that RealtivePath should not be allowed to escape CWD by using '../' - The invaiant was inverted. A RelativePath was only allowed to be absolute before -- uups.
Diffstat (limited to 'src/CabalHelper')
-rw-r--r--src/CabalHelper/Compiletime/Types/RelativePath.hs28
1 files changed, 22 insertions, 6 deletions
diff --git a/src/CabalHelper/Compiletime/Types/RelativePath.hs b/src/CabalHelper/Compiletime/Types/RelativePath.hs
index 107a8ce..ac26de2 100644
--- a/src/CabalHelper/Compiletime/Types/RelativePath.hs
+++ b/src/CabalHelper/Compiletime/Types/RelativePath.hs
@@ -27,14 +27,30 @@ module CabalHelper.Compiletime.Types.RelativePath
import System.FilePath
--- | A path guaranteed to be relative. The constructor is not exposed, use the
--- 'mkRelativePath' smart constructor.
+-- | A path guaranteed to be relative and not escape the base path. The
+-- constructor is not exposed, use the 'mkRelativePath' smart constructor.
newtype RelativePath = RelativePath { unRelativePath :: FilePath }
deriving (Show)
--- | Smart constructor for 'RelativePath'. Checks if the given path is absolute
--- and throws 'UserError' if not.
+-- | Smart constructor for 'RelativePath'. Checks if the given path
+-- satisfies the constraints and throws 'UserError' if not.
mkRelativePath :: FilePath -> RelativePath
mkRelativePath dir
- | isAbsolute dir = RelativePath dir
- | otherwise = error "mkRelativePath: the path given was absolute!"
+ | isAbsolute dir =
+ error $ "mkRelativePath: the path given was absolute! got: " ++ dir
+ | doesRelativePathEscapeCWD dir =
+ error $ "mkRelativePath: the path given escapes the base dir! got: " ++ dir
+ | otherwise =
+ RelativePath dir
+
+doesRelativePathEscapeCWD :: FilePath -> Bool
+doesRelativePathEscapeCWD path =
+ go [] $ splitDirectories $ normalise path
+ -- normalise collapses '.' in path, this is very important or this
+ -- check would be traivial to defeat. For example './../' would be
+ -- able to escape.
+ where
+ go (_:xs) ("..":ys) = go xs ys
+ go [] ("..":__) = True
+ go xs (y :ys) = go (y:xs) ys
+ go _ [] = False