From efb64e0228c19ef7936446d3ca14a7d7a6e2540b Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sun, 28 Nov 2021 22:24:30 +0100
Subject: various fixes to bugs

Among them
 - always set correct exit codes
 - refuse to write out files if the out path already exists
 - calculate the overall severity correctly
 - slightly changed the json output schema
 - also output the text output format in json
 - make the default config.json suitable for a production environment
---
 lib/Properties.hs | 68 +++++++++++++++++++++++++++----------------------------
 1 file changed, 34 insertions(+), 34 deletions(-)

(limited to 'lib/Properties.hs')

diff --git a/lib/Properties.hs b/lib/Properties.hs
index ea9f1ac..85ef7c0 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -43,17 +43,17 @@ checkMap = do
 
   -- some layers should exist
   hasLayerNamed "start" (const True)
-    "The map must have one layer named \"start\""
+    "The map must have one layer named \"start\"."
   hasLayerNamed "floorLayer" ((==) "objectgroup" . layerType)
-    "The map must have one layer named \"floorLayer\" of type \"objectgroup\""
+    "The map must have one layer named \"floorLayer\" of type \"objectgroup\"."
   hasLayer (flip containsProperty "exitUrl" . getProperties)
-    "The map must contain at least one layer with the property \"exitUrl\" set"
+    "The map must contain at least one layer with the property \"exitUrl\" set."
 
   -- reject maps not suitable for workadventure
   unless (tiledmapOrientation tiledmap == "orthogonal")
-    $ complain "The map's orientation must be set to \"orthogonal\""
+    $ complain "The map's orientation must be set to \"orthogonal\"."
   unless (tiledmapTileheight tiledmap == 32 && tiledmapTilewidth tiledmap == 32)
-    $ complain "The map's tile size must be 32 by 32 pixels"
+    $ complain "The map's tile size must be 32 by 32 pixels."
   where
     hasLayerNamed name p = hasLayer (\l -> layerName l == name && p l)
     hasLayer p err = do
@@ -79,6 +79,11 @@ checkMapProperty (Property name _value) = case name of
     lintConfig configScriptInject >>= \case
       Nothing  -> pure ()
       Just url -> setProperty "script" url
+  "mapName" -> pure ()
+  "mapLink" -> pure ()
+  "mapImage" -> pure ()
+  "mapDescription" -> pure ()
+  "mapCopyright" -> pure ()
 
   _        -> complain $ "unknown map property " <> prettyprint name
   where
@@ -97,15 +102,18 @@ checkTileset = do
 
   -- reject tilesets unsuitable for workadventure
   unless (tilesetTilewidth tileset == 32 && tilesetTileheight tileset == 32)
-    $ complain "Tilesets must have tile size 32×32"
+    $ complain "Tilesets must have tile size 32×32."
 
   unless (tilesetImageheight tileset < 4096 && tilesetImagewidth tileset < 4096)
-    $ warn "Tilesets should not be larger than 4096×4096 pixels in total"
+    $ warn "Tilesets should not be larger than 4096×4096 pixels in total."
 
   when (isJust (tilesetSource tileset))
     $ complain "Tilesets must be embedded and cannot be loaded from external files."
   -- TODO: check copyright!
-  requireProperty "copyright"
+  unlessHasProperty "copyright"
+    $ forbid "property \"copyright\" is required for tilesets."
+
+
   mapM_ checkTilesetProperty (fromMaybe [] $ tilesetProperties tileset)
 
 checkTilesetProperty :: Property -> LintWriter Tileset
@@ -125,7 +133,7 @@ checkLayer = do
     "tilelayer" -> mapM_ checkLayerProperty (getProperties layer)
     "group" -> pure ()
     ty -> unless (layerName layer == "floorLayer" && ty == "objectgroup")
-          $ complain "only tilelayer are supported."
+          $ complain "only group and tilelayer are supported."
 
   if layerType layer == "group"
     then when (null (layerLayers layer))
@@ -149,7 +157,7 @@ checkLayerProperty p@(Property name _value) = case name of
     "jitsiTrigger" -> do
       isString p
       unlessHasProperty "jitsiTriggerMessage"
-       $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter in jitsi meet room\""
+       $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter in jitsi meet room\"."
       requireProperty "jitsiRoom"
     "jitsiTriggerMessage" -> do
       isString p
@@ -183,7 +191,7 @@ checkLayerProperty p@(Property name _value) = case name of
     "openWebsiteTrigger" -> do
       isString p
       unlessHasProperty "openWebsiteTriggerMessage"
-        $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to overwrite the default \"press SPACE to open Website\""
+        $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to overwrite the default \"press SPACE to open Website\"."
       requireProperty "openWebsite"
     "openWebsiteTriggerMessage" -> do
       isString p
@@ -212,7 +220,7 @@ checkLayerProperty p@(Property name _value) = case name of
       offersEntrypoint $ layerName layer
       unwrapBool p $ \case
         True  -> pure ()
