linter: allow unrestricted domain scopes

1 files changed, 7 insertions, 8 deletions

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