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