From 0dbe448959d6aa03f0ea99a7e180e2cafaedf651 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sat, 4 Dec 2021 15:12:30 +0100
Subject: better lints for invalid links

---
 lib/Properties.hs | 33 +++++++++++++++------------------
 lib/Uris.hs       | 10 +++++++---
 2 files changed, 22 insertions(+), 21 deletions(-)

diff --git a/lib/Properties.hs b/lib/Properties.hs
index 07b4397..1d01216 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -11,7 +11,7 @@ module Properties (checkMap, checkTileset, checkLayer) where
 
 
 import           Control.Monad (forM_, unless, when)
-import           Data.Text     (Text, isPrefixOf)
+import           Data.Text     (Text, isPrefixOf, intercalate)
 import qualified Data.Vector   as V
 import           Tiled         (Layer (..), Object (..), Property (..),
                                 PropertyValue (..), Tile (..), Tiledmap (..),
@@ -147,7 +147,7 @@ checkTileset = do
       where checkTileProperty :: Property -> LintWriter Tileset
             checkTileProperty p@(Property name _) = case name of
               "collides" -> isBool p
-              _ -> warn $ "uknown tile property " <> prettyprint name
+              _ -> warn $ "unknown tile property " <> prettyprint name
                         <> " in tile with global id "
                         <> showText (tileId tile)
 
@@ -283,9 +283,9 @@ checkTileLayerProperty p@(Property name _value) = case name of
         (setProperty "openWebsiteTriggerMessage")
     "playAudio" -> do
       uselessEmptyLayer
-      unwrapLink p $ \link -> if "https://" `isPrefixOf` link
-        then dependsOn $ Link link
-        else unwrapPath link (dependsOn . Local)
+      unwrapURI (Proxy @"audio") p
+        (dependsOn . Link)
+        (dependsOn . Local)
     "audioLoop" -> do
       isBool p
       requireProperty "playAudio"
@@ -339,6 +339,8 @@ checkTileLayerProperty p@(Property name _value) = case name of
       unwrapBool p $ \case
         True  -> pure ()
         False -> warn "property \"collides\" set to 'false' is useless."
+    "getBadge" -> complain "\"getBadge\" must be set on an \"objectgroup\" \
+                           \ layer; it does not work on tile layers."
     "name" -> isUnsupported
     _ ->
         warn $ "unknown property type " <> prettyprint name
@@ -439,7 +441,7 @@ propertyRequiredBy req by =
 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<>"\"."
 
 
 
@@ -472,15 +474,6 @@ unwrapString (Property name value) f = case value of
   _ -> complain $ "type error: property "
                <> prettyprint name <> " should be of type string."
 
--- | same as unwrapString, but also forbids http:// as prefix
-unwrapLink :: Property -> (Text -> LintWriter a) -> LintWriter a
-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 in your repository instead."
-    else f str
-  _ -> 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
@@ -512,9 +505,10 @@ unwrapBadgeToken str f = case parseToken str of
   Just a  -> f a
   Nothing -> complain "invalid badge token."
 
+
 unwrapURI :: (KnownSymbol s, HasProperties a)
   => Proxy s -> Property -> (Text -> LintWriter a) -> (RelPath -> LintWriter a) -> LintWriter a
-unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do
+unwrapURI sym p@(Property name _) f g = unwrapString p $ \link -> do
   subst <- lintConfig configUriSchemas
   case applySubst sym subst link of
     Right uri -> do
@@ -526,8 +520,11 @@ unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do
       InvalidLink -> link <> " is invalid."
       SchemaDoesNotExist schema ->
         "the URI schema " <> schema <> ":// does not exist."
-      WrongScope schema ->
-        "the URI schema " <> schema <> ":// cannot be used on \""<>name<>"\"."
+      WrongScope schema allowed ->
+        "the URI schema " <> schema <> ":// cannot be used in property \
+        \\"" <> name <> "\"; allowed "
+        <> (if length allowed == 1 then "is " else "are ")
+        <> intercalate ", " (fmap (<> "://") allowed) <> "."
 
 -- | just asserts that this is a string
 isString :: Property -> LintWriter a
diff --git a/lib/Uris.hs b/lib/Uris.hs
index dfbd454..b674d37 100644
--- a/lib/Uris.hs
+++ b/lib/Uris.hs
@@ -57,15 +57,19 @@ data SubstError =
   | NotALink
   | IsBlocked
   | InvalidLink
-  | WrongScope Text
+  | WrongScope Text [Text]
+  -- ^ This link's schema exists, but cannot be used in this scope.
+  -- The second field contains a list of schemas that may be used instead.
 
 
-applySubst :: KnownSymbol s => Proxy s -> SchemaSet -> Text -> Either SubstError Text
+applySubst :: KnownSymbol s
+  => Proxy s -> SchemaSet -> Text -> Either SubstError Text
 applySubst s substs uri =  do
   (schema, domain, rest) <- note NotALink $ parseUri uri
   rules <- note (SchemaDoesNotExist schema) ( M.lookup schema substs)
   unless (symbolVal s `elem` scope rules)
-    $ Left (WrongScope schema)
+    $ Left (WrongScope schema
+            (M.keys . M.filter (elem (symbolVal s) . scope) $ substs))
   case rules of
     Explicit table _  -> do
       prefix <- note InvalidLink $ M.lookup domain table
-- 
cgit v1.2.3