From eb214ab01fc39809e39eeb7fa701ecb765eafbae Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 30 Sep 2021 17:26:16 +0200
Subject: check if assets exist

---
 lib/CheckDir.hs | 48 ++++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 40 insertions(+), 8 deletions(-)

(limited to 'lib')

diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index 2a35c12..7280887 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -10,7 +10,7 @@ module CheckDir (recursiveCheckDir)  where
 
 import           CheckMap              (MapResult (mapresultProvides),
                                         loadAndLintMap, mapresultDepends)
-import           Control.Monad         (void)
+import Control.Monad ( void, foldM )
 import           Control.Monad.Extra   (mapMaybeM)
 import           Data.Aeson            (ToJSON, (.=))
 import qualified Data.Aeson            as A
@@ -25,8 +25,11 @@ import           Paths                 (normalise, normaliseWithFrag)
 import           System.FilePath       (splitPath, (</>))
 import qualified System.FilePath       as FP
 import           System.FilePath.Posix (takeDirectory)
-import           Types                 (Dep (LocalMap), Level)
+import           Types                 (Dep (LocalMap, Local), Level)
 import           Util                  (PrettyPrint (prettyprint))
+import Data.Foldable (fold)
+import Data.Functor ((<&>))
+import System.Directory.Extra (doesFileExist)
 
 
 -- based on the startling observation that Data.Map has lower complexity
@@ -41,6 +44,7 @@ listFromSet = map fst . M.toList
 data DirResult = DirResult
   { dirresultMaps :: Map FilePath MapResult
   , dirresultDeps :: [MissingDep]
+  , dirresultMissingAssets :: [MissingAsset]
   } deriving (Generic)
 
 data MissingDep = MissingDep
@@ -48,12 +52,22 @@ data MissingDep = MissingDep
   , 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
@@ -79,12 +93,15 @@ 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 = []
+    , dirresultDeps = mempty
+    , dirresultMissingAssets = mempty
     }
 
 
@@ -95,7 +112,10 @@ instance Monoid DirResult where
 recursiveCheckDir :: FilePath -> FilePath -> IO DirResult
 recursiveCheckDir prefix root = do
   linted <- recursiveCheckDir' prefix [root] mempty mempty
-  pure $ linted <> mempty { dirresultDeps = missingDeps linted }
+  mAssets <- missingAssets prefix linted
+  pure $ linted <> mempty { dirresultDeps = missingDeps linted
+                          , dirresultMissingAssets = mAssets
+                          }
 
 
 -- | Given a (partially) completed DirResult, check which local
@@ -123,6 +143,20 @@ missingDeps 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.
 --
@@ -145,7 +179,7 @@ recursiveCheckDir' prefix paths done acc = do
        (\(m,res) ->
           let ps = mapMaybe
                 (\case {LocalMap p -> Just p; _ -> Nothing})
-                (mapresultDepends $ res)
+                (mapresultDepends res)
           in map (FP.normalise . normalise (takeDirectory m)) ps
        )
        lints
@@ -160,9 +194,7 @@ recursiveCheckDir' prefix paths done acc = do
   let knowns = M.union done $ setFromList paths
 
   -- Monoids!
-  let acc' = acc <> DirResult
-                { dirresultMaps = M.fromList lints
-                , dirresultDeps = [] }
+  let acc' = acc <> mempty { dirresultMaps = M.fromList lints }
   -- Tail recursion!
   case unknowns of
     [] -> pure acc'
-- 
cgit v1.2.3