-        False -> complain "property \"startLayer\" must be set to true"
+        False -> complain "property \"startLayer\" must be set to true."
     "silent" -> do
       isBool p
       uselessEmptyLayer
@@ -229,7 +237,7 @@ checkLayerProperty p@(Property name _value) = case name of
                     , "jsonSchema"
                     , "zone" ] ->
         do
-          forbid "the workadventure scripting API and variables are not (?) supported."
+          warn "the workadventure scripting API and variables are not (yet?) supported."
           removeProperty name
       | otherwise ->
         complain $ "unknown property type " <> prettyprint name
@@ -245,12 +253,12 @@ checkLayerProperty p@(Property name _value) = case name of
       forbidEmptyLayer = do
         layer <- askContext
         when (layerIsEmpty layer)
-          $ complain ("property " <> prettyprint name <> " should not be set on an empty layer")
+          $ complain ("property " <> prettyprint name <> " should not be set on an empty layer.")
       -- | this layer is allowed, but also useless on a layer that contains no tiles
       uselessEmptyLayer = do
         layer <- askContext
         when (layerIsEmpty layer)
-          $ warn ("property " <> prettyprint name <> " set on an empty layer is useless")
+          $ warn ("property " <> prettyprint name <> " set on an empty layer is useless.")
 
 
 
@@ -268,27 +276,19 @@ unlessHasProperty name andthen = do
 -- | this property is forbidden and should not be used
 forbidProperty :: Text -> LintWriter Layer
 forbidProperty name = do
-  forbid $ "property " <> prettyprint name <> " should not be used"
-
-
-
--- | require some property
-requireProperty :: HasProperties a => Text -> LintWriter a
-requireProperty name =
-  unlessHasProperty name
-  $ complain $ "property "<>prettyprint name<>" is required"
+  forbid $ "property " <> prettyprint name <> " should not be used."
 
 propertyRequiredBy :: HasProperties a => Text -> Text -> LintWriter a
 propertyRequiredBy req by =
   unlessHasProperty req
-  $ complain $ "property "<>prettyprint req<>" is required by property "<> prettyprint by
+  $ complain $ "property "<>prettyprint req<>" is required by property "<> prettyprint by<>"."
 
 -- | suggest some value for another property if that property does not
 -- also already exist
 suggestProperty :: Property -> LintWriter Layer
 suggestProperty (Property name value) =
   unlessHasProperty name
-  $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value
+  $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value<>"."
 
 -- | set a property, overwriting whatever value it had previously
 setProperty :: (IsProperty prop, HasProperties ctxt)
@@ -314,7 +314,7 @@ containsProperty props name = any
 unwrapString :: Property -> (Text -> LintWriter a) -> LintWriter a
 unwrapString (Property name value) f = case value of
   StrProp str -> f str
-  _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string"
+  _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string."
 
 unwrapString' :: Property -> LintWriter a -> LintWriter a
 unwrapString' prop f = unwrapString prop (const f)
@@ -325,18 +325,18 @@ unwrapLink (Property name value) f = case value of
   StrProp str -> if "http://" `isPrefixOf` str
     then complain "cannot access content via http; either use https or include it locally instead."
     else f str
-  _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string and contain a valid uri"
+  _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string and contain a valid uri."
 
 -- | asserts that this property is a boolean, and unwraps it
 unwrapBool :: Property -> (Bool -> LintWriter a) -> LintWriter a
 unwrapBool (Property name value) f = case value of
   BoolProp b -> f b
-  _ -> complain $ "type error: property " <> prettyprint name <> " should be of type bool"
+  _ -> 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"
+  _ -> 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
@@ -344,8 +344,8 @@ unwrapPath str f = case parsePath str of
     depth <- askFileDepth
     if up <= depth
       then f p
-      else complain $ "cannot acess paths \"" <> str <> "\" which is outside your repository"
-  NotAPath -> complain $ "path \"" <> str <> "\" is invalid"
+      else complain $ "cannot acess paths \"" <> str <> "\" which is outside your repository."
+  NotAPath -> complain $ "path \"" <> str <> "\" is invalid."
   AbsolutePath -> complain "absolute paths are disallowed. Use world:// instead."
   UnderscoreMapLink -> complain "map links using /_/ are disallowed. Use world:// instead."
   AtMapLink -> complain "map links using /@/ are disallowed. Use world:// instead."
@@ -361,7 +361,7 @@ 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
+  else complain $ "Property " <> prettyprint name <> " should be between" <> showText l <> " and " <> showText r<>"."
 
 
 unwrapURI :: (KnownSymbol s, HasProperties a)
@@ -379,4 +379,4 @@ unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do
       SchemaDoesNotExist schema ->
         "the URI schema " <> schema <> ":// does not exist."
       WrongScope schema ->
-        "the URI schema " <> schema <> ":// cannot be used on \""<>name<>"\""
+        "the URI schema " <> schema <> ":// cannot be used on \""<>name<>"\"."
-- 
cgit v1.2.3