From 968038c403e71b98a8f55a4d79e64beca8349ab3 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Mon, 20 Sep 2021 01:26:27 +0200 Subject: lint general map properties --- lib/CheckMap.hs | 19 ++++--- lib/LintWriter.hs | 13 ++++- lib/Properties.hs | 157 ++++++++++++++++++++++++++++++++---------------------- lib/Tiled2.hs | 4 +- 4 files changed, 121 insertions(+), 72 deletions(-) diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 9908fdd..08932b4 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -17,10 +17,12 @@ import qualified Data.Vector as V import GHC.Generics (Generic) import LintWriter (LintResult (..), LintWriter, - lintsToDeps) -import Properties (checkProperty) + lintsToDeps, resultToLints, + runLintWriter) +import Properties (checkLayerProperty, + checkMapProperty) import Tiled2 (Layer (layerName, layerProperties), - Tiledmap (tiledmapLayers), + Tiledmap (tiledmapLayers, tiledmapProperties), loadTiledmap) import Types (Dep, Level (..), Lint (..), hint, lintLevel) @@ -55,7 +57,7 @@ loadAndLintMap path = loadTiledmap path >>= pure . \case runLinter :: Tiledmap -> MapResult () runLinter tiledmap = MapResult { mapresultLayer = Just layerMap - , mapresultGeneral = [] -- no general lints for now + , mapresultGeneral = propertyLints -- no general lints for now , mapresultDepends = concatMap (lintsToDeps . snd) layer } where @@ -64,10 +66,15 @@ runLinter tiledmap = MapResult layer = V.toList . V.map runCheck $ tiledmapLayers tiledmap where runCheck l = (layerName l, LintResult $ runWriterT (checkLayer l)) + -- lints collected from properties + propertyLints = runLintWriter + $ mapM_ (checkMapProperty tiledmap) (tiledmapProperties tiledmap) + + -- | collect lints on a single map layer checkLayer :: Layer -> LintWriter () checkLayer layer = - mapM_ (checkProperty layer) (layerProperties layer) + mapM_ (checkLayerProperty layer) (layerProperties layer) -- human-readable lint output, e.g. for consoles instance PrettyPrint a => PrettyPrint (MapResult a) where @@ -79,7 +86,7 @@ instance PrettyPrint a => PrettyPrint (MapResult a) where (uncurry showResult) (maybe [] toList . mapresultLayer $ mapResult) prettyGeneral :: [Text] - prettyGeneral = prettyprint <$> mapresultGeneral mapResult + prettyGeneral = flip (<>) "\n" . prettyprint <$> mapresultGeneral mapResult -- TODO: possibly expand this to something more detailed? diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index 055e2d4..02815e3 100644 --- a/lib/LintWriter.hs +++ b/lib/LintWriter.hs @@ -9,7 +9,8 @@ module LintWriter where import Control.Monad.Trans.Maybe () import Control.Monad.Writer (MonadTrans (lift), - MonadWriter (tell), WriterT) + MonadWriter (tell), WriterT, + runWriterT) import Data.Aeson (ToJSON (toJSON)) import Data.Text (Text) @@ -45,6 +46,16 @@ lintsToDeps (LintResult a) = case a of Left _ -> [] Right (_, lints) -> mapMaybe lintToDep lints +-- | convert a lint result into a flat list of lints +-- (throwing away information on if a single error was fatal) +resultToLints :: LintResult a -> [Lint] +resultToLints (LintResult res) = case res of + Left l -> [l] + Right (_, lints) -> lints + +-- | Confusingly, this returns lints, not a … +runLintWriter :: LintWriter a -> [Lint] +runLintWriter = resultToLints . LintResult . runWriterT -- | write a hint into the LintWriter monad lint :: Level -> Text -> LintWriter () diff --git a/lib/Properties.hs b/lib/Properties.hs index 405e984..0805a4d 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -3,13 +3,13 @@ {-# LANGUAGE OverloadedStrings #-} -- | Contains checks for custom properties of the map json -module Properties (checkProperty) where +module Properties (checkLayerProperty, checkMapProperty) where import Control.Monad (unless, when) import Data.Text (Text, isPrefixOf) import Tiled2 (Layer (layerProperties), Property (..), - PropertyValue (..)) + PropertyValue (..), Tiledmap) import Util (layerIsEmpty, prettyprint) import LintWriter (LintWriter, complain, dependsOn, forbid, info, @@ -29,97 +29,80 @@ import Types (Dep (Link, Local, LocalMap, MapLink)) -- -- I've attempted to build the LintWriter monad in a way -- that should make this readable even to non-Haskellers -checkProperty :: Layer -> Property -> LintWriter () -checkProperty layer (Property name value) = case name of +checkLayerProperty :: Layer -> Property -> LintWriter () +checkLayerProperty layer p@(Property name value) = case name of "jitsiRoom" -> do uselessEmptyLayer - unwrapString $ \val -> do + unwrapString p $ \val -> do info $ "found jitsi room: " <> prettyprint val - suggestPropertyValue "jitsiTrigger" "onaction" + suggestProp $ Property "jitsiTrigger" (StrProp "onaction") "jitsiTrigger" -> do - isString - unless (hasProperty "jitsiTriggerMessage" layer) + isString p + unless (hasProperty "jitsiTriggerMessage") $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter in jitsi meet room\"" - requireProperty "jitsiRoom" + requireProp "jitsiRoom" "jitsiTriggerMessage" -> do - isString - requireProperty "jitsiTrigger" + isString p + requireProp "jitsiTrigger" "jitsiUrl" -> isForbidden "jitsiConfig" -> isForbidden "jitsiClientConfig" -> isForbidden "jitsiRoomAdminTag" -> isForbidden "playAudio" -> do uselessEmptyLayer - unwrapLink $ \link -> dependsOn $ if "https://" `isPrefixOf` link + unwrapLink p $ \link -> dependsOn $ if "https://" `isPrefixOf` link then Link link else Local link "audioLoop" -> do - isBool - requireProperty "playAudio" + isBool p + requireProp "playAudio" "audioVolume" -> do - isBool - requireProperty "playAudio" + isBool p + requireProp "playAudio" "openWebsite" -> do uselessEmptyLayer - suggestPropertyValue "openWebsiteTrigger" "onaction" - unwrapLink $ \link -> dependsOn $ if "https://" `isPrefixOf` link + suggestProp $ Property "openWebsiteTrigger" (StrProp "onaction") + unwrapLink p $ \link -> dependsOn $ if "https://" `isPrefixOf` link then Link link else Local link "openWebsiteTrigger" -> do - isString - unless (hasProperty "openWebsiteTriggerMessage" layer) + isString p + unless (hasProperty "openWebsiteTriggerMessage") $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to overwrite the generic \"press SPACE to open Website\"" - requireProperty "openWebsite" + requireProp "openWebsite" "openWebsiteTriggerMessage" -> do - isString - requireProperty "openWebsiteTrigger" + isString p + requireProp "openWebsiteTrigger" "openWebsitePolicy" -> do - isString - requireProperty "openWebsite" + isString p + requireProp "openWebsite" "openTab" -> do - isString - requireProperty "openWebsite" + isString p + requireProp "openWebsite" "url" -> isForbidden "allowApi" -> isForbidden "exitUrl" -> do forbidEmptyLayer - unwrapLink $ \link -> dependsOn $ if "https://" `isPrefixOf` link + unwrapLink p $ \link -> dependsOn $ if "https://" `isPrefixOf` link then MapLink link else LocalMap link "startLayer" -> do forbidEmptyLayer - unwrapBool $ \case + unwrapBool p $ \case True -> pure () False -> complain "startLayer must be set to true" "silent" -> do - isBool + isBool p uselessEmptyLayer _ -> complain $ "unknown property type " <> prettyprint name where + properties = layerProperties layer + hasProperty = containsProperty properties + isForbidden = forbidProperty name + requireProp = requireProperty properties + suggestProp = suggestPropertyValue properties - -- | asserts that this property is a string, and unwraps it - unwrapString f = case value of - StrProp str -> f str - _ -> complain $ "type mismatch in property " <> name <> "; should be of type string" - -- | same as unwrapString, but also forbids http:// as prefix - unwrapLink f = case value of - StrProp str -> if "http://" `isPrefixOf` str - then complain "cannot access content via http; either use https or include it locally instead." - else f str - _ -> complain $ "type mismatch in property " <> name <> "; should be of typ string" - -- | asserts that this property is a boolean, and unwraps it - unwrapBool f = case value of - BoolProp b -> f b - _ -> complain $ "type mismatch in property " <> name <> "; should be of type bool" - -- | just asserts that this is a string - isString = unwrapString (const $ pure ()) - -- | just asserts that this is a boolean - isBool = unwrapBool (const $ pure ()) - - - -- | this property is forbidden and should not be used - isForbidden = forbid $ "property " <> prettyprint name <> " should not be used" -- | 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") @@ -127,19 +110,67 @@ checkProperty layer (Property name value) = case name of uselessEmptyLayer = when (layerIsEmpty layer) $ warn ("property" <> name <> " was set on an empty layer and is thereby useless") - -- | require some property in this layer - requireProperty name = unless (hasProperty name layer) - $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint name - -- | suggest a certain value for some other property in this layer - suggestPropertyValue :: Text -> Text -> LintWriter () - suggestPropertyValue name value = unless (hasProperty name layer) - $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value +-- | Checks a single property of a map. +-- +-- 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 + "script" -> isForbidden + _ -> complain $ "unknown map property " <> name + where + -- | this property is forbidden and should not be used + isForbidden = forbid $ "property " <> prettyprint name <> " should not be used" + -- | does this layer have the given property? -hasProperty :: Text -> Layer -> Bool -hasProperty name = any - (\(Property name' _) -> name' == name) - . layerProperties +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 () +forbidProperty name = forbid $ "property " <> prettyprint name <> " should not be used" + + +-- | asserts that this property is a string, and unwraps it +unwrapString :: Property -> (Text -> LintWriter ()) -> LintWriter () +unwrapString (Property name value) f = case value of + StrProp str -> f str + _ -> complain $ "type mismatch in property " <> name <> "; should be of type string" + +-- | same as unwrapString, but also forbids http:// as prefix +unwrapLink :: Property -> (Text -> LintWriter ()) -> LintWriter () +unwrapLink (Property name value) f = case value of + StrProp str -> if "http://" `isPrefixOf` str + then complain "cannot access content via http; either use https or include it locally instead." + else f str + _ -> complain $ "type mismatch in property " <> name <> "; should be of typ string" + +-- | asserts that this property is a boolean, and unwraps it +unwrapBool :: Property -> (Bool -> LintWriter ()) -> LintWriter () +unwrapBool (Property name value) f = case value of + BoolProp b -> f b + _ -> complain $ "type mismatch in property " <> name <> "; should be of type bool" + +-- | just asserts that this is a string +isString :: Property -> LintWriter () +isString = flip unwrapString (const $ pure ()) + +-- | just asserts that this is a boolean +isBool :: Property -> LintWriter () +isBool = flip unwrapBool (const $ pure ()) + +-- | require some property +requireProperty :: [Property] -> Text -> LintWriter () +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 () +suggestPropertyValue props (Property name value) = unless (containsProperty props name) + $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs index 8220bfb..79033f0 100644 --- a/lib/Tiled2.hs +++ b/lib/Tiled2.hs @@ -398,7 +398,7 @@ data Tiledmap = Tiledmap { tiledmapVersion :: Float -- ^ Hex-formatted color (#RRGGBB or #AARRGGBB) (optional) , tiledmapRenderorder :: String -- ^ Rendering direction (orthogonal maps only) - , tiledmapProperties :: Map Text Text + , tiledmapProperties :: [Property] -- ^ String key-value pairs , tiledmapNextobjectid :: Int -- ^ Auto-increments for each placed object @@ -416,7 +416,7 @@ instance FromJSON Tiledmap where <*> o .: "tilesets" <*> (o .: "backgroundcolor" <|> pure Nothing) <*> o .: "renderorder" - <*> (o .: "properties" <|> pure mempty) + <*> (o .:? "properties" <&> fromMaybe []) <*> o .: "nextobjectid" parseJSON invalid = typeMismatch "Tiledmap" invalid -- cgit v1.2.3