Expose the status of currently-running tasks

spectrometer.cabal

@@ -64,11 +64,13 @@ common deps
   build-depends:
     , aeson                        ^>=1.5.2.0
     , algebraic-graphs             ^>=0.5
+    , ansi-terminal                ^>=0.11
     , async                        ^>=2.2.2
     , attoparsec                   ^>=0.13.2.3
     , base16-bytestring            ^>=0.1.1.7
     , bytestring                   ^>=0.10.8
     , codec-rpm                    ^>=0.2.2
+    , concurrent-output            ^>=1.10.12
     , conduit                      ^>=1.3.2
     , conduit-extra                ^>=1.3.5
     , containers                   ^>=0.6.0
@@ -158,26 +160,34 @@ library
     App.Util
     App.Version
     App.Version.TH
+    Console.Sticky
     Control.Carrier.AtomicState
     Control.Carrier.Diagnostics
+    Control.Carrier.Diagnostics.StickyContext
     Control.Carrier.Finally
+    Control.Carrier.AtomicCounter
     Control.Carrier.Output.IO
+    Control.Carrier.StickyLogger
     Control.Carrier.TaskPool
     Control.Carrier.Threaded
     Control.Effect.AtomicState
+    Control.Effect.ConsoleRegion
     Control.Effect.Diagnostics
     Control.Effect.Finally
+    Control.Effect.AtomicCounter
     Control.Effect.Output
     Control.Effect.Path
     Control.Effect.Record
     Control.Effect.Record.TH
     Control.Effect.Replay
     Control.Effect.Replay.TH
+    Control.Effect.StickyLogger
     Control.Effect.TaskPool
     Control.Exception.Extra
     Data.FileEmbed.Extra
     Data.Flag
     Data.Functor.Extra
+    Data.String.Conversion
     Data.Text.Extra
     DepTypes
     Discovery.Archive

src/App/Fossa/API/BuildWait.hs

@@ -6,14 +6,15 @@ module App.Fossa.API.BuildWait
   )
 where
 
-import qualified App.Fossa.FossaAPIV1 as Fossa
-import qualified App.Fossa.VPS.Scan.Core as VPSCore
-import qualified App.Fossa.VPS.Scan.ScotlandYard as ScotlandYard
+import App.Fossa.FossaAPIV1 qualified as Fossa
+import App.Fossa.VPS.Scan.Core qualified as VPSCore
+import App.Fossa.VPS.Scan.ScotlandYard qualified as ScotlandYard
 import App.Types
 import Control.Carrier.Diagnostics
 import Control.Concurrent (threadDelay)
-import qualified Control.Concurrent.Async as Async
+import Control.Concurrent.Async qualified as Async
 import Control.Effect.Lift (Lift, sendIO)
