diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Badges.hs | 66 | ||||
| -rw-r--r-- | lib/CheckDir.hs | 284 | ||||
| -rw-r--r-- | lib/CheckMap.hs | 234 | ||||
| -rw-r--r-- | lib/Dirgraph.hs | 84 | ||||
| -rw-r--r-- | lib/LayerData.hs | 42 | ||||
| -rw-r--r-- | lib/LintConfig.hs | 193 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 198 | ||||
| -rw-r--r-- | lib/Paths.hs | 86 | ||||
| -rw-r--r-- | lib/Properties.hs | 753 | ||||
| -rw-r--r-- | lib/Types.hs | 130 | ||||
| -rw-r--r-- | lib/Uris.hs | 106 | ||||
| -rw-r--r-- | lib/Util.hs | 79 | ||||
| -rw-r--r-- | lib/WriteRepo.hs | 63 |
13 files changed, 0 insertions, 2318 deletions
diff --git a/lib/Badges.hs b/lib/Badges.hs deleted file mode 100644 index d6afc43..0000000 --- a/lib/Badges.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | module defining Badge types and utility functions -module Badges where - -import Universum - -import Data.Aeson (Options (fieldLabelModifier, sumEncoding), - SumEncoding (UntaggedValue), ToJSON (toJSON), - defaultOptions, genericToJSON, (.=)) -import qualified Data.Aeson as A -import Data.Char (toLower) -import Text.Regex.TDFA ((=~)) - - -data BadgeArea = - BadgePoint - { areaX :: Double - , areaY :: Double - } - | BadgeRect - { areaX :: Double - , areaY :: Double - , areaWidth :: Double - , areaHeight :: Double - } - deriving (Ord, Eq, Generic, Show, NFData) - -newtype BadgeToken = BadgeToken Text - deriving newtype (Eq, Ord, Show, NFData) - -instance ToJSON BadgeArea where - toJSON = genericToJSON defaultOptions - { fieldLabelModifier = drop 4 . map toLower - , sumEncoding = UntaggedValue } - -instance ToJSON BadgeToken where - toJSON (BadgeToken text) = toJSON text - -parseToken :: Text -> Maybe BadgeToken -parseToken text = if text =~ ("^[a-zA-Z0-9]{50}$" :: Text) - then Just (BadgeToken text) - else Nothing - -data Badge = Badge BadgeToken BadgeArea - deriving (Ord, Eq, Generic, Show, NFData) - -instance ToJSON Badge where - toJSON (Badge token area) = A.object $ case area of - BadgePoint x y -> [ "x" .= x - , "y" .= y - , "token" .= token - , "type" .= A.String "point" - ] - BadgeRect {..} -> [ "x" .= areaX - , "y" .= areaY - , "token" .= token - , "width" .= areaWidth - , "height" .= areaHeight - , "type" .= A.String "rectangle" - ] diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs deleted file mode 100644 index 104fdae..0000000 --- a/lib/CheckDir.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Module that contains high-level checking for an entire directory -module CheckDir ( maximumLintLevel - , recursiveCheckDir - , DirResult (..) - , MissingAsset(..) - , MissingDep(..) - , resultIsFatal - ,shrinkDirResult) where - -import Universum hiding (Set) - -import CheckMap (MapResult (..), Optional, - ResultKind (..), loadAndLintMap, - shrinkMapResult) -import Control.Monad.Extra (mapMaybeM) -import Data.Aeson (ToJSON, (.=)) -import qualified Data.Aeson as A -import Data.List (partition) -import qualified Data.Map as M -import Data.Map.Strict (mapKeys, mapWithKey, (\\)) -import Data.Text (isInfixOf) -import qualified Data.Text as T -import Data.Tiled (Tiledmap) -import Dirgraph (graphToDot, invertGraph, resultToGraph, - takeSubGraph, unreachableFrom) -import LintConfig (LintConfig', configMaxLintLevel) -import Paths (normalise, normaliseWithFrag) -import System.Directory.Extra (doesFileExist) -import qualified System.FilePath as FP -import System.FilePath (splitPath, (</>)) -import System.FilePath.Posix (takeDirectory) -import Text.Dot (showDot) -import Types (Dep (Local, LocalMap), Hint (Hint), - Level (..), hintLevel) -import Util (PrettyPrint (prettyprint), ellipsis) - - --- based on the startling observation that Data.Map has lower complexity --- for difference than Data.Set, but the same complexity for fromList -type Set a = Map a () -setFromList :: Ord a => [a] -> Set a -setFromList = M.fromList . flip zip (repeat ()) -listFromSet :: Set a -> [a] -listFromSet = map fst . M.toList - --- | Result of linting an entire directory / repository -data DirResult (complete :: ResultKind) = DirResult - { dirresultMaps :: Map FilePath (MapResult complete) - -- ^ all maps of this respository, by (local) filepath - , dirresultDeps :: [MissingDep] - -- ^ all dependencies to things outside this repository - , dirresultMissingAssets :: [MissingAsset] - -- ^ entrypoints of maps which are referred to but missing - , dirresultGraph :: Text - } deriving (Generic) - -instance NFData (Optional a (Maybe Tiledmap)) => NFData (DirResult a) - - -data MissingDep = MissingDep - { depFatal :: Maybe Bool - , entrypoint :: Text - , neededBy :: [FilePath] - } deriving (Generic, ToJSON, NFData) - --- | Missing assets are the same thing as missing dependencies, --- but should not be confused (and also serialise differently --- to json) -newtype MissingAsset = MissingAsset MissingDep - deriving (Generic, NFData) - - --- | "shrink" the result by throwing the adjusted tiledmaps away -shrinkDirResult :: DirResult Full -> DirResult Shrunk -shrinkDirResult !res = - res { dirresultMaps = fmap shrinkMapResult (dirresultMaps res) } - --- | given this config, should the result be considered to have failed? -resultIsFatal :: LintConfig' -> DirResult Full -> Bool -resultIsFatal config res = - not (null (dirresultMissingAssets res) || not (any (isJust . depFatal) (dirresultDeps res))) - || maximumLintLevel res > configMaxLintLevel config - --- | maximum lint level that was observed anywhere in any map. --- note that it really does go through all lints, so don't --- call it too often -maximumLintLevel :: DirResult a -> Level -maximumLintLevel res - | not (null (dirresultMissingAssets res)) = Fatal - | otherwise = - (maybe Info maximum . nonEmpty) - . map hintLevel - . concatMap (\map -> keys (mapresultLayer map) - <> keys (mapresultTileset map) - <> mapresultGeneral map - ) - . elems - . dirresultMaps - $ res - - - -instance ToJSON (DirResult a) where - toJSON res = A.object [ - "result" .= A.object - [ "missingDeps" .= dirresultDeps res - , "missingAssets" .= dirresultMissingAssets res - -- some repos have auto-generated maps which are basically all the - -- same; aggregate those to reduce output size - , "mapLints" .= (M.fromList - . fmap (first (ellipsis 6)) - . foldr aggregateSameResults [] - . M.toList - $ dirresultMaps res) - , "exitGraph" .= dirresultGraph res - ] - , "severity" .= maximumLintLevel res - , "mapInfo" .= fmap (\tm -> A.object [ "badges" .= mapresultBadges tm ]) - (dirresultMaps res) - ] - where - aggregateSameResults (path,res) acc = - case partition (\(_,res') -> res == res') acc of - ([],_) -> ([toText path], res):acc - ((paths,_):_,acc') -> (toText path:paths, res) : acc' - -instance ToJSON MissingAsset where - toJSON (MissingAsset md) = A.object - [ "asset" .= entrypoint md - , "neededBy" .= neededBy md - ] - - -instance PrettyPrint (Level, DirResult a) where - prettyprint (level, res) = prettyMapLints <> prettyMissingDeps - where - prettyMissingDeps = if not (null (dirresultDeps res)) - then "\nDependency Errors:\n" <> foldMap prettyprint (dirresultDeps res) - else "" - prettyMapLints = T.concat - (map prettyLint $ M.toList $ dirresultMaps res) - prettyLint :: (FilePath, MapResult a) -> Text - prettyLint (p, lint) = - "\nin " <> toText p <> ":\n" <> prettyprint (level, lint) - -instance PrettyPrint MissingDep where - prettyprint (MissingDep _ f n) = - " - " <> f <> " does not exist, but is required by " - <> prettyDependents <> "\n" - where - prettyDependents = - T.intercalate "," $ map toText n - - --- | check an entire repository -recursiveCheckDir - :: LintConfig' - -> FilePath - -- ^ the repository's prefix (i.e. path to its directory) - -> FilePath - -- ^ the repository's entrypoint (filename of a map, from the repo's root) - -> IO (DirResult Full) -recursiveCheckDir config prefix root = do - maps <- recursiveCheckDir' config prefix [root] mempty - - let exitGraph = resultToGraph maps - -- maps that don't have (local) ways back to the main entrypoint - let nowayback = - unreachableFrom root - . invertGraph - $ exitGraph - - -- inject warnings for maps that have no way back to the entrypoint - let maps' = flip mapWithKey maps $ \path res -> - if path `elem` nowayback - then res { mapresultGeneral = - Hint Warning ("Cannot go back to " <> toText root <> " from this map.") - : mapresultGeneral res - } - else res - - mAssets <- missingAssets prefix maps' - pure $ DirResult { dirresultDeps = missingDeps root maps' - , dirresultMissingAssets = mAssets - , dirresultMaps = maps' - , dirresultGraph = - toText - . showDot - . graphToDot - . takeSubGraph 7 root - $ exitGraph - } - - --- | Given a (partially) completed DirResult, check which local --- maps are referenced but do not actually exist. -missingDeps :: FilePath -> Map FilePath (MapResult a) -> [MissingDep] -missingDeps entrypoint maps = - let simple = M.insert (toText entrypoint) [] used \\ M.union defined trivial - in M.foldMapWithKey (\f n -> [MissingDep (Just $ not ("#" `isInfixOf` f)) f n]) simple - where - -- which maps are linked somewhere? - used :: Map Text [FilePath] - used = M.fromList - $ M.foldMapWithKey - (\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v) - maps - where extractLocalDeps prefix = \case - LocalMap name -> Just $ toText $ normaliseWithFrag prefix name - _ -> Nothing - -- which are defined using startLayer? - defined :: Set Text - defined = setFromList - $ M.foldMapWithKey - (\k v -> map ((toText k <> "#") <>) . mapresultProvides $ v) - maps - -- each map file is an entrypoint by itself - trivial = mapKeys toText $ void maps - --- | Checks if all assets referenced in the result actually exist as files -missingAssets :: FilePath -> Map FilePath (MapResult a) -> IO [MissingAsset] -missingAssets prefix maps = - mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList maps) <&> fold - where missingOfMap (path, mapres) = mapMaybeM - (\case Local relpath -> - let asset = normalise (takeDirectory path) relpath - in doesFileExist (prefix </> asset) <&> - \case True -> Nothing - False -> Just $ MissingDep Nothing (toText asset) [path] - _ -> pure Nothing) - (mapresultDepends mapres) - - --- | recursive checking of all maps in a repository -recursiveCheckDir' - :: LintConfig' - -> FilePath - -- ^ the repo's directory - -> [FilePath] - -- ^ paths of maps yet to check - -> Map FilePath (MapResult Full) - -- ^ accumulator for map results - -> IO (Map FilePath (MapResult Full)) -recursiveCheckDir' config prefix paths !acc = do - - -- lint all maps in paths. The double fmap skips maps which cause IO errors - -- (in which case loadAndLintMap returns Nothing); appropriate warnings will - -- show up later during dependency checks - lints <- - let lintPath p = fmap (fmap (p,)) (loadAndLintMap config (prefix </> p) depth) - where depth = length (splitPath p) - 1 - in mapMaybeM lintPath paths >>= evaluateNF - - - let mapdeps = setFromList (concatMap extractDeps lints) - where extractDeps (mappath, lintresult) = - fmap (FP.normalise . normalise (takeDirectory mappath)) - . mapMaybe onlyLocalMaps - $ mapresultDepends lintresult - onlyLocalMaps = \case - LocalMap p -> Just p - _ -> Nothing - - let acc' = acc <> M.fromList lints - - -- newly found maps that still need to be checked - let unknowns = listFromSet $ M.difference mapdeps acc - - -- no further maps? return acc'. Otherwise, recurse - case unknowns of - [] -> pure acc' - _ -> recursiveCheckDir' config prefix unknowns acc' diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs deleted file mode 100644 index a2a0f9f..0000000 --- a/lib/CheckMap.hs +++ /dev/null @@ -1,234 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Module that contains the high-level checking functions -module CheckMap (loadAndLintMap, MapResult(..), ResultKind(..), Optional,shrinkMapResult) where - -import Universum - -import Data.Aeson (ToJSON (toJSON)) -import qualified Data.Aeson as A -import Data.Aeson.Types ((.=)) -import qualified Data.Map as M -import qualified Data.Text as T -import qualified Data.Vector as V - - -import Badges (Badge) -import Data.Tiled (Layer (layerLayers, layerName), - Tiledmap (tiledmapLayers, tiledmapTilesets), - loadTiledmap) -import LintConfig (LintConfig (..), LintConfig') -import LintWriter (LintResult, invertLintResult, - resultToAdjusted, resultToBadges, - resultToCWs, resultToDeps, resultToJitsis, - resultToLints, resultToOffers, runLintWriter) -import Properties (checkLayer, checkMap, checkTileset) -import System.FilePath (takeFileName) -import Types (Dep (MapLink), - Hint (Hint, hintLevel, hintMsg), Level (..), - lintsToHints) -import Util (PrettyPrint (prettyprint), prettyprint) - - -data ResultKind = Full | Shrunk - -type family Optional (a :: ResultKind) (b :: Type) where - Optional Full b = b - Optional Shrunk b = () - --- | What this linter produces: lints for a single map -data MapResult (kind :: ResultKind) = MapResult - { mapresultLayer :: Map Hint [Text] - -- ^ lints that occurred in one or more layers - , mapresultTileset :: Map Hint [Text] - -- ^ lints that occurred in one or more tilesets - , mapresultDepends :: [Dep] - -- ^ (external and local) dependencies of this map - , mapresultProvides :: [Text] - -- ^ entrypoints provided by this map (needed for dependency checking) - , mapresultAdjusted :: Optional kind (Maybe Tiledmap) - -- ^ the loaded map, with adjustments by the linter - , mapresultBadges :: [Badge] - -- ^ badges that can be found on this map - , mapresultCWs :: [Text] - -- ^ collected CWs that apply to this map - , mapresultJitsis :: [Text] - -- ^ all jitsi room slugs mentioned in this map - , mapresultGeneral :: [Hint] - -- ^ general-purpose lints that didn't fit anywhere else - } deriving (Generic) - -instance NFData (Optional a (Maybe Tiledmap)) => NFData (MapResult a) - - -instance Eq (MapResult a) where - a == b = - mapresultLayer a == mapresultLayer b && - mapresultTileset a == mapresultTileset b && - -- mapresultBadges a == mapresultBadges b && - mapresultGeneral a == mapresultGeneral b - - -instance ToJSON (MapResult a) where - toJSON res = A.object - [ "layer" .= CollectedLints (mapresultLayer res) - , "tileset" .= CollectedLints (mapresultTileset res) - , "general" .= mapresultGeneral res - ] - -newtype CollectedLints = CollectedLints (Map Hint [Text]) - -instance ToJSON CollectedLints where - toJSON (CollectedLints col) = toJSON - . M.mapKeys hintMsg - $ M.mapWithKey (\h cs -> A.object [ "level" .= hintLevel h, "in" .= truncated cs ]) col - where truncated cs = if length cs > 10 - then take 9 cs <> [ "..." ] - else cs - - -shrinkMapResult :: MapResult Full -> MapResult Shrunk -shrinkMapResult !res = res { mapresultAdjusted = () } - --- | this module's raison d'être --- Lints the map at `path`, and limits local links to at most `depth` --- layers upwards in the file hierarchy -loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe (MapResult Full)) -loadAndLintMap config path depth = loadTiledmap path <&> \case - Left err -> Just (MapResult mempty mempty mempty mempty Nothing mempty mempty mempty - [ Hint Fatal . toText $ "Fatal: " <> err - ]) - Right waMap -> - Just (runLinter (takeFileName path == "main.json") config waMap depth) - --- | lint a loaded map -runLinter :: Bool -> LintConfig' -> Tiledmap -> Int -> MapResult Full -runLinter isMain config@LintConfig{..} tiledmap depth = MapResult - { mapresultLayer = invertThing layer - , mapresultTileset = invertThing tileset - , mapresultGeneral = - [Hint Warning "main.json should link back to the lobby" - | isMain && not (any linksLobby layerDeps)] - <> lintsToHints (resultToLints generalResult) - , mapresultDepends = resultToDeps generalResult - <> layerDeps - <> concatMap resultToDeps tileset - , mapresultProvides = concatMap resultToOffers layer - , mapresultAdjusted = Just adjustedMap - , mapresultCWs = resultToCWs generalResult - , mapresultJitsis = concatMap resultToJitsis tileset - <> concatMap resultToJitsis layer - , mapresultBadges = concatMap resultToBadges layer - <> resultToBadges generalResult - } - where - linksLobby = \case - MapLink link -> - ("/@/"<>configEventSlug<>"/lobby") `T.isPrefixOf` link - || configAssemblyTag == "lobby" - _ -> False - layerDeps = concatMap resultToDeps layer - layer = checkLayerRec config depth (V.toList $ tiledmapLayers tiledmap) - tileset = checkThing tiledmapTilesets checkTileset - generalResult = runLintWriter config tiledmap depth checkMap - - checkThing getter checker = V.toList . V.map runCheck $ getter tiledmap - where runCheck thing = runLintWriter config thing depth checker - - -- | "inverts" a LintResult, i.e. groups it by lints instead of - -- layers / maps - invertThing thing = M.unionsWith (<>) $ fmap invertLintResult thing - - adjustedMap = (resultToAdjusted generalResult) - { tiledmapLayers = V.fromList - . fmap resultToAdjusted - $ take (length (tiledmapLayers tiledmap)) layer - , tiledmapTilesets = V.fromList - . fmap resultToAdjusted - $ tileset - } - --- | Recursively checks a layer. --- --- This is apparently necessary because someone thought it would be a good --- idea to have group layers, even if their entire semantics appear to be --- "they're group layers"; they don't seem to /do/ anything … --- --- Note that this will flatten the layer structure and give them all back --- in a single list, but the ones that were passed in will always be at --- the head of the list. -checkLayerRec :: LintConfig' -> Int -> [Layer] -> [LintResult Layer] -checkLayerRec config depth layers = - -- reordering to get the correct ones back up front - (\rs -> fmap fst rs <> concatMap snd rs) - -- map over all input layers - $ flip fmap layers $ \parent -> - case layerLayers parent of - -- not a group layer; just lint this one - Nothing -> - (runLintWriter config parent depth checkLayer,[]) - -- this is a group layer. Fun! - Just sublayers -> - (parentResult, subresults) - where - -- Lintresults for sublayers with adjusted names - subresults :: [LintResult Layer] - subresults = - take (length sublayers) - . fmap (fmap (\l -> l { layerName = layerName parent <> "/" <> layerName l } )) - $ subresults' - - -- Lintresults for sublayers and subsublayers etc. - subresults' = - checkLayerRec config depth sublayers - - -- lintresult for the parent layer - parentResult = runLintWriter config parentAdjusted depth checkLayer - - -- the parent layer with adjusted sublayers - parentAdjusted = - parent { layerLayers = Just (fmap resultToAdjusted subresults') } - - - --- human-readable lint output, e.g. for consoles -instance PrettyPrint (Level, MapResult a) where - prettyprint (_, mapResult) = if complete == "" - then " all good!\n" else complete - where - complete = T.concat $ prettyGeneral - <> prettyLints mapresultLayer - <> prettyLints mapresultTileset - - -- | pretty-prints a collection of Hints, printing each - -- Hint only once, then a list of its occurences line-wrapped - -- to fit onto a decent-sized terminal - prettyLints :: (MapResult a -> Map Hint [Text]) -> [Text] - prettyLints getter = fmap - (\(h, cs) -> prettyprint h - <> "\n (in " - <> snd (foldl (\(l,a) c -> case l of - 0 -> (T.length c, c) - _ | l < 70 -> (l+2+T.length c, a <> ", " <> c) - _ -> (6+T.length c, a <> ",\n " <> c) - ) - (0, "") cs) - <> ")\n") - (M.toList . getter $ mapResult) - - prettyGeneral :: [Text] - prettyGeneral = map - ((<> "\n") . prettyprint) - $ mapresultGeneral mapResult diff --git a/lib/Dirgraph.hs b/lib/Dirgraph.hs deleted file mode 100644 index cc140a3..0000000 --- a/lib/Dirgraph.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} - --- | Simple directed graphs, for dependency checking -module Dirgraph where - -import Universum - -import CheckMap (MapResult (mapresultDepends)) -import Data.Map.Strict (mapMaybeWithKey, mapWithKey) -import qualified Data.Map.Strict as M -import Data.Set ((\\)) -import qualified Data.Set as S -import Paths (normalise) -import qualified Text.Dot as D -import Text.Dot (Dot, (.->.)) -import Types (Dep (LocalMap)) - --- | a simple directed graph -type Graph a = Map a (Set a) - -nodes :: Graph a -> Set a -nodes = M.keysSet - --- | simple directed graph of exits -resultToGraph :: Map FilePath (MapResult a) -> Graph FilePath -resultToGraph = fmap (S.fromList . mapMaybe onlyLocalMaps . mapresultDepends) - where onlyLocalMaps = \case - LocalMap path -> Just (normalise "" path) - _ -> Nothing - --- | invert edges of a directed graph -invertGraph :: (Eq a, Ord a) => Graph a -> Graph a -invertGraph graph = mapWithKey collectFroms graph - where collectFroms to _ = S.fromList . elems . mapMaybeWithKey (select to) $ graph - select to from elems = if to `elem` elems then Just from else Nothing - --- | all nodes reachable from some entrypoint -reachableFrom :: Ord a => a -> Graph a -> Set a -reachableFrom entrypoint graph = recursive mempty (S.singleton entrypoint) - where recursive seen current - | null current = seen - | otherwise = recursive (S.union seen current) (next \\ seen) - where next = S.unions - . S.fromList -- for some reason set is not filterable? - . mapMaybe (`M.lookup` graph) - . S.toList - $ current - -unreachableFrom :: Ord a => a -> Graph a -> Set a -unreachableFrom entrypoint graph = - nodes graph \\ reachableFrom entrypoint graph - -takeSubGraph :: (Eq a, Ord a) => Int -> a -> Graph a -> Graph a -takeSubGraph i start graph - | i <= 0 = mempty - | i == 1 = - M.singleton start reachable - `M.union` M.fromList ((,mempty) <$> S.toList reachable) - | otherwise = - M.singleton start reachable - `M.union` (M.unionsWith S.union - . S.map (flip (takeSubGraph (i-1)) graph) - $ reachable) - where reachable = fromMaybe mempty (M.lookup start graph) - -graphToDot :: Graph FilePath -> Dot () -graphToDot graph = do - main <- D.node [("label","main.json")] - nodes' <- M.traverseMaybeWithKey - (\name edges -> if name /= "main.json" - then D.node [("label",name)] <&> (, edges) <&> Just - else pure Nothing - ) - graph - - let reachable = fromMaybe mempty (M.lookup "main.json" graph) - let nodes = M.insert "main.json" (main,reachable) nodes' - forM_ nodes $ \(node, edges) -> - forM_ edges $ \key -> - case M.lookup key nodes of - Just (other,_) -> node .->. other - _ -> pure () diff --git a/lib/LayerData.hs b/lib/LayerData.hs deleted file mode 100644 index 82efbfc..0000000 --- a/lib/LayerData.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module LayerData where - -import Universum hiding (maximum, uncons) - -import Control.Monad.Zip (mzipWith) -import Data.Set (insert) -import Data.Tiled (GlobalId (unGlobalId), Layer (..)) -import Data.Vector (maximum, uncons) -import qualified Text.Show as TS -import Util (PrettyPrint (..)) - --- | A collision between two layers of the given names. --- Wrapped in a newtype so that Eq can ignore the order of the two -newtype Collision = Collision { fromCollision :: (Text, Text) } - deriving Ord - -instance Eq Collision where - (Collision (a,b)) == (Collision (a',b')) = ((a,b) == (a',b')) || ((a,b) == (b',a')) - -instance PrettyPrint Collision where - prettyprint (Collision (a,b)) = a <> " and " <> b - -instance TS.Show Collision where - show c = toString $ prettyprint c - --- | Finds pairwise tile collisions between the given layers. -layerOverlaps :: Vector Layer -> Set Collision -layerOverlaps layers = case uncons layers of - Nothing -> mempty - Just (l, ls) -> - fst . foldr overlapBetween (mempty, l) $ ls - where overlapBetween :: Layer -> (Set Collision, Layer) -> (Set Collision, Layer) - overlapBetween layer (acc, oldlayer) = - (if collides then insert collision acc else acc, layer) - where - collision = Collision (layerName layer, layerName oldlayer) - collides = case (layerData layer, layerData oldlayer) of - (Just d1, Just d2) -> - 0 /= maximum (mzipWith (\a b -> unGlobalId a * unGlobalId b) d1 d2) - _ -> False diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs deleted file mode 100644 index b0fa3b0..0000000 --- a/lib/LintConfig.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# 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', ConfigKind (..), patchConfig,stuffConfig,feedConfig) where - -import Universum - -import Data.Aeson (FromJSON (parseJSON), Options (..), - defaultOptions, eitherDecode) -import Data.Aeson.Types (genericParseJSON) -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy as LB -import qualified Data.Map.Strict as M -import GHC.Generics (Generic (Rep, from, to), K1 (..), - M1 (..), (:*:) (..)) -import Types (Level) -import Uris (SchemaSet, - Substitution (DomainSubstitution)) -import WithCli.Pure (Argument (argumentType, parseArgument)) - - - -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 :: WorldField f Text - -- ^ Assembly name (used for jitsiRoomAdminTag) - , configAssemblies :: StandaloneField f [Text] - -- ^ list of all assembly slugs (used to lint e.g. world:// links) - , 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 :: ConfigField f Bool - -- ^ Don't copy map assets (mostly useful for development) - , configAllowScripts :: ConfigField f Bool - -- ^ Allow defining custom scripts in maps - , configUriSchemas :: ConfigField f SchemaSet - } deriving (Generic) - -type LintConfig' = LintConfig Complete - -deriving instance Show (LintConfig Complete) -deriving instance Show (LintConfig Skeleton) -deriving instance Show (LintConfig Patch) -instance NFData (LintConfig Basic) - -aesonOptions :: Options -aesonOptions = defaultOptions - { omitNothingFields = True - , rejectUnknownFields = True - , fieldLabelModifier = drop 6 - } - -instance FromJSON (LintConfig Complete) where - parseJSON = genericParseJSON aesonOptions - -instance FromJSON (LintConfig Patch) where - parseJSON = genericParseJSON aesonOptions - -instance FromJSON (LintConfig Basic) where - parseJSON = genericParseJSON aesonOptions - - - --- | generic typeclass for things that are "patchable" -class GPatch i m where - gappend :: i p -> m p -> i p - --- generic instances. It's category theory, but with confusing names! -instance GPatch (K1 a k) (K1 a (Maybe k)) where - gappend _ (K1 (Just k')) = K1 k' - gappend (K1 k) (K1 Nothing) = K1 k - {-# INLINE gappend #-} - -instance (GPatch i o, GPatch i' o') - => GPatch (i :*: i') (o :*: o') where - gappend (l :*: r) (l' :*: r') = gappend l l' :*: gappend r r' - {-# INLINE gappend #-} - -instance GPatch i o - => GPatch (M1 _a _b i) (M1 _a' _b' o) where - gappend (M1 x) (M1 y) = M1 (gappend x y) - {-# INLINE gappend #-} - - --- | A patch function. For (almost) and a :: * -> *, --- take an a Identity and an a Maybe, then replace all appropriate --- values in the former with those in the latter. --- --- There isn't actually any useful reason for this function to be this --- abstract, I just wanted to play around with higher kinded types for --- a bit. -patch :: - ( Generic (f Patch) - , Generic (f Complete) - , GPatch (Rep (f Complete)) - (Rep (f Patch)) - ) - => f Complete - -> f Patch - -> f Complete -patch x y = to (gappend (from x) (from y)) - -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 = - case eitherDecode (LB.fromStrict $ C8.pack str) of - Left _ -> Nothing - Right res -> Just res - - argumentType Proxy = "LintConfig" diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs deleted file mode 100644 index afcec65..0000000 --- a/lib/LintWriter.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} - --- | a monad that collects warnings, outputs, etc, -module LintWriter - ( runLintWriter - , LintWriter - , LintWriter' - , LintResult - , invertLintResult - , zoom - -- * working with lint results - , resultToDeps - , resultToOffers - , resultToBadges - , resultToLints - , resultToAdjusted - -- * Add lints to a linter - , info - , suggest - , warn - , forbid - , complain - -- * add other information to the linter - , offersEntrypoint - , offersBadge - , dependsOn - -- * get information about the linter's context - , askContext - , askFileDepth - , lintConfig - -- * adjust the linter's context - , adjust - ,offersCWs,resultToCWs,offersJitsi,resultToJitsis) where - -import Universum - - -import Badges (Badge) -import Data.Map (fromListWith) -import Data.Tiled.Abstract (HasName (getName)) -import LintConfig (LintConfig') -import Types (Dep, Hint, Level (..), Lint (..), hint, - lintsToHints) - - --- | A monad modelling the main linter features -type LintWriter ctxt = LintWriter' ctxt () --- | A linter that can use pure / return things monadically -type LintWriter' ctxt res = - StateT (LinterState ctxt) (Reader (Context, ctxt, LintConfig')) res - --- | A Linter's state: some context (which it may adjust), and a list of lints --- | it already collected. -newtype LinterState ctxt = LinterState - { fromLinterState :: ([Lint], ctxt)} - deriving Functor - --- | The result of running a linter: an adjusted context, and a list of lints. --- | This is actually just a type synonym of LinterState, but kept seperately --- | for largely historic reasons since I don't think I'll change it again -type LintResult ctxt = LinterState ctxt - --- | for now, all context we have is how "deep" in the directory tree --- we currently are -type Context = Int - --- | run a linter. Returns the adjusted context, and a list of lints -runLintWriter - :: LintConfig' -> ctxt -> Context -> LintWriter ctxt -> LintResult ctxt -runLintWriter config context depth linter = LinterState - . fromLinterState - . snd - . runReader runstate - $ (depth, context, config) - where runstate = runStateT linter (LinterState ([], context)) - - -zoom :: (a -> b) -> (b -> a) -> LintWriter a -> LintWriter' b a -zoom embed extract operation = do - config <- lintConfig id - depth <- askFileDepth - let result ctxt = runLintWriter config ctxt depth operation - LinterState (lints,a) <- get - let res = result . extract $ a - put $ LinterState - . (resultToLints res <> lints,) - . embed - . resultToAdjusted - $ res - pure $ resultToAdjusted res - - --- | "invert" a linter's result, grouping lints by their messages -invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [Text] -invertLintResult (LinterState (lints, ctxt)) = - fmap (sortNub . map getName) . fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints - -resultToDeps :: LintResult a -> [Dep] -resultToDeps (LinterState (lints,_)) = mapMaybe lintToDep lints - where lintToDep = \case - Depends dep -> Just dep - _ -> Nothing - -resultToOffers :: LintResult a -> [Text] -resultToOffers (LinterState a) = mapMaybe lintToOffer $ fst a - where lintToOffer = \case - Offers frag -> Just frag - _ -> Nothing - -resultToBadges :: LintResult a -> [Badge] -resultToBadges (LinterState a) = mapMaybe lintToBadge $ fst a - where lintToBadge (Badge badge) = Just badge - lintToBadge _ = Nothing - -resultToCWs :: LintResult a -> [Text] -resultToCWs (LinterState a) = fold $ mapMaybe lintToCW $ fst a - where lintToCW = \case (CW cw) -> Just cw; _ -> Nothing - -resultToJitsis :: LintResult a -> [Text] -resultToJitsis (LinterState a) = mapMaybe lintToJitsi $ fst a - where lintToJitsi = \case (Jitsi room) -> Just room; _ -> Nothing - --- | convert a lint result into a flat list of lints -resultToLints :: LintResult a -> [Lint] -resultToLints (LinterState res) = fst res - --- | extract the adjusted context from a lint result -resultToAdjusted :: LintResult a -> a -resultToAdjusted (LinterState res) = snd res - - - - --- | fundamental linter operations: add a lint of some severity -info = lint Info -suggest = lint Suggestion -warn = lint Warning -forbid = lint Forbidden -complain = lint Error - --- | add a dependency to the linter -dependsOn :: Dep -> LintWriter a -dependsOn dep = tell' $ Depends dep - --- | add an offer for an entrypoint to the linter -offersEntrypoint :: Text -> LintWriter a -offersEntrypoint text = tell' $ Offers text - --- | add an offer for a badge to the linter -offersBadge :: Badge -> LintWriter a -offersBadge badge = tell' $ Badge badge - -offersCWs :: [Text] -> LintWriter a -offersCWs = tell' . CW - -offersJitsi :: Text -> LintWriter a -offersJitsi = tell' . Jitsi - - --- | get the context as it was initially, without any modifications -askContext :: LintWriter' a a -askContext = lift $ asks (\(_,a,_) -> a) - --- | ask for the file depth within the repository tree of the current map. --- | This function brings in a lot more conceptual baggage than I'd like, but --- | it's needed to check if relative paths lie outside the repository -askFileDepth :: LintWriter' a Int -askFileDepth = lift $ asks (\(a,_,_) -> a) - --- | ask for a specific part of the linter's global config -lintConfig :: (LintConfig' -> a) -> LintWriter' ctxt a -lintConfig get = lift $ asks (\(_,_,config) -> get config) - - - - --- | tell, but for a singular lint. Leaves the context unchanged -tell' :: Lint -> LintWriter ctxt -tell' l = modify $ \(LinterState (lints, ctxt)) -> LinterState (l:lints, ctxt) - --- | small helper to tell a singlular proper lint -lint :: Level -> Text -> LintWriter a -lint level text = tell' $ hint level text - --- | adjusts the context. Gets a copy of the /current/ context, --- | i.e. one which might have already been changed by other adjustments -adjust :: (a -> a) -> LintWriter a -adjust f = modify $ LinterState . second f . fromLinterState diff --git a/lib/Paths.hs b/lib/Paths.hs deleted file mode 100644 index f4dc3ed..0000000 --- a/lib/Paths.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Paths are horrible, so they have their own module now. --- I just hope you are running this on some kind of Unix -module Paths where - -import Universum -import qualified Universum.Unsafe as Unsafe - -import qualified Data.Text as T -import System.FilePath (splitPath) -import System.FilePath.Posix ((</>)) -import Text.Regex.TDFA -import Util (PrettyPrint (prettyprint)) - - --- | a normalised path: a number of "upwards" steps, and --- a path without any . or .. in it. Also possibly a --- fragment, mostly for map links. -data RelPath = Path Int Text (Maybe Text) - deriving (Show, Eq, Ord, NFData, Generic) - - - -data PathResult = OkRelPath RelPath - | AbsolutePath - | NotAPath - | UnderscoreMapLink - | AtMapLink - | PathVarsDisallowed - --- | horrible regex parsing for filepaths that is hopefully kinda safe -parsePath :: Text -> PathResult -parsePath text = - if | T.isInfixOf "{{" text || T.isInfixOf "}}" text -> PathVarsDisallowed - | rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) -> OkRelPath (Path up path fragment) - | "/_/" `T.isPrefixOf` text -> UnderscoreMapLink - | "/@/" `T.isPrefixOf` text -> AtMapLink - | "/" `T.isPrefixOf` text -> AbsolutePath - | otherwise -> NotAPath - where - (_, prefix, rest, _) = - text =~ ("^((\\.|\\.\\.)/)*" :: Text) :: (Text, Text, Text, [Text]) - -- how many steps upwards in the tree? - up = length . filter (".." ==) . T.splitOn "/" $ prefix - parts = T.splitOn "#" rest - -- `head` is unsafe, but splitOn will always produce lists with at least one element - path = Unsafe.head parts - fragment = case nonEmpty parts of - Nothing -> Nothing - Just p -> Just $ T.concat $ tail p - -instance PrettyPrint RelPath where - prettyprint (Path up rest frag) = ups <> rest <> fragment - where ups = T.concat $ replicate up "../" - fragment = maybe mempty ("#" <>) frag - --- | Normalises a path. --- --- It takes a `prefix`, and will "truncate" the .. operator --- at the end of the prefix, i.e. it will never return paths --- that lie (naïvely) outside of the prefix. -normalise :: FilePath -> RelPath -> FilePath -normalise prefix (Path 0 path _) = prefix </> toString path -normalise prefix (Path i path _) = - concat (take (length dirs - i) dirs) </> toString path - where dirs = splitPath prefix - -normaliseWithFrag :: FilePath -> RelPath -> FilePath -normaliseWithFrag prefix (Path i path frag) = - normalise prefix (Path (i+1) path frag) <> toString (maybe mempty ("#" <>) frag) - --- | does this path contain an old-style pattern for inter-repository --- links as was used at rc3 in 2020? -isOldStyle :: RelPath -> Bool -isOldStyle (Path _ text frag) = path =~ ("{<.+>*}" :: Text) - where path = case frag of - Just f -> text <> f - _ -> text - -getExtension :: RelPath -> Text -getExtension (Path _ text _) = maybe "" last (nonEmpty splitted) - where splitted = T.splitOn "." text 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<>"." diff --git a/lib/Types.hs b/lib/Types.hs deleted file mode 100644 index acba99d..0000000 --- a/lib/Types.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - - --- | basic types for the linter to eat and produce --- The dark magic making thse useful is in LintWriter -module Types - ( Level(..) - , Lint(..) - , Dep(..) - , Hint(..) - , hint - , lintLevel - , lintsToHints - ) where - -import Universum - -import Control.Monad.Trans.Maybe () -import Data.Aeson (FromJSON, ToJSON (toJSON), - ToJSONKey, (.=)) - -import Badges (Badge) -import qualified Data.Aeson as A -import Paths (RelPath) -import Util (PrettyPrint (..)) -import WithCli (Argument, atomicArgumentsParser) -import WithCli.Pure (Argument (argumentType, parseArgument), - HasArguments (argumentsParser)) - - --- | Levels of errors and warnings, collectively called --- "Hints" until I can think of some better name -data Level = Info | Suggestion | Warning | Forbidden | Error | Fatal - deriving (Show, Generic, Ord, Eq, ToJSON, FromJSON, NFData) - -instance Argument Level where - argumentType Proxy = "Lint Level" - parseArgument arg = case arg of - "info" -> Just Info - "suggestion" -> Just Suggestion - "warning" -> Just Warning - "forbidden" -> Just Forbidden - "error" -> Just Error - "fatal" -> Just Fatal - _ -> Nothing - - -instance HasArguments Level where - argumentsParser = atomicArgumentsParser - --- | a hint comes with an explanation (and a level), or is a dependency --- (in which case it'll be otherwise treated as an info hint) -data Lint = Depends Dep | Offers Text | Lint Hint | Badge Badge | CW [Text] | Jitsi Text - deriving (Ord, Eq, Generic) - -data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath - deriving (Generic, Ord, Eq, NFData) - -data Hint = Hint - { hintLevel :: Level - , hintMsg :: Text - } deriving (Generic, Ord, Eq, NFData) - --- | shorter constructor (called hint because (a) older name and --- (b) lint also exists and is monadic) -hint :: Level -> Text -> Lint -hint level msg = Lint Hint { hintLevel = level, hintMsg = msg } - --- | dependencies just have level Info -lintLevel :: Lint -> Level -lintLevel (Lint h) = hintLevel h -lintLevel _ = Info - -lintsToHints :: [Lint] -> [Hint] -lintsToHints = mapMaybe (\case {Lint hint -> Just hint ; _ -> Nothing}) - --- instance PrettyPrint Lint where --- prettyprint (Lint Hint { hintMsg, hintLevel } ) = --- " " <> show hintLevel <> ": " <> hintMsg --- prettyprint (Depends dep) = --- " Info: found dependency: " <> prettyprint dep --- prettyprint (Offers dep) = --- " Info: map offers entrypoint " <> prettyprint dep --- prettyprint (Badge _) = --- " Info: found a badge." --- prettyprint (CW cws) = --- " CWs: " <> show cws - -instance PrettyPrint Hint where - prettyprint (Hint level msg) = " " <> show level <> ": " <> msg - --- instance ToJSON Lint where --- toJSON (Lint h) = toJSON h --- toJSON (Depends dep) = A.object --- [ "msg" .= prettyprint dep --- , "level" .= A.String "Dependency Info" ] --- toJSON (Offers l) = A.object --- [ "msg" .= prettyprint l --- , "level" .= A.String "Entrypoint Info" ] --- toJSON (Badge _) = A.object --- [ "msg" .= A.String "found a badge" --- , "level" .= A.String "Badge Info"] --- toJSON (CW cws) = A.object --- [ "msg" .= A.String "Content Warning" --- , "level" .= A.String "CW Info" ] - -instance ToJSON Hint where - toJSON (Hint l m) = A.object - [ "msg" .= m, "level" .= l ] - -instance ToJSON Dep where - toJSON = \case - Local text -> json "local" $ prettyprint text - Link text -> json "link" text - MapLink text -> json "mapservice" text - LocalMap text -> json "map" $ prettyprint text - where - json :: A.Value -> Text -> A.Value - json kind text = A.object [ "kind" .= kind, "dep" .= text ] - -instance PrettyPrint Dep where - prettyprint = \case - Local dep -> "[local dep: " <> prettyprint dep <> "]" - Link dep -> "[link dep: " <> dep <> "]" - MapLink dep -> "[map service dep: " <> dep <> "]" - LocalMap dep -> "[local map dep: " <> prettyprint dep <> "]" diff --git a/lib/Uris.hs b/lib/Uris.hs deleted file mode 100644 index 127b7f1..0000000 --- a/lib/Uris.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# 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 - -import Universum - -import Data.Aeson (FromJSON (..), Options (..), - SumEncoding (UntaggedValue), - defaultOptions, genericParseJSON) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import GHC.TypeLits (KnownSymbol, symbolVal) -import Network.URI (URI (..), URIAuth (..), parseURI, - uriToString) -import qualified Network.URI.Encode as URI - -data Substitution = - Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] } - | DomainSubstitution { substs :: Map Text Text, scope :: [String] } - | Allowed { scope :: [String], allowed :: [Text] } - | Unrestricted { scope :: [String] } - deriving (Generic, Show, NFData) - - -instance FromJSON Substitution where - parseJSON = genericParseJSON defaultOptions - { sumEncoding = UntaggedValue - , rejectUnknownFields = True - } - -type SchemaSet = Map Text [Substitution] - - --- | 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 (T.strip raw)) of - Nothing -> Nothing - Just uri@URI{..} -> case uriAuthority of - Nothing -> Nothing - Just URIAuth {..} -> Just - ( fromString uriScheme - , fromString $ uriUserInfo <> uriRegName <> uriPort - , fromString $ uriPath <> uriQuery <> uriFragment - , fromString $ uriToString id uri "" - ) - - -data SubstError = - SchemaDoesNotExist Text - | NotALink - | DomainDoesNotExist Text - | 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. - 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 "{{" uri || T.isInfixOf "}}" uri) - $ Left VarsDisallowed - parts@(schema, _, _, _) <- maybeToRight NotALink $ parseUri uri - - let rules = filter (elem thisScope . scope) . concat $ M.lookup schema substs - - case nonEmpty $ map (applySubst parts) rules of - Nothing -> Left (SchemaDoesNotExist schema) - Just result -> minimum result - where - 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 -- make list of available uri schemes - . filter (any (elem thisScope . scope) . snd) - $ toPairs substs) - - case rule of - DomainSubstitution table _ -> do - 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 -> Right uri - | otherwise -> Right (prefix <> URI.encodeText uri) - Allowed _ allowlist - | domain `elem` allowlist -> Right uri - | otherwise -> Left (DomainIsBlocked allowlist) - Unrestricted _ -> Right uri diff --git a/lib/Util.hs b/lib/Util.hs deleted file mode 100644 index ef35139..0000000 --- a/lib/Util.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Util - ( mkProxy - , PrettyPrint(..) - , printPretty - , naiveEscapeHTML - , ellipsis - ) where - -import Universum - -import Data.Aeson as Aeson -import qualified Data.Set as S -import qualified Data.Text as T -import Data.Tiled (Layer, PropertyValue (..), Tileset (tilesetName), - layerName) - --- | helper function to create proxies -mkProxy :: a -> Proxy a -mkProxy = const Proxy - --- | a class to address all the string conversions necessary --- when using Show to much that just uses Text instead -class PrettyPrint a where - prettyprint :: a -> Text - --- | let's see if this is a good idea or makes type inference bite us -instance PrettyPrint Text where - prettyprint text = "\"" <> text <> "\"" - --- | same as show json, but without the "String" prefix for json strings -instance PrettyPrint Aeson.Value where - prettyprint = \case - Aeson.String s -> prettyprint s - v -> show v - -instance PrettyPrint t => PrettyPrint (Set t) where - prettyprint = prettyprint . S.toList - -instance PrettyPrint PropertyValue where - prettyprint = \case - StrProp str -> str - BoolProp bool -> if bool then "true" else "false" - IntProp int -> show int - FloatProp float -> show float - --- | here since Unit is sometimes used as dummy type -instance PrettyPrint () where - prettyprint _ = error "shouldn't pretty-print Unit" - -instance PrettyPrint Layer where - prettyprint = (<>) "layer " . layerName - -instance PrettyPrint Tileset where - prettyprint = (<>) "tileset " . tilesetName - -instance PrettyPrint a => PrettyPrint [a] where - prettyprint = T.intercalate ", " . fmap prettyprint - -printPretty :: PrettyPrint a => a -> IO () -printPretty = putStr . toString . prettyprint - - --- | for long lists which shouldn't be printed out in their entirety -ellipsis :: Int -> [Text] -> Text -ellipsis i texts - | i < l = prettyprint (take i texts) <> " ... (and " <> show (l-i) <> " more)" - | otherwise = prettyprint texts - where l = length texts - - - --- | naive escaping of html sequences, just to be sure that --- | workadventure won't mess things up again … -naiveEscapeHTML :: Text -> Text -naiveEscapeHTML = T.replace "<" "<" . T.replace ">" ">" diff --git a/lib/WriteRepo.hs b/lib/WriteRepo.hs deleted file mode 100644 index af4d4d7..0000000 --- a/lib/WriteRepo.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} - - --- | Module for writing an already linted map Repository back out again. -module WriteRepo (writeAdjustedRepository) where - -import Universum - -import CheckDir (DirResult (..), resultIsFatal) -import CheckMap (MapResult (..), ResultKind (..)) -import Data.Aeson (encodeFile) -import qualified Data.Set as S -import LintConfig (LintConfig (configDontCopyAssets), - LintConfig') -import Paths (normalise) -import System.Directory.Extra (copyFile, createDirectoryIfMissing, - doesDirectoryExist) -import System.Exit (ExitCode (..)) -import qualified System.FilePath as FP -import System.FilePath (takeDirectory) -import System.FilePath.Posix ((</>)) -import Types (Dep (Local)) - - --- TODO: make this return a custom error type, not an exitcode -writeAdjustedRepository :: LintConfig' -> FilePath -> FilePath -> DirResult Full -> IO ExitCode -writeAdjustedRepository config inPath outPath result - | resultIsFatal config result = - pure (ExitFailure 1) - | otherwise = do - ifM (doesDirectoryExist outPath) (pure (ExitFailure 2)) $ do - createDirectoryIfMissing True outPath - - -- write out all maps - forM_ (toPairs $ dirresultMaps result) $ \(path,out) -> do - createDirectoryIfMissing True (takeDirectory (outPath </> path)) - encodeFile (outPath </> path) $ mapresultAdjusted out - - unless (configDontCopyAssets config) $ do - -- collect asset dependencies of maps - -- TODO: its kinda weird doing that here, tbh - let localdeps :: Set FilePath = - S.fromList . concatMap - (\(mappath,mapresult) -> - let mapdir = takeDirectory mappath in - mapMaybe (\case - Local path -> Just . normalise mapdir $ path - _ -> Nothing) - $ mapresultDepends mapresult) - . toPairs $ dirresultMaps result - - -- copy all assets - forM_ localdeps $ \path -> - let - assetPath = FP.normalise $ inPath </> path - newPath = FP.normalise $ outPath </> path - in do - createDirectoryIfMissing True (takeDirectory newPath) - copyFile assetPath newPath - - pure ExitSuccess |