[ANE-2123] Address PR comments

spectrometer.cabal

@@ -383,6 +383,7 @@ library
     Data.String.Conversion
     Data.Tagged
     Data.Text.Extra
+    Data.Tuple.Extra
     Data.Tracing.Instrument
     DepTypes
     Diag.Common
@@ -647,6 +648,7 @@ test-suite unit-tests
     Erlang.Rebar3TreeSpec
     Extra.ListSpec
     Extra.TextSpec
+    Extra.TupleSpec
     Fortran.FpmTomlSpec
     Fossa.API.TypesSpec
     Go.GlideLockSpec

src/Data/List/Extra.hs

@@ -2,6 +2,7 @@ module Data.List.Extra (
   (!?),
   head',
   singleton,
+  notNull,
 ) where
 
 import Data.Maybe (listToMaybe)
@@ -21,3 +22,7 @@ head' = listToMaybe
 -- | Create a one-item list from the item given
 singleton :: a -> [a]
 singleton = (: [])
+
+-- | Composition of not and null
+notNull :: [a] -> Bool
+notNull = not . null

src/Data/Tuple/Extra.hs

@@ -0,0 +1,7 @@
+module Data.Tuple.Extra (
+  mapSnd,
+) where
+
+-- | Apply a function to a pair's second element
+mapSnd :: (b -> c) -> (a, b) -> (a, c)
+mapSnd f (a, b) = (a, f b)

src/Discovery/Walk.hs

@@ -14,21 +14,23 @@ module Discovery.Walk (
 ) where
 
 import Control.Carrier.Writer.Church
-import Control.Effect.Diagnostics
+import Control.Effect.Diagnostics ( Diagnostics, fatal, context )
 import Control.Effect.Reader (Reader, ask)
 import Control.Monad.Trans
 import Control.Monad.Trans.Maybe
 import Data.Foldable (find)
 import Data.Functor (void)
 import Data.Glob qualified as Glob
 import Data.List ((\\))
+import Data.List.Extra (notNull)
 import Data.Maybe (mapMaybe)
 import Data.Set qualified as Set
 import Data.String.Conversion (toString, toText)
 import Data.Text (Text)
 import Discovery.Filters (pathAllowed, AllFilters)
 import Effect.ReadFS
 import Path
+import Data.Tuple.Extra (mapSnd)
 
 data WalkStep
   = -- | Continue walking subdirectories
@@ -83,36 +85,32 @@ pathFilterIntercept filters base dir subdirs act = do
     Nothing -> act
     Just relative ->
       if pathAllowed filters relative
-        then skipDisallowed act
+        then fmap (mapSnd skipDisallowed) act
         else pure (mempty, WalkSkipAll)
   where
-    disallowedSubdirs :: [Path Abs Dir]
+    disallowedSubdirs :: [Text]
     disallowedSubdirs = do
       subdir <- subdirs
       stripped <- stripProperPrefix base subdir
       let isAllowed = pathAllowed filters stripped
       if isAllowed
         then mempty
-        else [subdir]
+        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 :: (Applicative m) => m (o, WalkStep) -> m (o, WalkStep)
-    skipDisallowed =
-      fmap $ \ (o, action) ->
-        let skipNames = map (toText . toFilePath . dirname) disallowedSubdirs
-        in if not (null disallowedSubdirs)
-            then
-              let step = case action of
-                    WalkContinue -> WalkSkipSome skipNames
-                    WalkSkipSome dirs -> WalkSkipSome $ skipNames ++ dirs
-                    WalkSkipAll -> action
-                    WalkStop -> action
-              in (o, step)
-            else
-              (o, action)
+    skipDisallowed :: WalkStep ->  WalkStep
+    skipDisallowed action =
+      if notNull disallowedSubdirs
+        then
+          case action of
+            WalkContinue -> WalkSkipSome disallowedSubdirs
+            WalkSkipSome dirs -> WalkSkipSome $ disallowedSubdirs ++ dirs
+            _ -> action
+        else
+          action
 
 -- | Like @walk@, but collects the output of @f@ in a monoid.
 walk' ::
@@ -198,6 +196,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

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,11 +285,6 @@ 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]
-
 excludeTool :: DiscoveredProjectType -> AllFilters
 excludeTool tool = AllFilters mempty $ comboExclude [TypeTarget $ toText tool] mempty
 

test/Discovery/WalkSpec.hs

@@ -18,9 +18,10 @@ import Effect.ReadFS
 import Path
 import Path.IO (createDir, createDirLink, setPermissions, emptyPermissions, getPermissions)
 import Test.Effect
+import Test.Fixtures (excludePath)
 import Test.Hspec
-import Discovery.Filters ( AllFilters(AllFilters), comboExclude )
 import Control.Carrier.Reader (runReader)
+import Discovery.Filters (AllFilters)
 
 walkWithFilters'Spec :: Spec
 walkWithFilters'Spec =
@@ -197,9 +198,4 @@ runWalkWithCircuitBreaker maxIters startDir =
             else do
               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]
+      startDir

test/Extra/ListSpec.hs

@@ -1,6 +1,6 @@
 module Extra.ListSpec (spec) where
 
-import Data.List.Extra (singleton, (!?))
+import Data.List.Extra (singleton, (!?), notNull)
 import Test.Hspec (Spec, describe, it, shouldBe)
 
 spec :: Spec
@@ -18,3 +18,13 @@ spec = do
       list !? 5 `shouldBe` Nothing -- index == length
       list !? 6 `shouldBe` Nothing -- index == length + 1
       list !? 20 `shouldBe` Nothing -- index > length
+
+  describe "notNull" $ do
+    it "should return True for a nonempty List" $
+      notNull [True] `shouldBe` True
+
+    it "should return False for an empty List" $
+      notNull [] `shouldBe` False
+
+    it "should return the opposite of what `null` returns" $
+      notNull [] `shouldBe` (not . notNull) [True]

test/Extra/TupleSpec.hs

@@ -0,0 +1,10 @@
+module Extra.TupleSpec (spec) where
+
+import Data.Tuple.Extra (mapSnd)
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+spec :: Spec
+spec = do
+    describe "mapSnd" $ do
+        it "should apply the given function to the second element of the tuple" $ do
+            mapSnd (+1) (1, 1) `shouldBe` (1, 2)

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]