From a318f848178cade371abfa01a36bf15bab6ec58f Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 16 Dec 2021 22:21:39 +0100
Subject: special handling of world:// and assembly names
these now have their own top-level config attribute which is essentially a
shorthand for setting one that's deeper nested.
---
config.json | 3 +--
lib/LintConfig.hs | 19 ++++++++++++++++++-
lib/Properties.hs | 9 +++++++--
lib/Uris.hs | 32 ++++++++++++++++----------------
4 files changed, 42 insertions(+), 21 deletions(-)
diff --git a/config.json b/config.json
index 0a2f914..35196df 100644
--- a/config.json
+++ b/config.json
@@ -1,5 +1,6 @@
{
"AssemblyTag":"assemblyname",
+ "Assemblies":["test", "metalab"],
"ScriptInject":null,
"AllowScripts":false,
"MaxLintLevel":"Warning",
@@ -14,8 +15,6 @@
"world" : {
"scope" : ["map"],
"substs" : {
- "lounge" : "/@/lalala",
- "lobby" : "/@/lounge"
}
},
"bbb" : {
diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs
index f540ae1..b6e6080 100644
--- a/lib/LintConfig.hs
+++ b/lib/LintConfig.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
@@ -17,11 +18,13 @@ import Data.Aeson (FromJSON (parseJSON), Options (..),
import Data.Aeson.Types (genericParseJSON)
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as LB
+import qualified Data.Map.Strict as M
import Data.Text (Text)
import GHC.Generics (Generic (Rep, from, to), K1 (..),
M1 (..), (:*:) (..))
import Types (Level)
-import Uris (SchemaSet)
+import Uris (SchemaSet,
+ Substitution (DomainSubstitution))
import WithCli (Proxy (..))
import WithCli.Pure (Argument (argumentType, parseArgument))
@@ -34,6 +37,8 @@ data LintConfig f = LintConfig
-- ^ Link to Script that should be injected
, configAssemblyTag :: HKD f Text
-- ^ Assembly name (used for jitsiRoomAdminTag)
+ , configAssemblies :: HKD f [Text]
+ -- ^ list of all assembly slugs (used to lint e.g. world:// links)
, configMaxLintLevel :: HKD f Level
-- ^ Maximum warn level allowed before the lint fails
, configDontCopyAssets :: HKD f Bool
@@ -123,6 +128,18 @@ patch ::
-> f Identity
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'}
+ 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, "/@/"<>slug)) <$> configAssemblies config'
+ other -> other
+
instance (FromJSON (LintConfig a)) => Argument (LintConfig a) where
parseArgument str =
case eitherDecode (LB.fromStrict $ C8.pack str) of
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 6a8c166..f6e2e0c 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -347,7 +347,11 @@ checkTileLayerProperty p@(Property name _value) = case name of
"exitUrl" -> do
forbidEmptyLayer
unwrapURI (Proxy @"map") p
- (dependsOn . MapLink)
+ (\link -> do
+ dependsOn (MapLink link)
+ warn $ "resolved link" <> link
+ setProperty "exitUrl" link
+ )
$ \path ->
let ext = getExtension path in
if | isOldStyle path ->
@@ -568,7 +572,8 @@ unwrapURI sym p@(Property name _) f g = unwrapString p $ \link -> do
Left NotALink -> unwrapPath link g
Left err -> complain $ case err of
IsBlocked -> link <> " is a blocked site."
- InvalidLink -> link <> " is invalid."
+ DomainDoesNotExist domain -> "The domain " <> domain <> " does not exist; \
+ \please make sure it is spelled correctly."
SchemaDoesNotExist schema ->
"the URI schema " <> schema <> ":// does not exist."
WrongScope schema allowed ->
diff --git a/lib/Uris.hs b/lib/Uris.hs
index b674d37..5ad9180 100644
--- a/lib/Uris.hs
+++ b/lib/Uris.hs
@@ -17,14 +17,14 @@ import Data.Data (Proxy)
import Data.Either.Combinators (maybeToRight)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
-import Data.Text (Text)
+import Data.Text (Text, pack)
import GHC.Generics (Generic)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Text.Regex.TDFA ((=~))
data Substitution =
Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] }
- | Explicit { substs :: Map Text Text, scope :: [String] }
+ | DomainSubstitution { substs :: Map Text Text, scope :: [String] }
| Allowed { scope :: [String] }
deriving (Generic, Show)
@@ -56,7 +56,7 @@ data SubstError =
SchemaDoesNotExist Text
| NotALink
| IsBlocked
- | InvalidLink
+ | DomainDoesNotExist Text
| WrongScope Text [Text]
-- ^ 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.
@@ -68,17 +68,17 @@ applySubst s substs uri = do
(schema, domain, rest) <- note NotALink $ parseUri uri
rules <- note (SchemaDoesNotExist schema) ( M.lookup schema substs)
unless (symbolVal s `elem` scope rules)
- $ Left (WrongScope schema
- (M.keys . M.filter (elem (symbolVal s) . scope) $ substs))
+ $ Left (WrongScope schema
+ (M.keys . M.filter (elem (symbolVal s) . scope) $ substs))
case rules of
- Explicit table _ -> do
- prefix <- note InvalidLink $ M.lookup domain table
- pure (prefix <> rest)
- Prefixed {..}
- | domain `elem` blocked -> Left IsBlocked
- | domain `elem` allowed -> Right uri
- | otherwise -> Right (prefix <> domain <> rest)
- Allowed _ -> Right uri
- where note = maybeToRight
-
-
+ DomainSubstitution table _ -> do
+ prefix <- note (DomainDoesNotExist (schema <> pack "://" <> domain))
+ $ M.lookup domain table
+ pure (prefix <> rest)
+ Prefixed {..}
+ | domain `elem` blocked -> Left IsBlocked
+ | domain `elem` allowed -> Right uri
+ | otherwise -> Right (prefix <> domain <> rest)
+ Allowed _ -> Right uri
+ where
+ note = maybeToRight
--
cgit v1.2.3