From 8082e9ef10a08c362adba26aff4f2e5140f6f7f0 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sat, 18 Dec 2021 17:19:48 +0100
Subject: badges are set on objects, not layers

(and `url` is, too)
---
 lib/Properties.hs    | 85 +++++++++++++++++++++++++++-------------------------
 lib/TiledAbstract.hs |  6 +++-
 2 files changed, 49 insertions(+), 42 deletions(-)

(limited to 'lib')

diff --git a/lib/Properties.hs b/lib/Properties.hs
index 0593658..db1ca41 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -68,7 +68,7 @@ checkMap = do
     $ 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)
+  unlessLayer (`containsProperty` "exitUrl")
     $ complain "The map must contain at least one layer with the property \"exitUrl\" set."
 
   -- reject maps not suitable for workadventure
@@ -195,31 +195,26 @@ checkLayer = do
     "group" -> pure ()
     "objectgroup" -> do
 
-      -- all objects which can't define badges, i.e. only texts
+      -- all objects which don't define badges
       publicObjects <- askContext <&>
-        fmap (V.filter (\case {ObjectText {} -> True; _ -> False})) . layerObjects
+        fmap (V.filter (`containsProperty` "getBadge")) . layerObjects
 
-      -- filter everything out that might define badges, but keep text
-      -- objects, which workadventure apparently supports but doesn't
-      -- really tell anyone about.
+      -- remove badges from output
       adjust $ \l -> l { layerObjects = publicObjects
                        , layerProperties = Nothing }
 
-      unless (layerName layer == "floorLayer") $
-        unlessHasProperty "getBadge" $
-          when (null publicObjects || publicObjects == Just mempty) $
-            warn "objectgroup layer (which aren't the floor layer) \
-                 \are useless if they do not contain the \"getBadge\" \
-                 \property and define at least one area for this badge, \
-                 \or do not contain at least one text element."
-
-      -- individual objects can't have properties
-      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."
+      -- check object properties
+      forM_ (fromMaybe mempty (layerObjects layer)) $ \object -> do
+        mapM_ (checkObjectProperty object) (getProperties object)
 
+      -- check layer properties
       forM_ (getProperties layer) checkObjectGroupProperty
+
+      unless (layerName layer == "floorLayer") $
+        when (null publicObjects || publicObjects == Just mempty) $
+          warn "objectgroup layer (which aren't the floorLayer) \
+               \are useless if they are empty."
+
     ty -> complain $ "unsupported layer type " <> prettyprint ty <> "."
 
   if layerType layer == "group"
@@ -228,27 +223,34 @@ checkLayer = do
     else when (isJust (layerLayers layer))
     $ complain "Layer is not of type \"group\", but has sublayers."
 
+checkObjectProperty :: Object -> Property -> LintWriter Layer
+checkObjectProperty obj p@(Property name _) = case name of
+  "url" -> pure ()
+  "allowApi" -> forbidProperty name
+  "getBadge" -> do
+    when (1 /= length (getProperties obj))
+      $ warn "Objects with the property \"getBadge\" set are removed at runtime, \
+             \and any other properties set on them will be gone."
+    unwrapString p $ \str ->
+      unwrapBadgeToken str $ \token -> do
+        case obj of
+          ObjectPoint {..} ->
+            offersBadge (Badge token (BadgePoint objectX objectY))
+          ObjectRectangle {..} ->
+            if isJust objectEllipse
+            then offersBadge
+              $ Badge token (BadgeRect objectX objectY objectWidth objectHeight)
+            else complain "ellipses are not supported."
+          ObjectPolygon {} -> complain "polygons are not supported."
+          ObjectPolyline {} -> complain "polylines are not supported."
+          ObjectText {} -> complain "cannot use texts to define badge areas."
+  _ -> warn $ "unknown object property " <> prettyprint name <> "."
+
 
 -- | Checks a single (custom) property of an objectgroup layer
 checkObjectGroupProperty :: Property -> LintWriter Layer
-checkObjectGroupProperty p@(Property name _) = case name of
-  "getBadge" ->
-    unwrapString p $ \str ->
-      unwrapBadgeToken str $ \token -> do
-        layer <- askContext
-        forM_ (fromMaybe (V.fromList []) $ layerObjects layer) $ \object -> do
-          case object of
-            ObjectPoint {..} ->
-              offersBadge (Badge token (BadgePoint objectX objectY))
-            ObjectRectangle {..} ->
-              if isJust objectEllipse
-              then offersBadge
-                $ Badge token (BadgeRect objectX objectY objectWidth objectHeight)
-              else complain "ellipses are not supported."
-            ObjectPolygon {} -> complain "polygons are not supported."
-            ObjectPolyline {} -> complain "polylines are not supported."
-            ObjectText {} -> complain "cannot use texts to define badge areas."
-  _ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers"
+checkObjectGroupProperty (Property name _) =
+  warn $ "unknown property " <> prettyprint name <> " for objectgroup layers"
 
 
 -- | Checks a single (custom) property of a "normal" tile layer
@@ -341,7 +343,8 @@ checkTileLayerProperty p@(Property name _value) = case name of
     "openTab" -> do
       isString p
       requireProperty "openWebsite"
-    "url" -> isForbidden
+    "url" -> complain "the property \"url\" defining embedded iframes must be \
+                      \set on an object in an objectgroup layer."
     "allowApi" -> isForbidden
     "exitUrl" -> do
       forbidEmptyLayer
@@ -455,9 +458,9 @@ unlessHasProperty name linter =
     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
+containsProperty :: HasProperties a => a -> Text -> Bool
+containsProperty thing name = any
+  (\(Property name' _) -> name' == name) (getProperties thing)
 
 -- | should the layers fulfilling the given predicate collide, then perform andthen.
 whenLayerCollisions
diff --git a/lib/TiledAbstract.hs b/lib/TiledAbstract.hs
index 88dd2ee..948a91a 100644
--- a/lib/TiledAbstract.hs
+++ b/lib/TiledAbstract.hs
@@ -7,7 +7,7 @@ import           Data.Proxy  (Proxy)
 import           Data.Text   (Text)
 import qualified Data.Vector as V
 import           Tiled       (Layer (..), Property (..), PropertyValue (..),
-                              Tile (..), Tiledmap (..), Tileset (..))
+                              Tile (..), Tiledmap (..), Tileset (..), Object(..))
 
 class HasProperties a where
   getProperties :: a -> [Property]
@@ -28,6 +28,10 @@ instance HasProperties Tile where
   adjustProperties f tile = tile
     { tileProperties = (fmap V.fromList . f) (getProperties tile) }
 
+instance HasProperties Object where
+  getProperties = V.toList . fromMaybe mempty . objectProperties
+  adjustProperties f obj = obj
+    { objectProperties = (fmap V.fromList . f) (getProperties obj) }
 
 instance HasProperties Tiledmap where
   getProperties = fromMaybe mempty . tiledmapProperties
-- 
cgit v1.2.3