Split inferProject into inferProjectFromVCS + inferProjectDefault + s…

…aveRevision; add inferProjectCached (#188)

src/App/Fossa/API/BuildLink.hs

@@ -20,7 +20,7 @@ import Srclib.Types (Locator (..))
 import qualified Text.URI as URI
 
 fossaProjectUrlPath :: Locator -> ProjectRevision -> Text
-fossaProjectUrlPath Locator {..} ProjectRevision {..} = "/projects/" <> encodedProject <> buildSelector
+fossaProjectUrlPath Locator {..} ProjectRevision {..} = "projects/" <> encodedProject <> buildSelector
   where
     encodedProject = urlEncode' (locatorFetcher <> "+" <> locatorProject)
     encodedRevision = urlEncode' $ fromMaybe projectRevision locatorRevision
@@ -43,8 +43,8 @@ getFossaBuildUrl revision apiopts locator = do
 samlUrlPath :: Organization -> Locator -> ProjectRevision -> Text
 samlUrlPath Organization {organizationId} locator revision = "account/saml/" <> showT organizationId <> "?" <> opts
   where
-    opts = "next=" <> urlEncode' redirectPath
+    opts = "next=%2F" <> urlEncode' redirectPath
     redirectPath = fossaProjectUrlPath locator revision
 
 urlEncode' :: Text -> Text
-urlEncode' = underBS (urlEncode True)
+urlEncode' = underBS (urlEncode True)

src/App/Fossa/Analyze.hs

@@ -14,7 +14,7 @@ module App.Fossa.Analyze
 import App.Fossa.Analyze.GraphMangler (graphingToGraph)
 import App.Fossa.Analyze.Project (ProjectResult(..), mkResult)
 import App.Fossa.FossaAPIV1 (UploadResponse (..), uploadAnalysis, uploadContributors)
-import App.Fossa.ProjectInference (inferProject, mergeOverride)
+import App.Fossa.ProjectInference (inferProjectFromVCS, inferProjectDefault, mergeOverride, saveRevision)
 import App.Types
 import qualified Control.Carrier.Diagnostics as Diag
 import Control.Carrier.Output.IO
@@ -83,6 +83,7 @@ import Types
 import VCS.Git (fetchGitContributors)
 import Data.Functor (void)
 import App.Fossa.API.BuildLink (getFossaBuildUrl)
+import Control.Effect.Diagnostics ((<||>))
 
 data ScanDestination
   = UploadScan ApiOpts ProjectMetadata -- ^ upload to fossa with provided api key and base url
@@ -171,7 +172,7 @@ analyze ::
   -> Flag UnpackArchives
   -> [BuildTargetFilter]
   -> m ()
-analyze basedir destination override unpackArchives filters = do
+analyze (BaseDir basedir) destination override unpackArchives filters = do
   capabilities <- sendIO getNumCapabilities
 
   (projectResults, ()) <-
@@ -180,10 +181,10 @@ analyze basedir destination override unpackArchives filters = do
       . runReadFSIO
       . runFinally
       . withTaskPool capabilities updateProgress
-      $ withDiscoveredProjects discoverFuncs (fromFlag UnpackArchives unpackArchives) (unBaseDir basedir) (runDependencyAnalysis basedir filters)
+      $ withDiscoveredProjects discoverFuncs (fromFlag UnpackArchives unpackArchives) basedir (runDependencyAnalysis (BaseDir basedir) filters)
 
   logSticky ""
-  let filteredProjects = filterProjects basedir projectResults
+  let filteredProjects = filterProjects (BaseDir basedir) projectResults
 
   case checkForEmptyUpload projectResults filteredProjects of
     NoneDiscovered -> logError "No projects were discovered" >> sendIO exitFailure
@@ -194,7 +195,8 @@ analyze basedir destination override unpackArchives filters = do
     FoundSome someProjects -> case destination of
       OutputStdout -> logStdout . pretty . decodeUtf8 . Aeson.encode . buildResult $ NE.toList someProjects
       UploadScan apiOpts metadata -> do
-        revision <- mergeOverride override <$> inferProject (unBaseDir basedir)
+        revision <- mergeOverride override <$> (inferProjectFromVCS basedir <||> inferProjectDefault basedir)
+        saveRevision revision
 
         logInfo ""
         logInfo ("Using project name: `" <> pretty (projectName revision) <> "`")
@@ -214,7 +216,7 @@ analyze basedir destination override unpackArchives filters = do
           ]
         traverse_ (\err -> logError $ "FOSSA error: " <> viaShow err) (uploadError uploadResult)
         -- Warn on contributor errors, never fail
