summaryrefslogtreecommitdiff
path: root/lib/CheckDir.hs
blob: d65181533128692bbad42514f75b84a1027387f0 (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
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections     #-}

-- | Module that contains high-level checking for an entire directory
module CheckDir (recursiveCheckDir)  where

import           CheckMap               (MapResult (mapresultProvides),
                                         loadAndLintMap, mapresultDepends)
import           Control.Monad          (void)
import           Control.Monad.Extra    (mapMaybeM)
import           Data.Aeson             (ToJSON, (.=))
import qualified Data.Aeson             as A
import           Data.Foldable          (fold)
import           Data.Functor           ((<&>))
import           Data.Map               (Map)
import qualified Data.Map               as M
import           Data.Map.Strict        (mapKeys, (\\))
import           Data.Maybe             (mapMaybe)
import           Data.Text              (Text)
import qualified Data.Text              as T
import           GHC.Generics           (Generic)
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           Types                  (Dep (Local, LocalMap), Level)
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

-- | Result of linting an entire directory / repository
data DirResult = DirResult
  { dirresultMaps          :: Map FilePath MapResult
  , dirresultDeps          :: [MissingDep]
  , dirresultMissingAssets :: [MissingAsset]
  } deriving (Generic)

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

newtype MissingAsset = MissingAsset MissingDep

instance ToJSON DirResult where
  toJSON res = A.object
    [ "missingDeps" .= dirresultDeps res
    , "missingAssets" .= dirresultMissingAssets res
    , "mapLints" .= dirresultMaps res
    ]

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


instance Semigroup DirResult where
  a <> b = DirResult
    { dirresultMaps = dirresultMaps a <> dirresultMaps b
    , dirresultDeps = dirresultDeps a <> dirresultDeps b
    , dirresultMissingAssets =
      dirresultMissingAssets a <> dirresultMissingAssets b
    }

instance Monoid DirResult where
  mempty = DirResult
    { dirresultMaps = mempty
    , dirresultDeps = mempty
    , dirresultMissingAssets = mempty
    }


-- | The nice function to check an entire repository with.
-- gets a prefix (i.e. the bare path to the repository) and
-- a root (i.e. the name of the file containing the entrypoint
-- map within that file)
recursiveCheckDir :: FilePath -> FilePath -> IO DirResult
recursiveCheckDir prefix root = do
  linted <- recursiveCheckDir' prefix [root] mempty mempty
  mAssets <- missingAssets prefix linted
  pure $ linted <> mempty { dirresultDeps = missingDeps linted
                          , dirresultMissingAssets = mAssets
                          }


-- | Given a (partially) completed DirResult, check which local
-- maps are referenced but do not actually exist.
missingDeps :: DirResult -> [MissingDep]
missingDeps res =
  let simple = M.insert "main.json" [] used \\ M.union defined trivial
  in M.foldMapWithKey (\f n -> [MissingDep 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)
      (dirresultMaps res)
      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)
      (dirresultMaps res)
    -- each map file is an entrypoint by itself
    trivial = mapKeys T.pack $ void (dirresultMaps res)

-- | Checks if all assets found (contained in the map's lints)
-- actually exist where they should exist
missingAssets :: FilePath -> DirResult -> IO [MissingAsset]
missingAssets prefix res =
  mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList . dirresultMaps $ res) <&> 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 (T.pack asset) [path]
                 _ -> pure Nothing)
          (mapresultDepends mapres)


-- | The less-nice function for checking an entire repository.
--
-- Strictly speaking it probably doesn't need to have `done` and
-- `acc` since they are essentially the same thing, but doing it
-- like this seemed convenient at the time
recursiveCheckDir' :: FilePath -> [FilePath] -> Set FilePath -> DirResult -> IO DirResult
recursiveCheckDir' prefix paths done 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 (prefix </> p) depth)
          where depth = length (splitPath p) - 1
    in mapMaybeM 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 <> mempty { dirresultMaps = M.fromList lints }
  -- Tail recursion!
  case unknowns of
    [] -> pure acc'
    _  -> recursiveCheckDir' prefix unknowns knowns acc'