diff options
Diffstat (limited to 'lib/Properties.hs')
-rw-r--r-- | lib/Properties.hs | 753 |
1 files changed, 0 insertions, 753 deletions
diff --git a/lib/Properties.hs b/lib/Properties.hs deleted file mode 100644 index e72bfd0..0000000 --- a/lib/Properties.hs +++ /dev/null @@ -1,753 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# 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<>"." |