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/CheckMap.hs | 17 ++++---- lib/LintWriter.hs | 28 +++++++++---- lib/Paths.hs | 31 ++++++++++++++ lib/Properties.hs | 120 ++++++++++++++++++++++++++++++------------------------ 4 files changed, 127 insertions(+), 69 deletions(-) create mode 100644 lib/Paths.hs 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 -- cgit v1.2.3