Merge branch 'main' into extended-scripts

6 files changed, 43 insertions, 26 deletions

diff --git a/config.json b/config.json
index 28d347e..f7fc59d 100644
--- a/config.json
+++ b/config.json
@@ -16,12 +16,6 @@
       "scope" : ["map"],
       "substs" : {
       }
-    },
-    "bbb" : {
-      "scope" : ["bbb"],
-      "allowed" : [],
-      "blocked" : [],
-      "prefix" : "https://bbb.rc3.world/"
     }
   }
 }
diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs
index b6e6080..1e9e538 100644
--- a/lib/LintConfig.hs
+++ b/lib/LintConfig.hs
@@ -137,7 +137,7 @@ patchConfig config p = config'
         assemblysubst = \case
           DomainSubstitution subst scope ->
             DomainSubstitution (subst <> M.fromList generated) scope
-            where generated = (\slug -> (slug, "/@/"<>slug)) <$> configAssemblies config'
+            where generated = (\slug -> (slug, "/@/rc3_21/"<>slug)) <$> configAssemblies config'
           other -> other
 
 instance (FromJSON (LintConfig a)) => Argument (LintConfig a) where
diff --git a/lib/Paths.hs b/lib/Paths.hs
index d2861eb..b9b0d50 100644
--- a/lib/Paths.hs
+++ b/lib/Paths.hs
@@ -30,7 +30,7 @@ data PathResult = OkRelPath RelPath
 -- | horrible regex parsing for filepaths that is hopefully kinda safe
 parsePath :: Text -> PathResult
 parsePath text =
