typechecking for path depths!

This now checks if relative paths are still inside the repository, as a
general safety mechanism to stop the linter from accidentally reading
other things, as well as a nice hint for users.

4 files changed, 127 insertions, 69 deletions

diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index b32bad6..3966988 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -16,7 +16,7 @@ import qualified Data.Text    as T
 import qualified Data.Vector  as V
 import           GHC.Generics (Generic)
 
-import           LintWriter   (LayerContext (..), LintResult (..), LintWriter,
+import           LintWriter   (LintResult (..), LintWriter, askContext,
                                lintToDep, resultToDeps, resultToLints,
                                runLintWriter)
 import           Properties   (checkLayerProperty, checkMap)
@@ -29,7 +29,7 @@ import           Util         (PrettyPrint (prettyprint), prettyprint)
 
 -- | What this linter produces: lints for a single map
 data MapResult a = MapResult
-  { mapresultLayer   :: Maybe (Map Text (LintResult LayerContext))
+  { mapresultLayer   :: Maybe (Map Text (LintResult Layer))
   , mapresultGeneral :: [Lint]
   , mapresultDepends :: [Dep]
   } deriving (Generic, ToJSON)
@@ -59,20 +59,21 @@ runLinter tiledmap = MapResult
     <> mapMaybe lintToDep generalLints
   }
   where
-    layerMap :: Map Text (LintResult LayerContext)
+    layerMap :: Map Text (LintResult Layer)
     layerMap = fromList layer
     layer = V.toList . V.map runCheck $ tiledmapLayers tiledmap
-      where runCheck l = (layerName l, runLintWriter (LayerContext ()) (checkLayer l))
+      where runCheck l = (layerName l, runLintWriter l 0 checkLayer)
 
     -- lints collected from properties
     generalLints =
-      resultToLints $ runLintWriter () (checkMap tiledmap)
+      resultToLints $ runLintWriter tiledmap 0 checkMap
 
 
 -- | collect lints on a single map layer
-checkLayer :: Layer -> LintWriter LayerContext
-checkLayer layer =
-  mapM_ (checkLayerProperty layer) (layerProperties layer)
+checkLayer :: LintWriter Layer
+checkLayer = do
+  layer <- askContext
+  mapM_ checkLayerProperty (layerProperties layer)
 
 -- human-readable lint output, e.g. for consoles
 instance PrettyPrint a => PrettyPrint (MapResult a) where
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index a6fa17e..de7d314 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -14,20 +14,26 @@ import           Control.Monad.Writer       (MonadWriter (tell), WriterT,
 import           Data.Aeson                 (ToJSON (toJSON))
 import           Data.Text                  (Text)
 
-import           Control.Monad.Trans.Reader (Reader, runReader)
+import           Control.Monad.Reader       (local)
+import           Control.Monad.Trans.Reader (Reader, asks, runReader)
+import           Control.Monad.Writer.Lazy  (lift)
 import           Data.Maybe                 (mapMaybe)
+import           GHC.Generics               (Generic)
 import           Types
-import GHC.Generics (Generic)
+
+
+-- | for now, all context we have is how "deep" in the directory tree
+-- we currently are
+type Context = Int
 
 -- | a monad to collect hints, with some context
-type LintWriter ctxt = WriterT [Lint] (Reader ctxt) ()
+type LintWriter ctxt = LintWriter' ctxt ()
+type LintWriter' ctxt res = WriterT [Lint] (Reader (Context, ctxt)) res
 
 -- wrapped to allow for manual writing of Aeson instances
 type LintResult' ctxt = (ctxt, [Lint]) -- Either Lint (a, [Lint])
 newtype LintResult ctxt = LintResult (LintResult' ctxt)
 
-data LayerContext = LayerContext ()
-  deriving (Generic, ToJSON)
 
 -- better, less confusing serialisation of an Either Hint (a, [Hint]).
 -- Note that Left hint is also serialised as a list to make the resulting
@@ -49,9 +55,9 @@ resultToLints :: LintResult a -> [Lint]
 resultToLints (LintResult res) = snd res
 
 -- | run a linter
-runLintWriter :: ctxt -> LintWriter ctxt -> LintResult ctxt
-runLintWriter c linter =  LintResult (c, lints)
-  where lints = snd $ flip runReader c $ runWriterT linter
+runLintWriter :: ctxt -> Context -> LintWriter ctxt -> LintResult ctxt
+runLintWriter c c' linter =  LintResult (c, lints)
+  where lints = snd $ flip runReader (c',c) $ runWriterT linter
 
 -- | write a hint into the LintWriter monad
 lint :: Level -> Text -> LintWriter a
@@ -66,3 +72,9 @@ suggest = lint Suggestion
 warn = lint Warning
 forbid = lint Forbidden
 complain = lint Error
+
+askContext :: LintWriter' a a
+askContext = lift $ asks snd
+
+askFileDepth :: LintWriter' a Int
+askFileDepth = lift $ asks fst
diff --git a/lib/Paths.hs b/lib/Paths.hs
new file mode 100644
index 0000000..7750723
--- /dev/null
+++ b/lib/Paths.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+
+module Paths where
+
+import           Data.Text       (Text)
+import qualified Data.Text       as T
+import           Text.Regex.TDFA
+import           Util            (PrettyPrint (prettyprint))
+
+-- | a normalised path: a number of "upwards" steps, and
+-- a path without any . or .. in it
+data RelPath = Path Int Text
+  deriving (Show, Eq)
+
+-- | horrible regex parsing for filepaths that is hopefully kinda safe
+parsePath :: Text -> Maybe RelPath
+parsePath text =
+  if rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) :: Bool
+  then Just $ Path up rest
+  else Nothing
+  where
+    (_, prefix, rest, _) =
+      text =~ ("^((\\.|\\.\\.)/)*" :: Text) :: (Text, Text, Text, [Text])
+    -- how many steps upwards in the tree?
+    up = length . filter (".." ==) . T.splitOn  "/" $ prefix
+
+instance PrettyPrint RelPath where
+  prettyprint (Path up rest) = ups <> rest
+    where ups = T.concat $ replicate up "../"
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 68cf88a..818378a 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -12,8 +12,8 @@ import           Tiled2        (Layer (..), Property (..), PropertyValue (..),
                                 Tiledmap (..), Tileset (..))
 import           Util          (layerIsEmpty, prettyprint)
 
-import           LintWriter    (LintWriter, complain, dependsOn, forbid, info,
-                                suggest, warn, LayerContext)
+import           LintWriter    (LintWriter, askContext, askFileDepth, complain,
+                                dependsOn, forbid, info, suggest, warn)
 import           Paths
 import           Types         (Dep (Link, Local, LocalMap, MapLink))
 
@@ -23,11 +23,12 @@ import           Types         (Dep (Link, Local, LocalMap, MapLink))
 -- Note that it does /not/ call checkMapProperty; this is handled
 -- seperately in CheckMap.hs, since these lints go into a different
 -- field of the resulting json.
-checkMap :: Tiledmap -> LintWriter ()
-checkMap tiledmap = do
-  -- check properties
-  mapM_ (checkMapProperty tiledmap) (tiledmapProperties tiledmap)
-  -- check tilesets
+checkMap :: LintWriter Tiledmap
+checkMap = do
+  tiledmap <- askContext
+
+  -- test other things
+  mapM_ checkMapProperty (tiledmapProperties tiledmap)
   mapM_ checkTileset (tiledmapTilesets tiledmap)
 
   -- some layers should exist
@@ -44,10 +45,10 @@ checkMap tiledmap = do
   unless (tiledmapTileheight tiledmap == 32 && tiledmapTilewidth tiledmap == 32)
     $ complain "The map's tile size must be 32 by 32 pixels"
   where
-    layers = tiledmapLayers tiledmap
-    hasLayerNamed name pred = hasLayer (\l -> layerName l == name && pred l)
-    hasLayer pred err =
-      unless (any pred layers)
+    hasLayerNamed name p = hasLayer (\l -> layerName l == name && p l)
+    hasLayer p err = do
+      tiledmap <- askContext
+      unless (any p (tiledmapLayers tiledmap))
         $ complain err
 
 
@@ -55,8 +56,8 @@ checkMap tiledmap = do
 --
 -- Doesn't really do all that much, but could in theory be expanded into a
 -- longer function same as checkLayerProperty.
-checkMapProperty :: Tiledmap -> Property -> LintWriter ()
-checkMapProperty map (Property name value) = case name of
+checkMapProperty :: Property -> LintWriter Tiledmap
+checkMapProperty (Property name _value) = case name of
   "script" -> isForbidden
   _        -> complain $ "unknown map property " <> name
   where
@@ -67,7 +68,7 @@ checkMapProperty map (Property name value) = case name of
 -- | check an embedded tile set.
 --
 -- Important to collect dependency files
-checkTileset :: Tileset -> LintWriter ()
+checkTileset :: Tileset -> LintWriter Tiledmap
 checkTileset tileset = do
   -- TODO: can tilesets be non-local dependencies?
   unwrapPath (tilesetImage tileset) (dependsOn . Local)
@@ -83,21 +84,21 @@ checkTileset tileset = do
 --
 -- It gets a reference to its own layer since sometimes the presence
 -- of one property implies the presence or absense of another.
-checkLayerProperty :: Layer -> Property -> LintWriter LayerContext
-checkLayerProperty layer p@(Property name value) = case name of
+checkLayerProperty :: Property -> LintWriter Layer
+checkLayerProperty p@(Property name _value) = case name of
     "jitsiRoom" -> do
       uselessEmptyLayer
       unwrapString p $ \val -> do
         info $ "found jitsi room: " <> prettyprint val
-        suggestProp $ Property "jitsiTrigger" (StrProp "onaction")
+        suggestProperty $ Property "jitsiTrigger" (StrProp "onaction")
     "jitsiTrigger" -> do
       isString p
-      unless (hasProperty "jitsiTriggerMessage")
+      unlessHasProperty "jitsiTriggerMessage"
        $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter in jitsi meet room\""
-      requireProp "jitsiRoom"
+      requireProperty "jitsiRoom"
     "jitsiTriggerMessage" -> do
       isString p
-      requireProp "jitsiTrigger"
+      requireProperty "jitsiTrigger"
     "jitsiUrl" -> isForbidden
     "jitsiConfig" -> isForbidden
     "jitsiClientConfig" -> isForbidden
@@ -109,30 +110,30 @@ checkLayerProperty layer p@(Property name value) = case name of
         else unwrapPath link (dependsOn . Local)
     "audioLoop" -> do
       isBool p
-      requireProp "playAudio"
+      requireProperty "playAudio"
     "audioVolume" -> do
       isBool p
-      requireProp "playAudio"
+      requireProperty "playAudio"
     "openWebsite" -> do
       uselessEmptyLayer
-      suggestProp $ Property "openWebsiteTrigger" (StrProp "onaction")
+      suggestProperty $ Property "openWebsiteTrigger" (StrProp "onaction")
       unwrapLink p $ \link -> if "https://" `isPrefixOf` link
         then dependsOn $ Link link
         else unwrapPath link (dependsOn . Local)
     "openWebsiteTrigger" -> do
       isString p
-      unless (hasProperty "openWebsiteTriggerMessage")
+      unlessHasProperty "openWebsiteTriggerMessage"
         $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to overwrite the generic \"press SPACE to open Website\""
-      requireProp "openWebsite"
+      requireProperty "openWebsite"
     "openWebsiteTriggerMessage" -> do
       isString p
-      requireProp "openWebsiteTrigger"
+      requireProperty "openWebsiteTrigger"
     "openWebsitePolicy" -> do
       isString p
-      requireProp "openWebsite"
+      requireProperty "openWebsite"
     "openTab" -> do
       isString p
-      requireProp "openWebsite"
+      requireProperty "openWebsite"
     "url" -> isForbidden
     "allowApi" -> isForbidden
     "exitUrl" -> do
@@ -151,29 +152,53 @@ checkLayerProperty layer p@(Property name value) = case name of
     _ ->
       complain $ "unknown property type " <> prettyprint name
     where
-      properties = layerProperties layer
-      hasProperty = containsProperty properties
       isForbidden = forbidProperty name
-      requireProp = requireProperty properties
-      suggestProp = suggestPropertyValue properties
 
       -- | this property can only be used on a layer that contains at least one tiles
-      forbidEmptyLayer = when (layerIsEmpty layer)
-        $ complain ("property " <> name <> " should not be set on an empty layer")
+      forbidEmptyLayer = do
+        layer <- askContext
+        when (layerIsEmpty layer)
+          $ complain ("property " <> name <> " should not be set on an empty layer")
       -- | this layer is allowed, but also useless on a layer that contains no tiles
-      uselessEmptyLayer = when (layerIsEmpty layer)
-        $ warn ("property" <> name <> " was set on an empty layer and is thereby useless")
+      uselessEmptyLayer = do
+        layer <- askContext
+        when (layerIsEmpty layer)
+          $ warn ("property" <> name <> " was set on an empty layer and is thereby useless")
 
 
 
 
 
+--------- Helper functions & stuff ---------
 
+unlessHasProperty :: Text -> LintWriter Layer -> LintWriter Layer
+unlessHasProperty name andthen = do
+  layer <- askContext
+  let hasprop = any (\(Property name' _) -> name == name') (layerProperties layer)
+  unless hasprop andthen
 
 
+-- | this property is forbidden and should not be used
+forbidProperty :: Text -> LintWriter Layer
+forbidProperty name = do
+  forbid $ "property " <> prettyprint name <> " should not be used"
+
+
+-- | require some property
+requireProperty :: Text -> LintWriter Layer
+requireProperty name =
+  unlessHasProperty name
+  $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint name
+
+-- | suggest some value for another property if that property does not
+-- also already exist
+suggestProperty :: Property -> LintWriter Layer
+suggestProperty (Property name value) =
+  unlessHasProperty name
+  $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value
+
 
 
---------- Helper functions & stuff ---------
 
 
 -- | does this layer have the given property?
@@ -181,10 +206,6 @@ containsProperty :: [Property] -> Text -> Bool
 containsProperty props name = any
   (\(Property name' _) -> name' == name) props
 
--- | this property is forbidden and should not be used
-forbidProperty :: Text -> LintWriter a
-forbidProperty name = forbid $ "property " <> prettyprint name <> " should not be used"
-
 
 -- | asserts that this property is a string, and unwraps it
 unwrapString :: Property -> (Text -> LintWriter a) -> LintWriter a
@@ -208,7 +229,11 @@ unwrapBool (Property name value) f = case value of
 
 unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a
 unwrapPath str f = case parsePath str of
-  Just path -> f path
+  Just p@(Path up _) -> do
+    depth <- askFileDepth
+    if up <= depth
+      then f p
+      else complain $ "cannot acess paths \"" <> str <> "\" which is outside your repository"
   Nothing   -> complain $ "path \"" <> str <> "\" is invalid"
 
 -- | just asserts that this is a string
@@ -218,14 +243,3 @@ isString = flip unwrapString (const $ pure ())
 -- | just asserts that this is a boolean
 isBool :: Property -> LintWriter a
 isBool = flip unwrapBool (const $ pure ())
-
--- | require some property
-requireProperty :: [Property] -> Text -> LintWriter a
-requireProperty props name = unless (containsProperty props name)
-  $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint name
-
--- | suggest soem value for another property if that property does not
--- also already exist
-suggestPropertyValue :: [Property] -> Property -> LintWriter a
-suggestPropertyValue props (Property name value) = unless (containsProperty props name)
-  $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value