diff --git a/config.json b/config.json
index 791220362d31985cd1329d8d69a8c6784ca4d131..d2417ebb431c91c98a4ddf00d3e6360d77df0363 100644
--- a/config.json
+++ b/config.json
@@ -5,17 +5,21 @@
"AllowScripts":false,
"MaxLintLevel":"Warning",
"DontCopyAssets":false,
- "UriSchemas": {
- "https" : {
- "scope" : ["website", "audio"],
+ "UriSchemas": [
+ ["https", {
+ "scope" : ["website"],
"allowed" : ["media.ccc.de", "streaming.media.ccc.de", "static.rc3.world", "cdn.c3voc.de"],
"blocked" : ["blocked.com"],
"prefix" : "https:\/\/rc3.world\/2021\/dereferrer\/"
- },
- "world" : {
+ }],
+ ["https", {
+ "scope" : ["audio"],
+ "allowed" : ["cdn.c3voc.de", "media.ccc.de", "streaming.media.ccc.de", "static.rc3.world"]
+ }],
+ ["world", {
"scope" : ["map"],
"substs" : {
}
- }
- }
+ }]
+ ]
}
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index 7b5e46d229e152977e499a4962428571fe15a264..59c6f2ffdf20c459310aee49c814c9e3fb6ff1d4 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 1e9e5381a64eff4912b7d204bddeb151ac4c1ade..904d930741cbf2c55544a8e58f0761d6aeb1ab93 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 d0f0d570419e5161a4d8571e06cbf80513e7da3d..16c8c63241b69d6fbb0286611d82311c76ea269f 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 40dc34aefe801602614c51033b6e11901d2ae94e..3aad1da711103ee85b4f206b2e076ccf648e638e 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)