From 42df3cf0eb0c5877ac3320994cadec07619bcd6b Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Mon, 20 Sep 2021 22:30:22 +0200
Subject: [PATCH] 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
--
GitLab