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/Properties.hs | 157 ++++++++++++++++++++++++++++++++---------------------- 1 file changed, 94 insertions(+), 63 deletions(-) (limited to 'lib/Properties.hs') 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 -- cgit v1.2.3