diff options
| -rw-r--r-- | lib/Properties.hs | 17 | ||||
| -rw-r--r-- | lib/Util.hs | 6 |
2 files changed, 17 insertions, 6 deletions
diff --git a/lib/Properties.hs b/lib/Properties.hs index 7772c26..f78ceff 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -68,7 +68,7 @@ checkMap = do -- Doesn't really do all that much, but could in theory be expanded into a -- longer function same as checkLayerProperty. checkMapProperty :: Property -> LintWriter Tiledmap -checkMapProperty (Property name _value) = case name of +checkMapProperty p@(Property name _value) = case name of "script" -> do -- this is kind of stupid, since if we also inject script this -- will be overriden anyways, but it also doesn't really hurt I guess @@ -80,11 +80,11 @@ checkMapProperty (Property name _value) = case name of lintConfig configScriptInject >>= \case Nothing -> pure () Just url -> setProperty "script" url - "mapName" -> pure () + "mapName" -> naiveEscapeProperty p "mapLink" -> pure () "mapImage" -> pure () - "mapDescription" -> pure () - "mapCopyright" -> pure () + "mapDescription" -> naiveEscapeProperty p + "mapCopyright" -> naiveEscapeProperty p _ -> complain $ "unknown map property " <> prettyprint name where @@ -118,8 +118,8 @@ checkTileset = do mapM_ checkTilesetProperty (fromMaybe [] $ tilesetProperties tileset) checkTilesetProperty :: Property -> LintWriter Tileset -checkTilesetProperty (Property name _value) = case name of - "copyright" -> pure () -- only allow some licenses? +checkTilesetProperty p@(Property name _value) = case name of + "copyright" -> naiveEscapeProperty p _ -> pure () -- are there any other properties? @@ -182,6 +182,7 @@ checkLayerProperty p@(Property name _value) = case name of (\link -> do dependsOn (Link link) setProperty "openWebsite" link + setProperty "silent" (BoolProp True) setProperty "openWebsitePolicy" ("fullscreen;camera;microphone;display-capture" :: Text) ) @@ -400,3 +401,7 @@ unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do "the URI schema " <> schema <> ":// does not exist." WrongScope schema -> "the URI schema " <> schema <> ":// cannot be used on \""<>name<>"\"." + +naiveEscapeProperty :: HasProperties a => Property -> LintWriter a +naiveEscapeProperty prop@(Property name _) = + unwrapString prop (setProperty name . naiveEscapeHTML) diff --git a/lib/Util.hs b/lib/Util.hs index 18dfb5b..948b725 100644 --- a/lib/Util.hs +++ b/lib/Util.hs @@ -35,6 +35,7 @@ instance PrettyPrint PropertyValue where prettyprint = \case StrProp str -> str BoolProp bool -> if bool then "true" else "false" + IntProp int -> showText int -- | here since Unit is sometimes used as dummy type instance PrettyPrint () where @@ -54,3 +55,8 @@ layerIsEmpty :: Layer -> Bool layerIsEmpty layer = case layerData layer of Nothing -> True Just d -> all ((==) $ mkTiledId 0) d + +-- | naive escaping of html sequences, just to be sure that +-- | workadventure won't mess things up again … +naiveEscapeHTML :: Text -> Text +naiveEscapeHTML = T.replace "<" "<" . T.replace ">" ">" |