Alternate WIP for ANE-2123 - uses more direct arguments, has more com…

…mentary, added back in test case

src/App/Fossa/Analyze.hs

@@ -512,7 +512,8 @@ doAssertRevisionBinaries ::
   Locator ->
   m ()
 doAssertRevisionBinaries (IATAssertion (Just dir)) locator =
-  assertRevisionBinaries dir locator
+  -- TODO: get an AllFilters here
+  assertRevisionBinaries Nothing dir locator
 doAssertRevisionBinaries _ _ = pure ()
 
 doAnalyzeDynamicLinkedBinary ::

src/App/Fossa/BinaryDeps.hs

@@ -29,7 +29,7 @@ import Types (DiscoveredProjectType (BinaryDepsProjectType), GraphBreadth (Compl
 -- Users may then use standard FOSSA UX flows to ignore or add license information to the detected binaries.
 analyzeBinaryDeps :: (Has (Lift IO) sig m, Has Diagnostics sig m, Has Logger sig m, Has ReadFS sig m) => Path Abs Dir -> AllFilters -> m (Maybe SourceUnit)
 analyzeBinaryDeps dir filters = do
-  binaryPaths <- findBinaries (toPathFilters dir filters) dir
+  binaryPaths <- findBinaries filters dir
   if null binaryPaths
     then pure Nothing
     else do
@@ -46,13 +46,14 @@ analyzeBinaryDeps dir filters = do
 analyzeSingleBinary :: (Has (Lift IO) sig m, Has Logger sig m, Has ReadFS sig m, Has Diagnostics sig m) => Path Abs Dir -> Path Abs File -> m SourceUserDefDep
 analyzeSingleBinary root file = context ("Analyzing " <> toText file) $ resolveBinary strategies root file
 
-findBinaries :: (Has (Lift IO) sig m, Has Diagnostics sig m, Has ReadFS sig m) => PathFilters -> Path Abs Dir -> m [Path Abs File]
-findBinaries filters = walk' $ \dir _ files -> do
-  if shouldFingerprintDir dir filters
-    then do
-      binaries <- filterM contentIsBinary files
-      pure (binaries, WalkContinue)
-    else pure ([], WalkContinue)
+findBinaries :: (Has (Lift IO) sig m, Has Diagnostics sig m, Has ReadFS sig m) => AllFilters -> Path Abs Dir -> m [Path Abs File]
+findBinaries filters = walk' (Just filters) $ \dir _ files -> do
+  let pathFilters = toPathFilters dir filters
+    in if shouldFingerprintDir dir pathFilters
+      then do
+        binaries <- filterM contentIsBinary files
+        pure (binaries, WalkContinue)
+      else pure ([], WalkContinue)
 
 -- | PathFilters is a specialized filter mechanism that operates only on absolute directory paths.
 data PathFilters = PathFilters
@@ -102,7 +103,8 @@ resolveBinary [] = strategyRawFingerprint
 -- | Functions which may be able to resolve a binary to a dependency.
 strategies :: (Has (Lift IO) sig m, Has Diagnostics sig m, Has Logger sig m, Has ReadFS sig m) => [(Path Abs Dir -> Path Abs File -> m (Maybe SourceUserDefDep))]
 strategies =
-  [resolveJar]
+  -- TODO: get an AllFilters in here
+  [resolveJar Nothing]
 
 -- | Fallback strategy: resolve to a user defined dependency for the binary, where the name is the relative path and the version is the fingerprint.
 -- This strategy is used if no other strategy succeeds at resolving the binary.

src/App/Fossa/BinaryDeps/Jar.hs

@@ -40,6 +40,7 @@ import Strategy.Maven.Pom.PomFile (
   pomLicenseName,
   validatePom,
  )
+import Discovery.Filters (AllFilters)
 
 data JarMetadata = JarMetadata
   { jarName :: Text
@@ -53,9 +54,9 @@ data JarMetadata = JarMetadata
 --   2. Search inside for a file named `pom.xml`; if there are multiple pick the one with the shortest path.
 --      If a representative pom.xml was found, parse it and return metadata derived from it.
 --   3. Attempt to open `META-INF/MANIFEST.MF`, parse it, and return metadata derived from it.
-resolveJar :: (Has (Lift IO) sig m, Has Diagnostics sig m, Has Logger sig m, Has ReadFS sig m) => Path Abs Dir -> Path Abs File -> m (Maybe SourceUserDefDep)
-resolveJar _ file | not $ fileHasSuffix file [".jar", ".aar"] = pure Nothing
-resolveJar root file = do
+resolveJar :: (Has (Lift IO) sig m, Has Diagnostics sig m, Has Logger sig m, Has ReadFS sig m) => Maybe AllFilters -> Path Abs Dir -> Path Abs File -> m (Maybe SourceUserDefDep)
+resolveJar _ _ file | not $ fileHasSuffix file [".jar", ".aar"] = pure Nothing
+resolveJar filters root file = do
   let fileDescription = toText file
   logDebug $ "Inferring metadata from " <> pretty fileDescription
   result <- recover
@@ -64,7 +65,7 @@ resolveJar root file = do
     . context ("Infer metadata from " <> fileDescription)
     . runFinally
     $ withArchive extractZip file
-    $ \dir -> tacticPom dir <||> tacticMetaInf dir
+    $ \dir -> tacticPom filters dir <||> tacticMetaInf dir
   pure $ fmap (toUserDefDep root file) (join result)
 
 newtype FailedToResolveJar = FailedToResolveJar (Path Abs File)
@@ -101,9 +102,9 @@ metaInfManifestToMeta manifest =
     <*> fromMaybeText "Missing implementation version" (Map.lookup "Implementation-Version" manifest)
     <*> pure "" -- Don't attempt to use Bundle-License; it's a URL and we don't parse it on the backend
 
-tacticPom :: (Has (Lift IO) sig m, Has Diagnostics sig m, Has Logger sig m, Has ReadFS sig m) => Path Abs Dir -> m JarMetadata
-tacticPom archive = context ("Parse representative pom.xml in " <> toText archive) $ do
-  poms <- context "Find pom.xml files" $ walk' (collectFilesNamed "pom.xml") (archive </> $(mkRelDir "META-INF"))
+tacticPom :: (Has (Lift IO) sig m, Has Diagnostics sig m, Has Logger sig m, Has ReadFS sig m) => Maybe AllFilters -> Path Abs Dir -> m JarMetadata
+tacticPom filters archive = context ("Parse representative pom.xml in " <> toText archive) $ do
+  poms <- context "Find pom.xml files" $ walk' filters (collectFilesNamed "pom.xml") (archive </> $(mkRelDir "META-INF"))
   when (length poms > 1) $
     logDebug $
       "Found multiple pom.xml files: " <> pretty (Text.intercalate "; " $ map (renderRelative archive) poms)

src/App/Fossa/LicenseScanner.hs

@@ -136,7 +136,7 @@ recursivelyScanArchives ::
   FileUpload ->
   Path Abs Dir ->
   m [LicenseUnit]
-recursivelyScanArchives pathPrefix licenseScanPathFilters uploadKind dir = flip walk' dir $
+recursivelyScanArchives pathPrefix licenseScanPathFilters uploadKind dir = flip (walk' Nothing) dir $
   \_ _ files -> do
     let process file unpackedDir = do
           let updatedPathPrefix = pathPrefix <> getPathPrefix dir (parent file)
@@ -292,7 +292,7 @@ hasAnyFiles ::
   m Bool
 hasAnyFiles path = getAny <$> go path
   where
-    go = walk' $ \_ _ files ->
+    go = walk' Nothing $ \_ _ files ->
       pure
         if null files
           then (Any False, WalkContinue)

src/App/Fossa/Reachability/Maven.hs

@@ -23,6 +23,7 @@ import Strategy.Maven.Pom.PomFile (
   PomBuild (PomBuild),
  )
 import Text.Pretty.Simple (pShow)
+import Discovery.Filters (AllFilters)
 
 -- | Discovers the JAR files associated with the project at the provided path,
 -- then returns the parsed results of analyzing these JARs.
@@ -33,10 +34,11 @@ mavenJarCallGraph ::
   , Has Exec sig m
   , Has (Lift IO) sig m
   ) =>
+  Maybe AllFilters ->
   Path Abs Dir ->
   m CallGraphAnalysis
-mavenJarCallGraph dir = context ("build call graph for " <> toText dir) $ do
-  jars <- getJarsByBuild dir
+mavenJarCallGraph filters dir = context ("build call graph for " <> toText dir) $ do
+  jars <- getJarsByBuild filters dir
   logDebug . pretty $ "found jars: " ++ show jars
   callGraphFromJars jars
 
@@ -45,10 +47,11 @@ getJarsByBuild ::
   , Has ReadFS sig m
   , Has Diagnostics sig m
   ) =>
+  Maybe AllFilters ->
   Path Abs Dir ->
   m [Path Abs File]
-getJarsByBuild dir = context ("find jars from build for project at '" <> toText dir <> "'") $ do
-  mvnProjectClosures <- findProjects dir
+getJarsByBuild filters dir = context ("find jars from build for project at '" <> toText dir <> "'") $ do
+  mvnProjectClosures <- findProjects filters dir
   let pomPathsAndPom = concatMap (Map.elems . closurePoms) mvnProjectClosures
 
   candidateJars <- catMaybes <$> traverse getJarPathFromPom pomPathsAndPom

src/App/Fossa/Reachability/Upload.hs

@@ -141,7 +141,8 @@ callGraphOf (Scanned dpi (Success _ projectResult)) = do
           callGraphFromJars jars
         Nothing -> do
           logDebug . pretty $ "Trying to infer build jars from maven project: " <> show (projectResultPath projectResult)
-          mavenJarCallGraph (projectResultPath projectResult)
+          --TODO: how to get an AllFilters here?
+          mavenJarCallGraph Nothing (projectResultPath projectResult)
       case analysis of
         Success wg r -> pure $ SourceUnitReachabilityFound dpi (Success wg $ unit{callGraphAnalysis = r})
         Failure wg eg -> pure $ SourceUnitReachabilityFound dpi (Failure wg eg)

src/App/Fossa/VSI/Analyze.hs

@@ -32,7 +32,7 @@ import Data.String.Conversion (decodeUtf8, toText)
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Discovery.Archive (withArchive')
-import Discovery.Filters (AllFilters, combinedPaths, excludeFilters, includeFilters)
+import Discovery.Filters (combinedPaths, excludeFilters, includeFilters, AllFilters)
 import Discovery.Walk (WalkStep (WalkContinue, WalkSkipAll), walk)
 import Effect.Logger (Color (..), Logger, Severity (SevError, SevInfo, SevWarn), annotate, color, hsep, logDebug, logInfo, plural, pretty)
 import Effect.ReadFS (ReadFS)
@@ -239,8 +239,10 @@ discover ::
   m ()
 discover output filters root renderAncestry =
   context "discover" $ do
+    -- TODO: get a Reader in the sig? Get an AllFilters?
+    -- allFilters <- ask @AllFilters
     logDebug . pretty $ "walking new root: " <> toText root
-    flip walk root $ \dir _ files -> handle dir files
+    flip (walk $ Nothing) root $ \dir _ files -> handle dir files
   where
     handle dir files | filters `allow` dir = do
       logDebug . pretty $ "processing dir: " <> toText dir

src/App/Fossa/VSI/Fingerprint.hs

@@ -29,6 +29,7 @@ import Data.Word8 (isSpace)
 import Discovery.Walk (WalkStep (..), walk')
 import Effect.ReadFS (ReadFS, contentIsBinary)
 import Path (Abs, Dir, File, Path, toFilePath)
+import Discovery.Filters (AllFilters)
 
 -- | Fingerprint deterministically idenfies a file and is derived from its content.
 --
@@ -99,8 +100,8 @@ fingerprintRaw file = context "raw" $ contentIsBinary file >>= doFingerprint
       fp <- hasher $ toFilePath file
       pure $ encodeFingerprint fp
 
-fingerprintContentsRaw :: (Has ReadFS sig m, Has Diagnostics sig m, Has (Lift IO) sig m) => Path Abs Dir -> m [Fingerprint Raw]
-fingerprintContentsRaw = walk' $ \_ _ files -> do
+fingerprintContentsRaw :: (Has ReadFS sig m, Has Diagnostics sig m, Has (Lift IO) sig m) => Maybe AllFilters -> Path Abs Dir -> m [Fingerprint Raw]
+fingerprintContentsRaw filters = walk' filters $ \_ _ files -> do
   fps <- traverse fingerprintRaw files
   pure (fps, WalkContinue)
 

src/App/Fossa/VSI/IAT/AssertRevisionBinaries.hs

@@ -11,6 +11,7 @@ import Effect.Logger (Logger, logInfo)
 import Effect.ReadFS (ReadFS)
 import Path (Abs, Dir, Path)
 import Srclib.Types (Locator)
+import Discovery.Filters (AllFilters (AllFilters))
 
 assertRevisionBinaries ::
   ( Has Diagnostics sig m
@@ -19,12 +20,13 @@ assertRevisionBinaries ::
   , Has Logger sig m
   , Has API.FossaApiClient sig m
   ) =>
+  Maybe AllFilters ->
   Path Abs Dir ->
   Locator ->
   m ()
-assertRevisionBinaries dir locator = do
+assertRevisionBinaries filters dir locator = do
   logInfo "Fingerprinting assertion directory contents"
-  fingerprints <- fingerprintContentsRaw dir
+  fingerprints <- fingerprintContentsRaw filters dir
 
   logInfo "Uploading assertion to FOSSA"
   API.assertRevisionBinaries locator fingerprints

src/App/Fossa/VSI/IAT/AssertUserDefinedBinaries.hs

@@ -38,7 +38,7 @@ assertUserDefinedBinaries LinkUserBinsConfig{..} = do
   void $ guardWithPreflightChecks apiOpts AssertUserDefinedBinariesChecks
 
   logInfo "Fingerprinting directory contents"
-  fingerprints <- fingerprintContentsRaw $ unBaseDir baseDir
+  fingerprints <- fingerprintContentsRaw Nothing $ unBaseDir baseDir
 
   logInfo "Uploading assertion to FOSSA"
   ignoreDebug . runFossaApiClient apiOpts $ API.assertUserDefinedBinaries binMetadata fingerprints

src/Discovery/Archive.hs

@@ -51,6 +51,8 @@ import Path qualified as P
 import Path.IO qualified as PIO
 import Prettyprinter (Pretty (pretty), hsep, viaShow, vsep)
 import Prelude hiding (zip)
+import Discovery.Filters (AllFilters (AllFilters))
+import Control.Carrier.Reader (Reader, ask)
 
 data ArchiveUnpackFailure = ArchiveUnpackFailure (Path Abs File) SomeException
 newtype UnsupportedArchiveErr = UnsupportedArchiveErr (Path Abs File)
@@ -84,7 +86,7 @@ convertArchiveToDir file = do
 
 -- | Given a function to run over unarchived contents, recursively unpack archives
 discover ::
-  (Has (Lift IO) sig m, Has ReadFS sig m, Has Diagnostics sig m, Has Finally sig m, Has TaskPool sig m) =>
+  (Has (Lift IO) sig m, Has ReadFS sig m, Has Diagnostics sig m, Has Finally sig m, Has TaskPool sig m, Has (Reader Discovery.Filters.AllFilters) sig m) =>
   -- | Callback to run on the discovered file
   (Path Abs Dir -> Maybe FileAncestry -> m ()) ->
   -- | Path to the archive
@@ -93,7 +95,8 @@ discover ::
   (Path Abs Dir -> Path Abs File -> m (Path Rel File)) ->
   m ()
 discover go dir renderAncestry = context "Finding archives" $ do
-  flip walk dir $ \_ _ files -> do
+  filters <- ask @Discovery.Filters.AllFilters
+  flip (walk $ Just filters) dir $ \_ _ files -> do
     -- To process an unpacked archive, run the provided function on the archive
     -- contents, and recursively call discover
     let process file unpackedDir = context (toText (fileName file)) $ do

src/Discovery/Walk.hs

@@ -22,7 +22,7 @@ import Data.Foldable (find)
 import Data.Functor (void)
 import Data.Glob qualified as Glob
 import Data.List ((\\))
-import Data.Maybe (mapMaybe)
+import Data.Maybe (mapMaybe, isJust)
 import Data.Set qualified as Set
 import Data.String.Conversion (toString, toText)
 import Data.Text (Text)
@@ -51,10 +51,11 @@ walk ::
   ( Has ReadFS sig m
   , Has Diagnostics sig m
   ) =>
+  Maybe AllFilters ->
   (Path Abs Dir -> [Path Abs Dir] -> [Path Abs File] -> m WalkStep) ->
   Path Abs Dir ->
   m ()
-walk f = walkDir $ \dir subdirs files -> do
+walk filters f = walkDir filters $ \dir subdirs files -> do
   -- Check that the path matches the filters
   step <- f dir subdirs files
   case step of
@@ -92,11 +93,12 @@ walk' ::
   , Has Diagnostics sig m
   , Monoid o
   ) =>
+  Maybe AllFilters ->
   (Path Abs Dir -> [Path Abs Dir] -> [Path Abs File] -> m (o, WalkStep)) ->
   Path Abs Dir ->
   m o
-walk' f base = do
-  foo <- runWriter (curry pure) $ walk mangled base
+walk' filters f base = do
+  foo <- runWriter (curry pure) $ walk filters mangled base
   pure (fst foo)
   where
     mangled :: Path Abs Dir -> [Path Abs Dir] -> [Path Abs File] -> WriterC o m WalkStep
@@ -118,7 +120,7 @@ walkWithFilters' ::
 walkWithFilters' f root = do
   filters <- ask
   let f' dir subdirs files = pathFilterIntercept filters root dir $ f dir subdirs files
-  walk' f' root
+  walk' (Just filters) f' root
 
 -- | Search upwards in the directory tree for the existence of the supplied file.
 findFileInAncestor :: (Has ReadFS sig m, Has Diagnostics sig m) => Path Abs Dir -> Text -> m (Path Abs File)
@@ -161,12 +163,14 @@ findFilesMatchingGlob g = filter (`Glob.matches` g)
 
 walkDir ::
   (Has ReadFS sig m, Has Diagnostics sig m) =>
+  -- | Optional Filters to respect dir exclusion filters
+  Maybe AllFilters ->
   -- | Handler (@dir -> subdirs -> files -> 'WalkAction'@)
   (Path Abs Dir -> [Path Abs Dir] -> [Path Abs File] -> m (WalkAction Abs)) ->
   -- | Directory where traversal begins
   Path Abs Dir ->
   m ()
-walkDir handler topdir =
+walkDir filters handler topdir =
   context "Walking the filetree" $
     void $
       -- makeAbsolute topdir >>= walkAvoidLoop Set.empty
@@ -177,19 +181,24 @@ walkDir handler topdir =
       case mRes of
         Nothing -> pure $ Just ()
         Just traversed' -> walktree traversed' curdir
-    walktree traversed curdir = do
-      (subdirs, files) <- listDir curdir
-      action <- handler curdir subdirs files
-      case action of
-        WalkFinish -> pure Nothing
-        WalkExclude xdirs ->
-          case subdirs \\ xdirs of
-            [] -> pure $ Just ()
-            ds ->
-              runMaybeT $
-                mapM_
-                  (MaybeT . walkAvoidLoop traversed)
-                  ds
+    walktree traversed curdir =
+        let isPathAllowed = maybe True ((flip pathAllowed) (dirname curdir)) filters
+        in if isPathAllowed
+          then do
+            (subdirs, files) <- listDir curdir
+            action <- handler curdir subdirs files
+            case action of
+              WalkFinish -> pure Nothing
+              WalkExclude xdirs ->
+                case subdirs \\ xdirs of
+                  [] -> pure $ Just ()
+                  ds ->
+                    runMaybeT $
+                      mapM_
+                        (MaybeT . walkAvoidLoop traversed)
+                        ds
+          else pure Nothing
+
     checkLoop traversed dir = do
       identifier <- getIdentifier dir
       pure $

src/Strategy/Maven.hs

@@ -20,7 +20,7 @@ import Data.Set.NonEmpty (nonEmpty, toSet)
 import Data.Text hiding (group, map)
 import DepTypes (Dependency)
 import Diag.Common (MissingDeepDeps (MissingDeepDeps), MissingEdges (MissingEdges))
-import Discovery.Filters (AllFilters, MavenScopeFilters, mavenScopeFilterSet)
+import Discovery.Filters (AllFilters (AllFilters), MavenScopeFilters, mavenScopeFilterSet)
 import Discovery.Simple (simpleDiscover)
 import Effect.Exec (CandidateCommandEffs, GetDepsEffs)
 import Effect.ReadFS (ReadFS)
@@ -44,9 +44,12 @@ discover ::
   Path Abs Dir ->
   m [DiscoveredProject MavenProject]
 discover = do
-  simpleDiscover findProjects mkProject MavenProjectType
+  -- TODO: why doesn't `Has (Reader AllFilters) sig m` give me the affordance to call `ask` here?
+  -- filters <- ask @AllFilters
+  filters :: AllFilters <- undefined
+  simpleDiscover (findProjects filters) mkProject MavenProjectType
   where
-    findProjects dir = map MavenProject <$> PomClosure.findProjects dir
+    findProjects filters dir = map MavenProject <$> PomClosure.findProjects (Just filters) dir
 
 mkProject :: MavenProject -> DiscoveredProject MavenProject
 mkProject (MavenProject closure) =