diff --git a/config.json b/config.json index 4870974df7ce50ec1c1db19ecfa7a6e2bd9fe9b7..32f566f5e1cfcf52a312a0d7258990abfefd93f8 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 d23735695f061222fec8bd4d7b32ac2c982fdbd7..d976352bc1c8ae5647153bcfbd8bfaf2dd613434 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 af66e77a9d8ee21d1579deb367f0e6b4705ef1b0..4082268f2edabeb584356d7488dcdd1943178c17 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 74fd72a81e4f644d92b01b9a5445768093a32f7e..3169e4df40104f82f10fc9ef78dd0b352b53d39c 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