diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/CheckMap.hs | 13 | ||||
| -rw-r--r-- | lib/LintConfig.hs | 163 | ||||
| -rw-r--r-- | lib/Properties.hs | 68 | ||||
| -rw-r--r-- | lib/Uris.hs | 90 |
4 files changed, 183 insertions, 151 deletions
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 9e3027c..8611f03 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -10,6 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RecordWildCards #-} -- | Module that contains the high-level checking functions module CheckMap (loadAndLintMap, MapResult(..), ResultKind(..), Optional,shrinkMapResult) where @@ -28,7 +29,7 @@ import Badges (Badge) import Data.Tiled (Layer (layerLayers, layerName), Tiledmap (tiledmapLayers, tiledmapTilesets), loadTiledmap) -import LintConfig (LintConfig (configAssemblyTag), LintConfig') +import LintConfig (LintConfig', LintConfig (..)) import LintWriter (LintResult, invertLintResult, resultToAdjusted, resultToBadges, resultToDeps, resultToLints, resultToOffers, @@ -111,11 +112,12 @@ loadAndLintMap config path depth = loadTiledmap path <&> \case -- | lint a loaded map runLinter :: Bool -> LintConfig' -> Tiledmap -> Int -> MapResult Full -runLinter isMain config tiledmap depth = MapResult +runLinter isMain config@LintConfig{..} tiledmap depth = MapResult { mapresultLayer = invertThing layer , mapresultTileset = invertThing tileset , mapresultGeneral = - ([Hint Error "main.json should link back to the lobby" | isMain && not (any linksLobby layerDeps)]) + [Hint Warning "main.json should link back to the lobby" + | isMain && not (any linksLobby layerDeps)] <> lintsToHints (resultToLints generalResult) , mapresultDepends = resultToDeps generalResult <> layerDeps @@ -127,9 +129,10 @@ runLinter isMain config tiledmap depth = MapResult } where linksLobby = \case - MapLink link -> "/@/rc3_21/lobby" `T.isPrefixOf` link + MapLink link -> + ("/@/"<>configEventSlug<>"/lobby") `T.isPrefixOf` link || configAssemblyTag config == "lobby" - _ -> False + _ -> False layerDeps = concatMap resultToDeps layer layer = checkLayerRec config depth (V.toList $ tiledmapLayers tiledmap) tileset = checkThing tiledmapTilesets checkTileset diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs index 11a8122..b0fa3b0 100644 --- a/lib/LintConfig.hs +++ b/lib/LintConfig.hs @@ -1,19 +1,21 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Module that deals with handling config options -module LintConfig (LintConfig(..), LintConfig', patchConfig) where +module LintConfig (LintConfig(..), LintConfig', ConfigKind (..), patchConfig,stuffConfig,feedConfig) where import Universum -import qualified Universum.Unsafe as Unsafe import Data.Aeson (FromJSON (parseJSON), Options (..), defaultOptions, eitherDecode) @@ -28,38 +30,51 @@ import Uris (SchemaSet, Substitution (DomainSubstitution)) import WithCli.Pure (Argument (argumentType, parseArgument)) -type family HKD f a where - HKD Identity a = a - HKD f a = f a -data LintConfig f = LintConfig - { configScriptInject :: HKD f (Maybe Text) + +data ConfigKind = Complete | Basic | Skeleton | Patch + +-- | a field that must be given in configs for both server & standalone linter +type family ConfigField (f::ConfigKind) a where + ConfigField Patch a = Maybe a + ConfigField _ a = a + +-- | a field that must be given for the standalone linter, but not the server +-- (usually because the server will infer them from its own config) +type family StandaloneField (f :: ConfigKind) a where + StandaloneField Complete a = a + StandaloneField Skeleton a = a + StandaloneField _ a = Maybe a + +-- | a field specific to a single world / assembly +type family WorldField (f :: ConfigKind) a where + WorldField Complete a = a + WorldField _ a = Maybe a + +data LintConfig (f :: ConfigKind) = LintConfig + { configScriptInject :: ConfigField f (Maybe Text) -- ^ Link to Script that should be injected - , configAssemblyTag :: HKD f Text + , configAssemblyTag :: WorldField f Text -- ^ Assembly name (used for jitsiRoomAdminTag) - , configAssemblies :: HKD f [Text] + , configAssemblies :: StandaloneField f [Text] -- ^ list of all assembly slugs (used to lint e.g. world:// links) - , configMaxLintLevel :: HKD f Level + , configEventSlug :: StandaloneField f Text + -- ^ slug of this event (used e.g. to resolve world:// links) + , configMaxLintLevel :: ConfigField f Level -- ^ Maximum warn level allowed before the lint fails - , configDontCopyAssets :: HKD f Bool + , configDontCopyAssets :: ConfigField f Bool -- ^ Don't copy map assets (mostly useful for development) - , configAllowScripts :: HKD f Bool + , configAllowScripts :: ConfigField f Bool -- ^ Allow defining custom scripts in maps - , configUriSchemas :: HKD f SchemaSet + , configUriSchemas :: ConfigField f SchemaSet } deriving (Generic) -type LintConfig' = LintConfig Identity +type LintConfig' = LintConfig Complete --- TODO: should probably find a way to write these constraints nicer ... -deriving instance - ( Show (HKD a (Maybe Text)) - , Show (HKD a Text) - , Show (HKD a Level) - , Show (HKD a [Text]) - , Show (HKD a Bool) - , Show (HKD a SchemaSet) - ) - => Show (LintConfig a) +deriving instance Show (LintConfig Complete) +deriving instance Show (LintConfig Skeleton) +deriving instance Show (LintConfig Patch) +instance NFData (LintConfig Basic) aesonOptions :: Options aesonOptions = defaultOptions @@ -68,23 +83,13 @@ aesonOptions = defaultOptions , fieldLabelModifier = drop 6 } -instance - ( FromJSON (HKD a (Maybe Text)) - , FromJSON (HKD a [Text]) - , FromJSON (HKD a Text) - , FromJSON (HKD a Level) - , FromJSON (HKD a Bool) - , FromJSON (HKD a SchemaSet) - ) - => FromJSON (LintConfig a) - where - parseJSON = genericParseJSON aesonOptions +instance FromJSON (LintConfig Complete) where + parseJSON = genericParseJSON aesonOptions --- need to define this one extra, since Aeson will not make --- Maybe fields optional if the type isn't given explicitly. --- --- Whoever said instances had confusing semantics? -instance {-# Overlapping #-} FromJSON (LintConfig Maybe) where +instance FromJSON (LintConfig Patch) where + parseJSON = genericParseJSON aesonOptions + +instance FromJSON (LintConfig Basic) where parseJSON = genericParseJSON aesonOptions @@ -118,30 +123,66 @@ instance GPatch i o -- abstract, I just wanted to play around with higher kinded types for -- a bit. patch :: - ( Generic (f Maybe) - , Generic (f Identity) - , GPatch (Rep (f Identity)) - (Rep (f Maybe)) + ( Generic (f Patch) + , Generic (f Complete) + , GPatch (Rep (f Complete)) + (Rep (f Patch)) ) - => f Identity - -> f Maybe - -> f Identity + => f Complete + -> f Patch + -> f Complete patch x y = to (gappend (from x) (from y)) -patchConfig :: LintConfig Identity -> Maybe (LintConfig Maybe) -> LintConfig Identity -patchConfig config p = config' - { configUriSchemas = ("world", assemblysubsts) : configUriSchemas config'} - where config' = case p of - Just p -> patch config p - Nothing -> config - assemblysubsts = - DomainSubstitution (M.fromList generated) scope - where generated = (\slug -> (slug, "/@/rc3_21/"<>slug)) <$> configAssemblies config' - scope = (\(DomainSubstitution _ s) -> s) - . snd . Unsafe.head - . filter ((==) "world" . fst) - $ configUriSchemas config' - +patchConfig + :: LintConfig Complete + -> Maybe (LintConfig Patch) + -> LintConfig Complete +patchConfig config p = expandWorlds config' + where + config' = case p of + Just p -> patch config p + Nothing -> config + + +-- | feed a basic server config +feedConfig + :: LintConfig Basic + -> [Text] + -> Text + -> LintConfig Skeleton +feedConfig LintConfig{..} worlds eventslug = expandWorlds $ + LintConfig + { configAssemblies = worlds + , configEventSlug = eventslug + , .. } + +-- | stuff a +stuffConfig :: LintConfig Skeleton -> Text -> LintConfig Complete +stuffConfig LintConfig{..} assemblyslug = + LintConfig + { configAssemblyTag = assemblyslug + , ..} + +class HasWorldList (a :: ConfigKind) +instance HasWorldList 'Complete +instance HasWorldList 'Skeleton + +-- kinda sad that ghc can't solve these contraints automatically, +-- though i guess it also makes sense … +expandWorlds + :: ( ConfigField a SchemaSet ~ SchemaSet + , StandaloneField a [Text] ~ [Text] + , StandaloneField a Text ~ Text + , HasWorldList a) + => LintConfig a -> LintConfig a +expandWorlds config = config { configUriSchemas = configUriSchemas' } + where + configUriSchemas' = + M.insert "world:" [assemblysubsts] (configUriSchemas config) + assemblysubsts = + DomainSubstitution (M.fromList generated) ["map"] + where generated = configAssemblies config + <&> \slug -> (slug, "/@/"<>configEventSlug config<>"/"<>slug) instance (FromJSON (LintConfig a)) => Argument (LintConfig a) where parseArgument str = diff --git a/lib/Properties.hs b/lib/Properties.hs index 63cea1f..b937534 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -15,7 +15,7 @@ module Properties (checkMap, checkTileset, checkLayer) where import Universum hiding (intercalate, isPrefixOf) -import Data.Text (intercalate, isInfixOf, isPrefixOf) +import Data.Text (intercalate, isPrefixOf) import qualified Data.Text as T import Data.Tiled (Layer (..), Object (..), Property (..), PropertyValue (..), Tile (..), @@ -42,8 +42,7 @@ import LintWriter (LintWriter, adjust, askContext, import Paths (PathResult (..), RelPath (..), getExtension, isOldStyle, parsePath) import Types (Dep (Link, Local, LocalMap, MapLink)) -import Uris (SubstError (..), applySubsts, - extractDomain, parseUri) +import Uris (SubstError (..), applySubsts) @@ -140,12 +139,9 @@ checkMapProperty p@(Property name _) = case name of -- "canonical" form, but allowing that here so that multiple -- scripts can be used by one map _ | T.toLower name == "script" -> - unwrapString p $ \str -> - unless (checkIsRc3Url str && - not ( "/../" `isInfixOf` str) && - not ( "%" `isInfixOf` str) && - not ( "@" `isInfixOf` str)) - $ forbid "only scripts hosted on static.rc3.world are allowed." + unwrapURI (Proxy @"script") p + (dependsOn . Link) + (const $ forbid "scripts loaded from local files are disallowed") | name `elem` ["jitsiRoom", "playAudio", "openWebsite" , "url", "exitUrl", "silent", "getBadge"] -> complain $ "property " <> name @@ -342,11 +338,6 @@ checkObjectGroupProperty (Property name _) = case name of \not the object layer." _ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers" -checkIsRc3Url :: Text -> Bool -checkIsRc3Url text= case extractDomain text of - Nothing -> False - Just domain -> do - domain == "https://static.rc3.world" -- | Checks a single (custom) property of a "normal" tile layer @@ -405,7 +396,8 @@ checkTileThing removeExits p@(Property name _value) = case name of unwrapURI (Proxy @"map") p (\link -> do assemblyslug <- lintConfig configAssemblyTag - case T.stripPrefix ("/@/rc3_21/"<>assemblyslug<>"/") link of + eventslug <- lintConfig configEventSlug + case T.stripPrefix ("/@/"<>eventslug<>"/"<>assemblyslug<>"/") link of Nothing -> do dependsOn (MapLink link) setProperty "exitUrl" link @@ -424,8 +416,8 @@ checkTileThing removeExits p@(Property name _value) = case name of let ext = getExtension path in if | isOldStyle path -> complain "Old-Style inter-repository links (using {<placeholder>}) \ - \cannot be used at rC3 2021; please use world:// instead \ - \(see howto.rc3.world)." + \cannot be used at divoc bb3; please use world:// instead \ + \(see https://di.c3voc.de/howto:world)." | ext == "tmx" -> complain "Cannot use .tmx map format; use Tiled's json export instead." | ext /= "json" -> @@ -471,22 +463,21 @@ checkTileThing removeExits p@(Property name _value) = case name of , "jitsiroomadmintag", "jitsiinterfaceconfig" , "openwebsitepolicy", "allowapi" ] -> forbidProperty name - -- the openWebsite Api can only be allowed if the website is on static.rc3.world - | T.toLower name == "openwebsiteallowapi" - -> do - properties <- askContext <&> getProperties - unless (all (\(Property name value) -> case value of - StrProp str -> name /= "openWebsite" || checkIsRc3Url str - _ -> True - ) properties) - $ complain "\"openWebsiteAllowApi\" can only be used with websites hosted \ - \on https://static.rc3.world" | name `elem` [ "openWebsite", "openTab" ] -> do uselessEmptyLayer - suggestProperty $ Property "openWebsiteTrigger" (StrProp "onaction") - unwrapURI (Proxy @"website") p - (dependsOn . Link) - (const $ forbid "accessing local html files is disallowed.") + suggestProperty $ Property "openWebsiteTrigger" "onaction" + + properties <- askContext <&> getProperties + let isScript = any (\(Property name _) -> + T.toLower name == "openwebsiteallowapi") + properties + if isScript + then unwrapURI (Proxy @"script") p + (dependsOn . Link) + (const $ forbid "accessing local html files is disallowed") + else unwrapURI (Proxy @"website") p + (dependsOn . Link) + (const $ forbid "accessing local html files is disallowed.") | otherwise -> when (not removeExits || name `notElem` [ "collides", "name", "tilesetCopyright" ]) $ do warnUnknown p knownTileLayerProperites @@ -634,11 +625,6 @@ setProperty name value = adjust $ \ctxt -> $ \ps -> Just $ Property name (asProperty value) : filter sameName ps where sameName (Property name' _) = name /= name' -removeProperty :: HasProperties ctxt => Text -> LintWriter ctxt -removeProperty name = adjust $ \ctxt -> - flip adjustProperties ctxt - $ \ps -> Just $ filter (\(Property name' _) -> name' /= name) ps - naiveEscapeProperty :: HasProperties a => Property -> LintWriter a naiveEscapeProperty prop@(Property name _) = unwrapString prop (setProperty name . naiveEscapeHTML) @@ -691,7 +677,9 @@ unwrapBadgeToken str f = case parseToken str of Nothing -> complain "invalid badge token." --- | unwraps a URI +-- | unwraps a link, giving two cases: +-- - the link might be an (allowed) remote URI +-- - the link might be relative to this map (i.e. just a filepath) unwrapURI :: (KnownSymbol s, HasProperties a) => Proxy s -> Property @@ -715,12 +703,12 @@ unwrapURI sym p@(Property name _) f g = unwrapString p $ \link -> do DomainDoesNotExist domain -> "The domain " <> domain <> " does not exist; \ \please make sure it is spelled correctly." SchemaDoesNotExist schema -> - "the URI schema " <> schema <> ":// cannot be used." + "the URI schema " <> schema <> "// cannot be used." WrongScope schema allowed -> - "the URI schema " <> schema <> ":// cannot be used in property \ + "the URI schema " <> schema <> "// cannot be used in property \ \\"" <> name <> "\"; allowed " <> (if length allowed == 1 then "is " else "are ") - <> intercalate ", " (fmap (<> "://") allowed) <> "." + <> intercalate ", " (map (<> "//") allowed) <> "." VarsDisallowed -> "extended API links are disallowed in links" diff --git a/lib/Uris.hs b/lib/Uris.hs index 596c272..40ea43e 100644 --- a/lib/Uris.hs +++ b/lib/Uris.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} -- | Functions to deal with uris and custom uri schemes module Uris where @@ -16,7 +17,8 @@ import Data.Aeson (FromJSON (..), Options (..), import qualified Data.Map.Strict as M import qualified Data.Text as T import GHC.TypeLits (KnownSymbol, symbolVal) -import Network.URI (URI (..), URIAuth (..), parseURI) +import Network.URI (URI (..), URIAuth (..), parseURI, + uriToString) import qualified Network.URI.Encode as URI data Substitution = @@ -24,7 +26,7 @@ data Substitution = | DomainSubstitution { substs :: Map Text Text, scope :: [String] } | Allowed { scope :: [String], allowed :: [Text] } | Unrestricted { scope :: [String] } - deriving (Generic, Show) + deriving (Generic, Show, NFData) instance FromJSON Substitution where @@ -33,30 +35,23 @@ instance FromJSON Substitution where , rejectUnknownFields = True } -type SchemaSet = Map Text Substitution +type SchemaSet = Map Text [Substitution] -extractDomain :: Text -> Maybe Text -extractDomain url = - case parseUri url of - Nothing -> Nothing - Just (_,domain,_) -> Just domain - - - - -parseUri :: Text -> Maybe (Text, Text, Text) -parseUri uri = - case parseURI (toString uri) of +-- | deconstruct a URI into a triple of [schema:]//[domain]/[tail...], +-- and a normalised version of the same URI +parseUri :: Text -> Maybe (Text, Text, Text, Text) +parseUri raw = + case parseURI (toString raw) of Nothing -> Nothing - Just parsedUri -> case uriAuthority parsedUri of + Just uri@URI{..} -> case uriAuthority of Nothing -> Nothing - -- https: - Just uriAuth -> Just (T.replace (fromString ":") (fromString "") (fromString (uriScheme parsedUri )), - -- //anonymous@ www.haskell.org :42 - fromString(uriUserInfo uriAuth++uriRegName uriAuth ++ uriPort uriAuth), - -- /ghc ?query #frag - fromString(uriPath parsedUri ++ uriQuery parsedUri ++ uriFragment parsedUri)) + Just URIAuth {..} -> Just + ( fromString uriScheme + , fromString $ uriUserInfo <> uriRegName <> uriPort + , fromString $ uriPath <> uriQuery <> uriFragment + , fromString $ uriToString id uri "" + ) data SubstError = @@ -66,41 +61,46 @@ data SubstError = | IsBlocked | DomainIsBlocked [Text] | VarsDisallowed + | WrongScope Text [Text] -- ^ This link's schema exists, but cannot be used in this scope. -- The second field contains a list of schemas that may be used instead. - | WrongScope Text [Text] deriving (Eq, Ord) -- errors are ordered so we can show more specific ones applySubsts :: KnownSymbol s => Proxy s -> SchemaSet -> Text -> Either SubstError Text applySubsts s substs uri = do - when (T.isInfixOf (toText "{{") uri || T.isInfixOf (toText "}}") uri) + when (T.isInfixOf "{{" uri || T.isInfixOf "}}" uri) $ Left VarsDisallowed - parts@(schema, _, _) <- note NotALink $ parseUri uri + parts@(schema, _, _, _) <- maybeToRight NotALink $ parseUri uri - let rule = M.lookup schema substs + let rules = filter (elem thisScope . scope) . concat $ M.lookup schema substs - case map (applySubst parts) rule of - Nothing -> Left (SchemaDoesNotExist schema) - Just result -> result + case nonEmpty $ map (applySubst parts) rules of + Nothing -> Left (SchemaDoesNotExist schema) + Just result -> minimum result where - note = maybeToRight - applySubst (schema, domain, rest) rule = do + thisScope = symbolVal s + applySubst (schema, domain, rest, uri) rule = do + + -- is this scope applicable? unless (symbolVal s `elem` scope rule) $ Left (WrongScope schema - (map fst . filter (elem (symbolVal s) . scope . snd) $ toPairs substs)) + $ map fst -- make list of available uri schemes + . filter (any (elem thisScope . scope) . snd) + $ toPairs substs) + case rule of DomainSubstitution table _ -> do - prefix <- note (DomainDoesNotExist (schema <> toText "://" <> domain)) - $ M.lookup domain table + prefix <- case M.lookup domain table of + Nothing -> Left (DomainDoesNotExist (schema <> "//" <> domain)) + Just a -> Right a pure (prefix <> rest) Prefixed {..} | domain `elem` blocked -> Left IsBlocked - | domain `elem` allowed || toText "streamproxy.rc3.world" `T.isSuffixOf` domain -> Right uri + | domain `elem` allowed -> Right uri | otherwise -> Right (prefix <> URI.encodeText uri) - Allowed _ domains -> if domain `elem` domains - || toText "streamproxy.rc3.world" `T.isSuffixOf` domain - then Right uri - else Left (DomainIsBlocked domains) + Allowed _ allowlist + | domain `elem` allowlist -> Right uri + | otherwise -> Left (DomainIsBlocked allowlist) Unrestricted _ -> Right uri |