diff options
Diffstat (limited to 'lib/Properties.hs')
| -rw-r--r-- | lib/Properties.hs | 209 |
1 files changed, 117 insertions, 92 deletions
diff --git a/lib/Properties.hs b/lib/Properties.hs index d65c9da..a9bf113 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -13,11 +13,10 @@ module Properties (checkMap, checkTileset, checkLayer) where import Control.Monad (forM_, unless, when) import Data.Text (Text, isPrefixOf) import qualified Data.Vector as V -import Tiled2 (HasName (getName), - HasProperties (adjustProperties, getProperties), - HasTypeName (typeName), IsProperty (asProperty), - Layer (..), Object (..), Property (..), +import Tiled (Layer (..), Object (..), Property (..), PropertyValue (..), Tiledmap (..), Tileset (..)) +import TiledAbstract (HasName (..), HasProperties (..), + HasTypeName (..), IsProperty (..)) import Util (layerIsEmpty, mkProxy, naiveEscapeHTML, prettyprint, showText) @@ -39,67 +38,59 @@ import Uris (SubstError (..), applySubst) -- | Checks an entire map for "general" lints. -- --- 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. +-- Note that it does /not/ check any tile layer/tileset properties; +-- these are handled seperately in CheckMap, since these lints go +-- into a different field of the output. checkMap :: LintWriter Tiledmap checkMap = do tiledmap <- askContext + let unlessLayer = unlessElement (tiledmapLayers tiledmap) - -- test other things - mapM_ checkMapProperty (fromMaybe [] $ tiledmapProperties tiledmap) - - -- some layers should exist - hasLayerNamed "start" (const True) - "The map must have one layer named \"start\"." - hasLayerNamed "floorLayer" ((==) "objectgroup" . layerType) - "The map must have one layer named \"floorLayer\" of type \"objectgroup\"." - hasLayer (flip containsProperty "exitUrl" . getProperties) - "The map must contain at least one layer with the property \"exitUrl\" set." + -- test custom map properties + mapM_ checkMapProperty (fromMaybe mempty $ tiledmapProperties tiledmap) + -- can't have these with the rest of layer/tileset lints since they're + -- not specific to any one of them refuseDoubledNames (tiledmapLayers tiledmap) refuseDoubledNames (tiledmapTilesets tiledmap) + -- some layers should exist + unlessElementNamed (tiledmapLayers tiledmap) "start" + $ complain "The map must have one layer named \"start\"." + unlessLayer (\l -> getName l == "floorLayer" && layerType l == "objectgroup") + $ complain "The map must have one layer named \"floorLayer\" of type \"objectgroup\"." + unlessLayer (flip containsProperty "exitUrl" . getProperties) + $ complain "The map must contain at least one layer with the property \"exitUrl\" set." + -- reject maps not suitable for workadventure unless (tiledmapOrientation tiledmap == "orthogonal") $ complain "The map's orientation must be set to \"orthogonal\"." unless (tiledmapTileheight tiledmap == 32 && tiledmapTilewidth tiledmap == 32) $ complain "The map's tile size must be 32 by 32 pixels." - where - hasLayerNamed name p = hasLayer (\l -> layerName l == name && p l) - hasLayer p err = do - tiledmap <- askContext - unless (any p (tiledmapLayers tiledmap)) - $ complain err - -- | 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 :: Property -> LintWriter Tiledmap -checkMapProperty p@(Property name _value) = case name of +checkMapProperty p@(Property name _) = case name of "script" -> do -- this is kind of stupid, since if we also inject script this -- will be overriden anyways, but it also doesn't really hurt I guess -- TODO: perhaps include an explanation in the lint, or allow -- exactly that one value? lintConfig configAllowScripts >>= \case - False -> isForbidden + False -> forbid "cannot use property \"script\"; custom scripts are disallowed" True -> pure () lintConfig configScriptInject >>= \case Nothing -> pure () Just url -> setProperty "script" url "mapName" -> naiveEscapeProperty p - "mapLink" -> pure () - "mapImage" -> pure () "mapDescription" -> naiveEscapeProperty p "mapCopyright" -> naiveEscapeProperty p - + "mapLink" -> pure () + "mapImage" -> pure () _ -> complain $ "unknown map property " <> prettyprint name - where - -- | this property is forbidden and should not be used - isForbidden = forbid $ "property " <> prettyprint name <> " should not be used" -- | check an embedded tile set. @@ -126,24 +117,25 @@ checkTileset = do unlessHasProperty "copyright" $ forbid "property \"copyright\" is required for tilesets." - + -- check individual tileset properties mapM_ checkTilesetProperty (fromMaybe [] $ tilesetProperties tileset) - -checkTilesetProperty :: Property -> LintWriter Tileset -checkTilesetProperty p@(Property name _value) = case name of - "copyright" -> naiveEscapeProperty p - _ -> pure () -- are there any other properties? + where + checkTilesetProperty :: Property -> LintWriter Tileset + checkTilesetProperty p@(Property name _value) = case name of + "copyright" -> naiveEscapeProperty p + _ -> warn $ "unknown tileset property " <> prettyprint name -- | collect lints on a single map layer checkLayer :: LintWriter Layer checkLayer = do layer <- askContext - when (isJust (layerImage layer)) - $ complain "imagelayer are not supported." refuseDoubledNames (getProperties layer) + when (isJust (layerImage layer)) + $ complain "imagelayer are not supported." + case layerType layer of "tilelayer" -> mapM_ checkTileLayerProperty (getProperties layer) "group" -> pure () @@ -154,18 +146,24 @@ checkLayer = do adjust $ \l -> l { layerObjects = Nothing, layerProperties = Nothing } unless (layerName layer == "floorLayer") $ do + + -- TODO: these two checks can probably be unified unlessHasProperty "getBadge" - $ warn "objectgrouop layer (which aren't the floor layer) are useless if not used to define badges." - when (null (layerObjects layer) || layerObjects layer == Just (V.fromList [])) - $ warn "empty objectgroup layers (which aren't the floor layer) are useless." + $ warn "objectgrouop layer (which aren't the floor layer)\ + \are useless if not used to define badges." + + when (null (layerObjects layer) || layerObjects layer == Just mempty) + $ warn "empty objectgroup layers (which aren't the floor\ + \layer) are useless." -- individual objects can't have properties - forM_ (fromMaybe (V.fromList []) $ layerObjects layer) $ \object -> + forM_ (fromMaybe mempty (layerObjects layer)) $ \object -> unless (null (objectProperties object)) - $ warn "Properties cannot be set on individual objects. For setting badge tokens, use per-layer properties instead." - mapM_ checkObjectGroupProperty (getProperties layer) - ty -> --unless (layerName layer == "floorLayer" && ty == "objectgroup") - complain $ "unsupported layer type " <> prettyprint ty <> "." + $ warn "Properties cannot be set on individual objects. For setting\ + \badge tokens, use per-layer properties instead." + + forM_ (getProperties layer) checkObjectGroupProperty + ty -> complain $ "unsupported layer type " <> prettyprint ty <> "." if layerType layer == "group" then when (null (layerLayers layer)) @@ -177,7 +175,7 @@ checkLayer = do -- | Checks a single (custom) property of an objectgroup layer checkObjectGroupProperty :: Property -> LintWriter Layer checkObjectGroupProperty p@(Property name _) = case name of - "getBadge" -> -- TODO check if all objects of this layer are allowed, then collect them + "getBadge" -> unwrapString p $ \str -> unwrapBadgeToken str $ \token -> do layer <- askContext @@ -195,10 +193,8 @@ checkObjectGroupProperty p@(Property name _) = case name of ObjectPolyline {} -> complain "cannot use polylines for badges." _ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers" + -- | Checks a single (custom) property of a "normal" tile layer --- --- It gets a reference to its own layer since sometimes the presence --- of one property implies the presence or absense of another. checkTileLayerProperty :: Property -> LintWriter Layer checkTileLayerProperty p@(Property name _value) = case name of "jitsiRoom" -> do @@ -216,7 +212,8 @@ checkTileLayerProperty p@(Property name _value) = case name of "jitsiTrigger" -> do isString p unlessHasProperty "jitsiTriggerMessage" - $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter in jitsi meet room\"." + $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite\ + \the default \"press SPACE to enter in jitsi meet room\"." requireProperty "jitsiRoom" "jitsiTriggerMessage" -> do isString p @@ -245,9 +242,10 @@ checkTileLayerProperty p@(Property name _value) = case name of unwrapString p (setProperty "openWebsiteTrigger") unlessHasProperty "bbbTriggerMessage" $ do - suggest "set \"bbbTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter the bbb room\"" setProperty "openWebsiteTriggerMessage" ("press SPACE to enter bbb room" :: Text) + suggest "set \"bbbTriggerMessage\" to a custom message to overwrite the\ + \default \"press SPACE to enter the bbb room\"" "bbbTriggerMessage" -> do removeProperty "bbbTriggerMessage" requireProperty "bbbRoom" @@ -274,9 +272,10 @@ checkTileLayerProperty p@(Property name _value) = case name of (dependsOn . Local) "openWebsiteTrigger" -> do isString p - unlessHasProperty "openWebsiteTriggerMessage" - $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to overwrite the default \"press SPACE to open Website\"." requireProperty "openWebsite" + unlessHasProperty "openWebsiteTriggerMessage" + $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to\ + \overwrite the default \"press SPACE to open Website\"." "openWebsiteTriggerMessage" -> do isString p requireProperty "openWebsiteTrigger" @@ -320,12 +319,13 @@ checkTileLayerProperty p@(Property name _value) = case name of deprecatedUseInstead instead = warn $ "property \"" <> name <> "\" is deprecated. Use \"" <> instead <> "\" instead." - - -- | this property can only be used on a layer that contains at least one tiles + -- | this property can only be used on a layer that contains + -- | at least one tile forbidEmptyLayer = do layer <- askContext when (layerIsEmpty layer) $ complain ("property " <> prettyprint name <> " should not be set on an empty layer.") + -- | this layer is allowed, but also useless on a layer that contains no tiles uselessEmptyLayer = do layer <- askContext @@ -349,24 +349,45 @@ refuseDoubledNames things = foldr folding base things mempty where name = getName thing base _ = pure () ---------- Helper functions & stuff --------- + +---- General functions ---- + +unlessElement + :: Foldable f + => f a + -> (a -> Bool) + -> LintWriter b + -> LintWriter b +unlessElement things op = unless (any op things) + +unlessElementNamed :: (HasName a, Foldable f) + => f a -> Text -> LintWriter b -> LintWriter b +unlessElementNamed things name = + unlessElement things ((==) name . getName) unlessHasProperty :: HasProperties a => Text -> LintWriter a -> LintWriter a -unlessHasProperty name andthen = do - layer <- askContext - let hasprop = any (\(Property name' _) -> name == name') (getProperties layer) - unless hasprop andthen +unlessHasProperty name linter = + askContext >>= \ctxt -> + unlessElementNamed (getProperties ctxt) name linter + +-- | does this layer have the given property? +containsProperty :: Foldable t => t Property -> Text -> Bool +containsProperty props name = any + (\(Property name' _) -> name' == name) props + +----- Functions with concrete lint messages ----- -- | this property is forbidden and should not be used forbidProperty :: Text -> LintWriter Layer forbidProperty name = do - forbid $ "property " <> prettyprint name <> " should not be used." + forbid $ "property " <> prettyprint name <> " is disallowed." propertyRequiredBy :: HasProperties a => Text -> Text -> LintWriter a propertyRequiredBy req by = unlessHasProperty req - $ complain $ "property "<>prettyprint req<>" is required by property "<> prettyprint by<>"." + $ complain $ "property " <> prettyprint req <> + " is required by property " <> prettyprint by <> "." -- | suggest some value for another property if that property does not -- also already exist @@ -375,6 +396,11 @@ suggestProperty (Property name value) = unlessHasProperty name $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value<>"." + + +---- Functions for adjusting the context ----- + + -- | set a property, overwriting whatever value it had previously setProperty :: (IsProperty prop, HasProperties ctxt) => Text -> prop -> LintWriter ctxt @@ -388,37 +414,41 @@ removeProperty name = adjust $ \ctxt -> flip adjustProperties ctxt $ \ps -> Just $ filter (\(Property name' _) -> name' /= name) ps +naiveEscapeProperty :: HasProperties a => Property -> LintWriter a +naiveEscapeProperty prop@(Property name _) = + unwrapString prop (setProperty name . naiveEscapeHTML) --- | does this layer have the given property? -containsProperty :: Foldable t => t Property -> Text -> Bool -containsProperty props name = any - (\(Property name' _) -> name' == name) props - +---- "unwrappers" checking that a property has some type, then do something ---- -- | asserts that this property is a string, and unwraps it unwrapString :: Property -> (Text -> LintWriter a) -> LintWriter a unwrapString (Property name value) f = case value of StrProp str -> f str - _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string." + _ -> complain $ "type error: property " + <> prettyprint name <> " should be of type string." -- | same as unwrapString, but also forbids http:// as prefix unwrapLink :: Property -> (Text -> LintWriter a) -> LintWriter a 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." + then complain "cannot access content via http; either use https or include\ + \it locally in your repository instead." else f str - _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string and contain a valid uri." + _ -> complain $ "type error: property " <> prettyprint name <> " should be\ + \of type string and contain a valid uri." -- | asserts that this property is a boolean, and unwraps it unwrapBool :: Property -> (Bool -> LintWriter a) -> LintWriter a unwrapBool (Property name value) f = case value of BoolProp b -> f b - _ -> complain $ "type error: property " <> prettyprint name <> " should be of type bool." + _ -> complain $ "type error: property " <> prettyprint name + <> " should be of type bool." unwrapInt :: Property -> (Int -> LintWriter a) -> LintWriter a unwrapInt (Property name value) f = case value of IntProp float -> f float - _ -> complain $ "type error: property " <> prettyprint name <> " should be of type int." + _ -> complain $ "type error: property " <> prettyprint name + <> " should be of type int." unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a unwrapPath str f = case parsePath str of @@ -437,20 +467,6 @@ unwrapBadgeToken str f = case parseToken str of Just a -> f a Nothing -> complain "invalid badge token." --- | just asserts that this is a string -isString :: Property -> LintWriter a -isString = flip unwrapString (const $ pure ()) - --- | just asserts that this is a boolean -isBool :: Property -> LintWriter a -isBool = flip unwrapBool (const $ pure ()) - -isIntInRange :: Int -> Int -> Property -> LintWriter a -isIntInRange l r p@(Property name _) = unwrapInt p $ \int -> - if l < int && int < r then pure () - else complain $ "Property " <> prettyprint name <> " should be between" <> showText l <> " and " <> showText r<>"." - - unwrapURI :: (KnownSymbol s, HasProperties a) => Proxy s -> Property -> (Text -> LintWriter a) -> (RelPath -> LintWriter a) -> LintWriter a unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do @@ -468,6 +484,15 @@ unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do WrongScope schema -> "the URI schema " <> schema <> ":// cannot be used on \""<>name<>"\"." -naiveEscapeProperty :: HasProperties a => Property -> LintWriter a -naiveEscapeProperty prop@(Property name _) = - unwrapString prop (setProperty name . naiveEscapeHTML) +-- | just asserts that this is a string +isString :: Property -> LintWriter a +isString = flip unwrapString (const $ pure ()) + +-- | just asserts that this is a boolean +isBool :: Property -> LintWriter a +isBool = flip unwrapBool (const $ pure ()) + +isIntInRange :: Int -> Int -> Property -> LintWriter a +isIntInRange l r p@(Property name _) = unwrapInt p $ \int -> + if l < int && int < r then pure () + else complain $ "Property " <> prettyprint name <> " should be between" <> showText l <> " and " <> showText r<>"." |