Skip to content
GitLab
Explore
Sign in
Primary navigation
Search or go to…
Project
W
walint
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package registry
Container registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
GitLab community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
This is an archived project. Repository and other project resources are read-only.
Show more breadcrumbs
hub
walint
Commits
0dbe4489
Commit
0dbe4489
authored
3 years ago
by
stuebinm
Browse files
Options
Downloads
Patches
Plain Diff
better lints for invalid links
parent
6a67d3e4
No related branches found
No related tags found
No related merge requests found
Changes
2
Show whitespace changes
Inline
Side-by-side
Showing
2 changed files
lib/Properties.hs
+15
-18
15 additions, 18 deletions
lib/Properties.hs
lib/Uris.hs
+7
-3
7 additions, 3 deletions
lib/Uris.hs
with
22 additions
and
21 deletions
lib/Properties.hs
+
15
−
18
View file @
0dbe4489
...
@@ -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
$
"u
n
known 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
unwrap
Link
p
$
\
link
->
if
"https://"
`
isPrefixOf
`
link
unwrap
URI
(
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
=
unwrap
L
in
k
p
$
\
link
->
do
unwrapURI
sym
p
@
(
Property
name
_
)
f
g
=
unwrap
Str
in
g
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
...
...
This diff is collapsed.
Click to expand it.
lib/Uris.hs
+
7
−
3
View file @
0dbe4489
...
@@ -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
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment