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