summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/LintConfig.hs11
-rw-r--r--lib/Paths.hs21
-rw-r--r--lib/Properties.hs59
3 files changed, 48 insertions, 43 deletions
diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs
index d976352..f540ae1 100644
--- a/lib/LintConfig.hs
+++ b/lib/LintConfig.hs
@@ -21,10 +21,10 @@ import Data.Text (Text)
import GHC.Generics (Generic (Rep, from, to), K1 (..),
M1 (..), (:*:) (..))
import Types (Level)
+import Uris (SchemaSet)
import WithCli (Proxy (..))
import WithCli.Pure (Argument (argumentType, parseArgument))
-
type family HKD f a where
HKD Identity a = a
HKD f a = f a
@@ -40,12 +40,7 @@ data LintConfig f = LintConfig
-- ^ Don't copy map assets (mostly useful for development)
, configAllowScripts :: HKD f Bool
-- ^ Allow defining custom scripts in maps
- , configLinkPrefix :: HKD f Text
- -- ^ prefix that will be added to all outgoing weblinks
- , configAllowedDomains :: HKD f [Text]
- -- ^ domains that are allowed in weblinks and will not be modified
- , configBlockedDomains :: HKD f [Text]
- -- ^ domains that are blocked; weblinks to these is an error
+ , configUriSchemas :: HKD f SchemaSet
} deriving (Generic)
type LintConfig' = LintConfig Identity
@@ -57,6 +52,7 @@ deriving instance
, Show (HKD a Level)
, Show (HKD a [Text])
, Show (HKD a Bool)
+ , Show (HKD a SchemaSet)
)
=> Show (LintConfig a)
@@ -73,6 +69,7 @@ instance
, FromJSON (HKD a Text)
, FromJSON (HKD a Level)
, FromJSON (HKD a Bool)
+ , FromJSON (HKD a SchemaSet)
)
=> FromJSON (LintConfig a)
where
diff --git a/lib/Paths.hs b/lib/Paths.hs
index 4082268..b628ee8 100644
--- a/lib/Paths.hs
+++ b/lib/Paths.hs
@@ -1,10 +1,11 @@
+{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Paths are horrible, so they have their own module now.
-- I just hope you are running this on some kind of Unix
module Paths where
-import Data.Text (Text)
+import Data.Text (Text, isPrefixOf)
import qualified Data.Text as T
import System.FilePath (splitPath)
import System.FilePath.Posix ((</>))
@@ -18,21 +19,17 @@ data RelPath = Path Int Text (Maybe Text)
deriving (Show, Eq, Ord)
-extractDomain :: Text -> Maybe Text
-extractDomain url =
- let (_,_,_,matches) = url =~ ("^https://([^/]+)/?.*$" :: Text) :: (Text,Text,Text,[Text])
- in case matches of
- [domain] -> Just domain
- _ -> Nothing
-
+data PathResult = OkRelPath RelPath | AbsolutePath | NotAPath | UnderscoreMapLink | AtMapLink
-- | horrible regex parsing for filepaths that is hopefully kinda safe
-parsePath :: Text -> Maybe RelPath
+parsePath :: Text -> PathResult
parsePath text =
- if rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) :: Bool
- then Just $ Path up path fragment
- else Nothing
+ if | rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) -> OkRelPath (Path up path fragment)
+ | "/_/" `isPrefixOf` text -> UnderscoreMapLink
+ | "/@/" `isPrefixOf` text -> AtMapLink
+ | "/" `isPrefixOf` text -> AbsolutePath
+ | otherwise -> NotAPath
where
(_, prefix, rest, _) =
text =~ ("^((\\.|\\.\\.)/)*" :: Text) :: (Text, Text, Text, [Text])
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 3169e4d..ea9f1ac 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -2,8 +2,10 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
-- | Contains checks for custom ties of the map json
+{-# LANGUAGE DataKinds #-}
module Properties (checkMap, checkTileset, checkLayer) where
@@ -15,13 +17,16 @@ import Tiled2 (HasProperties (adjustProperties, getProperties),
Tiledmap (..), Tileset (..))
import Util (layerIsEmpty, prettyprint, showText)
+import Data.Data (Proxy (Proxy))
import Data.Maybe (fromMaybe, isJust)
+import GHC.TypeLits (KnownSymbol)
import LintConfig (LintConfig (..))
import LintWriter (LintWriter, adjust, askContext, askFileDepth,
complain, dependsOn, forbid, lintConfig,
offersEntrypoint, suggest, warn)
-import Paths (RelPath (..), parsePath, extractDomain)
+import Paths (PathResult (..), RelPath (..), parsePath)
import Types (Dep (Link, Local, LocalMap, MapLink))
+import Uris (SubstError (..), applySubst)
-- | Checks an entire map for "general" lints.
@@ -172,22 +177,9 @@ checkLayerProperty p@(Property name _value) = case name of
"openWebsite" -> do
uselessEmptyLayer
suggestProperty $ Property "openWebsiteTrigger" (StrProp "onaction")
- unwrapLink p $ \link -> if "https://" `isPrefixOf` link
- then do
- config <- lintConfig id
- case extractDomain link of
- Just domain
- | domain `elem` configBlockedDomains config
- -> complain $ "domain " <> domain <> " is blocked."
- | domain `elem` configAllowedDomains config
- -> dependsOn $ Link link
- | otherwise
- -> do
- dependsOn $ Link link
- prefix <- lintConfig configLinkPrefix
- setProperty "openWebsite" (prefix <> link)
- Nothing -> complain "invalid link?"
- else unwrapPath link (dependsOn . Local)
+ unwrapURI (Proxy @"website") p
+ (dependsOn . Link)
+ (dependsOn . Local)
"openWebsiteTrigger" -> do
isString p
unlessHasProperty "openWebsiteTriggerMessage"
@@ -207,11 +199,9 @@ checkLayerProperty p@(Property name _value) = case name of
"allowApi" -> isForbidden
"exitUrl" -> do
forbidEmptyLayer
- unwrapLink p $ \link -> if
- | "/_/" `isPrefixOf` link ->
- complain "absolute map links (i.e. links starting with '/_/') are disallowed."
- | "/@/" `isPrefixOf` link -> dependsOn $ MapLink link -- TODO
- | otherwise -> unwrapPath link (dependsOn . LocalMap)
+ unwrapURI (Proxy @"map") p
+ (dependsOn . MapLink)
+ (dependsOn . LocalMap)
"exitSceneUrl" ->
deprecatedUseInstead "exitUrl"
"exitInstance" ->
@@ -350,12 +340,15 @@ unwrapInt (Property name value) f = case value of
unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a
unwrapPath str f = case parsePath str of
- Just p@(Path up _ _) -> do
+ OkRelPath p@(Path up _ _) -> do
depth <- askFileDepth
if up <= depth
then f p
else complain $ "cannot acess paths \"" <> str <> "\" which is outside your repository"
- Nothing -> complain $ "path \"" <> str <> "\" is invalid"
+ NotAPath -> complain $ "path \"" <> str <> "\" is invalid"
+ AbsolutePath -> complain "absolute paths are disallowed. Use world:// instead."
+ UnderscoreMapLink -> complain "map links using /_/ are disallowed. Use world:// instead."
+ AtMapLink -> complain "map links using /@/ are disallowed. Use world:// instead."
-- | just asserts that this is a string
isString :: Property -> LintWriter a
@@ -369,3 +362,21 @@ isIntInRange :: Int -> Int -> Property -> LintWriter a
isIntInRange l r p@(Property name _) = unwrapInt p $ \int ->
if l < int && int < r then pure ()
else complain $ "Property " <> prettyprint name <> " should be between" <> showText l <> " and " <> showText r
+
+
+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
+ subst <- lintConfig configUriSchemas
+ case applySubst sym subst link of
+ Right uri -> do
+ setProperty name uri
+ f uri
+ Left NotALink -> unwrapPath link g
+ Left err -> complain $ case err of
+ IsBlocked -> link <> " is a blocked site."
+ InvalidLink -> link <> " is invalid."
+ SchemaDoesNotExist schema ->
+ "the URI schema " <> schema <> ":// does not exist."
+ WrongScope schema ->
+ "the URI schema " <> schema <> ":// cannot be used on \""<>name<>"\""
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 08:36:11 +0000