From 25111b467c91e411f1c7a4281c2eee5671db7406 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sat, 19 Mar 2022 16:50:57 +0100
Subject: linter: allow unrestricted domain scopes

---
 config.json | 23 ++++++++---------------
 lib/Uris.hs | 15 +++++++--------
 2 files changed, 15 insertions(+), 23 deletions(-)

diff --git a/config.json b/config.json
index 9db5342..1ccb0a5 100644
--- a/config.json
+++ b/config.json
@@ -3,23 +3,16 @@
   "Assemblies":[],
   "ScriptInject":null,
   "AllowScripts":false,
-  "MaxLintLevel":"Warning",
+  "MaxLintLevel":"Fatal",
   "DontCopyAssets":false,
-  "UriSchemas": [
-    ["https", {
-      "scope" : ["website"],
-      "allowed" : ["media.ccc.de", "streaming.media.ccc.de", "static.rc3.world", "cdn.c3voc.de", "pretalx.c3voc.de"],
-      "blocked" : ["blocked.com"],
-      "prefix" : "https:\/\/rc3.world\/2021\/wa_dereferrer\/"
-    }],
-    ["https", {
-      "scope" : ["audio"],
-      "allowed" : ["cdn.c3voc.de", "media.ccc.de", "streaming.media.ccc.de", "static.rc3.world", "live.dort.c3voc.de"]
-    }],
-    ["world", {
+  "UriSchemas": {
+    "world": {
       "scope" : ["map"],
       "substs" : {
       }
-    }]
-  ]
+    },
+    "https": {
+      "scope" : [ "website", "audio" ]
+    }
+  }
 }
diff --git a/lib/Uris.hs b/lib/Uris.hs
index a8c7068..596c272 100644
--- a/lib/Uris.hs
+++ b/lib/Uris.hs
@@ -23,6 +23,7 @@ data Substitution =
     Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] }
   | DomainSubstitution { substs :: Map Text Text, scope :: [String] }
   | Allowed  { scope :: [String], allowed :: [Text] }
+  | Unrestricted { scope :: [String] }
   deriving (Generic, Show)
 
 
@@ -32,7 +33,7 @@ instance FromJSON Substitution where
     , rejectUnknownFields = True
     }
 
-type SchemaSet = [(Text, Substitution)]
+type SchemaSet = Map Text Substitution
 
 
 extractDomain :: Text -> Maybe Text
@@ -78,20 +79,17 @@ applySubsts s substs uri =  do
    $ Left VarsDisallowed
   parts@(schema, _, _) <- note NotALink $ parseUri uri
 
-  let rules = filter ((==) schema . fst) substs
+  let rule = M.lookup schema substs
 
-  case nonEmpty (map (applySubst parts . snd) rules) of
+  case map (applySubst parts) rule of
     Nothing  -> Left (SchemaDoesNotExist schema)
-    Just results -> case rights (toList results) of
-      suc:_ -> Right suc
-      _     -> minimum results
-
+    Just result -> result
   where
     note = maybeToRight
     applySubst (schema, domain, rest) rule = do
       unless (symbolVal s `elem` scope rule)
         $ Left (WrongScope schema
-         (fmap fst . filter (elem (symbolVal s) . scope . snd) $ substs))
+         (map fst . filter (elem (symbolVal s) . scope . snd) $ toPairs substs))
       case rule of
         DomainSubstitution table _  -> do
           prefix <- note (DomainDoesNotExist (schema <> toText "://" <> domain))
@@ -105,3 +103,4 @@ applySubsts s substs uri =  do
                     || toText "streamproxy.rc3.world" `T.isSuffixOf` domain
           then Right uri
           else Left (DomainIsBlocked domains)
+        Unrestricted _ -> Right uri
-- 
cgit v1.2.3