-        void . Diag.recover . runExecIO $ tryUploadContributors (unBaseDir basedir) apiOpts (uploadLocator uploadResult)
+        void . Diag.recover . runExecIO $ tryUploadContributors basedir apiOpts (uploadLocator uploadResult)
 
 data CountedResult
   = NoneDiscovered

src/App/Fossa/ProjectInference.hs

@@ -4,7 +4,10 @@
 {-# LANGUAGE TemplateHaskell #-}
 
 module App.Fossa.ProjectInference
-  ( inferProject,
+  ( inferProjectFromVCS,
+    inferProjectCached,
+    inferProjectDefault,
+    saveRevision,
     mergeOverride,
     readCachedRevision,
     InferredProject (..),
@@ -34,6 +37,7 @@ import Path.IO (getTempDir)
 import qualified System.FilePath.Posix as FP
 import Text.GitConfig.Parser (Section (..), parseConfig)
 import Text.Megaparsec (errorBundlePretty)
+import qualified Data.Text.IO as TIO
 
 revisionFileName :: Path Rel File
 revisionFileName = $(mkRelFile ".fossa.revision")
@@ -45,16 +49,27 @@ mergeOverride OverrideProject {..} InferredProject {..} = ProjectRevision name r
     revision = fromMaybe inferredRevision overrideRevision
     branch = overrideBranch <|> inferredBranch
 
-inferProject :: (Has Logger sig m, Has (Lift IO) sig m) => Path Abs Dir -> m InferredProject
-inferProject current = do
-  result <- runDiagnostics $ runReadFSIO $ runExecIO (inferGit current <||> inferSVN current)
+-- TODO: pass ReadFS and Exec constraints upward
+inferProjectFromVCS :: (Has Diagnostics sig m, Has (Lift IO) sig m) => Path Abs Dir -> m InferredProject
+inferProjectFromVCS current = runReadFSIO $ runExecIO (inferGit current <||> inferSVN current)
+
+-- | Similar to 'inferProjectDefault', but uses a saved revision
+inferProjectCached :: (Has (Lift IO) sig m, Has ReadFS sig m, Has Diagnostics sig m) => Path b Dir -> m InferredProject
+inferProjectCached dir = do
+  project <- inferProjectDefault dir
+  rev <- readCachedRevision
+  pure project { inferredRevision = rev }
+
+-- | Infer a default project name from the directory, and a default
+-- revision from the current time. Writes `.fossa.revision` to the system
+-- temp directory for use by `fossa test`
+inferProjectDefault :: Has (Lift IO) sig m => Path b Dir -> m InferredProject
+inferProjectDefault dir = sendIO $ do
+  let name = FP.dropTrailingPathSeparator (fromRelDir (dirname dir))
+  time <- floor <$> getPOSIXTime :: IO Int
+
+  pure (InferredProject (T.pack name) (T.pack (show time)) Nothing)
 
-  case result of
-    Right inferred -> pure (resultValue inferred)
-    Left failure -> do
-      logWarn "Project inference: couldn't find VCS root. Defaulting to directory name."
-      logDebug (renderFailureBundle failure)
-      inferDefault current
 
 svnCommand :: Command
 svnCommand = Command
@@ -99,25 +114,16 @@ inferSVN dir = do
           [key, val] -> Just (key, val)
           _ -> Nothing
 
+saveRevision :: Has (Lift IO) sig m => ProjectRevision -> m ()
+saveRevision project = do
+  tmp <- sendIO getTempDir
+  sendIO $ TIO.writeFile (fromAbsFile $ tmp </> revisionFileName) (projectRevision project)
+
 readCachedRevision :: (Has (Lift IO) sig m, Has ReadFS sig m, Has Diagnostics sig m) => m Text
 readCachedRevision = do
   tmp <- sendIO getTempDir
   readContentsText $ tmp </> revisionFileName
 
-
--- | Infer a default project name from the directory, and a default
--- revision from the current time. Writes `.fossa.revision` to the system
--- temp directory for use by `fossa test`
-inferDefault :: Has (Lift IO) sig m => Path b Dir -> m InferredProject
-inferDefault dir = sendIO $ do
-  let name = FP.dropTrailingPathSeparator (fromRelDir (dirname dir))
-  time <- floor <$> getPOSIXTime :: IO Int
-
-  tmp <- getTempDir
-  writeFile (fromAbsFile $ tmp </> revisionFileName) (show time)
-
-  pure (InferredProject (T.pack name) (T.pack (show time)) Nothing)
-
 -- like Text.stripPrefix, but with a non-Maybe result (defaults to the original text)
 dropPrefix :: Text -> Text -> Text
 dropPrefix pre txt = fromMaybe txt (T.stripPrefix pre txt)

src/App/Fossa/Report.hs

@@ -37,7 +37,7 @@ reportMain ::
   -> ReportType
   -> OverrideProject
   -> IO ()
-reportMain basedir apiOpts logSeverity timeoutSeconds reportType override = do
+reportMain (BaseDir basedir) apiOpts logSeverity timeoutSeconds reportType override = do
   -- TODO: refactor this code duplicate from `fossa test`
   {-
   Most of this module (almost everything below this line) has been copied
@@ -53,7 +53,7 @@ reportMain basedir apiOpts logSeverity timeoutSeconds reportType override = do
   void $ timeout timeoutSeconds $ withLogger logSeverity $ do
     result <- runDiagnostics . runReadFSIO $ do
       override' <- updateOverrideRevision override <$> readCachedRevision
-      revision <- mergeOverride override' <$> inferProject (unBaseDir basedir)
+      revision <- mergeOverride override' <$> (inferProjectFromVCS basedir <||> inferProjectCached basedir <||> inferProjectDefault basedir)
 
       logInfo ""
       logInfo ("Using project name: `" <> pretty (projectName revision) <> "`")

src/App/Fossa/Test.hs

@@ -30,11 +30,11 @@ testMain
   -> TestOutputType
   -> OverrideProject
   -> IO ()
-testMain basedir apiOpts logSeverity timeoutSeconds outputType override = do
+testMain (BaseDir basedir) apiOpts logSeverity timeoutSeconds outputType override = do
   void $ timeout timeoutSeconds $ withLogger logSeverity $ do
     result <- runDiagnostics . runReadFSIO $ do
       override' <- updateOverrideRevision override <$> readCachedRevision
-      revision <- mergeOverride override' <$> inferProject (unBaseDir basedir)
+      revision <- mergeOverride override' <$> (inferProjectFromVCS basedir <||> inferProjectCached basedir <||> inferProjectDefault basedir)
 
       logInfo ""
       logInfo ("Using project name: `" <> pretty (projectName revision) <> "`")

src/App/Fossa/VPS/NinjaGraph.hs

@@ -28,7 +28,6 @@ import Effect.Exec
 import Effect.Logger hiding (line)
 import Effect.ReadFS
 import Path
-import System.Exit (exitFailure)
 import qualified System.FilePath as FP
 import System.Process.Typed as PROC
 import Fossa.API.Types (ApiOpts)
@@ -55,22 +54,16 @@ data NinjaParseState = Starting | Parsing | Complete | Error
 
 ninjaGraphMain :: ApiOpts -> Severity -> OverrideProject -> NinjaGraphCLIOptions -> IO ()
 ninjaGraphMain apiOpts logSeverity overrideProject NinjaGraphCLIOptions{..} = do
-  basedir <- validateDir ninjaBaseDir
+  BaseDir basedir <- validateDir ninjaBaseDir
 
-  withLogger logSeverity $ do
-    ProjectRevision {..} <- mergeOverride overrideProject <$> inferProject (unBaseDir basedir)
+  withLogger logSeverity . logWithExit_ $ do
+    ProjectRevision {..} <- mergeOverride overrideProject <$> (inferProjectFromVCS basedir <||> inferProjectDefault basedir)
     let ninjaGraphOpts = NinjaGraphOpts apiOpts ninjaDepsFile ninjaLunchTarget ninjaScanId projectName ninjaBuildName
 
     ninjaGraphInner basedir apiOpts ninjaGraphOpts
 
-ninjaGraphInner :: (Has Logger sig m, Has (Lift IO) sig m) => BaseDir -> ApiOpts -> NinjaGraphOpts -> m ()
-ninjaGraphInner (BaseDir basedir) apiOpts ninjaGraphOpts = do
-  result <- runDiagnostics $ getAndParseNinjaDeps basedir apiOpts ninjaGraphOpts
-  case result of
-    Left failure -> do
-      sendIO . print $ renderFailureBundle failure
-      sendIO exitFailure
-    Right _ -> pure ()
+ninjaGraphInner :: (Has Logger sig m, Has (Lift IO) sig m, Has Diagnostics sig m) => Path Abs Dir -> ApiOpts -> NinjaGraphOpts -> m ()
+ninjaGraphInner basedir apiOpts ninjaGraphOpts = getAndParseNinjaDeps basedir apiOpts ninjaGraphOpts
 
 
 getAndParseNinjaDeps :: (Has Diagnostics sig m, Has (Lift IO) sig m, Has Logger sig m) => Path Abs Dir -> ApiOpts -> NinjaGraphOpts -> m ()

src/App/Fossa/VPS/Report.hs

@@ -37,7 +37,7 @@ reportMain ::
   -> ReportType
   -> OverrideProject
   -> IO ()
-reportMain basedir apiOpts logSeverity timeoutSeconds reportType override = do
+reportMain (BaseDir basedir) apiOpts logSeverity timeoutSeconds reportType override = do
   -- TODO: refactor this code duplicate from `fossa test`
   {-
   Most of this module (almost everything below this line) has been copied
@@ -53,7 +53,7 @@ reportMain basedir apiOpts logSeverity timeoutSeconds reportType override = do
   void $ timeout timeoutSeconds $ withLogger logSeverity $ do
     result <- runDiagnostics . runReadFSIO $ do
       override' <- updateOverrideRevision override <$> readCachedRevision 
-      revision <- mergeOverride override' <$> inferProject (unBaseDir basedir)
+      revision <- mergeOverride override' <$> (inferProjectFromVCS basedir <||> inferProjectCached basedir <||> inferProjectDefault basedir)
 
       logSticky "[ Getting latest scan ID ]"
 

src/App/Fossa/VPS/Scan.hs

@@ -41,7 +41,9 @@ vpsScan ::
   , Has (Lift IO) sig m
   ) => BaseDir -> Severity -> OverrideProject -> Flag SkipIPRScan -> Flag LicenseOnlyScan -> FilterExpressions -> ApiOpts -> ProjectMetadata -> BinaryPaths -> m ()
 vpsScan (BaseDir basedir) logSeverity overrideProject skipIprFlag licenseOnlyScan fileFilters apiOpts metadata binaryPaths = withLogger logSeverity $ do
-  projectRevision <- mergeOverride overrideProject <$> inferProject basedir
+  projectRevision <- mergeOverride overrideProject <$> (inferProjectFromVCS basedir <||> inferProjectDefault basedir)
+  saveRevision projectRevision
+
   let scanType = ScanType (fromFlag SkipIPRScan skipIprFlag) (fromFlag LicenseOnlyScan licenseOnlyScan)
   let wigginsOpts = generateWigginsScanOpts basedir logSeverity projectRevision scanType fileFilters apiOpts metadata
 

src/App/Fossa/VPS/Test.hs

@@ -37,11 +37,11 @@ testMain ::
   TestOutputType ->
   OverrideProject ->
   IO ()
-testMain basedir apiOpts logSeverity timeoutSeconds outputType override = do
+testMain (BaseDir basedir) apiOpts logSeverity timeoutSeconds outputType override = do
   _ <- timeout timeoutSeconds . withLogger logSeverity . runExecIO $ do
     result <- runDiagnostics . runReadFSIO $ do
       override' <- updateOverrideRevision override <$> readCachedRevision 
-      revision <- mergeOverride override' <$> inferProject (unBaseDir basedir)
+      revision <- mergeOverride override' <$> (inferProjectFromVCS basedir <||> inferProjectCached basedir <||> inferProjectDefault basedir)
 
       logInfo ""
       logInfo ("Using project name: `" <> pretty (projectName revision) <> "`")

src/Control/Carrier/Diagnostics.hs

@@ -82,7 +82,7 @@ renderWarnings :: [SomeDiagnostic] -> Doc AnsiStyle
 renderWarnings = align . vsep . map renderSomeDiagnostic
 
 logResultWarnings :: Has Logger sig m => ResultBundle a -> m a
-logResultWarnings ResultBundle {..} = logWarn (renderWarnings resultWarnings) $> resultValue
+logResultWarnings ResultBundle {..} = logDebug (renderWarnings resultWarnings) $> resultValue
 
 logErrorBundle :: Has Logger sig m => FailureBundle -> m ()
 logErrorBundle = logError . renderFailureBundle