[ANE-2123] A fix around listing excluded dirs (#1493)

* [ANE-2123] Get Walk.Discovery.walkWithFilters to avoid listDir calls on excluded dirs

* [ANE-2123] Add a spec for walkWithFilters' to check that it does not touch excluded dirs

* Update src/Discovery/Walk.hs

Co-authored-by: Christopher Sasarak <[email protected]>

* [ANE-2123] Address PR comments

* [ANE-2123] Fix formatting

* [ANE-2123] Update changelog to match our standard format and reflect our readers' expectations

---------

Co-authored-by: James Clemer <[email protected]>
Co-authored-by: Christopher Sasarak <[email protected]>

Author: 3 people

Changelog.md

@@ -1,5 +1,8 @@
 # FOSSA CLI Changelog
 
+## 3.9.43
+- Discovery: Fix a bug where directories in paths.exclude may still be accessed during discovery which causes an error when users don't have permission to read those directories.
+
 ## 3.9.42
 - Licensing: Adds support for the Text-Tabs+Wrap License
 

src/App/Fossa/Analyze.hs

@@ -413,7 +413,11 @@ analyze cfg = Diag.context "fossa-analyze" $ do
   reachabilityUnitsResult <-
     case orgInfo of
       (Just (Organization{orgSupportsReachability = False})) -> pure []
-      _ -> Diag.context "reachability analysis" . runReader (Config.reachabilityConfig cfg) $ analyzeForReachability projectScans
+      _ ->
+        Diag.context "reachability analysis"
+          . runReader (Config.reachabilityConfig cfg)
+          . runReader filters
+          $ analyzeForReachability projectScans
   let reachabilityUnits = onlyFoundUnits reachabilityUnitsResult
 
   let analysisResult = AnalysisScanResult projectScans vsiResults binarySearchResults manualSrcUnits dynamicLinkedResults maybeLernieResults reachabilityUnitsResult

src/App/Fossa/Reachability/Maven.hs

@@ -7,11 +7,13 @@ import App.Fossa.Reachability.Jar (callGraphFromJars, isValidJar)
 import App.Fossa.Reachability.Types (CallGraphAnalysis (..))
 import Control.Carrier.Lift (Lift)
 import Control.Effect.Diagnostics (Diagnostics, context, fromEither, recover)
+import Control.Effect.Reader (Reader)
 import Control.Monad (filterM, join)
 import Data.Map qualified as Map
 import Data.Maybe (catMaybes, fromMaybe)
 import Data.String.Conversion (ToText (toText))
 import Data.Text (Text, replace)
+import Discovery.Filters (AllFilters)
 import Effect.Exec (Exec)
 import Effect.Logger (Logger, logDebug, pretty)
 import Effect.ReadFS (Has, ReadFS, resolveDir', resolveFile)
@@ -32,6 +34,7 @@ mavenJarCallGraph ::
   , Has Diagnostics sig m
   , Has Exec sig m
   , Has (Lift IO) sig m
+  , Has (Reader AllFilters) sig m
   ) =>
   Path Abs Dir ->
   m CallGraphAnalysis
@@ -44,6 +47,7 @@ getJarsByBuild ::
   ( Has Logger sig m
   , Has ReadFS sig m
   , Has Diagnostics sig m
+  , Has (Reader AllFilters) sig m
   ) =>
   Path Abs Dir ->
   m [Path Abs File]

src/App/Fossa/Reachability/Upload.hs

@@ -37,6 +37,7 @@ import Data.List (nub)
 import Data.Map qualified as Map
 import Data.Maybe (mapMaybe)
 import Diag.Result (Result (..))
+import Discovery.Filters (AllFilters)
 import Effect.Exec (Exec)
 import Effect.Logger (Logger, logDebug, logInfo, pretty)
 import Effect.ReadFS (ReadFS)
@@ -57,6 +58,7 @@ analyzeForReachability ::
   , Has (Lift IO) sig m
   , Has Debug sig m
   , Has (Reader ReachabilityConfig) sig m
+  , Has (Reader AllFilters) sig m
   ) =>
   [DiscoveredProjectScan] ->
   m [SourceUnitReachabilityAttempt]
