From 321f4d5fa118515dcde522e1ad01ddd65741828b Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Fri, 19 Nov 2021 01:29:28 +0100
Subject: [PATCH] add domain allow- and blocklists for weblinks
(these use a rather crude regex for parsing, which may be possible to
side-step, and which should probably be replaced by something that was
actually written while following the relevant rfc)
---
config.json | 6 ++++--
lib/LintConfig.hs | 5 +++++
lib/Paths.hs | 10 ++++++++++
lib/Properties.hs | 18 ++++++++++++++----
4 files changed, 33 insertions(+), 6 deletions(-)
diff --git a/config.json b/config.json
index 4870974..32f566f 100644
--- a/config.json
+++ b/config.json
@@ -2,7 +2,9 @@
"AssemblyTag":"assemblyname",
"ScriptInject":null,
"AllowScripts":true,
- "MaxLintLevel":"Suggestion",
+ "MaxLintLevel":"Fatal",
"DontCopyAssets":true,
- "LinkPrefix":"https://exit.rc3.world?link="
+ "LinkPrefix":"https://exit.rc3.world?link=",
+ "AllowedDomains":["example.org"],
+ "BlockedDomains":[]
}
diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs
index d237356..d976352 100644
--- a/lib/LintConfig.hs
+++ b/lib/LintConfig.hs
@@ -41,6 +41,11 @@ data LintConfig f = LintConfig
, 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
} deriving (Generic)
type LintConfig' = LintConfig Identity
diff --git a/lib/Paths.hs b/lib/Paths.hs
index af66e77..4082268 100644
--- a/lib/Paths.hs
+++ b/lib/Paths.hs
@@ -17,6 +17,16 @@ import Util (PrettyPrint (prettyprint))
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
+
+
+
-- | horrible regex parsing for filepaths that is hopefully kinda safe
parsePath :: Text -> Maybe RelPath
parsePath text =
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 74fd72a..3169e4d 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -20,7 +20,7 @@ import LintConfig (LintConfig (..))
import LintWriter (LintWriter, adjust, askContext, askFileDepth,
complain, dependsOn, forbid, lintConfig,
offersEntrypoint, suggest, warn)
-import Paths (RelPath (..), parsePath)
+import Paths (RelPath (..), parsePath, extractDomain)
import Types (Dep (Link, Local, LocalMap, MapLink))
@@ -174,9 +174,19 @@ checkLayerProperty p@(Property name _value) = case name of
suggestProperty $ Property "openWebsiteTrigger" (StrProp "onaction")
unwrapLink p $ \link -> if "https://" `isPrefixOf` link
then do
- dependsOn $ Link link
- prefix <- lintConfig configLinkPrefix
- setProperty "openWebsite" (prefix <> link)
+ 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)
"openWebsiteTrigger" -> do
isString p
--
GitLab