From 1b05d896884a8c02306f73f82658e7c6f3825fff Mon Sep 17 00:00:00 2001
From: Daniel Gröber <dxld@darkboxed.org>
Date: Mon, 29 Jul 2019 21:53:57 +0200
Subject: 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.
---
 src/CabalHelper/Compiletime/Types/RelativePath.hs | 28 ++++++++++++++++++-----
 1 file changed, 22 insertions(+), 6 deletions(-)

(limited to 'src/CabalHelper/Compiletime')

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
-- 
cgit v1.2.3