diff options
| -rw-r--r-- | lib/Properties.hs | 73 |
1 files changed, 56 insertions, 17 deletions
diff --git a/lib/Properties.hs b/lib/Properties.hs index be6637b..2928152 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -13,7 +13,7 @@ import Tiled2 (HasProperties (adjustProperties, getProperties), IsProperty (asProperty), Layer (..), Property (..), PropertyValue (..), Tiledmap (..), Tileset (..)) -import Util (layerIsEmpty, prettyprint) +import Util (layerIsEmpty, prettyprint, showText) import Data.Maybe (fromMaybe, isJust) import LintConfig (LintConfig (..)) @@ -115,13 +115,15 @@ checkLayer = do layer <- askContext when (isJust (layerImage layer)) $ complain "imagelayer are not supported." - unless (layerType layer == "tilelayer") - $ complain "only tilelayer are supported." - mapM_ checkLayerProperty (getProperties layer) + + case layerType layer of + "tilelayer" -> mapM_ checkLayerProperty (getProperties layer) + ty -> unless (layerName layer == "floorLayer" && ty == "objectgroup") + $ complain "only tilelayer are supported." case layerLayers layer of Nothing -> pure () - Just layers -> error "walint doesn't support grouplayers for now" + Just _ -> complain "walint doesn't support grouplayers for now" @@ -135,8 +137,8 @@ checkLayerProperty p@(Property name _value) = case name of lintConfig configAssemblyTag >>= setProperty "jitsiRoomAdminTag" uselessEmptyLayer - unwrapString p $ \_val -> do - suggestProperty $ Property "jitsiTrigger" (StrProp "onaction") + unwrapString' p + $ suggestProperty $ Property "jitsiTrigger" (StrProp "onaction") "jitsiTrigger" -> do isString p unlessHasProperty "jitsiTriggerMessage" @@ -149,6 +151,9 @@ checkLayerProperty p@(Property name _value) = case name of "jitsiConfig" -> isForbidden "jitsiClientConfig" -> isForbidden "jitsiRoomAdminTag" -> isForbidden + "jitsiInterfaceConfig" -> isForbidden + "jitsiWidth" -> + isIntInRange 0 100 p "playAudio" -> do uselessEmptyLayer unwrapLink p $ \link -> if "https://" `isPrefixOf` link @@ -158,7 +163,7 @@ checkLayerProperty p@(Property name _value) = case name of isBool p requireProperty "playAudio" "playAudioLoop" -> - warn "'playAudioLoop' is deprecated; please use 'audioLoop' instead." + deprecatedUseInstead "audioLoop" "audioVolume" -> do isBool p requireProperty "playAudio" @@ -182,6 +187,7 @@ checkLayerProperty p@(Property name _value) = case name of "openWebsitePolicy" -> do isString p requireProperty "openWebsite" + "openWebsiteAllowApi" -> isForbidden "openTab" -> do isString p requireProperty "openWebsite" @@ -194,6 +200,10 @@ checkLayerProperty p@(Property name _value) = case name of complain "absolute map links (i.e. links starting with '/_/') are disallowed." | "/@/" `isPrefixOf` link -> dependsOn $ MapLink link -- TODO | otherwise -> unwrapPath link (dependsOn . LocalMap) + "exitSceneUrl" -> + deprecatedUseInstead "exitUrl" + "exitInstance" -> + deprecatedUseInstead "exitUrl" "startLayer" -> do forbidEmptyLayer layer <- askContext @@ -204,20 +214,30 @@ checkLayerProperty p@(Property name _value) = case name of "silent" -> do isBool p uselessEmptyLayer - "collides" -> isUnsupported - "default" -> isUnsupported - "exitSceneUrl" -> isUnsupported - "jitsiWidth" -> isUnsupported + "collides" -> + unwrapBool p $ \case + True -> pure () + False -> warn "property \"collides\" set to 'false' is useless." "name" -> isUnsupported - "readableBy" -> isUnsupported - "writableBy" -> isUnsupported - "zone" -> isUnsupported - _ -> - complain $ "unknown property type " <> prettyprint name + -- all properties relating to scripting are handled the same + _ | name `elem` [ "default" + , "readableBy" + , "writableBy" + , "persist" + , "jsonSchema" + , "zone" ] -> + do + forbid "the workadventure scripting API and variables are not (?) supported." + removeProperty name + | otherwise -> + complain $ "unknown property type " <> prettyprint name where isForbidden = forbidProperty name requireProperty req = propertyRequiredBy req name isUnsupported = warn $ "property " <> name <> " is not (yet) supported by walint." + 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 forbidEmptyLayer = do @@ -276,6 +296,12 @@ setProperty name value = adjust $ \ctxt -> $ \ps -> Just $ Property name (asProperty value) : filter sameName ps where sameName (Property name' _) = name /= name' +removeProperty :: HasProperties ctxt => Text -> LintWriter ctxt +removeProperty name = adjust $ \ctxt -> + flip adjustProperties ctxt + $ \ps -> Just $ filter (\(Property name' _) -> name' /= name) ps + + -- | does this layer have the given property? containsProperty :: Foldable t => t Property -> Text -> Bool containsProperty props name = any @@ -288,6 +314,9 @@ unwrapString (Property name value) f = case value of StrProp str -> f str _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string" +unwrapString' :: Property -> LintWriter a -> LintWriter a +unwrapString' prop f = unwrapString prop (const f) + -- | same as unwrapString, but also forbids http:// as prefix unwrapLink :: Property -> (Text -> LintWriter a) -> LintWriter a unwrapLink (Property name value) f = case value of @@ -302,6 +331,11 @@ unwrapBool (Property name value) f = case value of BoolProp b -> f b _ -> 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" + unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a unwrapPath str f = case parsePath str of Just p@(Path up _ _) -> do @@ -318,3 +352,8 @@ 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 |