Skip to content
Snippets Groups Projects
Commit 8082e9ef authored by stuebinm's avatar stuebinm
Browse files

badges are set on objects, not layers

(and `url` is, too)
parent 766f883e
Branches
No related tags found
No related merge requests found
Pipeline #10017 passed
......@@ -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 }
-- 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") $
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."
warn "objectgroup layer (which aren't the floorLayer) \
\are useless if they are empty."
forM_ (getProperties layer) checkObjectGroupProperty
ty -> complain $ "unsupported layer type " <> prettyprint ty <> "."
if layerType layer == "group"
......@@ -228,16 +223,17 @@ checkLayer = do
else when (isJust (layerLayers layer))
$ complain "Layer is not of type \"group\", but has sublayers."
-- | Checks a single (custom) property of an objectgroup layer
checkObjectGroupProperty :: Property -> LintWriter Layer
checkObjectGroupProperty p@(Property name _) = case name of
"getBadge" ->
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
layer <- askContext
forM_ (fromMaybe (V.fromList []) $ layerObjects layer) $ \object -> do
case object of
case obj of
ObjectPoint {..} ->
offersBadge (Badge token (BadgePoint objectX objectY))
ObjectRectangle {..} ->
......@@ -248,7 +244,13 @@ checkObjectGroupProperty p@(Property name _) = case name of
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"
_ -> warn $ "unknown object property " <> prettyprint name <> "."
-- | Checks a single (custom) property of an objectgroup layer
checkObjectGroupProperty :: Property -> LintWriter Layer
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
......
......@@ -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
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment