From 2511c52d9452f60c533871ac111ba9473065310c Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sat, 20 Nov 2021 02:30:20 +0100 Subject: make link adjustments configurable this allows for creating custom URI "schemas" in the linter's config, which may be either allowed, prefixed, or translated according to some (domain-based) substitution. --- config.json | 18 ++++++++++++++--- lib/LintConfig.hs | 11 ++++------- lib/Paths.hs | 21 +++++++++----------- lib/Properties.hs | 59 +++++++++++++++++++++++++++++++++---------------------- walint.cabal | 1 + 5 files changed, 64 insertions(+), 46 deletions(-) diff --git a/config.json b/config.json index 32f566f..b955e01 100644 --- a/config.json +++ b/config.json @@ -4,7 +4,19 @@ "AllowScripts":true, "MaxLintLevel":"Fatal", "DontCopyAssets":true, - "LinkPrefix":"https://exit.rc3.world?link=", - "AllowedDomains":["example.org"], - "BlockedDomains":[] + "UriSchemas": { + "https" : { + "scope" : ["website"], + "allowed" : ["example.org"], + "blocked" : ["blocked.com"], + "prefix" : "https://ausgang.rc3.world?link=" + }, + "world" : { + "scope" : ["map"], + "substs" : { + "lounge" : "/@/lalala", + "lobby" : "/@/lounge" + } + } + } } 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<>"\"" diff --git a/walint.cabal b/walint.cabal index 4faf69c..ce68a57 100644 --- a/walint.cabal +++ b/walint.cabal @@ -35,6 +35,7 @@ library Util Types Paths + Uris LintConfig build-depends: base, aeson, -- cgit v1.2.3