summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorstuebinm2021-12-26 03:05:58 +0100
committerstuebinm2021-12-26 03:05:58 +0100
commit4c9e6efc70b069b279e0e009e4dd836015bbf4df (patch)
treefb9aecf1d3e7d80cd0e5a2bea71f4563704ec6dc /lib
parent687e2369472a220293e89307493a21940ab8e4eb (diff)
separate blocking for separate contexts
(audio links now have their own allowlist, which won't put things through the dereferrer)
Diffstat (limited to 'lib')
-rw-r--r--lib/CheckDir.hs2
-rw-r--r--lib/LintConfig.hs15
-rw-r--r--lib/Properties.hs8
-rw-r--r--lib/Uris.hs45
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)