assorted lints for properties found in some maps

(mostly to do with the scripting API, but also some old ones which are
already deprecated / not even mentioned in the documentation anymore)

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