path: root/lib/CheckDir.hs

{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE TypeFamilies      #-}

-- | Module that contains high-level checking for an entire directory
module CheckDir (maximumLintLevel, recursiveCheckDir, DirResult(..), MissingAsset(..), MissingDep(..), resultIsFatal)  where

import           CheckMap               (MapResult (..), loadAndLintMap)
import           Control.Monad          (void)
import           Control.Monad.Extra    (mapMaybeM)
import           Data.Aeson             (ToJSON, (.=))
import qualified Data.Aeson             as A
import           Data.Bifunctor         (first)
import           Data.Foldable          (fold)
import           Data.Functor           ((<&>))
import           Data.List              (partition)
import           Data.Map               (Map, elems, keys)
import qualified Data.Map               as M
import           Data.Map.Strict        (mapKeys, mapWithKey, (\\))
import           Data.Maybe             (isJust, mapMaybe)
import           Data.Text              (Text, isInfixOf)
import qualified Data.Text              as T
import           Dirgraph               (graphToDot, invertGraph, resultToGraph,
                                         takeSubGraph, unreachableFrom)
import           GHC.Generics           (Generic)
import           LintConfig             (LintConfig', configMaxLintLevel)
import           Paths                  (normalise, normaliseWithFrag)
import           System.Directory.Extra (doesFileExist)
import           System.FilePath        (splitPath, (</>))
import qualified System.FilePath        as FP
import           System.FilePath.Posix  (takeDirectory)
import           Text.Dot               (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 = DirResult
  { dirresultMaps          :: Map FilePath MapResult
  -- ^ 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         :: Dot ()
  } deriving (Generic)

data MissingDep = MissingDep
  { depFatal   :: Maybe Bool
  , entrypoint :: Text
  , neededBy   :: [FilePath]
  } deriving (Generic, ToJSON)

-- | Missing assets are the same thing as missing dependencies,
-- but should not be confused (and also serialise differently
-- to json)
newtype MissingAsset = MissingAsset MissingDep

-- | given this config, should the result be considered to have failed?
resultIsFatal :: LintConfig' -> DirResult -> 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 -> Level
maximumLintLevel res
  | not (null (dirresultMissingAssets res)) = Fatal
  | otherwise =
    (\t -> if null t then Info else maximum t)
    . map hintLevel
    . concatMap (\map -> keys (mapresultLayer map)
                  <> keys (mapresultTileset map)
                  <> mapresultGeneral map
                )
    . elems
    . dirresultMaps
    $ res



instance ToJSON DirResult 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)
      -- unused in the hub, temporarily removed to make the output smaller
      , "exitGraph" .= showDot (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
          ([],_)             -> ([T.pack path], res):acc
          ((paths,_):_,acc') -> (T.pack path:paths, res) : acc'

instance ToJSON MissingAsset where
  toJSON (MissingAsset md) = A.object
    [ "asset" .= entrypoint md
    , "neededBy" .= neededBy md
    ]


instance PrettyPrint (Level, DirResult) 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) -> Text
      prettyLint (p, lint) =
        "\nin " <> T.pack 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 T.pack 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
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 " <> T.pack root <> " from this map.")
                   : mapresultGeneral res
                 }
        else res

  mAssets <- missingAssets prefix maps'
  pure $ DirResult { dirresultDeps = missingDeps root maps'
                   , dirresultMissingAssets = mAssets
                   , dirresultMaps = maps'
                   , dirresultGraph =
                     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 -> [MissingDep]
missingDeps entrypoint maps =
  let simple = M.insert (T.pack 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 $ T.pack $ normaliseWithFrag prefix name
              _             -> Nothing
    -- which are defined using startLayer?
    defined :: Set Text
    defined = setFromList
      $ M.foldMapWithKey
      (\k v -> map ((T.pack k <> "#") <>) . mapresultProvides $ v)
      maps
    -- each map file is an entrypoint by itself
    trivial = mapKeys T.pack $ void maps

-- | Checks if all assets referenced in the result actually exist as files
missingAssets :: FilePath -> Map FilePath MapResult -> 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 (T.pack 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
  -- ^ accumulator for map results
  -> IO (Map FilePath MapResult)
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


  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'