From 321f4d5fa118515dcde522e1ad01ddd65741828b Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Fri, 19 Nov 2021 01:29:28 +0100
Subject: 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)
---
 lib/Properties.hs | 18 ++++++++++++++----
 1 file changed, 14 insertions(+), 4 deletions(-)

(limited to 'lib/Properties.hs')

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
-- 
cgit v1.2.3