summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/LintConfig.hs2
-rw-r--r--lib/Paths.hs2
-rw-r--r--lib/Properties.hs51
-rw-r--r--lib/Uris.hs3
4 files changed, 40 insertions, 18 deletions
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