summaryrefslogtreecommitdiff
path: root/lib/CheckDir.hs
blob: eaf9aeebab4217b46fe6c7cb7aa4c24ae24d03b7 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
{-# 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           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               (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'