separate blocking for separate contexts

(audio links now have their own allowlist, which won't put things
through the dereferrer)

1 files changed, 30 insertions, 15 deletions

diff --git a/lib/Uris.hs b/lib/Uris.hs
index 40dc34a..3aad1da 100644
--- a/lib/Uris.hs
+++ b/lib/Uris.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds        #-}
 {-# LANGUAGE DeriveAnyClass   #-}
 {-# LANGUAGE DeriveGeneric    #-}
+{-# LANGUAGE LambdaCase       #-}
 {-# LANGUAGE RecordWildCards  #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -14,7 +15,7 @@ import           Data.Aeson              (FromJSON (..), Options (..),
                                           SumEncoding (UntaggedValue),
                                           defaultOptions, genericParseJSON)
 import           Data.Data               (Proxy)
-import           Data.Either.Combinators (maybeToRight)
+import           Data.Either.Combinators (maybeToRight, rightToMaybe)
 import           Data.Map.Strict         (Map)
 import qualified Data.Map.Strict         as M
 import           Data.Text               (Text, pack)
@@ -22,11 +23,13 @@ import qualified Data.Text               as T
 import           GHC.Generics            (Generic)
 import           GHC.TypeLits            (KnownSymbol, symbolVal)
 import           Text.Regex.TDFA         ((=~))
+import Witherable (mapMaybe)
+
 
 data Substitution =
     Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] }
   | DomainSubstitution { substs :: Map Text Text, scope :: [String] }
-  | Allowed  { scope :: [String] }
+  | Allowed  { scope :: [String], allowed :: [Text] }
   deriving (Generic, Show)
 
 
@@ -36,7 +39,7 @@ instance FromJSON Substitution where
     , rejectUnknownFields = True
     }
 
-type SchemaSet = Map Text Substitution
+type SchemaSet = [(Text, Substitution)]
 
 
 extractDomain :: Text -> Maybe Text
@@ -56,26 +59,38 @@ parseUri uri =
 data SubstError =
     SchemaDoesNotExist Text
   | NotALink
-  | IsBlocked
   | DomainDoesNotExist Text
-  | WrongScope Text [Text]
+  | IsBlocked
+  | DomainIsBlocked [Text]
   | VarsDisallowed
   -- ^ This link's schema exists, but cannot be used in this scope.
   -- The second field contains a list of schemas that may be used instead.
+  | WrongScope Text [Text]
+  deriving (Eq, Ord) -- errors are ordered so we can show more specific ones
 
 
-applySubst :: KnownSymbol s
+applySubsts :: KnownSymbol s
   => Proxy s -> SchemaSet -> Text -> Either SubstError Text
-applySubst s substs uri =  do
+applySubsts s substs uri =  do
   when (T.isInfixOf (pack "{{") uri || T.isInfixOf (pack "}}") uri)
    $ Left VarsDisallowed
-  (schema, domain, rest) <- note NotALink $ parseUri uri
+  parts@(schema, _, _) <- note NotALink $ parseUri uri
+
+  let rules = filter ((==) schema . fst) substs
+
+  case fmap (applySubst parts . snd) rules of
+    []  -> Left (SchemaDoesNotExist schema)
+    results@(_:_) -> case mapMaybe rightToMaybe results of
+      suc:_ -> Right suc
+      _ -> minimum results
 
-  rules <- note (SchemaDoesNotExist schema) ( M.lookup schema substs)
-  unless (symbolVal s `elem` scope rules)
+  where
+    note = maybeToRight
+    applySubst (schema, domain, rest) rule = do
+      unless (symbolVal s `elem` scope rule)
         $ Left (WrongScope schema
-         (M.keys . M.filter (elem (symbolVal s) . scope) $ substs))
-  case rules of
+         (fmap fst . filter (elem (symbolVal s) . scope . snd) $ substs))
+      case rule of
         DomainSubstitution table _  -> do
           prefix <- note (DomainDoesNotExist (schema <> pack "://" <> domain))
                        $ M.lookup domain table
@@ -84,6 +99,6 @@ applySubst s substs uri =  do
           | domain `elem` blocked -> Left IsBlocked
           | domain `elem` allowed -> Right uri
           | otherwise -> Right (prefix <> domain <> rest)
-        Allowed _ -> Right uri
-    where
-      note = maybeToRight
+        Allowed _ domains -> if domain `elem` domains
+          then Right uri
+          else Left (DomainIsBlocked domains)