From 42df3cf0eb0c5877ac3320994cadec07619bcd6b Mon Sep 17 00:00:00 2001 From: stuebinm Date: Mon, 20 Sep 2021 22:30:22 +0200 Subject: 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. --- lib/Properties.hs | 120 ++++++++++++++++++++++++++++++------------------------ 1 file changed, 67 insertions(+), 53 deletions(-) (limited to 'lib/Properties.hs') 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 -- cgit v1.2.3