From eb214ab01fc39809e39eeb7fa701ecb765eafbae Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Thu, 30 Sep 2021 17:26:16 +0200
Subject: [PATCH] check if assets exist
---
lib/CheckDir.hs | 48 ++++++++++++++++++++++++++++++++++++++++--------
1 file changed, 40 insertions(+), 8 deletions(-)
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'
--
GitLab