diff --git a/app/src/App/Effect/Registry.purs b/app/src/App/Effect/Registry.purs index 224e2363e..890afb3c2 100644 --- a/app/src/App/Effect/Registry.purs +++ b/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 diff --git a/app/src/App/Server/MatrixBuilder.purs b/app/src/App/Server/MatrixBuilder.purs index 856131504..73941d590 100644 --- a/app/src/App/Server/MatrixBuilder.purs +++ b/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 diff --git a/app/test/App/Effect/Registry.purs b/app/test/App/Effect/Registry.purs new file mode 100644 index 000000000..76f6b430b --- /dev/null +++ b/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" diff --git a/app/test/App/Server/MatrixBuilder.purs b/app/test/App/Server/MatrixBuilder.purs index ec481f83b..f8986502c 100644 --- a/app/test/App/Server/MatrixBuilder.purs +++ b/app/test/App/Server/MatrixBuilder.purs @@ -2,6 +2,7 @@ module Test.Registry.App.Server.MatrixBuilder (spec) where import Registry.App.Prelude +import Data.Array.NonEmpty as NonEmptyArray import Data.Map as Map import Data.Set as Set import Effect.Ref as Ref @@ -31,6 +32,89 @@ spec = do unless (Set.isEmpty result) do Assert.fail "Expected empty result set when compiler already tested" + Spec.it "propagates through already-compiled packages to reach stranded dependants" do + -- This is a regression test for a specific scenario when cascading matrix + -- jobs for a new compiler. Setup: + -- + -- prelude@5.0.0 (no deps) + -- prelude@6.0.0 (no deps) + -- leaf-dep@4.0.0 (prelude >=4.0.0 <6.0.0) -- old, wants old prelude + -- leaf-dep@6.0.0 (prelude >=6.0.0 <7.0.0) -- new, wants new prelude + -- mid-pkg@1.0.0 (leaf-dep >=4.0.0 <7.0.0) -- wide range on leaf-dep + -- top-pkg@1.0.0 (mid-pkg >=1.0.0 <2.0.0, prelude >=6.0.0 <7.0.0) + -- + -- top-pkg's prelude constraint forces the solver to pick leaf-dep@6.0.0. + -- When the old dep path completes first (leaf-dep@4.0.0 -> mid-pkg), + -- top-pkg fails because leaf-dep@6.0.0 isn't ready. Later when + -- leaf-dep@6.0.0 completes, mid-pkg already has the compiler. Without + -- special care (solveDependantsForCompiler recursing into transitive + -- dependants), the cascade stops at mid-pkg and top-pkg is never + -- retriggered. + let + cascadeIndex = Utils.fromRight "Failed to build ManifestIndex" do + ManifestIndex.insert ManifestIndex.ConsiderRanges prelude5Manifest ManifestIndex.empty + >>= ManifestIndex.insert ManifestIndex.ConsiderRanges preludeManifest + >>= ManifestIndex.insert ManifestIndex.ConsiderRanges leafDep4Manifest + >>= ManifestIndex.insert ManifestIndex.ConsiderRanges leafDep6Manifest + >>= ManifestIndex.insert ManifestIndex.ConsiderRanges midPkgManifest + >>= ManifestIndex.insert ManifestIndex.ConsiderRanges topPkgManifest + + -- Initial state: all packages only have 0.15.10 + initMetadata = Map.fromFoldable + [ Utils.unsafeMetadata "prelude" [ Tuple "5.0.0" [ "0.15.10" ], Tuple "6.0.0" [ "0.15.10" ] ] + , Utils.unsafeMetadata "leaf-dep" [ Tuple "4.0.0" [ "0.15.10" ], Tuple "6.0.0" [ "0.15.10" ] ] + , Utils.unsafeMetadata "mid-pkg" [ Tuple "1.0.0" [ "0.15.10" ] ] + , Utils.unsafeMetadata "top-pkg" [ Tuple "1.0.0" [ "0.15.10" ] ] + ] + + metadataRef <- liftEffect $ Ref.new initMetadata + indexRef <- liftEffect $ Ref.new cascadeIndex + + let + step name version dependencies = do + -- Simulate runMatrixJob completing: add 0.15.11 to metadata + liftEffect $ addCompilerToMetadata metadataRef name version compiler_0_15_11 + -- Rebuild CompilerIndex from current metadata (as JobExecutor does) + currentMetadata <- liftEffect $ Ref.read metadataRef + let compilerIndex = Solver.buildCompilerIndex allCompilers cascadeIndex currentMetadata + let solverData = { compilerIndex, compiler: compiler_0_15_11, name, version, dependencies } + runRegistryMock metadataRef indexRef + $ MatrixBuilder.solveDependantsForCompiler solverData + + -- Wave 0: leaves complete + -- prelude@5.0.0 -> should find leaf-dep@4.0.0 (prelude >=4.0.0 <6.0.0 includes 5.0.0) + r1 <- step preludeName prelude5Version Map.empty + let r1Names = Set.map _.name r1 + unless (Set.member leafDepName r1Names) do + Assert.fail $ "Step 1: Expected leaf-dep in cascade from prelude@5.0.0, got: " + <> show (Set.map PackageName.print r1Names) + + -- prelude@6.0.0 -> should try leaf-dep@6.0.0 and top-pkg, but they can't solve yet + _r2 <- step preludeName preludeVersion Map.empty + + -- Old dep path resolves first + -- leaf-dep@4.0.0 -> should find mid-pkg@1.0.0 (leaf-dep >=4.0.0 <7.0.0) + r3 <- step leafDepName leafDep4Version (depsOf leafDep4Manifest) + let r3Names = Set.map _.name r3 + unless (Set.member midPkgName r3Names) do + Assert.fail $ "Step 3: Expected mid-pkg in cascade from leaf-dep@4.0.0, got: " + <> show (Set.map PackageName.print r3Names) + + -- mid-pkg@1.0.0 -> tries top-pkg, but top-pkg needs leaf-dep@6.0.0 which isn't ready + r4 <- step midPkgName midPkgVersion (depsOf midPkgManifest) + let r4Names = Set.map _.name r4 + when (Set.member topPkgName r4Names) do + Assert.fail "Step 4: top-pkg should NOT be enqueued yet (leaf-dep@6.0.0 not ready)" + + -- New dep path resolves later + -- leaf-dep@6.0.0 -> finds mid-pkg (already has compiler) -> PROPAGATES through -> + -- finds top-pkg -> solver now succeeds because leaf-dep@6.0.0 is ready + r5 <- step leafDepName leafDep6Version (depsOf leafDep6Manifest) + let r5Names = Set.map _.name r5 + unless (Set.member topPkgName r5Names) do + Assert.fail $ "Step 5: Expected top-pkg via propagation through mid-pkg, got: " + <> show (Set.map PackageName.print r5Names) + where preludeName = Utils.unsafePackageName "prelude" effectName = Utils.unsafePackageName "effect" @@ -45,18 +129,6 @@ spec = do effectManifest = Utils.unsafeManifest "effect" "4.0.0" [ Tuple "prelude" ">=6.0.0 <7.0.0" ] - dummySha = Utils.unsafeSha256 "sha256-aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa=" - dummyTime = Utils.unsafeDateTime "2022-08-18T20:04:00.000Z" - - mkPublishedMeta version compilers = - Map.singleton version - { bytes: 1000.0 - , compilers: Utils.unsafeNonEmptyArray (map Utils.unsafeVersion compilers) - , hash: dummySha - , publishedTime: dummyTime - , ref: Nothing - } - -- | Set up a test scenario where prelude@6.0.0 (no deps) has completed its -- | matrix job for 0.15.11, and effect@4.0.0 (depends on prelude) has the -- | given compilers in its metadata. @@ -74,21 +146,10 @@ spec = do -- solveDependantsForCompiler. Without 0.15.11 here, the solver -- would compute purs >=0.15.10 <0.15.11 for prelude, excluding -- the target compiler from effect's build plan. - preludeMetadata = Metadata - { location: Git { url: "https://github.com/purescript/purescript-prelude.git", subdir: Nothing } - , owners: Nothing - , published: mkPublishedMeta preludeVersion [ "0.15.10", "0.15.11" ] - , unpublished: Map.empty - } - - effectMetadata = Metadata - { location: Git { url: "https://github.com/purescript/purescript-effect.git", subdir: Nothing } - , owners: Nothing - , published: mkPublishedMeta (Utils.unsafeVersion "4.0.0") effectCompilers - , unpublished: Map.empty - } - - metadata = Map.fromFoldable [ Tuple preludeName preludeMetadata, Tuple effectName effectMetadata ] + metadata = Map.fromFoldable + [ Utils.unsafeMetadata "prelude" [ Tuple "6.0.0" [ "0.15.10", "0.15.11" ] ] + , Utils.unsafeMetadata "effect" [ Tuple "4.0.0" effectCompilers ] + ] compilerIndex = Solver.buildCompilerIndex allCompilers index metadata @@ -102,6 +163,46 @@ spec = do { solverData, index, metadata } + -- Cascade test: package graph with transitive version conflict + leafDepName = Utils.unsafePackageName "leaf-dep" + midPkgName = Utils.unsafePackageName "mid-pkg" + topPkgName = Utils.unsafePackageName "top-pkg" + + prelude5Version = Utils.unsafeVersion "5.0.0" + leafDep4Version = Utils.unsafeVersion "4.0.0" + leafDep6Version = Utils.unsafeVersion "6.0.0" + midPkgVersion = Utils.unsafeVersion "1.0.0" + + prelude5Manifest = Utils.unsafeManifest "prelude" "5.0.0" [] + leafDep4Manifest = Utils.unsafeManifest "leaf-dep" "4.0.0" + [ Tuple "prelude" ">=4.0.0 <6.0.0" ] + leafDep6Manifest = Utils.unsafeManifest "leaf-dep" "6.0.0" + [ Tuple "prelude" ">=6.0.0 <7.0.0" ] + midPkgManifest = Utils.unsafeManifest "mid-pkg" "1.0.0" + [ Tuple "leaf-dep" ">=4.0.0 <7.0.0" ] + topPkgManifest = Utils.unsafeManifest "top-pkg" "1.0.0" + [ Tuple "mid-pkg" ">=1.0.0 <2.0.0" + , Tuple "prelude" ">=6.0.0 <7.0.0" + ] + + depsOf (Manifest m) = m.dependencies + + addCompilerToMetadata :: Ref (Map PackageName Metadata) -> PackageName -> Version -> Version -> Effect Unit + addCompilerToMetadata ref name version compiler = do + Ref.modify_ (Map.update (Just <<< addCompiler version compiler) name) ref + + addCompiler :: Version -> Version -> Metadata -> Metadata + addCompiler version compiler (Metadata m) = Metadata $ m + { published = Map.update + ( \entry -> Just $ entry + { compilers = Utils.unsafeNonEmptyArray + (NonEmptyArray.toArray entry.compilers <> [ compiler ]) + } + ) + version + m.published + } + runSolver solverData index metadata = liftAff do indexRef <- liftEffect $ Ref.new index metadataRef <- liftEffect $ Ref.new metadata diff --git a/app/test/Main.purs b/app/test/Main.purs index 15cae06e6..a7b0e622c 100644 --- a/app/test/Main.purs +++ b/app/test/Main.purs @@ -10,6 +10,7 @@ import Test.Registry.App.CLI.Purs as Test.CLI.Purs import Test.Registry.App.CLI.PursVersions as Test.CLI.PursVersions import Test.Registry.App.CLI.Tar as Test.CLI.Tar import Test.Registry.App.Effect.PackageSets as Test.Effect.PackageSets +import Test.Registry.App.Effect.Registry as Test.Effect.Registry import Test.Registry.App.GitHubIssue as Test.GitHubIssue import Test.Registry.App.Legacy.LenientRange as Test.Legacy.LenientRange import Test.Registry.App.Legacy.LenientVersion as Test.Legacy.LenientVersion @@ -38,6 +39,7 @@ main = runSpecAndExitProcess' config [ consoleReporter ] do Spec.describe "Registry.App.Effect" do Test.Effect.PackageSets.spec + Spec.describe "Registry" Test.Effect.Registry.spec Spec.describe "Registry.App.GitHubIssue" do Test.GitHubIssue.spec diff --git a/lib/src/Solver.purs b/lib/src/Solver.purs index d3dcec10c..14be1a220 100644 --- a/lib/src/Solver.purs +++ b/lib/src/Solver.purs @@ -1,5 +1,27 @@ -- | # Public API -module Registry.Solver where +module Registry.Solver + ( CompilerIndex + , DependencyIndex + , buildCompilerIndex + , updateCompilerIndex + , solveWithCompiler + , solve + , SolverError(..) + , SolverErrors + , SolverPosition(..) + , LocalSolverPosition(..) + , Sourced(..) + , Intersection(..) + , MinSourced(..) + , MaxSourced(..) + , printSolverError + , initializeRegistry + , initializeRequired + , solveSeed + , solveSteps + , lowerBound + , upperBound + ) where import Prelude @@ -54,41 +76,74 @@ import Safe.Coerce (coerce) newtype CompilerIndex = CompilerIndex DependencyIndex derive instance Newtype CompilerIndex _ +derive newtype instance Eq CompilerIndex -- | Associate the compiler versions supported by each package version by -- | inserting them as a range in the version's dependencies. +-- | +-- | Crashes if any package in the ManifestIndex is missing from `metadata`: +-- | this is a registry invariant (publish writes metadata before indexing +-- | the manifest), so a violation indicates registry-level data inconsistency. buildCompilerIndex :: NonEmptyArray Version -> ManifestIndex -> Map PackageName Metadata -> CompilerIndex -buildCompilerIndex pursCompilers index metadata = CompilerIndex do +buildCompilerIndex pursCompilers index metadata = do let - purs = Either.fromRight' (\_ -> Partial.unsafeCrashWith "Invalid package name!") (PackageName.parse "purs") - - getDependencies (Manifest manifest) = fromMaybe manifest.dependencies do - Metadata { published } <- Map.lookup manifest.name metadata - { compilers } <- Map.lookup manifest.version published - -- Construct a maximal range for the compilers the - -- indicated package version supports. + pursVersions = Map.singleton purs + (Map.fromFoldable $ map (\v -> Tuple v Map.empty) (NonEmptyArray.toArray pursCompilers)) + seed = CompilerIndex pursVersions + + Array.foldl + ( \ci manifest@(Manifest m) -> case Map.lookup m.name metadata of + Nothing -> Partial.unsafeCrashWith + ("buildCompilerIndex: no metadata for " <> PackageName.print m.name <> " (present in ManifestIndex)") + Just meta -> updateCompilerIndex ci manifest meta + ) + seed + (ManifestIndex.toArray index) + +-- | Incrementally update a CompilerIndex after a single package version has +-- | been recompiled with a new compiler. Only recomputes the entry for the +-- | (manifest.name, manifest.version) pair; other entries are untouched. +-- | +-- | If `manifest.version` is not in `metadata.published`, or the compilers +-- | list produces no valid `Range`, the entry falls back to the raw manifest +-- | dependencies (no purs range). +-- | +-- | TODO: use this to implement a cached CompilerIndex (see TODOs in +-- | MatrixBuilder.readCompilerIndex and JobExecutor) so matrix jobs don't +-- | rebuild from scratch. +updateCompilerIndex :: CompilerIndex -> Manifest -> Metadata -> CompilerIndex +updateCompilerIndex (CompilerIndex index) (Manifest m) (Metadata { published }) = CompilerIndex do + let + deps = fromMaybe m.dependencies do + { compilers } <- Map.lookup m.version published let min = Foldable1.minimum compilers max = Version.bumpPatch $ Foldable1.maximum compilers pursRange <- Range.mk min max - pure $ Map.insert purs pursRange manifest.dependencies - - newPurs version = Map.singleton purs (Map.singleton version Map.empty) - pursVersions = Array.foldl (\acc compiler -> Map.unionWith Map.union (newPurs compiler) acc) Map.empty (NonEmptyArray.toArray pursCompilers) - dependencyIndex = map (map getDependencies) (ManifestIndex.toMap index) + pure $ Map.insert purs pursRange m.dependencies - Map.unionWith Map.union pursVersions dependencyIndex + Map.alter + ( Just <<< case _ of + Nothing -> Map.singleton m.version deps + Just versions -> Map.insert m.version deps versions + ) + m.name + index -- | Solve the given dependencies using a dependency index that includes compiler -- | versions, such that the solution prunes results that would fall outside -- | a compiler range accepted by all dependencies. solveWithCompiler :: Range -> CompilerIndex -> Map PackageName Range -> Either SolverErrors (Tuple Version (Map PackageName Version)) solveWithCompiler pursRange (CompilerIndex index) required = do - let purs = Either.fromRight' (\_ -> Partial.unsafeCrashWith "Invalid package name!") (PackageName.parse "purs") results <- solveFull { registry: initializeRegistry index, required: initializeRequired (Map.insert purs pursRange required) } let pursVersion = Maybe.fromMaybe' (\_ -> Partial.unsafeCrashWith "Produced a compiler-derived build plan with no compiler!") $ Map.lookup purs results pure $ Tuple pursVersion $ Map.delete purs results +-- | The "purs" pseudo-package used to thread compiler version constraints +-- | through the dependency index. +purs :: PackageName +purs = Either.fromRight' (\_ -> Partial.unsafeCrashWith "Invalid package name!") (PackageName.parse "purs") + -- | Data from the registry index, listing dependencies for each version of -- | each package type DependencyIndex = Map PackageName (Map Version (Map PackageName Range)) diff --git a/lib/test/Registry/Solver.purs b/lib/test/Registry/Solver.purs index a45cf92f9..ac5932640 100644 --- a/lib/test/Registry/Solver.purs +++ b/lib/test/Registry/Solver.purs @@ -17,11 +17,13 @@ import Data.Set.NonEmpty as NES import Data.Tuple (Tuple(..)) import Data.Tuple.Nested ((/\)) import Partial.Unsafe (unsafeCrashWith) +import Registry.Manifest (Manifest(..)) +import Registry.ManifestIndex as ManifestIndex import Registry.PackageName as PackageName import Registry.Range as Range -import Registry.Solver (Intersection(..), LocalSolverPosition(..), SolverError(..), SolverPosition(..), Sourced(..), initializeRegistry, initializeRequired, lowerBound, printSolverError, solve, solveSeed, solveSteps, upperBound) +import Registry.Solver (Intersection(..), LocalSolverPosition(..), SolverError(..), SolverPosition(..), Sourced(..), buildCompilerIndex, initializeRegistry, initializeRequired, lowerBound, printSolverError, solve, solveSeed, solveSteps, solveWithCompiler, updateCompilerIndex, upperBound) import Registry.Test.Assert as Assert -import Registry.Test.Utils (fromRight) +import Registry.Test.Utils (fromRight, unsafeManifest, unsafeMetadata, unsafeNonEmptyArray, unsafeVersion) import Registry.Types (PackageName, Range, Version) import Registry.Version as Version import Test.Spec as Spec @@ -285,6 +287,93 @@ spec = do } ] + Spec.describe "CompilerIndex" do + let + -- Package graph: + -- prelude@6.0.1 (no deps) + -- effect@4.0.0 (depends on prelude >=6.0.0 <7.0.0) + -- effect@5.0.0 (depends on prelude >=6.0.0 <7.0.0) + -- my-pkg@1.0.0 (depends on prelude >=6.0.0 <7.0.0, effect >=4.0.0 <5.0.0) + preludeManifest = unsafeManifest "prelude" "6.0.1" [] + effectManifest = unsafeManifest "effect" "4.0.0" [ Tuple "prelude" ">=6.0.0 <7.0.0" ] + effect5Manifest = unsafeManifest "effect" "5.0.0" [ Tuple "prelude" ">=6.0.0 <7.0.0" ] + myPkgManifest = unsafeManifest "my-pkg" "1.0.0" [ Tuple "prelude" ">=6.0.0 <7.0.0", Tuple "effect" ">=4.0.0 <5.0.0" ] + + Manifest myPkg = myPkgManifest + + compilers = unsafeNonEmptyArray [ unsafeVersion "0.15.15", unsafeVersion "0.15.16" ] + + manifestIndex = fromRight "Failed to build ManifestIndex" do + ManifestIndex.insert ManifestIndex.ConsiderRanges preludeManifest ManifestIndex.empty + >>= ManifestIndex.insert ManifestIndex.ConsiderRanges effectManifest + >>= ManifestIndex.insert ManifestIndex.ConsiderRanges effect5Manifest + >>= ManifestIndex.insert ManifestIndex.ConsiderRanges myPkgManifest + + -- All packages present, only support 0.15.15 + oldCompilerMetadata = Map.fromFoldable + [ unsafeMetadata "prelude" [ Tuple "6.0.1" [ "0.15.15" ] ] + , unsafeMetadata "effect" + [ Tuple "4.0.0" [ "0.15.15" ] + , Tuple "5.0.0" [ "0.15.15" ] + ] + , unsafeMetadata "my-pkg" [ Tuple "1.0.0" [ "0.15.15" ] ] + ] + + -- All packages present, support both compilers + bothCompilersMetadata = Map.fromFoldable + [ unsafeMetadata "prelude" [ Tuple "6.0.1" [ "0.15.15", "0.15.16" ] ] + , unsafeMetadata "effect" + [ Tuple "4.0.0" [ "0.15.15", "0.15.16" ] + , Tuple "5.0.0" [ "0.15.15", "0.15.16" ] + ] + , unsafeMetadata "my-pkg" [ Tuple "1.0.0" [ "0.15.15", "0.15.16" ] ] + ] + + Spec.it "Complete metadata rejects incompatible compiler" do + let compilerIndex = buildCompilerIndex compilers manifestIndex oldCompilerMetadata + case solveWithCompiler (Range.exact (unsafeVersion "0.15.16")) compilerIndex myPkg.dependencies of + Left _ -> pure unit -- expected: effect's purs range >=0.15.15 <0.15.16 excludes 0.15.16 + Right _ -> + Assert.fail "Expected solver to reject build plan where effect only supports 0.15.15" + + Spec.it "Complete metadata accepts compatible compiler" do + let compilerIndex = buildCompilerIndex compilers manifestIndex bothCompilersMetadata + case solveWithCompiler (Range.exact (unsafeVersion "0.15.16")) compilerIndex myPkg.dependencies of + Left errs -> + Assert.fail $ "Expected solver to succeed but it failed:\n" <> foldMapWithIndex + (\i error -> "[Error " <> show (i + 1) <> "] " <> printSolverError error <> "\n") + errs + Right (Tuple _solvedCompiler resolutions) -> do + Map.lookup (package "prelude") resolutions `Assert.shouldEqual` Just (unsafeVersion "6.0.1") + Map.lookup (package "effect") resolutions `Assert.shouldEqual` Just (unsafeVersion "4.0.0") + + Spec.it "updateCompilerIndex produces same result as full rebuild" do + -- Setup: effect has two versions (4.0.0 and 5.0.0) both supporting + -- only 0.15.15. The incremental update adds 0.15.16 to effect@4.0.0; + -- effect@5.0.0 must be left untouched. Equivalence with a full + -- rebuild verifies both that the updated entry matches and that + -- unrelated entries are preserved (e.g. a bug that inserted at the + -- package-name level instead of the (name, version) level would + -- drop effect@5.0.0 in the incremental). + let + fullOld = buildCompilerIndex compilers manifestIndex oldCompilerMetadata + + Tuple _ updatedEffectMeta = unsafeMetadata "effect" + [ Tuple "4.0.0" [ "0.15.15", "0.15.16" ] + , Tuple "5.0.0" [ "0.15.15" ] + ] + + updatedMetadata = Map.fromFoldable + [ unsafeMetadata "prelude" [ Tuple "6.0.1" [ "0.15.15" ] ] + , Tuple (package "effect") updatedEffectMeta + , unsafeMetadata "my-pkg" [ Tuple "1.0.0" [ "0.15.15" ] ] + ] + fullNew = buildCompilerIndex compilers manifestIndex updatedMetadata + + incremental = updateCompilerIndex fullOld effectManifest updatedEffectMeta + + incremental `Assert.shouldEqual` fullNew + solverIndex :: Map PackageName (Map Version (Map PackageName Range)) solverIndex = Map.fromFoldable $ map buildPkg -- simple and prelude have corresponding versions 0.0.0 and 1.0.0 diff --git a/test-utils/src/Registry/Test/Utils.purs b/test-utils/src/Registry/Test/Utils.purs index 57f177890..a74c1fa34 100644 --- a/test-utils/src/Registry/Test/Utils.purs +++ b/test-utils/src/Registry/Test/Utils.purs @@ -12,7 +12,7 @@ import Data.Either as Either import Data.Formatter.DateTime as DateTime.Formatters import Data.Map as Map import Data.Maybe (Maybe(..)) -import Data.Tuple (Tuple) +import Data.Tuple (Tuple(..)) import JSON (JSON) import JSON as JSON import Partial.Unsafe (unsafeCrashWith) @@ -21,11 +21,13 @@ import Registry.Internal.Format as Internal.Format import Registry.License as License import Registry.Location (Location(..)) import Registry.Manifest (Manifest(..)) +import Registry.Metadata (Metadata(..)) import Registry.PackageName (PackageName) import Registry.PackageName as PackageName import Registry.Range as Range import Registry.SSH as SSH import Registry.Sha256 as Sha256 +import Registry.Test.Fixtures (defaultHash, defaultLocation) import Registry.Version (Version) import Registry.Version as Version import Unsafe.Coerce (unsafeCoerce) @@ -155,6 +157,23 @@ unsafeManifest name version dependencies = Manifest , excludeFiles: Nothing } +unsafeMetadata :: String -> Array (Tuple String (Array String)) -> Tuple PackageName Metadata +unsafeMetadata name versions = Tuple (unsafePackageName name) $ Metadata + { location: defaultLocation + , owners: Nothing + , published: Map.fromFoldable $ map + ( \(Tuple ver comps) -> Tuple (unsafeVersion ver) + { bytes: 1000.0 + , compilers: unsafeNonEmptyArray (map unsafeVersion comps) + , hash: defaultHash + , publishedTime: unsafeDateTime "2024-01-01T00:00:00.000Z" + , ref: Nothing + } + ) + versions + , unpublished: Map.empty + } + -- | Format a package version as a string in the form 'name@X.Y.Z' formatPackageVersion :: PackageName -> Version -> String formatPackageVersion name version = PackageName.print name <> "@" <> Version.print version