summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Properties.hs73
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-24 18:14:05 +0000