summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Properties.hs33
-rw-r--r--lib/Uris.hs10
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