Fix STM error when fetching a container needs multiple different tokens

.hlint.yaml

@@ -41,6 +41,22 @@
 - suggest: {lhs: "(Data.Set.size x) == 0" , rhs: "Data.Set.null x"}
 - suggest: {lhs: "(Data.Set.size x) /= 0" , rhs: "not $ Data.Set.null x"}
 
+- group:
+    name: stm
+    enabled: true
+    rules:
+    - hint: {lhs: Control.Concurrent.STM.takeTMVar, rhs: Control.Concurrent.STM.tryTakeTMVar, note: "Blocks if the TMVar is empty. Be sure this is correct behavior."}
+    - hint: {lhs: Control.Concurrent.STM.putTMVar, rhs: Control.Concurrent.STM.writeTMVar, note: "Blocks if the TMVar is empty. Be sure this is correct behavior."}
+    - hint: {lhs: Control.Concurrent.STM.readTMVar, rhs: Control.Concurrent.STM.tryReadTMVar, note: "Blocks if the TMVar is empty. Be sure this is correct behavior."}
+    - hint: {lhs: Control.Concurrent.STM.TQueue.readTQueue, rhs: Control.Concurrent.STM.TQueue.tryReadTQueue, note: "Retries and blocks if the TBQueue is empty. Be sure this is correct behavior."}
+    - hint: {lhs: Control.Concurrent.STM.TQueue.peekTQueue, rhs: Control.Concurrent.STM.TQueue.tryPeekTQueue, note: "Retries and blocks if the TBQueue is empty. Be sure this is correct behavior."}
+    - hint: {lhs: Control.Concurrent.STM.TBQueue.readTBQueue, rhs: Control.Concurrent.STM.TBQueue.tryReadTBQueue, note: "Retries and blocks if the TBQueue is empty. Be sure this is correct behavior."}
+    - hint: {lhs: Control.Concurrent.STM.TBQueue.peekTBQueue, rhs: Control.Concurrent.STM.TBQueue.tryPeekTBQueue, note: "Retries and blocks if the TBQueue is empty. Be sure this is correct behavior."}
+    - hint: {lhs: Control.Concurrent.STM.TBQueue.unGetTBQueue, rhs: Control.Concurrent.STM.TBQueue.unGetTBQueue, note: "Retries and blocks if the TBQueue is full. Be sure this is correct behavior."}
+    - hint: {lhs: Control.Concurrent.STM.TBMQueue.readTBMQueue, rhs: Control.Concurrent.STM.TBMQueue.tryReadTBMQueue, note: "Retries and blocks if the TBMQueue is empty and open. Be sure this is correct behavior."}
+    - hint: {lhs: Control.Concurrent.STM.TBMQueue.peekTBMQueue, rhs: Control.Concurrent.STM.TBMQueue.tryPeekTBMQueue, note: "Retries and blocks if the TBMQueue is empty. Be sure this is correct behavior."}
+    - hint: {lhs: Control.Concurrent.STM.TBMQueue.writeTBMQueue, rhs: Control.Concurrent.STM.TBMQueue.tryWriteTBMQueue, note: "Retries and blocks if the TBMQueue is full. Be sure this is correct behavior."}
+
 # Forbidden items, only allowed in compile-time code, or test code (however, it should be avoided in tests as much as possible).
 - functions:
   - {name: error, within: [Data.String.Conversion, Control.Effect.Replay]}

Changelog.md

@@ -1,9 +1,14 @@
 # FOSSA CLI Changelog
 