-  if | text =~ ("{{{.*}}}" :: Text) -> PathVarsDisallowed
+  if | T.isInfixOf "{{" text || T.isInfixOf "}}" text -> PathVarsDisallowed
      | rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) -> OkRelPath (Path up path fragment)
      | "/_/" `isPrefixOf` text ->  UnderscoreMapLink
      | "/@/" `isPrefixOf` text ->  AtMapLink
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 0eaa245..1c81f87 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -40,7 +40,7 @@ import           LintWriter    (LintWriter, adjust, askContext, askFileDepth,
 import           Paths         (PathResult (..), RelPath (..), getExtension,
                                 isOldStyle, parsePath)
 import           Types         (Dep (Link, Local, LocalMap, MapLink))
-import           Uris          (SubstError (..), applySubst)
+import           Uris          (SubstError (..), applySubst, parseUri)
 
 
 -- | Checks an entire map for "general" lints.
@@ -135,7 +135,7 @@ checkTileset = do
 
   -- reject tilesets unsuitable for workadventure
   unless (tilesetTilewidth tileset == 32 && tilesetTileheight tileset == 32)
-    $ complain "Tilesets must have tile size 32×32."
+    $ complain "Tilesets must have tile size 32x32."
 
   unless (tilesetImageheight tileset < 4096 && tilesetImagewidth tileset < 4096)
     $ warn "Tilesets should not be larger than 4096x4096 pixels in total."
@@ -365,15 +365,21 @@ checkTileLayerProperty p@(Property name _value) = case name of
       isIntInRange 0 100 p
     "bbbRoom" -> do
       removeProperty "bbbRoom"
-      unwrapURI (Proxy @"bbb") p
-        (\link -> do
-            dependsOn (Link link)
-            setProperty "openWebsite" link
-            setProperty "silent" (BoolProp True)
-            setProperty "openWebsitePolicy"
-              ("fullscreen;camera;microphone;display-capture" :: Text)
-        )
-        (const $ complain "property \"bbbRoom\" cannot be used with local links.")
+      unwrapString p $ \str -> case parseUri str of
+        Just ("bbb",assembly_slug, room_slug)
+          | "/" `isPrefixOf` room_slug
+            && T.length room_slug >= 2  -> do
+          assemblies <- lintConfig configAssemblies
+          if assembly_slug `elem` assemblies
+            then do
+              let link = "https://rc3.world/assembly/"<>assembly_slug<>"/bbb"<>room_slug
+              dependsOn (Link link)
+              setProperty "openWebsite" link
+              setProperty "silent" (BoolProp True)
+              setProperty "openWebsitePolicy"
+                ("fullscreen;camera;microphone;display-capture" :: Text)
+            else complain $ prettyprint assembly_slug <> " is not a registered assembly and therefore cannot be used in `bbbUrl`."
+        _ -> complain "the \"bbbRoom\" property must take a link of the form bbb://assembly_slug/room_slug."
     "bbbTrigger" -> do
       removeProperty "bbbTrigger"
       requireProperty "bbbRoom"
@@ -691,13 +697,17 @@ unwrapBadgeToken str f = case parseToken str of
   Nothing -> complain "invalid badge token."
 
 
-unwrapURI :: (KnownSymbol s, HasProperties a)
-  => Proxy s -> Property -> (Text -> LintWriter a) -> (RelPath -> LintWriter a) -> LintWriter a
-unwrapURI sym p@(Property name _) f g = unwrapString p $ \link -> do
+-- | unwraps a URI
+unwrapURI' :: (KnownSymbol s)
+  => Proxy s
+  -> Property
+  -> (Text -> LintWriter a)
+  -> (RelPath -> LintWriter a)
+  -> LintWriter a
+unwrapURI' sym p@(Property name _) f g = unwrapString p $ \link -> do
   subst <- lintConfig configUriSchemas
   case applySubst sym subst link of
     Right uri -> do
-      setProperty name uri
       f uri
     Left NotALink -> unwrapPath link g
     Left err -> complain $ case err of
@@ -713,6 +723,17 @@ unwrapURI sym p@(Property name _) f g = unwrapString p $ \link -> do
         <> intercalate ", " (fmap (<> "://") allowed) <> "."
       VarsDisallowed -> "extended API links are disallowed in links"
 
+-- | unwraps a URI and adjusts the linter's output
+unwrapURI :: (KnownSymbol s, HasProperties a)
+  => Proxy s
+  -> Property
+  -> (Text -> LintWriter a)
+  -> (RelPath -> LintWriter a)
+  -> LintWriter a
+unwrapURI sym p@(Property name _) f =
+  unwrapURI' sym p $ \uri -> setProperty name uri >> f uri
+
+
 -- | just asserts that this is a string
 isString :: Property -> LintWriter a
 isString = flip unwrapString (const $ pure ())
diff --git a/lib/Uris.hs b/lib/Uris.hs
index e2d9a5f..24ddd93 100644
--- a/lib/Uris.hs
+++ b/lib/Uris.hs
@@ -18,6 +18,7 @@ import           Data.Either.Combinators (maybeToRight)
 import           Data.Map.Strict         (Map)
 import qualified Data.Map.Strict         as M
 import           Data.Text               (Text, pack)
+import qualified Data.Text as T
 import           GHC.Generics            (Generic)
 import           GHC.TypeLits            (KnownSymbol, symbolVal)
 import           Text.Regex.TDFA         ((=~))
@@ -66,7 +67,7 @@ data SubstError =
 applySubst :: KnownSymbol s
   => Proxy s -> SchemaSet -> Text -> Either SubstError Text
 applySubst s substs uri =  do
-  when (uri =~ "{{{.*}}}")
+  when (T.isInfixOf (pack "{{") uri || T.isInfixOf (pack "}}") uri)
    $ Left VarsDisallowed
   (schema, domain, rest) <- note NotALink $ parseUri uri
 
diff --git a/src/Main.hs b/src/Main.hs
index 7415e18..32afb6a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -11,8 +11,9 @@ import           Control.Monad.Identity   (Identity)
 import           Data.Aeson               (eitherDecode, encode)
 import           Data.Aeson.Encode.Pretty (encodePretty)
 import           Data.Aeson.KeyMap        (coercionToHashMap)
-import qualified Data.ByteString.Char8    as C8
 import qualified Data.ByteString.Lazy     as LB
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.IO as T
 import           Data.Maybe               (fromMaybe)
 import           System.Exit              (ExitCode (..), exitWith)
 import           WithCli
@@ -88,7 +89,7 @@ run options = do
 
 -- | haskell's many string types are FUN …
 printLB :: LB.ByteString -> IO ()
-printLB a = putStrLn $ C8.unpack $ LB.toStrict a
+printLB a = T.putStrLn $ T.decodeUtf8 $ LB.toStrict a
 
 
 -- if Aesons's internal map and HashMap are the same type, then coercionToHashMap