From 7e77e6335bab772c4be1b3f0594113d09cd4a366 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Thu, 23 Sep 2021 03:01:09 +0200 Subject: handle all maps in entire repositories (+ checking that paths don't run outside of respositories) --- lib/CheckDir.hs | 98 +++++++++++++++++++++++++++++++++++---------------------- lib/CheckMap.hs | 48 +++++++++++++++------------- lib/Paths.hs | 16 ++++++---- 3 files changed, 96 insertions(+), 66 deletions(-) (limited to 'lib') diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs index 1ca71eb..753d5ab 100644 --- a/lib/CheckDir.hs +++ b/lib/CheckDir.hs @@ -2,35 +2,44 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} -- | Module that contains high-level checking for an entire directory module CheckDir (recursiveCheckDir) where -import CheckMap (MapResult, loadAndLintMap, mapresultDepends) -import Data.Aeson (ToJSON) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics (Generic) -import Paths (normalise) -import Types (Dep (LocalMap)) -import Util (PrettyPrint (prettyprint)) +import CheckMap (MapResult, loadAndLintMap, + mapresultDepends) +import Data.Aeson (ToJSON) +import Data.Functor ((<&>)) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Paths (normalise) +import System.FilePath (splitPath, ()) +import qualified System.FilePath as FP +import System.FilePath.Posix (takeDirectory) +import Types (Dep (LocalMap)) +import Util (PrettyPrint (prettyprint)) +-- 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 data DirResult = DirResult - { dirresultMaps :: [MapResult] + { dirresultMaps :: Map FilePath MapResult , dirresultDeps :: [Text] } deriving (Generic, ToJSON) - instance PrettyPrint DirResult where - prettyprint res = "Here's a result:" <> T.concat (map prettyprint $ dirresultMaps res) - --- 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 () - + prettyprint res = T.concat + (map (\(p,lints) -> "\nin " <> T.pack p <> ":\n" <> prettyprint lints) $ M.toList $ dirresultMaps res) instance Semigroup DirResult where a <> b = DirResult @@ -40,37 +49,50 @@ instance Semigroup DirResult where instance Monoid DirResult where mempty = DirResult - { dirresultMaps = [] + { dirresultMaps = mempty , dirresultDeps = [] } -- TODO: options? -recursiveCheckDir :: FilePath -> IO DirResult -recursiveCheckDir root = recursiveCheckDir' [root] mempty mempty +recursiveCheckDir :: FilePath -> FilePath -> IO DirResult +recursiveCheckDir prefix root = recursiveCheckDir' prefix [root] mempty mempty -recursiveCheckDir' :: [FilePath] -> Set FilePath -> DirResult -> IO DirResult -recursiveCheckDir' paths done acc = do +recursiveCheckDir' :: FilePath -> [FilePath] -> Set FilePath -> DirResult -> IO DirResult +recursiveCheckDir' prefix paths done acc = do putStrLn $ "linting " <> show paths + -- lint all maps in paths - lints <- mapM loadAndLintMap paths - -- get new deps - let deps = concatMap mapresultDepends lints - -- filter deps for map dependencies - let mapdeps = - map (\(LocalMap path) -> normalise path) - . filter (\case { LocalMap _ -> True; _ -> False }) - $ deps - -- build a Map FilePath () containing all map dependencies - let mapmapdeps = M.fromList $ zip mapdeps (repeat ()) - -- take difference of that with what's already done (O(m+n)) - let unknowns = map fst . M.toList $ M.difference mapmapdeps done - let known = M.union done . M.fromList . zip paths $ repeat () + lints <- + let lintPath p = loadAndLintMap (prefix p) depth <&> (p,) + where depth = length (splitPath p) - 1 + in mapM lintPath paths + + + let mapdeps = concatMap + (\(m,res) -> + let ps = mapMaybe + (\case {LocalMap p -> Just p; _ -> Nothing}) + (mapresultDepends res) + in map (FP.normalise . normalise (takeDirectory m)) ps + ) + lints + + -- build a Set containing all newly found dependencies, with paths + -- from the repository's directory, normalised not to start with ./ etc. + let setdeps = setFromList + mapdeps + -- that which is yet to do (O(m+n)) + let unknowns = listFromSet $ M.difference setdeps done + -- that which is done + let knowns = M.union done $ setFromList paths + -- Monoids! let acc' = acc <> DirResult - { dirresultMaps = lints + { dirresultMaps = M.fromList lints , dirresultDeps = [] } + -- Tail recursion! case unknowns of [] -> pure acc' - _ -> recursiveCheckDir' unknowns known acc' + _ -> recursiveCheckDir' prefix unknowns knowns acc' diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 8d670d5..016ec0b 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -7,22 +7,24 @@ -- | Module that contains the high-level checking functions module CheckMap (loadAndLintMap, MapResult(..)) where -import Data.Aeson (ToJSON) -import Data.Map (Map, fromList, toList) -import Data.Maybe (mapMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Vector as V -import GHC.Generics (Generic) +import Data.Aeson (ToJSON) +import Data.Map (Map, fromList, toList) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import GHC.Generics (Generic) +import System.FilePath.Posix (splitPath) -import LintWriter (LintResult (..), LintWriter, askContext, - lintToDep, resultToDeps, resultToLints, - runLintWriter) -import Properties (checkLayerProperty, checkMap) -import Tiled2 (Layer (layerName, layerProperties), - Tiledmap (tiledmapLayers), loadTiledmap) -import Types (Dep, Level (..), Lint (..), hint) -import Util (PrettyPrint (prettyprint), prettyprint) + +import LintWriter (LintResult (..), LintWriter, askContext, + lintToDep, resultToDeps, resultToLints, + runLintWriter) +import Properties (checkLayerProperty, checkMap) +import Tiled2 (Layer (layerName, layerProperties), + Tiledmap (tiledmapLayers), loadTiledmap) +import Types (Dep, Level (..), Lint (..), hint) +import Util (PrettyPrint (prettyprint), prettyprint) @@ -36,8 +38,10 @@ data MapResult = MapResult -- | this module's raison d'être -loadAndLintMap :: FilePath -> IO MapResult -loadAndLintMap path = loadTiledmap path >>= pure . \case +-- Lints the map at `path`, and limits local links to at most `depth` +-- layers upwards in the file hierarchy +loadAndLintMap :: FilePath -> Int -> IO MapResult +loadAndLintMap path depth = loadTiledmap path >>= pure . \case Left err -> MapResult { mapresultLayer = Nothing , mapresultDepends = [] @@ -47,11 +51,11 @@ loadAndLintMap path = loadTiledmap path >>= pure . \case ] } Right waMap -> - runLinter waMap + runLinter waMap depth -- | lint a loaded map -runLinter :: Tiledmap -> MapResult -runLinter tiledmap = MapResult +runLinter :: Tiledmap -> Int -> MapResult +runLinter tiledmap depth = MapResult { mapresultLayer = Just layerMap , mapresultGeneral = generalLints -- no general lints for now , mapresultDepends = concatMap (resultToDeps . snd) layer @@ -61,11 +65,11 @@ runLinter tiledmap = MapResult layerMap :: Map Text (LintResult Layer) layerMap = fromList layer layer = V.toList . V.map runCheck $ tiledmapLayers tiledmap - where runCheck l = (layerName l, runLintWriter l 0 checkLayer) + where runCheck l = (layerName l, runLintWriter l depth checkLayer) -- lints collected from properties generalLints = - resultToLints $ runLintWriter tiledmap 0 checkMap + resultToLints $ runLintWriter tiledmap depth checkMap -- | collect lints on a single map layer diff --git a/lib/Paths.hs b/lib/Paths.hs index 4dcaa53..49c0295 100644 --- a/lib/Paths.hs +++ b/lib/Paths.hs @@ -4,10 +4,12 @@ module Paths where -import Data.Text (Text) -import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Text as T +import System.FilePath (splitPath) +import System.FilePath.Posix (()) import Text.Regex.TDFA -import Util (PrettyPrint (prettyprint)) +import Util (PrettyPrint (prettyprint)) -- | a normalised path: a number of "upwards" steps, and -- a path without any . or .. in it @@ -35,6 +37,8 @@ instance PrettyPrint RelPath where prettyprint (Path up rest _) = ups <> rest where ups = T.concat $ replicate up "../" -normalise :: RelPath -> FilePath -normalise (Path 0 path _) = T.unpack path -normalize _ = error "not implemented yet" +normalise :: FilePath -> RelPath -> FilePath +normalise prefix (Path 0 path _) = prefix T.unpack path +normalise prefix (Path i path _) = + concat (take (length dirs - i) dirs) T.unpack path + where dirs = splitPath prefix -- cgit v1.2.3