summaryrefslogtreecommitdiff
path: root/lib/Uris.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Uris.hs')
-rw-r--r--lib/Uris.hs15
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