diff options
Diffstat (limited to 'walint/Properties.hs')
| -rw-r--r-- | walint/Properties.hs | 748 |
1 files changed, 748 insertions, 0 deletions
diff --git a/walint/Properties.hs b/walint/Properties.hs new file mode 100644 index 0000000..7b5a181 --- /dev/null +++ b/walint/Properties.hs @@ -0,0 +1,748 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Contains checks for custom ties of the map json +module Properties (checkMap, checkTileset, checkLayer) where + +import Universum hiding (intercalate, isPrefixOf) + +import Data.Text (intercalate, isPrefixOf) +import qualified Data.Text as T +import Data.Tiled (Layer (..), Object (..), Property (..), + PropertyValue (..), Tile (..), + Tiledmap (..), Tileset (..)) +import Data.Tiled.Abstract (HasData (..), HasName (..), + HasProperties (..), HasTypeName (..), + IsProperty (..), layerIsEmpty) +import qualified Data.Vector as V +import Util (mkProxy, naiveEscapeHTML, prettyprint) + +import Badges (Badge (Badge), + BadgeArea (BadgePoint, BadgeRect), + BadgeToken, parseToken) +import Data.List ((\\)) +import qualified Data.Set as S +import Data.Text.Metrics (damerauLevenshtein) +import GHC.TypeLits (KnownSymbol) +import LayerData (Collision, layerOverlaps) +import LintConfig (LintConfig (..)) +import LintWriter (LintWriter, adjust, askContext, + askFileDepth, complain, dependsOn, forbid, + lintConfig, offersBadge, offersCWs, + offersEntrypoint, offersJitsi, suggest, + warn, zoom) +import Paths (PathResult (..), RelPath (..), + getExtension, isOldStyle, parsePath) +import Types (Dep (Link, Local, LocalMap, MapLink)) +import Uris (SubstError (..), applySubsts) + + +knownMapProperties :: Vector Text +knownMapProperties = V.fromList + [ "mapName", "mapDescription", "mapCopyright", "mapLink", "script" + , "contentWarnings" ] + +knownTilesetProperties :: Vector Text +knownTilesetProperties = V.fromList + [ "tilesetCopyright", "collides"] + +knownObjectProperties :: Vector Text +knownObjectProperties = V.fromList + [ "name", "url", "getBadge", "soundRadius", "default", "persist", "openLayer" + , "closeLayer", "door", "bell", "openSound", "closeSound", "bellSound" + , "allowapi"] + +knownTileLayerProperites :: Vector Text +knownTileLayerProperites = V.fromList + [ "jitsiRoom", "jitsiTrigger", "jitsiTriggerMessage", "jitsiWidth" + , "playAudio", "audioLoop", "audioVolumne" + , "openWebsite", "openWebsiteTrigger", "openWebsiteTriggerMessage", "openTag" + , "exitUrl", "startLayer", "silent", "getBadge", "zone", "name", "doorVariable" + , "bindVariable", "bellVariable", "code", "openTriggerMessage" + , "closeTriggerMessage", "autoOpen", "autoClose", "bellButtonText", "bellPopup" + , "enterValue", "leaveValue" ] + +-- | Checks an entire map for "general" lints. +-- +-- Note that it does /not/ check any tile layer/tileset properties; +-- these are handled seperately in CheckMap, since these lints go +-- into a different field of the output. +checkMap :: LintWriter Tiledmap +checkMap = do + tiledmap <- askContext + let layers = collectLayers tiledmap + let unlessLayer = unlessElement layers + + -- test custom map properties + mapM_ checkMapProperty (maybeToMonoid $ tiledmapProperties tiledmap) + + -- can't have these with the rest of layer/tileset lints since they're + -- not specific to any one of them + refuseDoubledNames layers + refuseDoubledNames (tiledmapTilesets tiledmap) + refuseDoubledNames (getProperties tiledmap) + + -- some layers should exist + unlessElementNamed layers "start" + $ complain "The map must have one layer named \"start\"." + unlessLayer (\l -> getName l == "floorLayer" && layerType l == "objectgroup") + $ complain "The map must have one layer named \"floorLayer\" of type \"objectgroup\"." + unlessLayer (`containsProperty` "exitUrl") + $ complain "The map must contain at least one layer with the property \"exitUrl\" set." + + -- reject maps not suitable for workadventure + unless (tiledmapOrientation tiledmap == "orthogonal") + $ complain "The map's orientation must be set to \"orthogonal\"." + unless (tiledmapTileheight tiledmap == 32 && tiledmapTilewidth tiledmap == 32) + $ complain "The map's tile size must be 32 by 32 pixels." + + unlessHasProperty "mapCopyright" + $ suggest "document the map's copyright via the \"mapCopyright\" property." + + unlessHasProperty "contentWarnings" + $ suggest "set content warnings for your map via the \"contentWarnings\" property." + + -- TODO: this doesn't catch collisions with the default start layer! + whenLayerCollisions layers (\(Property name _) -> name == "exitUrl" || name == "startLayer") + $ \cols -> warn $ "collisions between entry and / or exit layers: " <> prettyprint cols + + let missingMetaInfo = + ["mapName","mapDescription","mapLink"] + \\ map getName (getProperties tiledmap) + + unless (null missingMetaInfo) + $ suggest $ "consider adding meta information to your map using the " + <> prettyprint missingMetaInfo <> " properties." + + where + -- recursively find all layers (to deal with nested group layers) + collectLayers :: Tiledmap -> V.Vector Layer + collectLayers tiledmap = tiledmapLayers tiledmap <> + V.fromList (concatMap groupmembers (tiledmapLayers tiledmap)) + where groupmembers :: Layer -> [Layer] + groupmembers layer = concatMap groupmembers layers <> layers + where layers = fromMaybe [] $ layerLayers layer + +-- | Checks a single property of a map. +checkMapProperty :: Property -> LintWriter Tiledmap +checkMapProperty p@(Property name _) = case name of + "mapName" -> naiveEscapeProperty p + "mapDescription" -> naiveEscapeProperty p + "mapCopyright" -> naiveEscapeProperty p + "mapLink" -> pure () + "contentWarnings" -> + unwrapString p $ \str -> do + offersCWs (T.splitOn "," str) + -- usually the linter will complain if names aren't in their + -- "canonical" form, but allowing that here so that multiple + -- scripts can be used by one map + _ | T.toLower name == "script" -> + 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 + <> " should be set on layers, not the map directly" + | otherwise + -> warnUnknown p knownMapProperties + + +-- | check an embedded tileset. +-- +-- Important to collect dependency files +checkTileset :: LintWriter Tileset +checkTileset = do + tileset <- askContext + case tilesetImage tileset of + Just str -> unwrapPath str (dependsOn . Local) + Nothing -> complain "Tileset does not refer to an image." + + refuseDoubledNames (getProperties tileset) + + -- reject tilesets unsuitable for workadventure + unless (tilesetTilewidth tileset == 32 && tilesetTileheight tileset == 32) + $ complain "Tilesets must have tile size 32x32." + + when (tilesetImageheight tileset > 4096 || tilesetImagewidth tileset > 4096) + $ warn "Tilesets should not be larger than 4096x4096 pixels in total." + + when (isJust (tilesetSource tileset)) + $ complain "Tilesets must be embedded and cannot be loaded from external files." + + unlessHasProperty "tilesetCopyright" + $ forbid "property \"tilesetCopyright\" for tilesets must be set." + + when (isJust (tilesetFileName tileset)) + $ complain "The \"filename\" property on tilesets was removed; use \"image\" instead (and perhaps a newer version of the Tiled Editor)." + + -- check properties of individual tiles + tiles' <- forM (tilesetTiles tileset) $ mapM $ \tile -> do + mapM_ (checkTileProperty tile) (getProperties tile) + zoom (const tileset) (const tile) $ mapM_ (checkTileThing True) (getProperties tile) + + adjust (\t -> t { tilesetTiles = tiles' }) + + -- check individual tileset properties + mapM_ checkTilesetProperty (maybeToMonoid $ tilesetProperties tileset) + + case tilesetTiles tileset of + Nothing -> pure () + Just tiles -> ifDoubledThings tileId + -- can't set properties on the same tile twice + (\tile -> complain $ "cannot set properties on the \ + \tile with the id" <> show (tileId tile) <> "twice.") + tiles + + where + checkTilesetProperty :: Property -> LintWriter Tileset + checkTilesetProperty p@(Property name _value) = case name of + "tilesetCopyright" -> naiveEscapeProperty p + "collides" -> warn "property \"collides\" should be set on individual tiles, not the tileset" + _ -> warn $ "unknown tileset property " <> prettyprint name + + checkTileProperty :: Tile -> Property -> LintWriter Tileset + checkTileProperty tile p@(Property name _) = + case name of + "collides" -> isBool p + -- named tiles are needed for scripting and do not hurt otherwise + "name" -> isString p + "tilesetCopyright" -> warn "the \"tilesetCopyright\" property should be set on the entire tileset, \ + \not an individual tile." + _ -> warnUnknown' ("unknown tile property " + <> prettyprint name <> " in tile with global id " + <> show (tileId tile)) p knownTilesetProperties + + +-- | collect lints on a single map layer +checkLayer :: LintWriter Layer +checkLayer = do + layer <- askContext + + refuseDoubledNames (getProperties layer) + + when (isJust (layerImage layer)) + $ complain "imagelayer are not supported." + + case layerType layer of + "tilelayer" -> mapM_ (checkTileThing False) (getProperties layer) + "group" -> pure () + "objectgroup" -> do + + -- check object properties + objs <- forM (layerObjects layer) $ mapM $ \object -> do + -- this is a confusing constant zoom ... + zoom (const layer) (const object) $ mapM_ checkObjectProperty (getProperties object) + adjust (\l -> l { layerObjects = objs }) + + -- all objects which don't define badges + let publicObjects = map (V.filter (not . (`containsProperty` "getBadge"))) objs + + -- remove badges from output + adjust $ \l -> l { layerObjects = publicObjects + , layerProperties = Nothing } + + -- check layer properties + forM_ (getProperties layer) checkObjectGroupProperty + + unless (layerName layer == "floorLayer") $ + when (isNothing (layerObjects layer) || layerObjects layer == Just mempty) $ + warn "objectgroup layer (which aren't the floorLayer) \ + \are useless if they are empty." + + ty -> complain $ "unsupported layer type " <> prettyprint ty <> "." + + if layerType layer == "group" + then when (isNothing (layerLayers layer)) + $ warn "Empty group layers are pointless." + else when (isJust (layerLayers layer)) + $ complain "Layer is not of type \"group\", but has sublayers." + +checkObjectProperty :: Property -> LintWriter Object +checkObjectProperty p@(Property name _) = do + obj <- askContext + case name of + "url" -> do + unwrapURI (Proxy @"website") p + (dependsOn . Link) + (const $ forbid "using \"url\" to open local html files is disallowed.") + unless (objectType obj == "website") + $ complain "\"url\" can only be set for objects of type \"website\"" + "getBadge" -> do + when (1 /= length (getProperties obj)) + $ warn "Objects with the property \"getBadge\" set are removed at runtime, \ + \and any other properties set on them will be gone." + unwrapString p $ \str -> + unwrapBadgeToken str $ \token -> do + case obj of + ObjectPolygon {} -> complain "polygons are not supported." + ObjectPolyline {} -> complain "polylines are not supported." + ObjectText {} -> complain "cannot use texts to define badge areas." + ObjectRectangle {..} -> + if objectEllipse == Just True + then complain "ellipses are not supported." + else offersBadge + $ Badge token $ case (objectWidth, objectHeight) of + (Just w, Just h) | w /= 0 && h /= 0 -> + BadgeRect objectX objectY w h + _ -> BadgePoint objectX objectY + "soundRadius" -> do + isIntInRange 0 maxBound p + unless (containsProperty obj "door" || containsProperty obj "bell") + $ complain "property \"soundRadius\" can only be set on objects with \ + \either property \"bell\" or \"door\" also set." + + _ | name `elem` [ "default", "persist" ] -> + suggestPropertyName' "door" + -- extended API for doors and bells + | name `elem` [ "openLayer", "closeLayer" ] -> do + isString p + suggestPropertyName' "door" + -- extended API for doors and bells + | name `elem` ["door", "bell"] -> do + isBool p + unless (objectType obj == "variable") $ + complain $ "the "<>prettyprint name<>" property should only be set \ + \on objects of type \"variable\"" + when (isNothing (objectName obj) || objectName obj == Just mempty) $ + complain $ "Objects with the property "<>prettyprint name<>" set must \ + \be named." + | name `elem` [ "openSound", "closeSound", "bellSound", "loadSound" ] -> do + isString p + unwrapURI (Proxy @"audio") p + (dependsOn . Link) + (dependsOn . Local) + case name of + "bellSound" -> + suggestPropertyName' "bell" + "closeSound" | containsProperty obj "openSound" -> + suggestPropertyName' "door" + _ -> do + suggestPropertyName' "door" + suggestPropertyName "soundRadius" + "set \"soundRadius\" to limit the door sound to a certain area." + | T.toLower name == "allowapi" + -> forbidProperty name + | otherwise -> + warnUnknown p knownObjectProperties + +-- | Checks a single (custom) property of an objectgroup layer +checkObjectGroupProperty :: Property -> LintWriter Layer +checkObjectGroupProperty (Property name _) = case name of + "getBadge" -> warn "the property \"getBadge\" must be set on individual objects, \ + \not the object layer." + _ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers" + + + +-- | Checks a single (custom) property. Since almost all properties +-- can be set on tile layer AND on tilesets, this function aims to +-- be generic over both — the only difference is that tilesets can't +-- have exits, which is specified by the sole boolean argument +checkTileThing + :: (HasProperties a, HasName a, HasData a) + => Bool -> Property -> LintWriter a +checkTileThing removeExits p@(Property name _value) = case name of + "jitsiRoom" -> do + uselessEmptyLayer + -- members of an assembly should automatically get + -- admin rights in jitsi (prepending "assembly-" here + -- to avoid namespace clashes with other admins) + lintConfig configAssemblyTag + >>= setProperty "jitsiRoomAdminTag" + . ("assembly-" <>) + unwrapString p $ \jitsiRoom -> do + suggestProperty $ Property "jitsiTrigger" "onaction" + + -- prevents namespace clashes for jitsi room names + if not ("shared" `isPrefixOf` jitsiRoom) then do + assemblyname <- lintConfig configAssemblyTag + setProperty "jitsiRoom" (assemblyname <> "-" <> jitsiRoom) + offersJitsi (assemblyname <> "-" <> jitsiRoom) + else + offersJitsi jitsiRoom + "jitsiTrigger" -> do + isString p + unlessHasProperty "jitsiTriggerMessage" + $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite \ + \the default \"press SPACE to enter in jitsi meet room\"." + requireProperty "jitsiRoom" + "jitsiTriggerMessage" -> do + isString p + requireProperty "jitsiTrigger" + "jitsiWidth" -> + isIntInRange 0 100 p + "playAudio" -> do + uselessEmptyLayer + unwrapURI (Proxy @"audio") p + (dependsOn . Link) + (dependsOn . Local) + "audioLoop" -> do + isBool p + requireProperty "playAudio" + "playAudioLoop" -> + deprecatedUseInstead "audioLoop" + "audioVolume" -> do + isOrdInRange unwrapFloat 0 1 p + requireProperty "playAudio" + "openWebsiteTrigger" -> do + isString p + requireOneOf ["openWebsite", "openTab"] + unlessHasProperty "openWebsiteTriggerMessage" + $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to \ + \overwrite the default \"press SPACE to open Website\"." + "openWebsiteTriggerMessage" -> do + isString p + requireProperty "openWebsiteTrigger" + "url" -> complain "the property \"url\" defining embedded iframes must be \ + \set on an object in an objectgroup layer." + "exitUrl" -> if not removeExits + then do + forbidEmptyLayer + unwrapURI (Proxy @"map") p + (\link -> do + assemblyslug <- lintConfig configAssemblyTag + eventslug <- lintConfig configEventSlug + case T.stripPrefix ("/@/"<>eventslug<>"/"<>assemblyslug<>"/") link of + Nothing -> do + dependsOn (MapLink link) + setProperty "exitUrl" link + Just path -> case parsePath path of + OkRelPath (Path _ p frag) -> do + up <- askFileDepth + dependsOn (LocalMap (Path up p frag)) + setProperty "exitUrl" path + warn "You should use relative links to your own assembly instead \ + \of world://-style links (I've tried to adjust them \ + \automatically for now)." + _ -> complain "There's a path I don't understand here. Perhaps try \ + \asking a human?" + ) + ( \path -> + let ext = getExtension path in + if | isOldStyle path -> do + eventslug <- lintConfig configEventSlug + complain $ + "Old-Style inter-repository links (using {<placeholder>}) \ + \cannot be used at "<>eventslug<>"; please use world:// \ + \instead (see the howto)." + | ext == "tmx" -> + complain "Cannot use .tmx map format; use Tiled's json export instead." + | ext /= "json" -> + complain "All exit links must link to .json files." + | otherwise -> dependsOn . LocalMap $ path + ) + else do + warn "exitUrls in Tilesets are not unsupported; if you want to \ + \add an exit, please use a tile layer instead." + "exitSceneUrl" -> + deprecatedUseInstead "exitUrl" + "exitInstance" -> + deprecatedUseInstead "exitUrl" + "startLayer" -> do + forbidEmptyLayer + layer <- askContext + unwrapBool p $ \case + True -> offersEntrypoint $ getName layer + False -> warn "property \"startLayer\" is useless if set to false." + "silent" -> do + isBool p + uselessEmptyLayer + "getBadge" -> complain "\"getBadge\" must be set on an \"objectgroup\" \ + \ layer; it does not work on tile layers." + + -- extended API stuff + "zone" -> do + isString p + uselessEmptyLayer + -- name on tile layer unsupported + "name" -> isUnsupported + _ | name `elem` [ "doorVariable", "bindVariable", "bellVariable" ] + -> do { isString p; requireProperty "zone" } + | name `elem` [ "code", "openTriggerMessage", "closeTriggerMessage"] + -> do { isString p; requireProperty "doorVariable" } + | name `elem` [ "autoOpen", "autoClose"] + -> do { isBool p; requireProperty "doorVariable" } + | name `elem` [ "bellButtonText", "bellPopup" ] + -> do { isString p; requireProperty "bellVariable" } + | name `elem` [ "enterValue", "leaveValue" ] + -> do { isString p; requireProperty "bindVariable" } + | T.toLower name `elem` [ "jitsiurl", "jitsiconfig", "jitsiclientconfig" + , "jitsiroomadmintag", "jitsiinterfaceconfig" + , "openwebsitepolicy", "allowapi" ] + -> forbidProperty name + | name `elem` [ "openWebsite", "openTab" ] -> do + uselessEmptyLayer + 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 + where + requireProperty req = propertyRequiredBy req name + requireOneOf names = do + context <- askContext + unless (any (containsProperty context) names) + $ complain $ "property " <> prettyprint name <> " requires one of " + <> prettyprint names + + isUnsupported = warn $ "property " <> name <> " is not (yet) supported by walint." + deprecatedUseInstead instead = + warn $ "property \"" <> name <> "\" is deprecated. Use \"" <> instead <> "\" instead." + + -- | this property can only be used on a layer that contains + -- | at least one tile + forbidEmptyLayer = when removeExits $ do + layer <- askContext + when (layerIsEmpty layer) + $ complain ("property " <> prettyprint name <> " should not be set on an empty layer.") + + -- | this layer is allowed, but also useless on a layer that contains no tiles + uselessEmptyLayer = when removeExits $ do + layer <- askContext + when (layerIsEmpty layer) + $ warn ("property " <> prettyprint name <> " set on an empty layer is useless.") + + +-- | refuse doubled names in everything that's somehow a collection of names +refuseDoubledNames + :: (Container t, HasName (Element t), HasTypeName (Element t)) + => t + -> LintWriter b +refuseDoubledNames = ifDoubledThings getName + (\thing -> complain $ "cannot use " <> typeName (mkProxy thing) <> " name " + <> getName thing <> " multiple times.") + +-- | do `ifDouble` if any element of `things` occurs more than once under +-- the function `f` +ifDoubledThings + :: (Eq a, Ord a, Container t) + => (Element t -> a) + -> (Element t -> LintWriter b) + -> t + -> LintWriter b +ifDoubledThings f ifDouble things = foldr folding base things (mempty, mempty) + where + folding thing cont (seen, twice) + | f thing `elem` seen && f thing `notElem` twice = do + ifDouble thing + cont (seen, S.insert (f thing) twice) + | otherwise = + cont (S.insert (f thing) seen, twice) + base _ = pure () + +-- | we don't know this property; give suggestions for ones with similar names +warnUnknown' :: Text -> Property -> Vector Text -> LintWriter a +warnUnknown' msg (Property name _) knowns = + if snd minDist < 4 + then warn (msg <> ", perhaps you meant " <> prettyprint (fst minDist) <> "?") + else warn msg + where dists = V.map (\n -> (n, damerauLevenshtein name n)) knowns + minDist = V.minimumBy (\(_,a) (_,b) -> compare a b) dists + +warnUnknown :: Property -> Vector Text -> LintWriter a +warnUnknown p@(Property name _) = + warnUnknown' ("unknown property " <> prettyprint name) p + +---- General functions ---- + +unlessElement + :: Container f + => f + -> (Element f -> Bool) + -> LintWriter b + -> LintWriter b +unlessElement things op = unless (any op things) + +unlessElementNamed :: (HasName (Element f), Container f) + => f -> Text -> LintWriter b -> LintWriter b +unlessElementNamed things name = + unlessElement things ((==) name . getName) + +unlessHasProperty :: HasProperties a => Text -> LintWriter a -> LintWriter a +unlessHasProperty name linter = + askContext >>= \ctxt -> + unlessElementNamed (getProperties ctxt) name linter + +-- | does this layer have the given property? +containsProperty :: HasProperties a => a -> Text -> Bool +containsProperty thing name = any + (\(Property name' _) -> name' == name) (getProperties thing) + +-- | should the layers fulfilling the given predicate collide, then perform andthen. +whenLayerCollisions + :: V.Vector Layer + -> (Property -> Bool) + -> (Set Collision -> LintWriter a) + -> LintWriter a +whenLayerCollisions layers f andthen = do + let collisions = layerOverlaps . V.filter (any f . getProperties) $ layers + unless (null collisions) + $ andthen collisions + +----- Functions with concrete lint messages ----- + +-- | this property is forbidden and should not be used +forbidProperty :: HasProperties a => Text -> LintWriter a +forbidProperty name = + forbid $ "property " <> prettyprint name <> " is disallowed." + +propertyRequiredBy :: HasProperties a => Text -> Text -> LintWriter a +propertyRequiredBy req by = + unlessHasProperty req + $ complain $ "property " <> prettyprint req <> + " is required by property " <> prettyprint by <> "." + +-- | suggest some value for another property if that property does not +-- also already exist +suggestProperty :: HasProperties a => Property -> LintWriter a +suggestProperty p@(Property name value) = + suggestProperty' p $ "add property " <> prettyprint name <> " to \"" <> prettyprint value<>"\"." + +suggestProperty' :: HasProperties a => Property -> Text -> LintWriter a +suggestProperty' (Property name _) msg = + unlessHasProperty name (suggest msg) + +suggestPropertyName :: HasProperties a => Text -> Text -> LintWriter a +suggestPropertyName name msg = + unlessHasProperty name (suggest msg) + +suggestPropertyName' :: HasProperties a => Text -> LintWriter a +suggestPropertyName' name = suggestPropertyName name + $ "consider setting property " <> prettyprint name <> "." + +---- Functions for adjusting the context ----- + + +-- | set a property, overwriting whatever value it had previously +setProperty :: (IsProperty prop, HasProperties ctxt) + => Text -> prop -> LintWriter ctxt +setProperty name value = adjust $ \ctxt -> + flip adjustProperties ctxt + $ \ps -> Just $ Property name (asProperty value) : filter sameName ps + where sameName (Property name' _) = name /= name' + +naiveEscapeProperty :: HasProperties a => Property -> LintWriter a +naiveEscapeProperty prop@(Property name _) = + unwrapString prop (setProperty name . naiveEscapeHTML) + +---- "unwrappers" checking that a property has some type, then do something ---- + +-- | asserts that this property is a string, and unwraps it +unwrapString :: Property -> (Text -> LintWriter a) -> LintWriter a +unwrapString (Property name value) f = case value of + StrProp str -> f str + _ -> complain $ "type error: property " + <> prettyprint name <> " should be of type string." + + +-- | asserts that this property is a boolean, and unwraps it +unwrapBool :: Property -> (Bool -> LintWriter a) -> LintWriter a +unwrapBool (Property name value) f = case value of + BoolProp b -> f b + _ -> complain $ "type error: property " <> prettyprint name + <> " should be of type bool." + +unwrapInt :: Property -> (Int -> LintWriter a) -> LintWriter a +unwrapInt (Property name value) f = case value of + IntProp float -> f float + _ -> complain $ "type error: property " <> prettyprint name + <> " should be of type int." + +unwrapFloat :: Property -> (Float -> LintWriter a) -> LintWriter a +unwrapFloat (Property name value) f = case value of + FloatProp float -> f float + _ -> complain $ "type error: property " <> prettyprint name + <> " should be of type float." + +unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a +unwrapPath str f = case parsePath str of + OkRelPath p@(Path up _ _) -> do + depth <- askFileDepth + if up <= depth + then f p + else complain $ "cannot acess paths \"" <> str <> "\" which is outside your repository." + NotAPath -> complain $ "path \"" <> str <> "\" is invalid." + AbsolutePath -> forbid "absolute paths are disallowed. Use world:// instead." + UnderscoreMapLink -> forbid "map links using /_/ are disallowed. Use world:// instead." + AtMapLink -> forbid "map links using /@/ are disallowed. Use world:// instead." + PathVarsDisallowed -> forbid "extended API variables are not allowed in asset paths." + +unwrapBadgeToken :: Text -> (BadgeToken -> LintWriter a) -> LintWriter a +unwrapBadgeToken str f = case parseToken str of + Just a -> f a + Nothing -> complain "invalid badge token." + + +-- | 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 + -> (Text -> LintWriter a) + -> (RelPath -> LintWriter a) + -> LintWriter a +unwrapURI sym p@(Property name _) f g = unwrapString p $ \link -> do + subst <- lintConfig configUriSchemas + case applySubsts sym subst link of + Right uri -> do + setProperty name uri + f uri + Left NotALink -> unwrapPath link g + Left err -> do + isLobby <- lintConfig configAssemblyTag <&> (== "lobby") + + (if isLobby then warn else complain) $ case err of + DomainIsBlocked domains -> link <> " is a blocked site; links in this \ + \context may link to " <> prettyprint domains + IsBlocked -> link <> " is blocked." + DomainDoesNotExist domain -> "The domain " <> domain <> " does not exist; \ + \please make sure it is spelled correctly." + SchemaDoesNotExist schema -> + "the URI schema " <> schema <> "// cannot be used." + WrongScope schema allowed -> + "the URI schema " <> schema <> "// cannot be used in property \ + \\"" <> name <> "\"; allowed " + <> (if length allowed == 1 then "is " else "are ") + <> intercalate ", " (map (<> "//") allowed) <> "." + VarsDisallowed -> "extended API links are disallowed in links" + + + +-- | just asserts that this is a string +isString :: Property -> LintWriter a +isString = flip unwrapString (const $ pure ()) + +-- | just asserts that this is a boolean +isBool :: Property -> LintWriter a +isBool = flip unwrapBool (const $ pure ()) + +isIntInRange :: Int -> Int -> Property -> LintWriter b +isIntInRange = isOrdInRange @Int unwrapInt + +isOrdInRange :: (Ord a, Show a) + => (Property -> (a -> LintWriter b) -> LintWriter b) + -> a + -> a + -> Property + -> LintWriter b +isOrdInRange unwrapa l r p@(Property name _) = unwrapa p $ \int -> + if l < int && int < r then pure () + else complain $ "Property " <> prettyprint name <> " should be between " + <> show l <> " and " <> show r<>"." |