From 4c9e6efc70b069b279e0e009e4dd836015bbf4df Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sun, 26 Dec 2021 03:05:58 +0100 Subject: separate blocking for separate contexts (audio links now have their own allowlist, which won't put things through the dereferrer) --- config.json | 18 +++++++++++------- lib/CheckDir.hs | 2 +- lib/LintConfig.hs | 15 +++++++++------ lib/Properties.hs | 8 +++++--- lib/Uris.hs | 45 ++++++++++++++++++++++++++++++--------------- 5 files changed, 56 insertions(+), 32 deletions(-) diff --git a/config.json b/config.json index 7912203..d2417eb 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 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) -- cgit v1.2.3