summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorstuebinm2023-10-23 23:18:34 +0200
committerstuebinm2023-10-24 01:21:52 +0200
commit9110064fe62f98dd3ecc5fb4c3915a843492b8fb (patch)
tree6a8e3d54bef365bf1c6c4f72a7a75dd5d1f05d40 /lib
parenta4461ce5d73a617e614e259bfe30b4e895c38a19 (diff)
a year went byHEADmain
This does many meta-things, but changes no functionality: - get rid of stack, and use just cabal with a stackage snapshot instead (why did I ever think stack was a good idea?) - update the stackage snapshot to something halfway recent - thus making builds work on nixpkgs-23.05 (current stable) - separating out packages into their own cabal files - use the GHC2021 set of extensions as default - very slight code changes to make things build again - update readme accordingly - stylish-haskell run
Diffstat (limited to 'lib')
-rw-r--r--lib/Badges.hs66
-rw-r--r--lib/CheckDir.hs284
-rw-r--r--lib/CheckMap.hs234
-rw-r--r--lib/Dirgraph.hs84
-rw-r--r--lib/LayerData.hs42
-rw-r--r--lib/LintConfig.hs193
-rw-r--r--lib/LintWriter.hs198
-rw-r--r--lib/Paths.hs86
-rw-r--r--lib/Properties.hs753
-rw-r--r--lib/Types.hs130
-rw-r--r--lib/Uris.hs106
-rw-r--r--lib/Util.hs79
-rw-r--r--lib/WriteRepo.hs63
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 "<" "&lt;" . T.replace ">" "&gt;"
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-01 13:42:58 +0000