@@ -107,6 +109,7 @@ callGraphOf ::
   , Has (Lift IO) sig m
   , Has Debug sig m
   , Has (Reader ReachabilityConfig) sig m
+  , Has (Reader AllFilters) sig m
   ) =>
   DiscoveredProjectScan ->
   m SourceUnitReachabilityAttempt

src/Discovery/Walk.hs

@@ -14,10 +14,11 @@ module Discovery.Walk (
 ) where
 
 import Control.Carrier.Writer.Church
-import Control.Effect.Diagnostics
+import Control.Effect.Diagnostics (Diagnostics, context, fatal)
 import Control.Effect.Reader (Reader, ask)
 import Control.Monad.Trans
 import Control.Monad.Trans.Maybe
+import Data.Bifunctor (second)
 import Data.Foldable (find)
 import Data.Functor (void)
 import Data.Glob qualified as Glob
@@ -73,17 +74,41 @@ pathFilterIntercept ::
   AllFilters ->
   Path Abs Dir ->
   Path Abs Dir ->
+  [Path Abs Dir] ->
   m (o, WalkStep) ->
   m (o, WalkStep)
-pathFilterIntercept filters base path act = do
+pathFilterIntercept filters base dir subdirs act = do
   -- We know that the two have the same base, but if that invariant is broken,
   -- we just allow the path during discovery.  It's better than crashing.
-  case stripProperPrefix base path of
+  case stripProperPrefix base dir of
     Nothing -> act
     Just relative ->
       if pathAllowed filters relative
-        then act
+        then (fmap . second) skipDisallowed act
         else pure (mempty, WalkSkipAll)
+  where
+    disallowedSubdirs :: [Text]
+    disallowedSubdirs = do
+      subdir <- subdirs
+      stripped <- stripProperPrefix base subdir
+      let isAllowed = pathAllowed filters stripped
+      if isAllowed
+        then mempty
+        else pure $ (toText . toFilePath . dirname) subdir
+
+    -- skipDisallowed needs to look at either:
+    --  * WalkStep.WalkContinue
+    --  * WalkStep.WalkSkipSome [Text]
+    -- and add on any missing disallowed subdirs
+    skipDisallowed :: WalkStep -> WalkStep
+    skipDisallowed action =
+      if null disallowedSubdirs
+        then
+          action
+        else case action of
+          WalkContinue -> WalkSkipSome disallowedSubdirs
+          WalkSkipSome dirs -> WalkSkipSome $ disallowedSubdirs ++ dirs
+          _ -> action
 
 -- | Like @walk@, but collects the output of @f@ in a monoid.
 walk' ::
@@ -117,7 +142,7 @@ walkWithFilters' ::
   m o
 walkWithFilters' f root = do
   filters <- ask
-  let f' dir subdirs files = pathFilterIntercept filters root dir $ f dir subdirs files
+  let f' dir subdirs files = pathFilterIntercept filters root dir subdirs $ f dir subdirs files
   walk' f' root
 
 -- | Search upwards in the directory tree for the existence of the supplied file.
@@ -169,6 +194,7 @@ walkDir ::
 walkDir handler topdir =
   context "Walking the filetree" $
     void $
+      -- makeAbsolute topdir >>= walkAvoidLoop Set.empty
       -- makeAbsolute topdir >>= walkAvoidLoop Set.empty
       walkAvoidLoop Set.empty topdir
   where

src/Strategy/Maven/Pom/Closure.hs

@@ -27,21 +27,24 @@ import Path.IO qualified as PIO
 import Strategy.Maven.Pom.PomFile
 import Strategy.Maven.Pom.Resolver
 
+import Control.Effect.Reader (Reader)
 import Data.Text (Text)
+import Discovery.Filters (AllFilters)
 
