Traverse subdirectories in Yarn and NPM analysis (#174)

src/App/Fossa/Analyze.hs

@@ -28,6 +28,7 @@ import qualified Data.Aeson as Aeson
 import Data.ByteString (ByteString)
 import Data.Flag (Flag, fromFlag)
 import Data.Foldable (traverse_)
+import Data.List (isInfixOf, stripPrefix)
 import Data.Maybe (fromMaybe)
 import Data.Set (Set)
 import Data.Text (Text)
@@ -176,9 +177,10 @@ analyze basedir destination override unpackArchives filters = do
       $ withDiscoveredProjects discoverFuncs (fromFlag UnpackArchives unpackArchives) (unBaseDir basedir) (runDependencyAnalysis basedir filters)
 
   logSticky ""
+  let filteredProjects = filterProjects basedir projectResults
 
   case destination of
-    OutputStdout -> logStdout $ pretty (decodeUtf8 (Aeson.encode (buildResult projectResults)))
+    OutputStdout -> logStdout $ pretty (decodeUtf8 (Aeson.encode (buildResult filteredProjects)))
     UploadScan apiOpts metadata -> do
       revision <- mergeOverride override <$> inferProject (unBaseDir basedir)
 
@@ -188,7 +190,7 @@ analyze basedir destination override unpackArchives filters = do
       let branchText = fromMaybe "No branch (detached HEAD)" $ projectBranch revision
       logInfo ("Using branch: `" <> pretty branchText <> "`")
 
-      uploadResult <- Diag.runDiagnostics $ uploadAnalysis basedir apiOpts revision metadata projectResults
+      uploadResult <- Diag.runDiagnostics $ uploadAnalysis apiOpts revision metadata filteredProjects
       case uploadResult of
         Left failure -> logError (Diag.renderFailureBundle failure)
         Right success -> do
@@ -208,6 +210,36 @@ analyze basedir destination override unpackArchives filters = do
             Left failure -> logDebug (Diag.renderFailureBundle failure)
             Right _ -> pure ()
 
+-- For each of the projects, we need to strip the root directory path from the prefix of the project path.
+-- We don't want parent directories of the scan root affecting "production path" filtering -- e.g., if we're
+-- running in a directory called "tmp", we still want results.
+filterProjects :: BaseDir -> [ProjectResult] -> [ProjectResult]
+filterProjects rootDir projects = filter (isProductionPath . dropPrefix rootPath . fromAbsDir . projectResultPath) projects 
+  where 
+    rootPath = fromAbsDir $ unBaseDir rootDir
+    dropPrefix :: String -> String -> String
+    dropPrefix prefix str = fromMaybe prefix (stripPrefix prefix str)
+
+isProductionPath :: FilePath -> Bool
+isProductionPath path = not $ any (`isInfixOf` path)
+  [ "doc/"
+  , "docs/"
+  , "test/"
+  , "example/"
+  , "examples/"
+  , "vendor/"
+  , "node_modules/"
+  , ".srclib-cache/"
+  , "spec/"
+  , "Godeps/"
+  , ".git/"
+  , "bower_components/"
+  , "third_party/"
+  , "third-party/"
+  , "Carthage/"
+  , "Checkouts/"
+  ]
+
 tryUploadContributors ::
   ( Has Diag.Diagnostics sig m,
     Has Exec sig m,

src/App/Fossa/FossaAPIV1.hs

@@ -39,7 +39,6 @@ import Control.Effect.Diagnostics hiding (fromMaybe)
 import Control.Effect.Lift (Lift, sendIO)
 import Control.Monad.IO.Class (MonadIO (..))
 import Data.Aeson
-import Data.List (isInfixOf, stripPrefix)
 import Data.Map (Map)
 import Data.Maybe (catMaybes, fromMaybe)
 import Data.Text (Text)
@@ -48,7 +47,6 @@ import Effect.Logger
 import qualified Network.HTTP.Client as HTTP
 import Network.HTTP.Req
 import qualified Network.HTTP.Types as HTTP
-import Path
 import Srclib.Converter (toSourceUnit)
 import Srclib.Types
 import Text.URI (URI)
@@ -123,24 +121,15 @@ instance ToDiagnostic FossaError where
 
 uploadAnalysis
   :: (Has (Lift IO) sig m, Has Diagnostics sig m)
-  => BaseDir -- ^ root directory for analysis
-  -> ApiOpts
+  => ApiOpts
   -> ProjectRevision
   -> ProjectMetadata
   -> [ProjectResult]
   -> m UploadResponse
-uploadAnalysis rootDir apiOpts ProjectRevision{..} metadata projects = fossaReq $ do
+uploadAnalysis apiOpts ProjectRevision{..} metadata projects = fossaReq $ do
   (baseUrl, baseOpts) <- useApiOpts apiOpts
 
-  -- For each of the projects, we need to strip the root directory path from the prefix of the project path.
-  -- We don't want parent directories of the scan root affecting "production path" filtering -- e.g., if we're
-  -- running in a directory called "tmp", we still want results.
-  let rootPath = fromAbsDir $ unBaseDir rootDir
-      dropPrefix :: String -> String -> String
-      dropPrefix prefix str = fromMaybe prefix (stripPrefix prefix str)
-      filteredProjects = filter (isProductionPath . dropPrefix rootPath . fromAbsDir . projectResultPath) projects
-
-      sourceUnits = map toSourceUnit filteredProjects
+  let sourceUnits = map toSourceUnit projects
       opts = "locator" =: renderLocator (Locator "custom" projectName (Just projectRevision))
           <> "cliVersion" =: cliVersion
           <> "managedBuild" =: True
@@ -173,26 +162,6 @@ mangleError err = case err of
   JsonHttpException msg -> JsonDeserializeError msg
   _ -> OtherError err
 
-isProductionPath :: FilePath -> Bool
-isProductionPath path = not $ any (`isInfixOf` path)
-  [ "doc/"
-  , "docs/"
-  , "test/"
-  , "example/"
-  , "examples/"
-  , "vendor/"
-  , "node_modules/"
-  , ".srclib-cache/"
-  , "spec/"
-  , "Godeps/"
-  , ".git/"
-  , "bower_components/"
-  , "third_party/"
-  , "third-party/"
-  , "Carthage/"
-  , "Checkouts/"
-  ]
-
 -----
 
 buildsEndpoint :: Url 'Https -> Int -> Locator -> Url 'Https

src/Discovery/Walk.hs

@@ -15,7 +15,7 @@ where
 
 import Control.Carrier.Writer.Church
 import Control.Monad.Trans
-import Control.Carrier.Lift
+import Control.Carrier.Lift ( runM, LiftC )
 import Data.Foldable (find)
 import Data.Maybe (mapMaybe)
 import Data.Text (Text)
@@ -54,7 +54,7 @@ walk f = walkDir $ \dir subdirs files -> do
     WalkSkipSome dirs ->
       -- we normalize the passed in [Text] as relative directories for more reliable comparisons
       let parsedDirs = mapMaybe (parseRelDir . T.unpack) dirs
-       in pure . WalkExclude . filter (not . (`elem` parsedDirs) . dirname) $ subdirs
+       in pure . WalkExclude . filter ((`elem` parsedDirs) . dirname) $ subdirs
     WalkSkipAll -> pure $ WalkExclude subdirs
     WalkStop -> pure WalkFinish
 

src/Strategy/Npm.hs

@@ -22,7 +22,7 @@ discover dir = map mkProject <$> findProjects dir
 findProjects :: MonadIO m => Path Abs Dir -> m [NpmProject]
 findProjects = walk' $ \dir _ files -> do
   case findFileNamed "package.json" files of
-    Nothing -> pure ([], WalkContinue)
+    Nothing -> pure ([], WalkSkipSome ["node_modules"])
     Just packageJson -> do
       let packageLock = findFileNamed "package-lock.json" files
 
@@ -33,7 +33,7 @@ findProjects = walk' $ \dir _ files -> do
                 npmPackageLock = packageLock
               }
 
-      pure ([project], WalkSkipAll)
+      pure ([project], WalkSkipSome ["node_modules"])
 
 data NpmProject = NpmProject
   { npmDir :: Path Abs Dir,

src/Strategy/Yarn.hs

@@ -18,15 +18,15 @@ discover dir = map mkProject <$> findProjects dir
 findProjects :: MonadIO m => Path Abs Dir -> m [YarnProject]
 findProjects = walk' $ \dir _ files -> do
   case findFileNamed "yarn.lock" files of
-    Nothing -> pure ([], WalkContinue)
+    Nothing -> pure ([], WalkSkipSome ["node_modules"])
     Just lock -> do
       let project =
             YarnProject
             { yarnDir = dir
             , yarnLock = lock
             }
 
-      pure ([project], WalkSkipAll)
+      pure ([project], WalkSkipSome ["node_modules"])
 
 mkProject :: YarnProject -> DiscoveredProject
 mkProject project =