From c2a49d6ea46c38f107ac1a47a965e4777be2aecc Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 2 Dec 2021 02:27:30 +0100
Subject: do (naïve) html escaping

because we can't ever trust workadventure, apparently.

why are we using that thing again?
---
 lib/Properties.hs | 17 +++++++++++------
 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 "<" "&lt;" . T.replace ">" "&gt;"
-- 
cgit v1.2.3