+## 3.8.37
+
+- Container Scans: Bugfix for some registry scans that fail with an STM error. ([#1370](https://github.com/fossas/fossa-cli/pull/1370))
+
 ## v3.8.36
 - `fossa feedback`: Allow users to provide feedback on their cli experience ([#1368](https://github.com/fossas/fossa-cli/pull/1368))
 - Add preflight checks to validate API key, connection to FOSSA app, and ability to write to temp directory in relevant commands
 
+
 ## v3.8.35
 - Running `fossa analyze --detect-vendored` no longer fails if there are no detected vendored dependencies ([#1373](https://github.com/fossas/fossa-cli/pull/1373)).
 

fourmolu.yaml

@@ -31,3 +31,4 @@ fixities:
 - infixr 3 &&
 - infix 4 ==
 - infixl 4 <$>, <*>
+- infixr 6 <>

integration-test/Container/AnalysisSpec.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Container.AnalysisSpec (spec) where
+
+import App.Fossa.Config.Common (ScanDestination (OutputStdout))
+import App.Fossa.Config.Container.Analyze (ContainerAnalyzeConfig (..))
+import App.Fossa.Config.Container.Common (ImageText (ImageText))
+import App.Fossa.Container.AnalyzeNative (analyzeExperimental)
+import App.Types (OverrideProject (OverrideProject))
+import Container.FixtureUtils (runContainerEffs)
+import Container.Types (
+  ContainerScan (imageData, imageTag),
+  ContainerScanImage (imageLayers, imageOs, imageOsRelease),
+ )
+import Data.Flag (toFlag')
+import Diag.Result (Result (..))
+import Effect.Logger (Severity (SevInfo))
+import Test.Hspec (Spec, aroundAll, describe, it, shouldBe, shouldSatisfy)
+
+spec :: Spec
+spec = describe "Container Scanning" registrySourceAnalysis
+
+registrySourceCfg :: ContainerAnalyzeConfig
+registrySourceCfg =
+  ContainerAnalyzeConfig
+    { scanDestination = OutputStdout
+    , revisionOverride = OverrideProject Nothing Nothing Nothing
+    , imageLocator = ImageText "public.ecr.aws/docker/library/alpine:3.19.1"
+    , jsonOutput = toFlag' False
+    , usesExperimentalScanner = True
+    , dockerHost = ""
+    , arch = "amd64"
+    , severity = SevInfo
+    , onlySystemDeps = False
+    , filterSet = mempty
+    }
+
+runAnalyze :: ContainerAnalyzeConfig -> (ContainerScan -> IO ()) -> IO ()
+runAnalyze analyzeCfg action = do
+  res <- runContainerEffs (analyzeExperimental analyzeCfg)
+  case res of
+    Failure _ errGroup -> fail . show $ errGroup
+    Success _ a -> action a
+
+registrySourceAnalysis :: Spec
+registrySourceAnalysis = do
+  aroundAll (runAnalyze registrySourceCfg) $ do
+    describe "Container analysis from registry source" $ do
+      it "Has the correct OS" $
+        \res -> res.imageData.imageOs `shouldBe` "alpine"
+      it "Has the correct OS release version" $
+        \res -> res.imageData.imageOsRelease `shouldBe` "3.19.1"
+      it "Has the expected image tag" $
+        \res -> res.imageTag `shouldBe` "public.ecr.aws/docker/library/alpine"
+      it "Has at least one layer" $
+        \res -> res.imageData.imageLayers `shouldSatisfy` (not . null)

integration-test/Container/FixtureUtils.hs

@@ -0,0 +1,32 @@
+module Container.FixtureUtils (
+  ContainerAnalysisC,
+  runContainerEffs,
+) where
+
+import Control.Carrier.Diagnostics (DiagnosticsC, runDiagnostics)
+import Control.Carrier.Stack (StackC, runStack)
+import Control.Carrier.Telemetry (IgnoreTelemetryC, withoutTelemetry)
+import Data.Function ((&))
+import Diag.Result (Result)
+import Effect.Exec (ExecIOC, runExecIO)
+import Effect.Logger (LoggerC, Severity (SevWarn), withDefaultLogger)
+import Effect.ReadFS (ReadFSIOC, runReadFSIO)
+import Type.Operator (type ($))
+
+type ContainerAnalysisC m =
+  ExecIOC
+    $ ReadFSIOC
+    $ LoggerC
+    $ DiagnosticsC
+    $ StackC
+    $ IgnoreTelemetryC m
+
+runContainerEffs :: ContainerAnalysisC IO a -> IO (Result a)
+runContainerEffs f =
+  f
+    & runExecIO
+    & runReadFSIO
+    & withDefaultLogger SevWarn
+    & runDiagnostics
+    & runStack
+    & withoutTelemetry

spectrometer.cabal

@@ -704,6 +704,8 @@ test-suite integration-tests
     Analysis.RustSpec
     Analysis.ScalaSpec
     Analysis.SwiftSpec
+    Container.AnalysisSpec
+    Container.FixtureUtils
     SpecHook
 
   build-tool-depends: hspec-discover:hspec-discover ^>=2.10.0.1

src/App/Fossa/Container/AnalyzeNative.hs

@@ -80,8 +80,8 @@ analyzeExperimental ::
   , Has Telemetry sig m
   ) =>
   ContainerAnalyzeConfig ->
-  m Aeson.Value
-analyzeExperimental cfg =
+  m ContainerScan
+analyzeExperimental cfg = do
   case Config.severity cfg of
     SevDebug -> do
       (scope, res) <- collectDebugBundle cfg $ Diag.errorBoundaryIO $ analyze cfg
@@ -99,7 +99,7 @@ analyze ::
   , Has Debug sig m
   ) =>
   ContainerAnalyzeConfig ->
-  m Aeson.Value
+  m ContainerScan
 analyze cfg = do
   _ <- case scanDestination cfg of
     OutputStdout -> pure ()
@@ -119,7 +119,7 @@ analyze cfg = do
     UploadScan apiOpts projectMeta ->
       void $ runFossaApiClient apiOpts $ uploadScan revision projectMeta (jsonOutput cfg) scannedImage
 
-  pure $ Aeson.toJSON scannedImage
+  pure scannedImage
 
 uploadScan ::
   ( Has Diagnostics sig m

src/Control/Carrier/ContainerRegistryApi.hs

@@ -46,15 +46,14 @@ import Control.Carrier.ContainerRegistryApi.Common (
   RegistryCtx (RegistryCtx),
   fromResponse,
   getContentType,
-  getToken,
  )
 
 import Control.Carrier.Finally (runFinally)
 import Control.Carrier.Reader (ReaderC, ask, runReader)
 import Control.Carrier.Simple (SimpleC, interpret)
 import Control.Carrier.StickyLogger (runStickyLogger)
 import Control.Carrier.TaskPool (withTaskPool)
-import Control.Concurrent (getNumCapabilities)
+import Control.Concurrent (getNumCapabilities, myThreadId)
 import Control.Concurrent.STM (newEmptyTMVarIO)
 import Control.Effect.ContainerRegistryApi (
   ContainerRegistryApiF (ExportImage, GetImageManifest),
@@ -75,13 +74,16 @@ import Data.Aeson (eitherDecode, encode)
 import Data.ByteString (ByteString, writeFile)
 import Data.ByteString.Lazy qualified as ByteStringLazy
 import Data.Conduit.Zlib (ungzip)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isNothing)
 import Data.String.Conversion (
   LazyStrict (toStrict),
+  showText,
   toString,
   toText,
  )
 import Data.Text (Text)
+import Data.UUID qualified as UUID (toText)
+import Data.UUID.V4 qualified as UUID (nextRandom)
 import Effect.Logger (
   Logger,
   Pretty (pretty),
@@ -251,31 +253,41 @@ exportBlob ::
   (RepoDigest, Bool, Text) ->
   m (Path Abs File)
 exportBlob manager imgSrc dir (digest, isGzip, targetFilename) = do
-  ctx <- ask
-  let sinkTarget :: Path Abs File
-      sinkTarget = dir </> Path (toString targetFilename)
-
-  let imgSrc' = imgSrc{registryContainerRepositoryReference = RepoReferenceDigest digest}
-
-  -- Prepare request with necessary authorization
-  req <- blobEndpoint imgSrc'
-  token <- getAuthToken (registryCred imgSrc) req manager Nothing =<< getToken ctx
-  let req' = applyAuthToken token req
-
-  -- Download image artifact
-  sendIO . runResourceT $ do
-    response <- HTTPConduit.http req' manager
-    runConduit $
-      HTTPConduit.responseBody response
-        .| (if isGzip then ungzip else idC)
-        .| sinkFile (toString sinkTarget)
-
-  logInfo . pretty $
-    if isGzip
-      then "Gzip extracted & downloaded: " <> targetFilename
-      else "Downloaded: " <> targetFilename
-
-  pure sinkTarget
+  exportJobId <- sendIO UUID.nextRandom
+  threadId <- sendIO myThreadId
+  let exportDesc = "Export job ID: " <> UUID.toText exportJobId <> ", Export thread ID: " <> showText threadId
+  context exportDesc $ do
+    let sinkTarget :: Path Abs File
+        sinkTarget = dir </> Path (toString targetFilename)
+
+    let imgSrc' = imgSrc{registryContainerRepositoryReference = RepoReferenceDigest digest}
+
+    -- Prepare request with necessary authorization
+    req <- blobEndpoint imgSrc'
+    -- The current RegistryCtx is shared amongst multiple threads exporting blobs.
+    -- This could potentially be a problem if layers in a manifest file need different tokens to fetch.
+    -- I think the only way this *might* be possible is through redirects when fetching blobs.
+    -- I think the registry fetcher would still make progress in that case, but would just make more token reqs than necessary.
+    token <- getAuthToken (registryCred imgSrc) req manager Nothing =<< ask
+    -- This message generally means that auth is not required.
+    -- It may also indicate a bug in how we update/share tokens between threads.
+    when (isNothing token) $ logDebug "Got Nothing as a token."
+    let req' = applyAuthToken token req
+
+    -- Download image artifact
+    sendIO . runResourceT $ do
+      response <- HTTPConduit.http req' manager
+      runConduit $
+        HTTPConduit.responseBody response
+          .| (if isGzip then ungzip else idC)
+          .| sinkFile (toString sinkTarget)
+
+    logInfo . pretty $
+      if isGzip
+        then "Gzip extracted & downloaded: " <> targetFilename
+        else "Downloaded: " <> targetFilename
+
+    pure sinkTarget
 
 -- | Identity Conduit
 idC :: (PrimMonad m) => ConduitT ByteString ByteString m ()