diff options
| -rw-r--r-- | lib/Properties.hs | 33 | ||||
| -rw-r--r-- | 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 |