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)

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