From 847addf0625fcc1dcc224bca80cacea222d2bcd6 Mon Sep 17 00:00:00 2001 From: james-fossa <167804629+james-fossa@users.noreply.github.com> Date: Wed, 15 Jan 2025 15:59:31 -0500 Subject: [PATCH] [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 * [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 Co-authored-by: Christopher Sasarak --- Changelog.md | 3 ++ src/App/Fossa/Analyze.hs | 6 ++- src/App/Fossa/Reachability/Maven.hs | 4 ++ src/App/Fossa/Reachability/Upload.hs | 3 ++ src/Discovery/Walk.hs | 36 +++++++++++-- src/Strategy/Maven/Pom/Closure.hs | 17 +++--- src/Strategy/Node.hs | 6 +-- src/Strategy/SwiftPM.hs | 44 +++++++++++---- test/Discovery/FiltersSpec.hs | 4 +- test/Discovery/WalkSpec.hs | 80 ++++++++++++++++++++++++++-- test/Test/Fixtures.hs | 12 ++++- 11 files changed, 181 insertions(+), 34 deletions(-) diff --git a/Changelog.md b/Changelog.md index d07347a554..d77a586edd 100644 --- a/Changelog.md +++ b/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 diff --git a/src/App/Fossa/Analyze.hs b/src/App/Fossa/Analyze.hs index 206ebc2b7f..1d7dc43600 100644 --- a/src/App/Fossa/Analyze.hs +++ b/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 diff --git a/src/App/Fossa/Reachability/Maven.hs b/src/App/Fossa/Reachability/Maven.hs index 3dee031702..2421fe4b67 100644 --- a/src/App/Fossa/Reachability/Maven.hs +++ b/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] diff --git a/src/App/Fossa/Reachability/Upload.hs b/src/App/Fossa/Reachability/Upload.hs index a2cec00b94..3f8c6228bd 100644 --- a/src/App/Fossa/Reachability/Upload.hs +++ b/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 diff --git a/src/Discovery/Walk.hs b/src/Discovery/Walk.hs index 7feab80b84..9a08443c56 100644 --- a/src/Discovery/Walk.hs +++ b/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 diff --git a/src/Strategy/Maven/Pom/Closure.hs b/src/Strategy/Maven/Pom/Closure.hs index 6bc35ebc67..b86b7e541e 100644 --- a/src/Strategy/Maven/Pom/Closure.hs +++ b/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 diff --git a/src/Strategy/Node.hs b/src/Strategy/Node.hs index 78ea856d7c..1682fadf42 100644 --- a/src/Strategy/Node.hs +++ b/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) diff --git a/src/Strategy/SwiftPM.hs b/src/Strategy/SwiftPM.hs index f6d12c9ee6..8ba5e93b87 100644 --- a/src/Strategy/SwiftPM.hs +++ b/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|] diff --git a/test/Discovery/FiltersSpec.hs b/test/Discovery/FiltersSpec.hs index 910b29ebea..1076de8053 100644 --- a/test/Discovery/FiltersSpec.hs +++ b/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 diff --git a/test/Discovery/WalkSpec.hs b/test/Discovery/WalkSpec.hs index ffe6969823..3dd14d6684 100644 --- a/test/Discovery/WalkSpec.hs +++ b/test/Discovery/WalkSpec.hs @@ -5,6 +5,7 @@ module Discovery.WalkSpec ( spec, ) where +import Control.Carrier.Reader (runReader) import Control.Carrier.State.Strict (runState) import Control.Carrier.Writer.Strict (runWriter, tell) import Control.Effect.Diagnostics (Diagnostics) @@ -13,15 +14,55 @@ import Control.Effect.State (get, put) import Data.Foldable (traverse_) import Data.Map (Map) import Data.Map qualified as Map +import Discovery.Filters (AllFilters) import Discovery.Walk import Effect.ReadFS import Path -import Path.IO (createDir, createDirLink) +import Path.IO (createDir, createDirLink, emptyPermissions, getPermissions, setPermissions) import Test.Effect +import Test.Fixtures (excludePath) import Test.Hspec -spec :: Spec -spec = +walkWithFilters'Spec :: Spec +walkWithFilters'Spec = + describe "walkWithFilters'" $ do + it' "ignores excluded paths" . withTempDir "test-Discovery-Walk-walkWithFilters'" $ \tmpDir -> do + let dirs@[foo, bar, baz] = + map + (tmpDir ) + [ $(mkRelDir "foo") + , $(mkRelDir "foo/bar") + , $(mkRelDir "foo/baz") + ] + sendIO $ do + traverse_ createDir dirs + setPermissions bar emptyPermissions + + case stripProperPrefix tmpDir bar of + Nothing -> expectationFailure' "Failed to get a relative path of foo/bar" + Just relBar -> do + let filters = excludePath relBar + paths <- runWalkWithFilters' 100 filters tmpDir + pathsToTree paths + `shouldBe'` dirTree + [ + ( tmpDir + , dirTree + [ + ( foo + , dirTree + [ (baz, dirTree []) + ] + ) + ] + ) + ] + sendIO $ do + fooPermissions <- getPermissions foo + setPermissions bar fooPermissions + +walkSpec :: Spec +walkSpec = describe "walk" $ do it' "does a pre-order depth-first traversal" . withTempDir "test-Discovery-Walk" $ \tmpDir -> do let dirs@[a, ab, c, cd] = @@ -88,6 +129,11 @@ spec = ) ] +spec :: Spec +spec = do + walkSpec + walkWithFilters'Spec + newtype DirTree = DirTree (Map (Path Abs Dir) DirTree) deriving (Show, Eq) dirTree :: [(Path Abs Dir, DirTree)] -> DirTree @@ -108,6 +154,34 @@ runWalk :: (Has ReadFS sig m, Has Diagnostics sig m) => Path Abs Dir -> m [Path Abs Dir] runWalk = runWalkWithCircuitBreaker 100 +runWalkWithFilters' :: + ( Has ReadFS sig m + , Has Diagnostics sig m + ) => + Int -> + AllFilters -> + Path Abs Dir -> + m [Path Abs Dir] +runWalkWithFilters' maxIters filters startDir = + do + fmap fst + . runWriter + . fmap snd + . runState (0 :: Int) + . runReader filters + $ walkWithFilters' + ( \dir _ _ -> do + iterations :: Int <- get + if iterations < maxIters + then do + put (iterations + 1) + tell [dir] + pure ((), WalkContinue) + else do + pure ((), WalkStop) + ) + startDir + runWalkWithCircuitBreaker :: (Has ReadFS sig m, Has Diagnostics sig m) => Int -> Path Abs Dir -> m [Path Abs Dir] runWalkWithCircuitBreaker maxIters startDir = diff --git a/test/Test/Fixtures.hs b/test/Test/Fixtures.hs index 7bc753afc4..c829e32f16 100644 --- a/test/Test/Fixtures.hs +++ b/test/Test/Fixtures.hs @@ -57,6 +57,7 @@ module Test.Fixtures ( releaseProject, policy, team, + excludePath, ) where import App.Fossa.Config.Analyze (AnalysisTacticTypes (Any), AnalyzeConfig (AnalyzeConfig), ExperimentalAnalyzeConfig (..), GoDynamicTactic (..), IncludeAll (..), JsonOutput (JsonOutput), NoDiscoveryExclusion (..), ScanDestination (..), UnpackArchives (..), VSIModeOptions (..), VendoredDependencyOptions (..), WithoutDefaultFilters (..)) @@ -80,12 +81,16 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text.Encoding qualified as TL import Data.Text.Extra (showT) -import Discovery.Filters (AllFilters, MavenScopeFilters (MavenScopeIncludeFilters)) +import Discovery.Filters ( + AllFilters (AllFilters), + MavenScopeFilters (MavenScopeIncludeFilters), + comboExclude, + ) import Effect.Logger (Severity (..)) import Fossa.API.CoreTypes qualified as CoreAPI import Fossa.API.Types (Archive (..)) import Fossa.API.Types qualified as API -import Path (Abs, Dir, Path, mkAbsDir, mkRelDir, parseAbsDir, ()) +import Path (Abs, Dir, Path, Rel, mkAbsDir, mkRelDir, parseAbsDir, ()) import Srclib.Types (LicenseScanType (..), LicenseSourceUnit (..), Locator (..), SourceUnit (..), SourceUnitBuild (..), SourceUnitDependency (..), emptyLicenseUnit) import System.Directory (getTemporaryDirectory) import Text.RawString.QQ (r) @@ -607,3 +612,6 @@ M:vuln.project.sample.App:parse(java.net.URL) (M)org.dom4j.io.SAXReader:read(jav sampleJarParsedContent' :: LB.ByteString sampleJarParsedContent' = LB.fromStrict . TL.encodeUtf8 $ sampleJarParsedContent + +excludePath :: Path Rel Dir -> AllFilters +excludePath path = AllFilters mempty $ comboExclude mempty [path]