-findProjects :: (Has ReadFS sig m, Has Diagnostics sig m) => Path Abs Dir -> m [MavenProjectClosure]
+findProjects :: (Has ReadFS sig m, Has Diagnostics sig m, Has (Reader AllFilters) sig m) => Path Abs Dir -> m [MavenProjectClosure]
 findProjects basedir = do
   pomFiles <- context "Finding pom files" $ findPomFiles basedir
   globalClosure <- context "Building global closure" $ buildGlobalClosure pomFiles
   context "Building project closures" $ pure (buildProjectClosures basedir globalClosure)
 
-findPomFiles :: (Has ReadFS sig m, Has Diagnostics sig m) => Path Abs Dir -> m [Path Abs File]
-findPomFiles dir = execState @[Path Abs File] [] $
-  flip walk dir $ \_ _ files -> do
-    let poms = filter (\file -> "pom.xml" `isSuffixOf` fileName file || ".pom" `isSuffixOf` fileName file) files
-    traverse_ (modify . (:)) poms
+findPomFiles :: (Has ReadFS sig m, Has Diagnostics sig m, Has (Reader AllFilters) sig m) => Path Abs Dir -> m [Path Abs File]
+findPomFiles dir =
+  execState @[Path Abs File] [] $
+    flip walkWithFilters' dir $ \_ _ files -> do
+      let poms = filter (\file -> "pom.xml" `isSuffixOf` fileName file || ".pom" `isSuffixOf` fileName file) files
+      traverse_ (modify . (:)) poms
 
-    pure (WalkSkipSome ["target"])
+      pure ((), WalkSkipSome ["target"])
 
 buildProjectClosures :: Path Abs Dir -> GlobalClosure -> [MavenProjectClosure]
 buildProjectClosures basedir global = closures

src/Strategy/Node.hs

