summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--config.json6
-rw-r--r--lib/LintConfig.hs2
-rw-r--r--lib/Paths.hs2
-rw-r--r--lib/Properties.hs51
-rw-r--r--lib/Uris.hs3
-rw-r--r--src/Main.hs5
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 17:58:38 +0000