Fixes mvn:tree tactic to exclude project as direct dependency for sin…

…gle && multi-module projects (#375)

Changelog.md

@@ -1,5 +1,8 @@
 # Spectrometer Changelog
 
+## v2.15.23
+- Maven: Fixes `mvn:dependency` tactic to exclude root project as direct dependency. ([#375](https://github.com/fossas/spectrometer/pull/375))
+
 ## v2.15.22
 - Adds branch and revision information to the URL reported at the end of a `fossa analyze --experimental-enable-monorepo` scan. ([#378](https://github.com/fossas/spectrometer/pull/378))
 

src/Graphing.hs

@@ -40,6 +40,7 @@ module Graphing (
   pruneUnreachable,
   stripRoot,
   promoteToDirect,
+  shrinkRoots,
 
   -- * Conversions
   fromAdjacencyMap,
@@ -160,6 +161,15 @@ stripRoot (Graphing gr) = Graphing $ AM.overlay newDirectEdges (AM.removeVertex
     newDirectEdges :: AM.AdjacencyMap (Node ty)
     newDirectEdges = AM.edges $ map (Root,) newDirect
 
+-- | Shrinks all root nodes.
+-- Remove current direct nodes. It will promote their immediate children as directs.
+-- Unlike @stripRoot@, it removes them from graphing, instead of preserving them (as node), and their edges.
+shrinkRoots :: forall ty. Ord ty => Graphing ty -> Graphing ty
+shrinkRoots (Graphing gr) = Graphing $ foldr AME.shrinkSingle gr currentDirect
+  where
+    currentDirect :: [Node ty]
+    currentDirect = Set.toList $ AM.postSet Root gr
+
 -- | Add a direct node to this Graphing
 direct :: Ord ty => ty -> Graphing ty
 direct node = Graphing (AM.edge Root (Node node))

src/Strategy/Maven/DepTree.hs

@@ -6,6 +6,7 @@ module Strategy.Maven.DepTree (
   DotGraph (..),
   PackageId (..),
   toDependency,
+  buildGraph,
 ) where
 
 import Control.Algebra (Has, run)
@@ -28,7 +29,7 @@ import DepTypes (
 import Effect.Exec (AllowErr (..), Command (..), Exec, exec)
 import Effect.Grapher (direct, edge, evalGrapher)
 import Effect.ReadFS (ReadFS, doesFileExist, readContentsParser)
-import Graphing (Graphing, gmap)
+import Graphing (Graphing, gmap, shrinkRoots)
 import Path (Abs, Dir, File, Path, Rel, fromAbsFile, parseRelFile, (</>))
 import Path.IO (getTempDir, removeFile)
 import System.Random (randomIO)
@@ -142,7 +143,9 @@ analyze dir = do
       Nothing -> fatal $ toText $ "invalid file name: " <> f
 
 buildGraph :: [DotGraph] -> Graphing Dependency
-buildGraph = gmap toDependency . foldMap toGraph
+buildGraph = withoutProjectAsDep . gmap toDependency . foldMap toGraph
+  where
+    withoutProjectAsDep = shrinkRoots
 
 toDependency :: PackageId -> Dependency
 toDependency PackageId{groupName, artifactName, artifactVersion, buildTag} =

test/GraphingSpec.hs

@@ -80,3 +80,41 @@ spec = do
       expectDirect [] graph'
       expectDeps [1, 4, 5] graph'
       expectEdges [(1, 4), (4, 5)] graph'
+
+  describe "stripRoot" $ do
+    let graph :: Graphing Int
+        graph = Graphing.directs [1] <> Graphing.edges [(1, 2), (1, 3), (2, 4), (3, 6)]
+
+    it "should promote immediate children as direct nodes" $ do
+      let graph' = Graphing.stripRoot graph
+      expectDirect [2, 3] graph'
+
+    it "should preserve current root nodes in the graphing as nodes" $ do
+      let graph' = Graphing.stripRoot graph
+      expectDeps [1, 2, 3, 4, 6] graph'
+
+    it "should preserve edges of current root nodes in the graphing" $ do
+      let graph' = Graphing.stripRoot graph
+      expectEdges [(1, 2), (1, 3), (2, 4), (3, 6)] graph'
+
+  describe "shrinkRoots" $ do
+    let graph :: Graphing Int
+        graph = Graphing.directs [1] <> Graphing.edges [(1, 2), (1, 3), (2, 4), (3, 6)]
+
+    it "should remove direct nodes" $ do
+      let graph' = Graphing.shrinkRoots graph
+
+      expectDirect [2, 3] graph'
+      expectDeps [2, 3, 4, 6] graph'
+      expectEdges [(2, 4), (3, 6)] graph'
+
+    it "should not modify when there are no direct nodes" $ do
+      let graphWithoutDirectNodes :: Graphing Int
+          graphWithoutDirectNodes = Graphing.edges [(1, 2), (1, 3), (2, 4), (3, 6)]
+
+          graph' :: Graphing Int
+          graph' = Graphing.shrinkRoots graphWithoutDirectNodes
+
+      expectDirect [] graph'
+      expectDeps [1, 2, 3, 4, 6] graph'
+      expectEdges [(1, 2), (1, 3), (2, 4), (3, 6)] graph'

test/Maven/DepTreeSpec.hs

@@ -8,9 +8,11 @@ import DepTypes (
   Dependency (..),
   VerConstraint (..),
  )
+import GraphUtil
 import Strategy.Maven.DepTree (
   DotGraph (..),
   PackageId (..),
+  buildGraph,
   parseDotGraphs,
   toDependency,
  )
@@ -29,6 +31,22 @@ spec =
     it "parses single dot graphs" $
       parse parseDotGraphs fixtureSingleFile single `shouldParse` fixtureSingleGraph
 
+    it "should build dependency graph without project as dependency" $ do
+      -- Setup
+      let depRngCore = Dependency MavenType "org.apache.commons:commons-rng-core" (Just $ CEq "1.4-SNAPSHOT") [] [EnvProduction] (mempty)
+      let depMath3 = Dependency MavenType "org.apache.commons:commons-math3" (Just $ CEq "3.6.1") [] [EnvTesting] (mempty)
+      let depJunit = Dependency MavenType "junit:junit" (Just $ CEq "4.13.1") [] [EnvTesting] (mempty)
+      let depRngClientApi = Dependency MavenType "org.apache.commons:commons-rng-client-api" (Just $ CEq "1.4-SNAPSHOT") [] [EnvProduction] (mempty)
+      let depHamcrestCore = Dependency MavenType "org.hamcrest:hamcrest-core" (Just $ CEq "1.3") [] [EnvTesting] (mempty)
+
+      -- Act
+      let graph = buildGraph fixtureSingleGraph
+
+      -- Assert
+      expectDeps [depRngCore, depMath3, depJunit, depRngClientApi, depHamcrestCore] graph
+      expectDirect [depRngCore, depMath3, depJunit] graph
+      expectEdges [(depRngCore, depRngClientApi), (depJunit, depHamcrestCore)] graph
+
     multi <- runIO $ TextIO.readFile fixtureMultiFile
     it "parses multiple dot graphs in one file" $
       parse parseDotGraphs fixtureMultiFile multi `shouldParse` fixtureMultiGraph