@@ -49,7 +49,7 @@ import Discovery.Filters (AllFilters, withMultiToolFilter)
 import Discovery.Walk (
   WalkStep (WalkSkipSome),
   findFileNamed,
-  walk',
+  walkWithFilters',
  )
 import Effect.Logger (
   Logger,
@@ -129,8 +129,8 @@ discover dir = withMultiToolFilter [YarnProjectType, NpmProjectType, PnpmProject
         graphs <- context "Splitting global graph into chunks" $ fromMaybe CyclicPackageJson $ splitGraph globalGraph
         context "Converting graphs to analysis targets" $ traverse (mkProject <=< identifyProjectType) graphs
 
-collectManifests :: (Has ReadFS sig m, Has Diagnostics sig m) => Path Abs Dir -> m [Manifest]
-collectManifests = walk' $ \_ _ files ->
+collectManifests :: (Has ReadFS sig m, Has Diagnostics sig m, Has (Reader AllFilters) sig m) => Path Abs Dir -> m [Manifest]
+collectManifests = walkWithFilters' $ \_ _ files ->
   case findFileNamed "package.json" files of
     Nothing -> pure ([], skipJsFolders)
     Just jsonFile -> pure ([Manifest jsonFile], skipJsFolders)

src/Strategy/SwiftPM.hs

@@ -18,7 +18,7 @@ import Discovery.Simple (simpleDiscover)
 import Discovery.Walk (
   WalkStep (WalkContinue, WalkSkipSome),
   findFileNamed,
-  walk',
+  walkWithFilters',
  )
 import Effect.Logger (Logger, Pretty (pretty), logDebug)
 import Effect.ReadFS (ReadFS)
@@ -54,15 +54,27 @@ instance ToJSON SwiftProject
 discover :: (Has ReadFS sig m, Has Diagnostics sig m, Has Logger sig m, Has (Reader AllFilters) sig m) => Path Abs Dir -> m [DiscoveredProject SwiftProject]
 discover = simpleDiscover findProjects mkProject SwiftProjectType
 
-findProjects :: (Has ReadFS sig m, Has Diagnostics sig m, Has Logger sig m) => Path Abs Dir -> m [SwiftProject]
+findProjects ::
+  ( Has ReadFS sig m
+  , Has Diagnostics sig m
+  , Has Logger sig m
+  , Has (Reader AllFilters) sig m
+  ) =>
+  Path Abs Dir ->
+  m [SwiftProject]
 findProjects dir = do
   swiftPackageProjects <- context "Finding swift package projects" $ findSwiftPackageProjects dir
   xCodeProjects <- context "Finding xcode projects using swift package manager" $ findXcodeProjects dir
   pure (swiftPackageProjects <> xCodeProjects)
 
--- TODO: determine if walkWithFilters' is safe here
-findSwiftPackageProjects :: (Has ReadFS sig m, Has Diagnostics sig m) => Path Abs Dir -> m [SwiftProject]
-findSwiftPackageProjects = walk' $ \dir _ files -> do
+findSwiftPackageProjects ::
+  ( Has ReadFS sig m
+  , Has Diagnostics sig m
+  , Has (Reader AllFilters) sig m
+  ) =>
+  Path Abs Dir ->
+  m [SwiftProject]
+findSwiftPackageProjects = walkWithFilters' $ \dir _ files -> do
   let packageManifestFile = findFileNamed "Package.swift" files
   let packageResolvedFile = findFileNamed "Package.resolved" files
   case (packageManifestFile, packageResolvedFile) of
@@ -72,9 +84,15 @@ findSwiftPackageProjects = walk' $ \dir _ files -> do
     -- Package.resolved without Package.swift or Xcode project file is not a valid swift project.
     (Nothing, _) -> pure ([], WalkContinue)
 
--- TODO: determine if walkWithFilters' is safe here
-findXcodeProjects :: (Has ReadFS sig m, Has Diagnostics sig m, Has Logger sig m) => Path Abs Dir -> m [SwiftProject]
-findXcodeProjects = walk' $ \dir _ files -> do
+findXcodeProjects ::
+  ( Has ReadFS sig m
+  , Has Diagnostics sig m
+  , Has Logger sig m
+  , Has (Reader AllFilters) sig m
+  ) =>
+  Path Abs Dir ->
+  m [SwiftProject]
+findXcodeProjects = walkWithFilters' $ \dir _ files -> do
   let xcodeProjectFile = findFileNamed "project.pbxproj" files
   case xcodeProjectFile of
     Nothing -> pure ([], WalkContinue)
@@ -89,8 +107,14 @@ findXcodeProjects = walk' $ \dir _ files -> do
 -- XCode projects using swift package manager retain Package.resolved,
 -- not in the same directory as project file, but rather in workspace's xcshareddata/swiftpm directory.
 -- Reference: https://developer.apple.com/documentation/swift_packages/adding_package_dependencies_to_your_app.
-findFirstResolvedFileRecursively :: (Has ReadFS sig m, Has Diagnostics sig m) => Path Abs Dir -> m (Maybe (Path Abs File))
-findFirstResolvedFileRecursively baseDir = listToMaybe <$> walk' findFile baseDir
+findFirstResolvedFileRecursively ::
+  ( Has ReadFS sig m
+  , Has Diagnostics sig m
+  , Has (Reader AllFilters) sig m
+  ) =>
+  Path Abs Dir ->
+  m (Maybe (Path Abs File))
+findFirstResolvedFileRecursively baseDir = listToMaybe <$> walkWithFilters' findFile baseDir
   where
     isParentDirSwiftPm :: Path Abs Dir -> Bool
     isParentDirSwiftPm d = (dirname d) == [reldir|swiftpm|]

test/Discovery/FiltersSpec.hs

@@ -24,6 +24,7 @@ import Discovery.Filters (
   withToolFilter,
  )
 import Path (Dir, Path, Rel, mkRelDir)
+import Test.Fixtures (excludePath)
 import Test.Hspec (
   Expectation,
   Spec,
@@ -284,9 +285,6 @@ testHarness include exclude = traverse_ testSingle
   where
     testSingle ((buildtool, dir), targets, expected) = applyFilters (AllFilters include exclude) buildtool dir targets `shouldBe` expected
 
-excludePath :: Path Rel Dir -> AllFilters
-excludePath path = AllFilters mempty $ comboExclude mempty [path]
-
 excludeTool :: DiscoveredProjectType -> AllFilters
 excludeTool tool = AllFilters mempty $ comboExclude [TypeTarget $ toText tool] mempty