{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | Module that contains high-level checking for an entire directory module CheckDir ( maximumLintLevel , recursiveCheckDir , DirResult (..) , MissingAsset(..) , MissingDep(..) , resultIsFatal ,shrinkDirResult) where import Universum hiding (Set) import CheckMap (MapResult (..), Optional, ResultKind (..), loadAndLintMap, shrinkMapResult) import Control.Monad.Extra (mapMaybeM) import Data.Aeson (ToJSON, (.=)) import qualified Data.Aeson as A import Data.List (partition) import qualified Data.Map as M import Data.Map.Strict (mapKeys, mapWithKey, (\\)) import Data.Text (isInfixOf) import qualified Data.Text as T import Data.Tiled (Tiledmap) import Dirgraph (graphToDot, invertGraph, resultToGraph, takeSubGraph, unreachableFrom) import LintConfig (LintConfig', configMaxLintLevel) import Paths (normalise, normaliseWithFrag) import System.Directory.Extra (doesFileExist) import qualified System.FilePath as FP import System.FilePath (splitPath, (</>)) import System.FilePath.Posix (takeDirectory) import Text.Dot (showDot) import Types (Dep (Local, LocalMap), Hint (Hint), Level (..), hintLevel) import Util (PrettyPrint (prettyprint), ellipsis) -- based on the startling observation that Data.Map has lower complexity -- for difference than Data.Set, but the same complexity for fromList type Set a = Map a () setFromList :: Ord a => [a] -> Set a setFromList = M.fromList . flip zip (repeat ()) listFromSet :: Set a -> [a] listFromSet = map fst . M.toList -- | Result of linting an entire directory / repository data DirResult (complete :: ResultKind) = DirResult { dirresultMaps :: Map FilePath (MapResult complete) -- ^ all maps of this respository, by (local) filepath , dirresultDeps :: [MissingDep] -- ^ all dependencies to things outside this repository , dirresultMissingAssets :: [MissingAsset] -- ^ entrypoints of maps which are referred to but missing , dirresultGraph :: Text } deriving (Generic) instance NFData (Optional a (Maybe Tiledmap)) => NFData (DirResult a) data MissingDep = MissingDep { depFatal :: Maybe Bool , entrypoint :: Text , neededBy :: [FilePath] } deriving (Generic, ToJSON, NFData) -- | Missing assets are the same thing as missing dependencies, -- but should not be confused (and also serialise differently -- to json) newtype MissingAsset = MissingAsset MissingDep deriving (Generic, NFData) -- | "shrink" the result by throwing the adjusted tiledmaps away shrinkDirResult :: DirResult Full -> DirResult Shrunk shrinkDirResult !res = res { dirresultMaps = fmap shrinkMapResult (dirresultMaps res) } -- | given this config, should the result be considered to have failed? resultIsFatal :: LintConfig' -> DirResult Full -> Bool resultIsFatal config res = not (null (dirresultMissingAssets res) || not (any (isJust . depFatal) (dirresultDeps res))) || maximumLintLevel res > configMaxLintLevel config -- | maximum lint level that was observed anywhere in any map. -- note that it really does go through all lints, so don't -- call it too often maximumLintLevel :: DirResult a -> Level maximumLintLevel res | not (null (dirresultMissingAssets res)) = Fatal | otherwise = (maybe Info maximum . nonEmpty) . map hintLevel . concatMap (\map -> keys (mapresultLayer map) <> keys (mapresultTileset map) <> mapresultGeneral map ) . elems . dirresultMaps $ res instance ToJSON (DirResult a) where toJSON res = A.object [ "result" .= A.object [ "missingDeps" .= dirresultDeps res , "missingAssets" .= dirresultMissingAssets res -- some repos have auto-generated maps which are basically all the -- same; aggregate those to reduce output size , "mapLints" .= (M.fromList . fmap (first (ellipsis 6)) . foldr aggregateSameResults [] . M.toList $ dirresultMaps res) , "exitGraph" .= dirresultGraph res ] , "severity" .= maximumLintLevel res , "mapInfo" .= fmap (\tm -> A.object [ "badges" .= mapresultBadges tm ]) (dirresultMaps res) ] where aggregateSameResults (path,res) acc = case partition (\(_,res') -> res == res') acc of ([],_) -> ([toText path], res):acc ((paths,_):_,acc') -> (toText path:paths, res) : acc' instance ToJSON MissingAsset where toJSON (MissingAsset md) = A.object [ "asset" .= entrypoint md , "neededBy" .= neededBy md ] instance PrettyPrint (Level, DirResult a) where prettyprint (level, res) = prettyMapLints <> prettyMissingDeps where prettyMissingDeps = if not (null (dirresultDeps res)) then "\nDependency Errors:\n" <> foldMap prettyprint (dirresultDeps res) else "" prettyMapLints = T.concat (map prettyLint $ M.toList $ dirresultMaps res) prettyLint :: (FilePath, MapResult a) -> Text prettyLint (p, lint) = "\nin " <> toText p <> ":\n" <> prettyprint (level, lint) instance PrettyPrint MissingDep where prettyprint (MissingDep _ f n) = " - " <> f <> " does not exist, but is required by " <> prettyDependents <> "\n" where prettyDependents = T.intercalate "," $ map toText n -- | check an entire repository recursiveCheckDir :: LintConfig' -> FilePath -- ^ the repository's prefix (i.e. path to its directory) -> FilePath -- ^ the repository's entrypoint (filename of a map, from the repo's root) -> IO (DirResult Full) recursiveCheckDir config prefix root = do maps <- recursiveCheckDir' config prefix [root] mempty let exitGraph = resultToGraph maps -- maps that don't have (local) ways back to the main entrypoint let nowayback = unreachableFrom root . invertGraph $ exitGraph -- inject warnings for maps that have no way back to the entrypoint let maps' = flip mapWithKey maps $ \path res -> if path `elem` nowayback then res { mapresultGeneral = Hint Warning ("Cannot go back to " <> toText root <> " from this map.") : mapresultGeneral res } else res mAssets <- missingAssets prefix maps' pure $ DirResult { dirresultDeps = missingDeps root maps' , dirresultMissingAssets = mAssets , dirresultMaps = maps' , dirresultGraph = toText . showDot . graphToDot . takeSubGraph 7 root $ exitGraph } -- | Given a (partially) completed DirResult, check which local -- maps are referenced but do not actually exist. missingDeps :: FilePath -> Map FilePath (MapResult a) -> [MissingDep] missingDeps entrypoint maps = let simple = M.insert (toText entrypoint) [] used \\ M.union defined trivial in M.foldMapWithKey (\f n -> [MissingDep (Just $ not ("#" `isInfixOf` f)) f n]) simple where -- which maps are linked somewhere? used :: Map Text [FilePath] used = M.fromList $ M.foldMapWithKey (\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v) maps where extractLocalDeps prefix = \case LocalMap name -> Just $ toText $ normaliseWithFrag prefix name _ -> Nothing -- which are defined using startLayer? defined :: Set Text defined = setFromList $ M.foldMapWithKey (\k v -> map ((toText k <> "#") <>) . mapresultProvides $ v) maps -- each map file is an entrypoint by itself trivial = mapKeys toText $ void maps -- | Checks if all assets referenced in the result actually exist as files missingAssets :: FilePath -> Map FilePath (MapResult a) -> IO [MissingAsset] missingAssets prefix maps = mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList maps) <&> fold where missingOfMap (path, mapres) = mapMaybeM (\case Local relpath -> let asset = normalise (takeDirectory path) relpath in doesFileExist (prefix </> asset) <&> \case True -> Nothing False -> Just $ MissingDep Nothing (toText asset) [path] _ -> pure Nothing) (mapresultDepends mapres) -- | recursive checking of all maps in a repository recursiveCheckDir' :: LintConfig' -> FilePath -- ^ the repo's directory -> [FilePath] -- ^ paths of maps yet to check -> Map FilePath (MapResult Full) -- ^ accumulator for map results -> IO (Map FilePath (MapResult Full)) recursiveCheckDir' config prefix paths !acc = do -- lint all maps in paths. The double fmap skips maps which cause IO errors -- (in which case loadAndLintMap returns Nothing); appropriate warnings will -- show up later during dependency checks lints <- let lintPath p = fmap (fmap (p,)) (loadAndLintMap config (prefix </> p) depth) where depth = length (splitPath p) - 1 in mapMaybeM lintPath paths >>= evaluateNF let mapdeps = setFromList (concatMap extractDeps lints) where extractDeps (mappath, lintresult) = fmap (FP.normalise . normalise (takeDirectory mappath)) . mapMaybe onlyLocalMaps $ mapresultDepends lintresult onlyLocalMaps = \case LocalMap p -> Just p _ -> Nothing let acc' = acc <> M.fromList lints -- newly found maps that still need to be checked let unknowns = listFromSet $ M.difference mapdeps acc -- no further maps? return acc'. Otherwise, recurse case unknowns of [] -> pure acc' _ -> recursiveCheckDir' config prefix unknowns acc'