separate blocking for separate contexts

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

4 files changed, 45 insertions, 25 deletions

diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index 7b5e46d..59c6f2f 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -19,7 +19,7 @@ import           Data.Functor           ((<&>))
 import           Data.Map               (Map, elems, keys)
 import qualified Data.Map               as M
 import           Data.Map.Strict        (mapKeys, mapWithKey, (\\))
-import           Data.Maybe             (mapMaybe, isJust)
+import           Data.Maybe             (isJust, mapMaybe)
 import           Data.Text              (Text, isInfixOf)
 import qualified Data.Text              as T
 import           Dirgraph               (graphToDot, invertGraph, resultToGraph,
diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs
index 1e9e538..904d930 100644
--- a/lib/LintConfig.hs
+++ b/lib/LintConfig.hs
@@ -130,15 +130,18 @@ patch x y = to (gappend (from x) (from y))
 
 patchConfig :: LintConfig Identity -> Maybe (LintConfig Maybe) -> LintConfig Identity
 patchConfig config p = config'
-  { configUriSchemas = M.adjust assemblysubst "world" $ configUriSchemas config'}
+  { configUriSchemas = ("world", assemblysubsts) : configUriSchemas config'}
   where config' = case p of
           Just p  -> patch config p
           Nothing -> config
-        assemblysubst = \case
-          DomainSubstitution subst scope ->
-            DomainSubstitution (subst <> M.fromList generated) scope
-            where generated = (\slug -> (slug, "/@/rc3_21/"<>slug)) <$> configAssemblies config'
-          other -> other
+        assemblysubsts =
+          DomainSubstitution (M.fromList generated) scope
+          where generated = (\slug -> (slug, "/@/rc3_21/"<>slug)) <$> configAssemblies config'
+        scope = (\(DomainSubstitution _ s) -> s)
+         . snd . head
+         . filter ((==) "world" . fst)
+         $ configUriSchemas config'
+
 
 instance (FromJSON (LintConfig a)) => Argument (LintConfig a) where
   parseArgument str =
diff --git a/lib/Properties.hs b/lib/Properties.hs
index d0f0d57..16c8c63 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -44,7 +44,7 @@ import           LintWriter        (LintWriter, adjust, askContext,
 import           Paths             (PathResult (..), RelPath (..), getExtension,
                                     isOldStyle, parsePath)
 import           Types             (Dep (Link, Local, LocalMap, MapLink))
-import           Uris              (SubstError (..), applySubst, parseUri)
+import           Uris              (SubstError (..), applySubsts, parseUri)
 
 
 
@@ -699,7 +699,7 @@ unwrapURI :: (KnownSymbol s, HasProperties a)
   -> LintWriter a
 unwrapURI sym p@(Property name _) f g = unwrapString p $ \link -> do
   subst <- lintConfig configUriSchemas
-  case applySubst sym subst link of
+  case applySubsts sym subst link of
     Right uri -> do
       setProperty name uri
       f uri
@@ -708,7 +708,9 @@ unwrapURI sym p@(Property name _) f g = unwrapString p $ \link -> do
       isLobby <- lintConfig configAssemblyTag <&> (== "lobby")
 
       (if isLobby then warn else complain) $ case err of
-        IsBlocked -> link <> " is a blocked site."
+        DomainIsBlocked domains -> link <> " is a blocked site; links in this \
+                                   \context may link to " <> prettyprint domains
+        IsBlocked -> link <> " is blocked."
         DomainDoesNotExist domain -> "The domain " <> domain <> " does not exist; \
                                      \please make sure it is spelled correctly."
         SchemaDoesNotExist schema ->
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)