diff --git a/src/App/Fossa/Analyze/Discover.hs b/src/App/Fossa/Analyze/Discover.hs index 26bd961918..2def7d9daa 100644 --- a/src/App/Fossa/Analyze/Discover.hs +++ b/src/App/Fossa/Analyze/Discover.hs @@ -47,7 +47,7 @@ import Strategy.SwiftPM qualified as SwiftPM import Types (DiscoveredProject) discoverFuncs :: DiscoverTaskEffs sig m => [DiscoverFunc m] -discoverFuncs = +discoverFuncs = [ DiscoverFunc Bundler.discover , DiscoverFunc Cabal.discover , DiscoverFunc Cargo.discover diff --git a/src/Strategy/SwiftPM.hs b/src/Strategy/SwiftPM.hs index f6d12c9ee6..9d8b61ae39 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,13 @@ 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..407a284c79 100644 --- a/test/Discovery/FiltersSpec.hs +++ b/test/Discovery/FiltersSpec.hs @@ -284,6 +284,8 @@ testHarness include exclude = traverse_ testSingle where testSingle ((buildtool, dir), targets, expected) = applyFilters (AllFilters include exclude) buildtool dir targets `shouldBe` expected +-- This is copy/pasted into WalkSpec.hs +-- and might deserve a common definition excludePath :: Path Rel Dir -> AllFilters excludePath path = AllFilters mempty $ comboExclude mempty [path] diff --git a/test/Discovery/WalkSpec.hs b/test/Discovery/WalkSpec.hs index ffe6969823..733ebbaa72 100644 --- a/test/Discovery/WalkSpec.hs +++ b/test/Discovery/WalkSpec.hs @@ -16,12 +16,52 @@ import Data.Map qualified as Map import Discovery.Walk import Effect.ReadFS import Path -import Path.IO (createDir, createDirLink) +import Path.IO (createDir, createDirLink, setPermissions, emptyPermissions, getPermissions) import Test.Effect import Test.Hspec +import Discovery.Filters ( AllFilters(AllFilters), comboExclude ) +import Control.Carrier.Reader (runReader) -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 -> error "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 +128,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 +153,31 @@ 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 = @@ -128,3 +198,8 @@ runWalkWithCircuitBreaker maxIters startDir = pure WalkStop ) startDir + +-- This is copy/pasted from FilterSpec.hs +-- and might deserve a common definition +excludePath :: Path Rel Dir -> AllFilters +excludePath path = AllFilters mempty $ comboExclude mempty [path] \ No newline at end of file