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.

1 files changed, 67 insertions, 53 deletions

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