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.

3 files changed, 41 insertions, 19 deletions

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