From 7e77e6335bab772c4be1b3f0594113d09cd4a366 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Thu, 23 Sep 2021 03:01:09 +0200
Subject: [PATCH] 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 +++++---
src/Main.hs | 15 ++++----
tiled-hs.cabal | 1 +
5 files changed, 105 insertions(+), 73 deletions(-)
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
diff --git a/src/Main.hs b/src/Main.hs
index 33db91c..41f5da6 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -15,16 +15,15 @@ import Data.Text.Lazy as T
import System.IO (utf8)
import WithCli
-import CheckMap (loadAndLintMap)
import Util (printPretty)
import CheckDir (recursiveCheckDir)
-- | the options this cli tool can take
data Options = Options
- { inpath :: Maybe String
- -- ^ path to input map files
- , outpath :: Maybe String
- -- ^ path to out directory (should be empty)
+ { repository :: Maybe String
+ -- ^ path to the repository containing maps to lint
+ , entrypoint :: Maybe String
+ -- ^ entrypoint in that repository
, allowScripts :: Bool
-- ^ pass --allowScripts to allow javascript in map
, scriptInject :: Maybe String
@@ -41,8 +40,10 @@ main = withCli run
run :: Options -> IO ()
run options = do
- --lints <- loadAndLintMap (fromMaybe "example.json" (inpath options))
- lints <- recursiveCheckDir (fromMaybe "example.json" (inpath options))
+ let repo = fromMaybe "." (repository options)
+ let entry = fromMaybe "main.json" (entrypoint options)
+
+ lints <- recursiveCheckDir repo entry
if json options
then printLB
diff --git a/tiled-hs.cabal b/tiled-hs.cabal
index b4401ca..7793f23 100644
--- a/tiled-hs.cabal
+++ b/tiled-hs.cabal
@@ -43,6 +43,7 @@ library
transformers,
mtl,
either,
+ filepath,
regex-tdfa ^>= 1.3.1.1
-- TODO: move more stuff into lib, these dependencies are silly
--
GitLab