From 5c69c3118d60ff445905201669bd48cc8d2ed909 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Mon, 20 Dec 2021 13:07:49 +0100 Subject: something something encoding mismatch --- lib/Properties.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Properties.hs b/lib/Properties.hs index 05020f5..94cfe24 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -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." -- cgit v1.2.3 From 65e496a811002af9948d0453675567c9eaf827d9 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Mon, 20 Dec 2021 13:51:28 +0100 Subject: generalise unwrapURI a bit --- lib/Properties.hs | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/lib/Properties.hs b/lib/Properties.hs index 94cfe24..37b6bc4 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -566,13 +566,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 @@ -588,6 +592,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 ()) -- cgit v1.2.3 From 3a9af9322c1348b03034b80fb11b5a22e3b811a2 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Mon, 20 Dec 2021 17:14:13 +0100 Subject: turns out apparently C8.unpack assumes ascii (and no one's documented that) Anyways it now uses utf8 which seems a little more reasonable. --- src/Main.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) 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 -- cgit v1.2.3 From 5970aaec26b95b2023b5823a7af89645a11b04a4 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Tue, 21 Dec 2021 13:42:28 +0100 Subject: disallow double courly braces as per yesterday's discussion about extended scripting variables --- lib/Paths.hs | 2 +- lib/Uris.hs | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) 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/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 -- cgit v1.2.3 From 92d73fdfd296a38cb385108ce63291bdc718fc40 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Tue, 21 Dec 2021 13:51:49 +0100 Subject: need rc3_21 slug in inter-assembly-links --- lib/LintConfig.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 -- cgit v1.2.3 From 714ddd55d1cc6ef55941ecba1b0fdbce2f3193db Mon Sep 17 00:00:00 2001 From: stuebinm Date: Tue, 21 Dec 2021 21:20:43 +0100 Subject: correct bbb link substitution (unfortunately this one's hardcoded, the config options just aren't general enough) --- config.json | 6 ------ lib/Properties.hs | 21 +++++++++++---------- 2 files changed, 11 insertions(+), 16 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/Properties.hs b/lib/Properties.hs index 37b6bc4..dd680ea 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. @@ -289,15 +289,16 @@ 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 + 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) + _ -> complain "the \"bbbRoom\" property must take a link of the form bbb://assembly_slug/room_slug." "bbbTrigger" -> do removeProperty "bbbTrigger" requireProperty "bbbRoom" -- cgit v1.2.3 From e8fca76246a313f743180408c5745cb050d1d1a6 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Tue, 21 Dec 2021 21:40:10 +0100 Subject: check that bbbRoom contains a valid assembly_slug --- lib/Properties.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/lib/Properties.hs b/lib/Properties.hs index dd680ea..f60758f 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -291,13 +291,18 @@ checkTileLayerProperty p@(Property name _value) = case name of removeProperty "bbbRoom" unwrapString p $ \str -> case parseUri str of Just ("bbb",assembly_slug, room_slug) - | "/" `isPrefixOf` room_slug && T.length room_slug >= 2 -> 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) + | "/" `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" -- cgit v1.2.3