diff options
Diffstat (limited to 'lib/Properties.hs')
| -rw-r--r-- | lib/Properties.hs | 51 |
1 files changed, 36 insertions, 15 deletions
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 ()) |