+import Control.Carrier.StickyLogger (StickyLogger, logSticky')
 import Data.Functor (($>))
 import Data.Text (Text)
 import Effect.Logger
@@ -32,7 +33,7 @@ instance ToDiagnostic WaitError where
 
 -- | Wait for a "normal" (non-VPS) build completion
 waitForBuild ::
-  (Has Diagnostics sig m, Has (Lift IO) sig m, Has Logger sig m) =>
+  (Has Diagnostics sig m, Has (Lift IO) sig m, Has Logger sig m, Has StickyLogger sig m) =>
   ApiOpts ->
   ProjectRevision ->
   m ()
@@ -43,7 +44,7 @@ waitForBuild apiOpts revision = do
     Fossa.StatusSucceeded -> pure ()
     Fossa.StatusFailed -> fatal BuildFailed
     otherStatus -> do
-      logSticky $ "[ Waiting for build completion... last status: " <> viaShow otherStatus <> " ]"
+      logSticky' $ "[ Waiting for build completion... last status: " <> viaShow otherStatus <> " ]"
       sendIO $ threadDelay (pollDelaySeconds * 1_000_000)
       waitForBuild apiOpts revision
 
@@ -62,7 +63,7 @@ waitForIssues apiOpts revision = do
 
 -- | Wait for sherlock scan completion (VPS)
 waitForSherlockScan ::
-  (Has Diagnostics sig m, Has (Lift IO) sig m, Has Logger sig m) =>
+  (Has Diagnostics sig m, Has (Lift IO) sig m, Has Logger sig m, Has StickyLogger sig m) =>
   ApiOpts ->
   VPSCore.Locator ->
   -- | scan ID
@@ -74,7 +75,7 @@ waitForSherlockScan apiOpts locator scanId = do
     Just "AVAILABLE" -> pure ()
     Just "ERROR" -> fatalText "The component scan failed. Check the FOSSA webapp for more details."
     Just otherStatus -> do
-      logSticky $ "[ Waiting for component scan... last status: " <> pretty otherStatus <> " ]"
+      logSticky' $ "[ Waiting for component scan... last status: " <> pretty otherStatus <> " ]"
       sendIO $ threadDelay (pollDelaySeconds * 1_000_000)
       waitForSherlockScan apiOpts locator scanId
     Nothing -> do

src/App/Fossa/Analyze.hs

@@ -16,9 +16,10 @@ import App.Fossa.FossaAPIV1 (UploadResponse (..), uploadAnalysis, uploadContribu
 import App.Fossa.ProjectInference (inferProjectDefault, inferProjectFromVCS, mergeOverride, saveRevision)
 import App.Types
 import App.Util (validateDir)
-import qualified Control.Carrier.Diagnostics as Diag
+import Control.Carrier.Diagnostics qualified as Diag
 import Control.Carrier.Finally
 import Control.Carrier.Output.IO
+import Control.Carrier.StickyLogger (runStickyLogger, logSticky', StickyLogger)
 import Control.Carrier.TaskPool
 import Control.Concurrent
 import Control.Effect.Diagnostics ((<||>))
@@ -28,16 +29,16 @@ import Control.Effect.Record
 import Control.Effect.Replay (runReplay)
 import Control.Monad.IO.Class (MonadIO)
 import Data.Aeson ((.=))
-import qualified Data.Aeson as Aeson
+import Data.Aeson qualified as Aeson
 import Data.Flag (Flag, fromFlag)
 import Data.Foldable (for_, traverse_)
 import Data.Functor (void)
 import Data.List (isInfixOf, stripPrefix)
-import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty qualified as NE
 import Data.Maybe (fromMaybe)
 import Data.Set (Set)
+import Data.String.Conversion (decodeUtf8)
 import Data.Text (Text)
-import Data.Text.Lazy.Encoding (decodeUtf8)
 import Data.Text.Prettyprint.Doc
 import Data.Text.Prettyprint.Doc.Render.Terminal
 import Discovery.Filters
@@ -48,40 +49,42 @@ import Effect.ReadFS
 import Fossa.API.Types (ApiOpts (..))
 import Path
 import Path.IO (makeRelative)
-import qualified Srclib.Converter as Srclib
+import Path.IO qualified as P
+import Srclib.Converter qualified as Srclib
 import Srclib.Types (parseLocator)
-import qualified Strategy.Bundler as Bundler
-import qualified Strategy.Cargo as Cargo
-import qualified Strategy.Carthage as Carthage
-import qualified Strategy.Cocoapods as Cocoapods
-import qualified Strategy.Composer as Composer
-import qualified Strategy.Glide as Glide
-import qualified Strategy.Godep as Godep
-import qualified Strategy.Gomodules as Gomodules
-import qualified Strategy.Googlesource.RepoManifest as RepoManifest
-import qualified Strategy.Gradle as Gradle
-import qualified Strategy.Haskell.Cabal as Cabal
-import qualified Strategy.Haskell.Stack as Stack
-import qualified Strategy.Leiningen as Leiningen
-import qualified Strategy.Maven as Maven
-import qualified Strategy.Npm as Npm
-import qualified Strategy.NuGet.Nuspec as Nuspec
-import qualified Strategy.NuGet.PackageReference as PackageReference
-import qualified Strategy.NuGet.PackagesConfig as PackagesConfig
-import qualified Strategy.NuGet.Paket as Paket
-import qualified Strategy.NuGet.ProjectAssetsJson as ProjectAssetsJson
-import qualified Strategy.NuGet.ProjectJson as ProjectJson
-import qualified Strategy.Python.Pipenv as Pipenv
-import qualified Strategy.Python.Setuptools as Setuptools
-import qualified Strategy.RPM as RPM
-import qualified Strategy.Rebar3 as Rebar3
-import qualified Strategy.Scala as Scala
-import qualified Strategy.UserSpecified.YamlDependencies as UserYaml
-import qualified Strategy.Yarn as Yarn
+import Strategy.Bundler qualified as Bundler
+import Strategy.Cargo qualified as Cargo
+import Strategy.Carthage qualified as Carthage
+import Strategy.Cocoapods qualified as Cocoapods
+import Strategy.Composer qualified as Composer
+import Strategy.Glide qualified as Glide
+import Strategy.Godep qualified as Godep
+import Strategy.Gomodules qualified as Gomodules
+import Strategy.Googlesource.RepoManifest qualified as RepoManifest
+import Strategy.Gradle qualified as Gradle
+import Strategy.Haskell.Cabal qualified as Cabal
+import Strategy.Haskell.Stack qualified as Stack
+import Strategy.Leiningen qualified as Leiningen
+import Strategy.Maven qualified as Maven
+import Strategy.Npm qualified as Npm
+import Strategy.NuGet.Nuspec qualified as Nuspec
+import Strategy.NuGet.PackageReference qualified as PackageReference
+import Strategy.NuGet.PackagesConfig qualified as PackagesConfig
+import Strategy.NuGet.Paket qualified as Paket
+import Strategy.NuGet.ProjectAssetsJson qualified as ProjectAssetsJson
+import Strategy.NuGet.ProjectJson qualified as ProjectJson
+import Strategy.Python.Pipenv qualified as Pipenv
+import Strategy.Python.Setuptools qualified as Setuptools
+import Strategy.RPM qualified as RPM
+import Strategy.Rebar3 qualified as Rebar3
+import Strategy.Scala qualified as Scala
+import Strategy.UserSpecified.YamlDependencies qualified as UserYaml
+import Strategy.Yarn qualified as Yarn
 import System.Exit (die, exitFailure)
 import Types
 import VCS.Git (fetchGitContributors)
-import qualified Path.IO as P
+import Control.Carrier.Diagnostics.StickyContext
+import Control.Carrier.AtomicCounter (AtomicCounter, runAtomicCounter)
 
 data ScanDestination
   = UploadScan ApiOpts ProjectMetadata -- ^ upload to fossa with provided api key and base url
@@ -98,7 +101,7 @@ data RecordMode =
 
 analyzeMain :: FilePath -> RecordMode -> Severity -> ScanDestination -> OverrideProject -> Flag UnpackArchives -> [BuildTargetFilter] -> IO ()
 analyzeMain workdir recordMode logSeverity destination project unpackArchives filters =
-  withLogger logSeverity
+  withDefaultLogger logSeverity
     . Diag.logWithExit_
     . runReadFSIO
     . runExecIO
@@ -170,18 +173,18 @@ discoverFuncs =
   ]
 
 runDependencyAnalysis ::
-  (Has (Lift IO) sig m, Has Logger sig m, Has (Output ProjectResult) sig m) =>
+  (Has (Lift IO) sig m, Has AtomicCounter sig m, Has Logger sig m, Has (Output ProjectResult) sig m) =>
   -- | Analysis base directory
   BaseDir ->
   [BuildTargetFilter] ->
-  DiscoveredProject (Diag.DiagnosticsC m) ->
+  DiscoveredProject (StickyDiagC (Diag.DiagnosticsC m)) ->
   m ()
 runDependencyAnalysis (BaseDir basedir) filters project = do
   case applyFiltersToProject basedir filters project of
     Nothing -> logInfo $ "Skipping " <> pretty (projectType project) <> " project at " <> viaShow (projectPath project) <> ": no filters matched"
     Just targets -> do
       logInfo $ "Analyzing " <> pretty (projectType project) <> " project at " <> pretty (toFilePath (projectPath project))
-      graphResult <- Diag.runDiagnosticsIO $ projectDependencyGraph project targets
+      graphResult <- Diag.runDiagnosticsIO . stickyDiag $ projectDependencyGraph project targets
       Diag.withResult SevWarn graphResult (output . mkResult project)
 
 applyFiltersToProject :: Path Abs Dir -> [BuildTargetFilter] -> DiscoveredProject n -> Maybe (Set BuildTarget)
@@ -212,11 +215,12 @@ analyze (BaseDir basedir) destination override unpackArchives filters = do
 
   (projectResults, ()) <-
     runOutput @ProjectResult
+      . runStickyLogger
       . runFinally
       . withTaskPool capabilities updateProgress
+      . runAtomicCounter
       $ withDiscoveredProjects discoverFuncs (fromFlag UnpackArchives unpackArchives) basedir (runDependencyAnalysis (BaseDir basedir) filters)
 
-  logSticky ""
   let filteredProjects = filterProjects (BaseDir basedir) projectResults
 
   case checkForEmptyUpload projectResults filteredProjects of
@@ -226,7 +230,7 @@ analyze (BaseDir basedir) destination override unpackArchives filters = do
       for_ projectResults $ \project -> logDebug ("Excluded by directory name: " <> pretty (toFilePath $ projectResultPath project))
       sendIO exitFailure
     FoundSome someProjects -> case destination of
-      OutputStdout -> logStdout . pretty . decodeUtf8 . Aeson.encode . buildResult $ NE.toList someProjects
+      OutputStdout -> logStdout . decodeUtf8 . Aeson.encode . buildResult $ NE.toList someProjects
       UploadScan apiOpts metadata -> do
         revision <- mergeOverride override <$> (inferProjectFromVCS basedir <||> inferProjectDefault basedir)
         saveRevision revision
@@ -329,13 +333,15 @@ buildProject project = Aeson.object
   , "graph" .= graphingToGraph (projectResultGraph project)
   ]
 
-updateProgress :: Has Logger sig m => Progress -> m ()
-updateProgress Progress{..} =
-  logSticky ( "[ "
-            <> annotate (color Cyan) (pretty pQueued)
-            <> " Waiting / "
-            <> annotate (color Yellow) (pretty pRunning)
-            <> " Running / "
-            <> annotate (color Green) (pretty pCompleted)
-            <> " Completed"
-            <> " ]" )
+updateProgress :: Has StickyLogger sig m => Progress -> m ()
+updateProgress Progress {..} =
+  logSticky'
+    ( "[ "
+        <> annotate (color Cyan) (pretty pQueued)
+        <> " Waiting / "
+        <> annotate (color Yellow) (pretty pRunning)
+        <> " Running / "
+        <> annotate (color Green) (pretty pCompleted)
+        <> " Completed"
+        <> " ]"
+    )

src/App/Fossa/Compatibility.hs

@@ -9,16 +9,16 @@ module App.Fossa.Compatibility
 where
 
 import App.Fossa.EmbeddedBinary (BinaryPaths, toExecutablePath, withCLIv1Binary)
+import Control.Carrier.StickyLogger (runStickyLogger, logSticky)
 import Control.Effect.Lift (sendIO)
+import Data.ByteString.Lazy.Char8 qualified as BL
+import Data.String.Conversion (decodeUtf8)
 import Data.Text (Text, pack)
-import Data.Foldable (traverse_)
-import Effect.Exec (CmdFailure(cmdFailureStdout), AllowErr (Never), Command (..), exec, runExecIO, cmdFailureStderr)
-import Path
-import qualified Data.ByteString.Lazy.Char8 as BL
+import Effect.Exec (AllowErr (Never), CmdFailure (cmdFailureStdout), Command (..), cmdFailureStderr, exec, runExecIO)
+import Effect.Logger (Pretty (pretty), Severity (SevInfo), logInfo, withDefaultLogger)
 import Options.Applicative (Parser, argument, help, metavar, str)
+import Path
 import System.Exit (exitFailure, exitSuccess)
-import Data.Text.Lazy.Encoding
-import Effect.Logger (Pretty(pretty), logInfo, logSticky, Severity(SevInfo), withLogger)
 
 type Argument = Text
 
@@ -28,14 +28,15 @@ argumentParser = pack <$> argument str (metavar "ARGS" <> help "arguments to fos
 compatibilityMain ::
   [Argument] ->
   IO ()
-compatibilityMain args = withLogger SevInfo . runExecIO . withCLIv1Binary $ \v1Bin -> do
-  logSticky "[ Waiting for fossa analyze completion ]"
-  cmd <- exec [reldir|.|] $ v1Command v1Bin $ args
-  logSticky ""
+compatibilityMain args = withDefaultLogger SevInfo . runExecIO . withCLIv1Binary $ \v1Bin -> do
+  cmd <- runStickyLogger $ do
+    logSticky "[ Waiting for fossa analyze completion ]"
+    exec [reldir|.|] $ v1Command v1Bin args
 
   case cmd of
     Left err -> do
-      traverse_ (\accessor -> logInfo . pretty . decodeUtf8 $ accessor err)  [cmdFailureStderr, cmdFailureStdout]
+      logInfo . pretty @Text . decodeUtf8 $ cmdFailureStderr err
+      logInfo . pretty @Text . decodeUtf8 $ cmdFailureStdout err
       sendIO exitFailure
     Right out -> sendIO (BL.putStr out >> exitSuccess)
 

src/App/Fossa/Configuration.hs

@@ -88,7 +88,7 @@ readConfigFileIO = do
   config <- Diag.runDiagnostics $ runReadFSIO $ readConfigFile defaultFile
   case config of
     Left err -> die $ show $ Diag.renderFailureBundle err
-    Right a -> pure $ Diag.resultValue a
+    Right a -> pure a
 
 mergeFileCmdMetadata :: ProjectMetadata -> ConfigFile -> ProjectMetadata
 mergeFileCmdMetadata meta file =

src/App/Fossa/Container.hs

@@ -35,8 +35,8 @@ import Data.List (nub)
 import qualified Data.Map.Lazy as LMap
 import Data.Map.Strict (Map)
 import Data.Maybe (listToMaybe, fromMaybe)
+import Data.String.Conversion (decodeUtf8)
 import Data.Text (Text, pack)
-import qualified Data.Text.Lazy.Encoding as TE
 import Data.Text.Extra (breakOnAndRemove)
 import Effect.Exec (AllowErr (Never), Command (..), execJson, runExecIO, Exec, execThrow)
 import Effect.Logger
@@ -268,7 +268,7 @@ syftCommand bin (ImageText image) =
     }
 
 parseSyftOutputMain :: Severity -> FilePath -> IO ()
-parseSyftOutputMain logseverity path = withLogger logseverity . logWithExit_ . runReadFSIO $ parseSyftOutput path
+parseSyftOutputMain logseverity path = withDefaultLogger logseverity . logWithExit_ . runReadFSIO $ parseSyftOutput path
 
 parseSyftOutput :: (Has Diagnostics sig m, Has ReadFS sig m, Has (Lift IO) sig m, Has Logger sig m) => FilePath -> m ()
 parseSyftOutput filepath = do
@@ -283,12 +283,12 @@ parseSyftOutput filepath = do
   payload <- toContainerScan response
   logInfo "Payload is valid!"
 
-  logStdout . pretty . TE.decodeUtf8 $ encode payload
+  logStdout . decodeUtf8 $ encode payload
 
   pure ()
 
 dumpSyftScanMain :: Severity -> Maybe FilePath -> ImageText -> IO ()
-dumpSyftScanMain logseverity path image = withLogger logseverity . logWithExit_ . runExecIO $ dumpSyftScan path image
+dumpSyftScanMain logseverity path image = withDefaultLogger logseverity . logWithExit_ . runExecIO $ dumpSyftScan path image
 
 dumpSyftScan ::
   ( Has Diagnostics sig m,