Skip to content
Snippets Groups Projects
Commit 0dbe4489 authored by stuebinm's avatar stuebinm
Browse files

better lints for invalid links

parent 6a67d3e4
No related branches found
No related tags found
No related merge requests found
...@@ -11,7 +11,7 @@ module Properties (checkMap, checkTileset, checkLayer) where ...@@ -11,7 +11,7 @@ module Properties (checkMap, checkTileset, checkLayer) where
import Control.Monad (forM_, unless, when) import Control.Monad (forM_, unless, when)
import Data.Text (Text, isPrefixOf) import Data.Text (Text, isPrefixOf, intercalate)
import qualified Data.Vector as V import qualified Data.Vector as V
import Tiled (Layer (..), Object (..), Property (..), import Tiled (Layer (..), Object (..), Property (..),
PropertyValue (..), Tile (..), Tiledmap (..), PropertyValue (..), Tile (..), Tiledmap (..),
...@@ -147,7 +147,7 @@ checkTileset = do ...@@ -147,7 +147,7 @@ checkTileset = do
where checkTileProperty :: Property -> LintWriter Tileset where checkTileProperty :: Property -> LintWriter Tileset
checkTileProperty p@(Property name _) = case name of checkTileProperty p@(Property name _) = case name of
"collides" -> isBool p "collides" -> isBool p
_ -> warn $ "uknown tile property " <> prettyprint name _ -> warn $ "unknown tile property " <> prettyprint name
<> " in tile with global id " <> " in tile with global id "
<> showText (tileId tile) <> showText (tileId tile)
...@@ -283,9 +283,9 @@ checkTileLayerProperty p@(Property name _value) = case name of ...@@ -283,9 +283,9 @@ checkTileLayerProperty p@(Property name _value) = case name of
(setProperty "openWebsiteTriggerMessage") (setProperty "openWebsiteTriggerMessage")
"playAudio" -> do "playAudio" -> do
uselessEmptyLayer uselessEmptyLayer
unwrapLink p $ \link -> if "https://" `isPrefixOf` link unwrapURI (Proxy @"audio") p
then dependsOn $ Link link (dependsOn . Link)
else unwrapPath link (dependsOn . Local) (dependsOn . Local)
"audioLoop" -> do "audioLoop" -> do
isBool p isBool p
requireProperty "playAudio" requireProperty "playAudio"
...@@ -339,6 +339,8 @@ checkTileLayerProperty p@(Property name _value) = case name of ...@@ -339,6 +339,8 @@ checkTileLayerProperty p@(Property name _value) = case name of
unwrapBool p $ \case unwrapBool p $ \case
True -> pure () True -> pure ()
False -> warn "property \"collides\" set to 'false' is useless." 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 "name" -> isUnsupported
_ -> _ ->
warn $ "unknown property type " <> prettyprint name warn $ "unknown property type " <> prettyprint name
...@@ -439,7 +441,7 @@ propertyRequiredBy req by = ...@@ -439,7 +441,7 @@ propertyRequiredBy req by =
suggestProperty :: Property -> LintWriter Layer suggestProperty :: Property -> LintWriter Layer
suggestProperty (Property name value) = suggestProperty (Property name value) =
unlessHasProperty name 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 ...@@ -472,15 +474,6 @@ unwrapString (Property name value) f = case value of
_ -> complain $ "type error: property " _ -> complain $ "type error: property "
<> prettyprint name <> " should be of type string." <> 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 -- | asserts that this property is a boolean, and unwraps it
unwrapBool :: Property -> (Bool -> LintWriter a) -> LintWriter a unwrapBool :: Property -> (Bool -> LintWriter a) -> LintWriter a
...@@ -512,9 +505,10 @@ unwrapBadgeToken str f = case parseToken str of ...@@ -512,9 +505,10 @@ unwrapBadgeToken str f = case parseToken str of
Just a -> f a Just a -> f a
Nothing -> complain "invalid badge token." Nothing -> complain "invalid badge token."
unwrapURI :: (KnownSymbol s, HasProperties a) unwrapURI :: (KnownSymbol s, HasProperties a)
=> Proxy s -> Property -> (Text -> LintWriter a) -> (RelPath -> LintWriter a) -> LintWriter 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 subst <- lintConfig configUriSchemas
case applySubst sym subst link of case applySubst sym subst link of
Right uri -> do Right uri -> do
...@@ -526,8 +520,11 @@ unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do ...@@ -526,8 +520,11 @@ unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do
InvalidLink -> link <> " is invalid." InvalidLink -> link <> " is invalid."
SchemaDoesNotExist schema -> SchemaDoesNotExist schema ->
"the URI schema " <> schema <> ":// does not exist." "the URI schema " <> schema <> ":// does not exist."
WrongScope schema -> WrongScope schema allowed ->
"the URI schema " <> schema <> ":// cannot be used on \""<>name<>"\"." "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 -- | just asserts that this is a string
isString :: Property -> LintWriter a isString :: Property -> LintWriter a
......
...@@ -57,15 +57,19 @@ data SubstError = ...@@ -57,15 +57,19 @@ data SubstError =
| NotALink | NotALink
| IsBlocked | IsBlocked
| InvalidLink | 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 applySubst s substs uri = do
(schema, domain, rest) <- note NotALink $ parseUri uri (schema, domain, rest) <- note NotALink $ parseUri uri
rules <- note (SchemaDoesNotExist schema) ( M.lookup schema substs) rules <- note (SchemaDoesNotExist schema) ( M.lookup schema substs)
unless (symbolVal s `elem` scope rules) unless (symbolVal s `elem` scope rules)
$ Left (WrongScope schema) $ Left (WrongScope schema
(M.keys . M.filter (elem (symbolVal s) . scope) $ substs))
case rules of case rules of
Explicit table _ -> do Explicit table _ -> do
prefix <- note InvalidLink $ M.lookup domain table prefix <- note InvalidLink $ M.lookup domain table
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment