Fix transitive propagation of matrix jobs through already-compiled dependants (#770)

Author: f-f

app/src/App/Effect/Registry.purs

@@ -333,26 +333,13 @@ handle env = Cache.interpret _registryCache (Cache.handleMemory env.cacheRef) <<
                 Log.debug $ "Successfully read metadata for " <> printedName <> " from path " <> path
                 pure (Just metadata)
 
-      -- Should be used when the cache may not be valid. Reads the metadata from
-      -- disk and replaces the cache with it.
-      resetFromDisk = readMetadataFromDisk >>= case _ of
-        Nothing -> do
-          Log.debug $ "Did not find " <> printedName <> " in memory cache or local registry repo checkout."
-          pure Nothing
-
-        Just metadata -> do
-          Log.debug $ "Successfully read metadata for " <> printedName <> " from path " <> path
-          Log.debug $ "Setting metadata cache to singleton entry (as cache was previously empty)."
-          Cache.put _registryCache AllMetadata (Map.singleton name metadata)
-          pure $ Just metadata
-
     pull RegistryRepo >>= case _ of
       Left error ->
         Except.throw $ "Could not read metadata because the registry repo could not be checked: " <> error
 
       Right Git.NoChange -> do
         Cache.get _registryCache AllMetadata >>= case _ of
-          Nothing -> resetFromDisk
+          Nothing -> readMetadataFromDisk
           Just allMetadata -> case Map.lookup name allMetadata of
             Nothing -> do
               Log.debug $ "Did not find " <> printedName <> " in memory cache, trying local registry checkout..."
@@ -372,7 +359,7 @@ handle env = Cache.interpret _registryCache (Cache.handleMemory env.cacheRef) <<
       Right Git.Changed -> do
         Log.info "Registry repo has changed, clearing metadata cache..."
         Cache.delete _registryCache AllMetadata
-        resetFromDisk
+        readMetadataFromDisk
 
   WriteMetadata name metadata reply -> map (map reply) Except.runExcept do
     let printedName = PackageName.print name

app/src/App/Server/MatrixBuilder.purs

@@ -14,6 +14,7 @@ import Registry.App.Prelude
 
 import Data.Array as Array
 import Data.Array.NonEmpty as NonEmptyArray
+import Data.Foldable (elem, foldM)
 import Data.FoldableWithIndex (foldMapWithIndex)
 import Data.Map as Map
 import Data.Set as Set
@@ -182,80 +183,98 @@ type MatrixSolverResult =
   }
 
 solveForAllCompilers :: forall r. MatrixSolverData -> Run (AFF + EXCEPT String + LOG + r) (Set MatrixSolverResult)
-solveForAllCompilers { compilerIndex, name, version, compiler, dependencies } = do
+solveForAllCompilers solverData@{ compiler } = do
   -- remove the compiler we tested with from the set of all of them
   compilers <- (Array.filter (_ /= compiler) <<< NonEmptyArray.toArray) <$> PursVersions.pursVersions
-  newJobs <- for compilers \target -> do
-    Log.debug $ "Trying compiler " <> Version.print target <> " for package " <> PackageName.print name
-    case Solver.solveWithCompiler (Range.exact target) compilerIndex dependencies of
-      Left solverErrors -> do
-        Log.info $ "Failed to solve with compiler " <> Version.print target <> ": " <> PackageName.print name <> "@" <> Version.print version
-        Log.debug $ "Solver errors:\n" <> foldMapWithIndex
-          (\i error -> "[Error " <> show (i + 1) <> "]\n" <> Solver.printSolverError error <> "\n")
-          solverErrors
-        pure Nothing
-      Right (Tuple solvedCompiler resolutions) -> case solvedCompiler == target of
-        true -> do
-          Log.debug $ "Solved with compiler " <> Version.print solvedCompiler
-          pure $ Just { compiler: target, resolutions, name, version }
-        false -> do
+  newJobs <- for compilers \target ->
+    trySolveForCompiler (solverData { compiler = target })
+  pure $ Set.fromFoldable $ Array.catMaybes newJobs
+
+solveDependantsForCompiler :: forall r. MatrixSolverData -> Run (EXCEPT String + LOG + REGISTRY + r) (Set MatrixSolverResult)
+solveDependantsForCompiler { compilerIndex, name, version, compiler } = do
+  manifestIndex <- Registry.readAllManifests
+  let seed = Tuple name version
+  { results, visited } <- go manifestIndex (Set.singleton seed) name version
+  Log.info $ Array.fold
+    [ "Cascade from "
+    , PackageName.print name
+    , "@"
+    , Version.print version
+    , ": "
+    , show (Set.size results)
+    , " enqueued out of "
+    , show (Set.size visited - 1)
+    , " dependants visited"
+    ]
+  pure results
+  where
+  -- Recursively find packages to enqueue. Trivially this includes direct
+  -- dependants, but we need more than that: when a direct dependant is already
+  -- compatible with the target compiler, recurse down to its own dependants,
+  -- and so on.
+  -- This handles niche cases of transitive version-conflict cascades:
+  -- if A depends on B which depends on C (wide range), and A's full plan forces
+  -- C@new (because of other packages) but all versions of B already compiled
+  -- against C@old, then - if we only propagated direct dependents - B will
+  -- never be retriggered.
+  -- With this recursive propagation, when C@new completes we cascade through
+  -- B (already compiled) and reach A, allowing for a plan to resolve.
+  go manifestIndex visited pkgName pkgVersion = do
+    let dependentManifests = ManifestIndex.dependants manifestIndex pkgName pkgVersion
+    foldM (processManifest manifestIndex) { visited, results: Set.empty } dependentManifests
+
+  processManifest manifestIndex acc (Manifest manifest) = do
+    let pv = Tuple manifest.name manifest.version
+    if Set.member pv acc.visited then
+      pure acc
+    else do
+      let newVisited = Set.insert pv acc.visited
+      Registry.readMetadata manifest.name >>= case _ of
+        Nothing -> do
+          Log.warn $ "No metadata for dependant " <> PackageName.print manifest.name <> ", skipping"
+          pure { visited: newVisited, results: acc.results }
+        Just metadata ->
+          case Map.lookup manifest.version (un Metadata metadata).published of
+            Nothing -> do
+              Log.warn $ "Dependant " <> PackageName.print manifest.name <> "@" <> Version.print manifest.version <> " not in metadata.published, skipping"
+              pure { visited: newVisited, results: acc.results }
+            Just { compilers }
+              | elem compiler compilers -> do
+                  -- Already has compiler: propagate through to find stranded packages
+                  sub <- go manifestIndex newVisited manifest.name manifest.version
+                  pure { visited: sub.visited, results: acc.results <> sub.results }
+              | otherwise -> do
+                  result <- trySolveForCompiler { compilerIndex, compiler, name: manifest.name, version: manifest.version, dependencies: manifest.dependencies }
+                  pure case result of
+                    Nothing -> { visited: newVisited, results: acc.results }
+                    Just entry -> { visited: newVisited, results: Set.insert entry acc.results }
+
+-- | Try to solve a package's dependencies for a specific compiler. Returns
+-- | the solver result if the produced build plan targets the expected compiler,
+-- | Nothing otherwise (solver failure or compiler mismatch).
+trySolveForCompiler :: forall r. MatrixSolverData -> Run (LOG + r) (Maybe MatrixSolverResult)
+trySolveForCompiler { compilerIndex, compiler, name, version, dependencies } = do
+  Log.debug $ "Trying compiler " <> Version.print compiler <> " for package " <> PackageName.print name
+  case Solver.solveWithCompiler (Range.exact compiler) compilerIndex dependencies of
+    Left solverErrors -> do
+      Log.info $ "Failed to solve with compiler " <> Version.print compiler <> ": " <> PackageName.print name <> "@" <> Version.print version
+      Log.debug $ "Solver errors:\n" <> foldMapWithIndex
+        (\i error -> "[Error " <> show (i + 1) <> "]\n" <> Solver.printSolverError error <> "\n")
+        solverErrors
+      pure Nothing
+    Right (Tuple solvedCompiler resolutions)
+      | solvedCompiler == compiler -> do
+          Log.debug $ "Solved " <> PackageName.print name <> "@" <> Version.print version <> " with compiler " <> Version.print solvedCompiler
+          pure $ Just { compiler, resolutions, name, version }
+      | otherwise -> do
           Log.debug $ Array.fold
             [ "Produced a compiler-derived build plan that selects a compiler ("
             , Version.print solvedCompiler
             , ") that differs from the target compiler ("
-            , Version.print target
+            , Version.print compiler
             , ")."
             ]
           pure Nothing
-  pure $ Set.fromFoldable $ Array.catMaybes newJobs
-
-solveDependantsForCompiler :: forall r. MatrixSolverData -> Run (EXCEPT String + LOG + REGISTRY + r) (Set MatrixSolverResult)
-solveDependantsForCompiler { compilerIndex, name, version, compiler } = do
-  manifestIndex <- Registry.readAllManifests
-  let dependentManifests = ManifestIndex.dependants manifestIndex name version
-  newJobs <- for dependentManifests \(Manifest manifest) -> do
-    -- We skip if this compiler is already in the package's metadata compilers
-    -- list (meaning it was already successfully tested). Failed compilations
-    -- are not recorded in metadata, but the DB deduplication in insertMatrixJob
-    -- prevents re-enqueuing jobs that already exist.
-    shouldAttemptToCompile <- Registry.readMetadata manifest.name >>= case _ of
-      Nothing -> do
-        Log.debug $ "Skipping " <> PackageName.print manifest.name <> "@" <> Version.print manifest.version <> ": no metadata found"
-        pure false
-      Just metadata -> do
-        let
-          result = case Map.lookup manifest.version (un Metadata metadata).published of
-            Nothing -> false
-            Just { compilers } -> all (_ /= compiler) compilers
-        unless result do
-          Log.debug $ "Skipping " <> PackageName.print manifest.name <> "@" <> Version.print manifest.version <> ": compiler " <> Version.print compiler <> " already tested or version not published"
-        pure result
-    case shouldAttemptToCompile of
-      false -> pure Nothing
-      true -> do
-        -- if all good then run the solver
-        Log.debug $ "Trying compiler " <> Version.print compiler <> " for package " <> PackageName.print manifest.name
-        case Solver.solveWithCompiler (Range.exact compiler) compilerIndex manifest.dependencies of
-          Left solverErrors -> do
-            Log.info $ "Failed to solve with compiler " <> Version.print compiler <> ": " <> PackageName.print manifest.name <> "@" <> Version.print manifest.version
-            Log.debug $ "Solver errors:\n" <> foldMapWithIndex
-              (\i error -> "[Error " <> show (i + 1) <> "]\n" <> Solver.printSolverError error <> "\n")
-              solverErrors
-            pure Nothing
-          Right (Tuple solvedCompiler resolutions) -> case compiler == solvedCompiler of
-            true -> do
-              Log.debug $ "Solved " <> PackageName.print manifest.name <> "@" <> Version.print manifest.version <> " with compiler " <> Version.print solvedCompiler
-              pure $ Just { compiler, resolutions, name: manifest.name, version: manifest.version }
-            false -> do
-              Log.debug $ Array.fold
-                [ "Produced a compiler-derived build plan that selects a compiler ("
-                , Version.print solvedCompiler
-                , ") that differs from the target compiler ("
-                , Version.print compiler
-                , ")."
-                ]
-              pure Nothing
-  pure $ Set.fromFoldable $ Array.catMaybes newJobs
 
 checkIfNewCompiler :: forall r. Run (EXCEPT String + LOG + REGISTRY + AFF + r) (Maybe Version)
 checkIfNewCompiler = do

app/test/App/Effect/Registry.purs

@@ -0,0 +1,115 @@
+module Test.Registry.App.Effect.Registry (spec) where
+
+import Registry.App.Prelude
+
+import Data.Map as Map
+import Effect.Aff as Aff
+import Effect.Ref as Ref
+import Node.Path as Path
+import Registry.App.CLI.Git as Git
+import Registry.App.Effect.Cache as Cache
+import Registry.App.Effect.GitHub (GITHUB, GitHub)
+import Registry.App.Effect.GitHub as GitHub
+import Registry.App.Effect.Log (LOG, Log(..))
+import Registry.App.Effect.Log as Log
+import Registry.App.Effect.Registry (REGISTRY, RegistryEnv, WriteMode(..))
+import Registry.App.Effect.Registry as Registry
+import Registry.Foreign.FSExtra as FS.Extra
+import Registry.Foreign.Tmp as Tmp
+import Registry.Metadata (Metadata(..))
+import Registry.Metadata as Metadata
+import Registry.Test.Assert as Assert
+import Registry.Test.Fixtures (defaultHash, defaultLocation)
+import Registry.Test.Utils (unsafeDateTime, unsafeNonEmptyArray, unsafePackageName, unsafeVersion)
+import Run (AFF, EFFECT, Run)
+import Run as Run
+import Run.Except (EXCEPT)
+import Run.Except as Except
+import Test.Spec as Spec
+
+spec :: Spec.Spec Unit
+spec = do
+  -- This test exercises the Registry.handle to verify that readMetadata does
+  -- not poison the AllMetadata cache: i.e. a single-package read must not seed
+  -- the cache with a singleton map that readAllMetadata would mistake for the
+  -- complete set.
+  Spec.it "readMetadata does not poison AllMetadata cache for readAllMetadata" do
+    Aff.bracket Tmp.mkTmpDir FS.Extra.remove \tmp -> do
+      let metadataDir = Path.concat [ tmp, "registry", "metadata" ]
+      FS.Extra.ensureDirectory metadataDir
+
+      -- Write 3 metadata files to disk
+      for_ packages \{ name, version, compilers } -> do
+        let
+          metadata = Metadata
+            { location: defaultLocation
+            , owners: Nothing
+            , published: Map.singleton (unsafeVersion version)
+                { bytes: 1000.0
+                , compilers: unsafeNonEmptyArray (map unsafeVersion compilers)
+                , hash: defaultHash
+                , publishedTime: unsafeDateTime "2024-01-01T00:00:00.000Z"
+                , ref: Nothing
+                }
+            , unpublished: Map.empty
+            }
+        liftAff $ writeJsonFile Metadata.codec (Path.concat [ metadataDir, name <> ".json" ]) metadata
+
+      -- Set up the RegistryEnv with a pre-populated debouncer so pull
+      -- returns NoChange without doing any git operations.
+      now <- nowUTC
+      let registryPath = Path.concat [ tmp, "registry" ]
+      debouncer <- liftEffect $ Ref.new (Map.singleton registryPath now)
+      cacheRef <- liftEffect Cache.newCacheRef
+      let
+        env =
+          { repos:
+              { registry: { owner: "test", repo: "test" }
+              , manifestIndex: { owner: "test", repo: "test" }
+              , legacyPackageSets: { owner: "test", repo: "test" }
+              }
+          , workdir: tmp
+          , pull: Git.ForceClean
+          , write: ReadOnly
+          , debouncer
+          , cacheRef
+          }
+
+      -- Step 1: readMetadata for one package.
+      -- Before the fix, resetFromDisk seeded the AllMetadata cache with
+      -- Map.singleton prelude metadata. After the fix, the cache is left alone.
+      _ <- runRealRegistry env $ Registry.readMetadata (unsafePackageName "prelude")
+
+      -- Step 2: readAllMetadata under Git.NoChange.
+      -- Before the fix, the singleton cache from step 1 was returned verbatim
+      -- and the assertion below would see size 1. After the fix, the handler
+      -- reads all three metadata files from disk.
+      allMetadata <- runRealRegistry env $ Registry.readAllMetadata
+
+      Map.size allMetadata `Assert.shouldEqual` 3
+
+  where
+  packages =
+    [ { name: "prelude", version: "6.0.1", compilers: [ "0.15.15" ] }
+    , { name: "effect", version: "4.0.0", compilers: [ "0.15.15" ] }
+    , { name: "control", version: "6.0.0", compilers: [ "0.15.15" ] }
+    ]
+
+  -- | Run the REGISTRY effect - can't use the mock here because the regression
+  -- | we are testing is in the caching code of the handle
+  runRealRegistry
+    :: forall a
+     . RegistryEnv
+    -> Run (REGISTRY + GITHUB + LOG + EXCEPT String + AFF + EFFECT + ()) a
+    -> Aff a
+  runRealRegistry env =
+    Registry.interpret (Registry.handle env)
+      >>> GitHub.interpret handleGitHubStub
+      >>> Log.interpret (\(Log _ _ next) -> pure next)
+      >>> Except.catch (\err -> Run.liftAff (Aff.throwError (Aff.error err)))
+      >>> Run.runBaseAff'
+
+  -- | Stub GitHub handler — crashes if called. ReadMetadata and ReadAllMetadata
+  -- | don't use the GITHUB effect, so this should never be reached.
+  handleGitHubStub :: forall r a. GitHub a -> Run r a
+  handleGitHubStub _ = unsafeCrashWith "GITHUB effect should not be called in this test"