diff --git a/.github/workflows/version-check.yml b/.github/workflows/version-check.yml new file mode 100644 index 000000000..13251fcc5 --- /dev/null +++ b/.github/workflows/version-check.yml @@ -0,0 +1,50 @@ +name: Daily package set planning + +on: + schedule: + - cron: '0 6 * * *' + workflow_dispatch: + +permissions: + contents: read + issues: write + +concurrency: + group: package-set-version-check + cancel-in-progress: false + +jobs: + version-check: + runs-on: ubuntu-latest + # Planning performs at most 96 incremental compile probes, then a submitted + # server job is polled for at most 60 minutes. Leave enough headroom that a + # difficult plan can still emit its report and reconcile trustee issues. + timeout-minutes: 180 + + steps: + - name: Checkout code + uses: actions/checkout@v6 + + - name: Install Nix + uses: DeterminateSystems/determinate-nix-action@v3 + + - name: Setup Nix cache + uses: DeterminateSystems/magic-nix-cache-action@v14 + with: + use-flakehub: false + + - name: Plan, verify, and submit pending package set updates + env: + GITHUB_TOKEN: ${{ github.token }} + run: nix run .#version-check -- --verify --submit --reconcile-issues --output version-check.json --markdown version-check.md + + - name: Upload report + if: ${{ !cancelled() }} + uses: actions/upload-artifact@v4 + with: + name: package-set-version-check + path: | + version-check.json + version-check.md + if-no-files-found: warn + retention-days: 14 diff --git a/SPEC.md b/SPEC.md index 77883eac2..be322b515 100644 --- a/SPEC.md +++ b/SPEC.md @@ -779,12 +779,13 @@ Anyone can suggest a package set update to the registry. However, community memb A package set update must be submitted to the registry via GitHub issues on the registry repository. The body of the issue should contain the JSON object specified below, optionally within a code fence. -A package set update is an object with two keys: `compiler`, an optional field that, if set, will update the compiler version used to compile the package sets (it cannot be downgraded), and `packages`, an object where keys are package names and values are either a version number or `null`. A version number indicates the package should be added to the set or updated to the given version, and `null` indicates the package should be dropped from the package set. +A package set update is an object with three keys: `expectedBaseline`, an optional package set version that the update was planned and verified against; `compiler`, an optional field that, if set, will update the compiler version used to compile the package sets (it cannot be downgraded); and `packages`, an object where keys are package names and values are either a version number or `null`. A version number indicates the package should be added to the set or updated to the given version, and `null` indicates the package should be dropped from the package set. If `expectedBaseline` is present and is not the latest package set version when the operation executes, then the operation is rejected before validation, compilation, or publication. The field may be omitted for compatibility with manually submitted updates, which apply to the latest package set available when they execute. ```jsonc { // Sets the package set compiler version to 0.15.2 + "expectedBaseline": "2.1.1", "compiler": "0.15.2", - "packages" { + "packages": { // Updates the `aff` package to v8.0.0 "aff": "8.0.0", // Removes the `argonaut` package from the package sets altogether @@ -812,13 +813,15 @@ The suggested new package set can only be released if: 1. All packages in the set depend only on other packages in the set 2. All packages in the set can be compiled together +Package set self-containment concerns dependency names, not the version ranges in package manifests. Every dependency name must occur in the package set, but its manifest range need not include the exact version selected by the set. Compiling the exact package versions in the set with the set's exact compiler version is the authoritative validity check. + To verify the package set, we take the following steps: -1. We apply the suggested changes to the package set and verify that the package set is still self-contained. If not, the update is rejected. +1. We apply all suggested changes to the package set as one exact batch and verify that the package set is still self-contained. If not, the update is rejected. 2. We install the previous package set and compile it. This ensures we are beginning from a known good state. 3. We install the new package set (uninstalling any packages that are removed) and compile the package set again. If compilation fails then the update is rejected. -When we have verified the package set is self-contained and all packages compile together then we can release the package set. +When we have verified the package set is self-contained and all packages compile together then we can release the package set. A submitted package set update is atomic: either its entire exact payload is released or it fails without releasing a subset. ##### Releasing the Package Set @@ -874,27 +877,25 @@ If documentation publishing fails (for example, due to a transient network error #### 6.3 Publish to Package Sets -The registry attempts to produce a new package set automatically every day, so long as packages have been uploaded that could be added or updated. No packages are ever dropped from a package set automatically; the only time packages are dropped from the package sets are during manual releases. +The registry attempts to produce a new package set automatically every day when eligible package versions exist. The latest package set and its compiler version are the starting point for every automatic plan. -Every day, the registry executes the following steps: +Newer registry versions of packages already in the package set remain candidates until they are included or superseded by the package set itself. They do not cease to be candidates merely because an automatic run could not include them or because time has passed since publication. An automatic plan may coordinate upgrades to several packages and may select an intermediate newer version instead of only the latest release when that produces a valid set. -First, we read the contents of the latest package set release and gather all package versions that have been uploaded to the registry since that release. These package versions are the "batch" of packages that we are considering for automatic inclusion to the next package set. +Packages that have never appeared in a package set are eligible only while they are recent additions. Their candidate set is recursively expanded with any dependency names absent from the current package set so the planner can consider a self-contained addition. -Second, we filter out any packages where, based on their metadata and manifest files alone, we know they can't be added to the package set. This happens for one of three reasons: +Every automatic plan must satisfy these constraints: -1. They have a dependency that is neither in the package sets nor in the batch that is up for consideration -2. They have had multiple releases since the last package set, in which case we only take the highest version -3. They already have a higher version published in a previous package set +1. It does not remove a package. +2. It does not downgrade a package. +3. It does not change the compiler version. +4. Every dependency name in the resulting set occurs in that set. Manifest version ranges are ignored for this self-containment check. +5. The exact resulting package set compiles as a whole with the unchanged, exact compiler version. -Third, we attempt to add the rest of the batch of package versions to the package set. Processing the batch follows these steps: +The whole-set compiler result is authoritative: manifest version ranges do not prevent an exact selection from being a valid package set, and manifest compatibility alone does not prove that a selection is valid. Each selected plan is submitted and released as one exact atomic package set update according to [Section 5.5 (Update the Package Set)](#55-update-the-package-set). -1. We install the previous package set and compile it. -2. We attempt to upgrade all package versions from the batch at once in the package set. Once the new versions are installed, we compile the package set. If it succeeds, then we're done. -3. If we couldn't compile the whole batch, then we order the batch first by their dependencies and then by their upload time. Packages with no dependencies on other packages in the batch go first, and ties are broken by upload time: older uploads go first. Then, we attempt to add packages to the package set one-by-one. -4. If a package fails to compile with the rest of the package set, then it is filtered from the batch. -5. Once there are no more packages to consider in the batch, the new package set is ready. +If an otherwise desirable upgrade requires removing packages, it is not an automatic plan. Registry Trustees handle such cases using the manual intervention process in [Section 9.5 (Package Sets)](#manual-intervention-in-the-package-sets-via-the-package-sets-api). -Fourth, we release the new package set (if we could produce one). Automatic package sets follow the versioning policy described in [Section 5.5 (Update the Package Set)](#releasing-the-package-set). +The automation reports residual upgrades it could not apply, including compiler evidence. It may report an exact removal-containing payload as compile-verified only after compiling that full payload against its original package set baseline. Such payloads are advisory and are never submitted automatically; a Registry Trustee must decide whether to apply them. Infrastructure failures and bounded searches must be reported distinctly from package incompatibility. ## 7. Non-JavaScript Backends diff --git a/app-e2e/src/Test/E2E/Scripts.purs b/app-e2e/src/Test/E2E/Scripts.purs index 424eec9ac..bd6e04207 100644 --- a/app-e2e/src/Test/E2E/Scripts.purs +++ b/app-e2e/src/Test/E2E/Scripts.purs @@ -20,7 +20,10 @@ import Registry.App.Effect.Cache as Cache import Registry.App.Effect.Env as Env import Registry.App.Effect.GitHub as GitHub import Registry.App.Effect.Log as Log +import Registry.App.Effect.PackageSets as PackageSets import Registry.App.Effect.Registry as Registry +import Registry.App.Effect.Storage as Storage +import Registry.Foreign.FSExtra as FS.Extra import Registry.Foreign.Octokit as Octokit import Registry.Location (Location(..)) import Registry.Operation (AuthenticatedPackageOperation(..)) @@ -140,19 +143,20 @@ spec = do jobs <- Client.getJobs let packageSetJobs = Array.filter isPackageSetJob jobs case Array.head packageSetJobs of - Just (PackageSetJob { payload }) -> - case payload of - Operation.PackageSetUpdate { packages } -> - case Map.lookup typeEqualityName packages of - Just (Just _) -> pure unit - _ -> Assert.fail "Expected type-equality in package set update" + Just (PackageSetJob { payload }) -> do + let { packages } = Operation.packageSetUpdateData payload + case Map.lookup typeEqualityName packages of + Just (Just _) -> pure unit + _ -> Assert.fail "Expected type-equality in package set update" Just _ -> Assert.fail "Expected PackageSetJob but got different job type" Nothing -> Assert.fail "Expected package set job to be enqueued" -- | Common environment for running read-only registry scripts in E2E tests type RegistryScriptSetup = - { resourceEnv :: Env.ResourceEnv + { cache :: FilePath + , resourceEnv :: Env.ResourceEnv , registryEnv :: Registry.RegistryEnv + , workdir :: FilePath } type GitHubScriptSetup = @@ -171,6 +175,9 @@ setupRegistryScript = do resourceEnv <- liftEffect Env.lookupResourceEnv registryCacheRef <- liftAff Cache.newCacheRef debouncer <- liftAff Registry.newDebouncer + let workdir = Path.concat [ stateDir, "scratch" ] + let cache = Path.concat [ workdir, ".cache" ] + liftAff $ FS.Extra.ensureDirectory cache let registryEnv :: Registry.RegistryEnv registryEnv = @@ -178,11 +185,11 @@ setupRegistryScript = do , pull: Git.Autostash , write: Registry.ReadOnly , repos: Registry.defaultRepos - , workdir: Path.concat [ stateDir, "scratch" ] + , workdir , debouncer , cacheRef: registryCacheRef } - pure { resourceEnv, registryEnv } + pure { cache, resourceEnv, registryEnv, workdir } setupGitHubScript :: E2E GitHubScriptSetup setupGitHubScript = do @@ -229,12 +236,15 @@ runPackageTransferrerScript = do -- | Run the PackageSetUpdater script in Submit mode runPackageSetUpdaterScript :: E2E Unit runPackageSetUpdaterScript = do - { resourceEnv, registryEnv } <- setupRegistryScript + { cache, resourceEnv, registryEnv, workdir } <- setupRegistryScript result <- liftAff $ PackageSetUpdater.runPackageSetUpdater PackageSetUpdater.Submit resourceEnv.registryApiUrl + # PackageSets.interpret (PackageSets.handle { workdir }) # Except.runExcept # Registry.interpretRead (Registry.handleRead registryEnv) + # Storage.interpret (Storage.handleReadOnly cache) # Log.interpret (Log.handleTerminal Quiet) + # Env.runResourceEnv resourceEnv # Run.runBaseAff' case result of Left err -> liftAff $ Aff.throwError $ Aff.error $ "PackageSetUpdater failed: " <> err diff --git a/app/src/App/API.purs b/app/src/App/API.purs index a4b69c5d3..33dd3af53 100644 --- a/app/src/App/API.purs +++ b/app/src/App/API.purs @@ -151,9 +151,10 @@ type PackageSetUpdateEffects r = (REGISTRY + PACKAGE_SETS + LOG + EXCEPT String -- | been verified at the API boundary, so we don't need to check team membership. packageSetUpdate :: forall r. PackageSetJobData -> Run (PackageSetUpdateEffects + r) Unit packageSetUpdate details = do - let Operation.PackageSetUpdate payload = details.payload + let payload = Operation.packageSetUpdateData details.payload + let expectedBaseline = Operation.packageSetUpdateExpectedBaseline details.payload - Log.debug $ "Package set update job starting with payload:\n" <> stringifyJson Operation.packageSetUpdateCodec payload + Log.debug $ "Package set update job starting with payload:\n" <> stringifyJson Operation.packageSetOperationCodec details.payload latestPackageSet <- Registry.readLatestPackageSet >>= case _ of Nothing -> do @@ -162,9 +163,17 @@ packageSetUpdate details = do Just set -> pure set Log.debug $ "Most recent package set was " <> stringifyJson PackageSet.codec latestPackageSet + let latestVersion = (un PackageSet latestPackageSet).version let prevCompiler = (un PackageSet latestPackageSet).compiler let prevPackages = (un PackageSet latestPackageSet).packages + for_ expectedBaseline \expected -> when (expected /= latestVersion) do + Except.throw $ Array.fold + [ "Package set update expected baseline " <> Version.print expected + , ", but the latest package set is " <> Version.print latestVersion + , ". Refusing to apply the update to a different baseline." + ] + -- Note: authentication for restricted operations (compiler change, package removal) -- is handled at the API boundary in the Router, not here. @@ -225,18 +234,13 @@ packageSetUpdate details = do let changeSet = candidates.accepted <#> maybe Remove Update Log.notice "Attempting to build package set update." - PackageSets.upgradeSequential latestPackageSet (fromMaybe prevCompiler payload.compiler) changeSet >>= case _ of - Nothing -> - Except.throw "No packages could be added to the package set. All packages failed to compile." - Just { failed, succeeded, result: packageSet } -> do - unless (Map.isEmpty failed) do - let - formatFailed = String.joinWith "\n" $ Array.catMaybes $ flip map (Map.toUnfoldable failed) \(Tuple name change) -> - case change of - PackageSets.Update version -> Just $ " - " <> formatPackageVersion name version - PackageSets.Remove -> Nothing - Log.warn $ "Some packages could not be added to the set:\n" <> formatFailed - let commitMessage = PackageSets.commitMessage latestPackageSet succeeded (un PackageSet packageSet).version + -- A submitted payload is exact. Sequential probing is useful for planning, + -- but must not turn this operation into a partial release. + PackageSets.upgradeAtomic latestPackageSet (fromMaybe prevCompiler payload.compiler) changeSet >>= case _ of + Left error -> + Except.throw $ "Package set update failed to compile atomically. No changes were published.\n\n" <> error + Right packageSet -> do + let commitMessage = PackageSets.commitMessage latestPackageSet changeSet (un PackageSet packageSet).version Registry.writePackageSet packageSet commitMessage Log.notice "Built and released a new package set! Now mirroring to the package-sets repo..." Registry.mirrorPackageSet packageSet diff --git a/app/src/App/GitHubIssue.purs b/app/src/App/GitHubIssue.purs index 65fdbdd39..dbb2ee8e6 100644 --- a/app/src/App/GitHubIssue.purs +++ b/app/src/App/GitHubIssue.purs @@ -41,7 +41,7 @@ import Registry.Foreign.JsonRepair as JsonRepair import Registry.Foreign.Octokit (GitHubToken, IssueNumber(..), Octokit) import Registry.Foreign.Octokit as Octokit import Registry.Internal.Format as Internal.Format -import Registry.Operation (AuthenticatedData, AuthenticatedPackageOperation(..), PackageOperation(..), PackageSetOperation(..)) +import Registry.Operation (AuthenticatedData, AuthenticatedPackageOperation(..), PackageOperation(..), PackageSetOperation) import Registry.Operation as Operation import Run (AFF, EFFECT, Run) import Run as Run @@ -86,9 +86,9 @@ runGitHubIssue env = do run do -- Determine endpoint and prepare the JSON payload { endpoint, jsonBody } <- case env.operation of - Left packageSetOp@(PackageSetUpdate payload) -> do + Left packageSetOp -> do -- Sign with pacchettibotti if submitter is a trustee - request <- signPackageSetIfTrustee packageSetOp payload + request <- signPackageSetIfTrustee packageSetOp pure { endpoint: "/v1/package-sets" , jsonBody: JSON.print $ CJ.encode Operation.packageSetUpdateRequestCodec request @@ -366,7 +366,7 @@ readOperation eventPath = do let keys = CJ.Object.keys object let hasKeys = all (flip Array.elem keys) if hasKeys [ "packages" ] then - map (Left <<< PackageSetUpdate) (CJ.decode Operation.packageSetUpdateCodec json) + map Left (CJ.decode Operation.packageSetOperationCodec json) else if hasKeys [ "name", "ref", "version" ] then map (Right <<< Publish) (CJ.decode Operation.publishCodec json) else if hasKeys [ "payload", "signature" ] then @@ -378,7 +378,7 @@ readOperation eventPath = do , "Received keys: " <> String.joinWith ", " keys , "" , "Expected one of:" - , " - Package set update: { packages, compiler? }" + , " - Package set update: { packages, compiler?, expectedBaseline? }" , " - Publish: { name, ref, compiler?, version, location?, resolutions? }" , " - Authenticated (unpublish/transfer): { payload, signature }" ] @@ -473,10 +473,9 @@ signPacchettiBottiIfTrustee auth = do signPackageSetIfTrustee :: forall r . PackageSetOperation - -> Operation.PackageSetUpdateData -> Run (GITHUB + PACCHETTIBOTTI_ENV + GITHUB_EVENT_ENV + LOG + EXCEPT String + r) Operation.PackageSetUpdateRequest -signPackageSetIfTrustee packageSetOp payload = do - let rawPayload = JSON.print $ CJ.encode Operation.packageSetUpdateCodec payload +signPackageSetIfTrustee packageSetOp = do + let rawPayload = JSON.print $ CJ.encode Operation.packageSetOperationCodec packageSetOp GitHub.listTeamMembers API.packagingTeam >>= case _ of Left githubError -> do Log.warn $ Array.fold diff --git a/app/src/App/Server/Router.purs b/app/src/App/Server/Router.purs index 090e348b5..08970c3fe 100644 --- a/app/src/App/Server/Router.purs +++ b/app/src/App/Server/Router.purs @@ -20,7 +20,6 @@ import Registry.App.Effect.Db as Db import Registry.App.Effect.Env as Env import Registry.App.Effect.Log as Log import Registry.App.Server.Env (ServerEffects, ServerEnv, jsonCreated, jsonDecoder, jsonOk, runEffects) -import Registry.Operation (PackageSetOperation(..)) import Registry.Operation as Operation import Run (Run) import Run as Run @@ -165,7 +164,7 @@ router { route, method, body } = HTTPurple.usingCont case route, method of -- Check if the operation requires authentication (compiler change or package removal) let - PackageSetUpdate payload = request.payload + payload = Operation.packageSetUpdateData request.payload didChangeCompiler = isJust payload.compiler didRemovePackages = any isNothing payload.packages requiresAuth = didChangeCompiler || didRemovePackages diff --git a/app/test/App/API.purs b/app/test/App/API.purs index 0ecd69fd2..053854482 100644 --- a/app/test/App/API.purs +++ b/app/test/App/API.purs @@ -15,10 +15,13 @@ import Effect.Ref as Ref import Node.FS.Aff as FS.Aff import Node.Path as Path import Node.Process as Process +import Registry.API.V1 (JobId(..), PackageSetJobData) import Registry.App.API (LicenseValidationError(..), validateLicense) import Registry.App.API as API import Registry.App.Effect.Env as Env import Registry.App.Effect.Log as Log +import Registry.App.Effect.PackageSets (Change(..)) +import Registry.App.Effect.PackageSets as PackageSets import Registry.App.Effect.Pursuit as Pursuit import Registry.App.Effect.Registry as Registry import Registry.App.Effect.Storage as Storage @@ -29,7 +32,8 @@ import Registry.Foreign.FastGlob as FastGlob import Registry.Foreign.Tmp as Tmp import Registry.License as License import Registry.Location (Location(..)) -import Registry.Operation (PublishData) +import Registry.ManifestIndex as ManifestIndex +import Registry.Operation (PackageSetOperation(..), PackageSetUpdateData, PublishData) import Registry.PackageName as PackageName import Registry.Test.Assert as Assert import Registry.Test.Assert.Run as Assert.Run @@ -39,6 +43,7 @@ import Run (EFFECT, Run) import Run as Run import Run.Except as Except import Test.Spec as Spec +import Type.Proxy (Proxy(..)) -- | The environment accessible to each assertion in the test suite, derived -- | from the fixtures. @@ -131,6 +136,9 @@ spec = do Spec.describe "Verifies build plans" do checkBuildPlanToResolutions + Spec.describe "Applies package set updates" do + packageSetUpdateSpec + Spec.describe "Parses source manifests" do parseSourceManifestSpec @@ -359,6 +367,143 @@ spec = do , githubDir: Path.concat [ testFixtures, "github-packages" ] } +type PackageSetUpdateCalls = + { atomicChanges :: Array PackageSets.ChangeSet + , sequentialCompiles :: Int + , writes :: Int + , mirrors :: Int + } + +packageSetUpdateSpec :: Spec.Spec Unit +packageSetUpdateSpec = do + Spec.it "rejects a stale expected baseline before validation, compilation, or publication" do + let operation = PackageSetUpdateFrom (Utils.unsafeVersion "1.0.0") packageSetUpdateData + { calls, result } <- liftEffect $ runPackageSetUpdate operation + + case result of + Left error -> error `Assert.shouldSatisfy` String.contains (Pattern "expected baseline 1.0.0, but the latest package set is 1.0.1") + Right _ -> Assert.fail "Expected a stale package set update to fail." + calls `Assert.shouldEqual` emptyPackageSetUpdateCalls + + Spec.it "does not publish a sequential subset when the exact update fails to compile" do + let + operation = PackageSetUpdateFrom (Utils.unsafeVersion "1.0.1") packageSetUpdateData + expectedChanges = packageSetUpdateData.packages <#> maybe Remove Update + { calls, result } <- liftEffect $ runPackageSetUpdate operation + + case result of + Left error -> error `Assert.shouldSatisfy` String.contains (Pattern "failed to compile atomically") + Right _ -> Assert.fail "Expected an atomically failing package set update to fail." + calls `Assert.shouldEqual` emptyPackageSetUpdateCalls { atomicChanges = [ expectedChanges ] } + +emptyPackageSetUpdateCalls :: PackageSetUpdateCalls +emptyPackageSetUpdateCalls = { atomicChanges: [], sequentialCompiles: 0, writes: 0, mirrors: 0 } + +runPackageSetUpdate + :: PackageSetOperation + -> Effect { calls :: PackageSetUpdateCalls, result :: Either String Unit } +runPackageSetUpdate operation = do + callsRef <- Ref.new emptyPackageSetUpdateCalls + result <- API.packageSetUpdate (packageSetJob operation) + # Registry.interpretWrite (handlePackageSetRegistryWrite callsRef) + # Registry.interpretRead handlePackageSetRegistryRead + # PackageSets.interpret (handlePackageSetCompileFailure callsRef) + # Log.interpret (\(Log.Log _ _ next) -> pure next) + # Except.runExcept + # Run.runBaseEffect + calls <- Ref.read callsRef + pure { calls, result } + +packageSetJob :: PackageSetOperation -> PackageSetJobData +packageSetJob payload = + { jobId: JobId "package-set-update-test" + , jobType: Proxy + , createdAt: Utils.unsafeDateTime "2026-07-27T00:00:00.000Z" + , startedAt: Nothing + , finishedAt: Nothing + , success: false + , logs: [] + , payload + } + +packageSetUpdateData :: PackageSetUpdateData +packageSetUpdateData = + { compiler: Nothing + , packages: Map.fromFoldable + [ Tuple (Utils.unsafePackageName "aff") (Just (Utils.unsafeVersion "2.0.0")) + , Tuple (Utils.unsafePackageName "prelude") (Just (Utils.unsafeVersion "2.0.0")) + ] + } + +latestPackageSet :: PackageSet +latestPackageSet = PackageSet + { compiler: Utils.unsafeVersion "0.15.15" + , packages: Map.fromFoldable + [ Tuple (Utils.unsafePackageName "aff") (Utils.unsafeVersion "1.0.0") + , Tuple (Utils.unsafePackageName "prelude") (Utils.unsafeVersion "1.0.0") + ] + , published: Utils.unsafeDate "2026-07-26" + , version: Utils.unsafeVersion "1.0.1" + } + +packageSetUpdateIndex :: ManifestIndex +packageSetUpdateIndex = unsafeFromRight $ ManifestIndex.fromSet ManifestIndex.IgnoreRanges $ Set.fromFoldable + [ Utils.unsafeManifest "aff" "1.0.0" [] + , Utils.unsafeManifest "aff" "2.0.0" [] + , Utils.unsafeManifest "prelude" "1.0.0" [] + , Utils.unsafeManifest "prelude" "2.0.0" [] + ] + +handlePackageSetCompileFailure + :: forall r a + . Ref PackageSetUpdateCalls + -> PackageSets.PackageSets a + -> Run (EFFECT + r) a +handlePackageSetCompileFailure callsRef = case _ of + PackageSets.UpgradeAtomic _ _ changes reply -> do + Run.liftEffect $ Ref.modify_ (\calls -> calls { atomicChanges = calls.atomicChanges <> [ changes ] }) callsRef + pure $ reply $ Right $ Left "injected multi-package compilation failure" + PackageSets.UpgradeSequential _ _ _ reply -> do + Run.liftEffect $ Ref.modify_ (\calls -> calls { sequentialCompiles = calls.sequentialCompiles + 1 }) callsRef + pure $ reply $ Right Nothing + +handlePackageSetRegistryRead + :: forall r a + . Registry.RegistryRead a + -> Run r a +handlePackageSetRegistryRead = case _ of + Registry.ReadManifest name version reply -> + pure $ reply $ Right $ ManifestIndex.lookup name version packageSetUpdateIndex + Registry.ReadAllManifests reply -> + pure $ reply $ Right packageSetUpdateIndex + Registry.ReadMetadata _ reply -> + pure $ reply $ Right Nothing + Registry.ReadAllMetadata reply -> + pure $ reply $ Right Map.empty + Registry.ReadLatestPackageSet reply -> + pure $ reply $ Right $ Just latestPackageSet + Registry.ReadAllPackageSets reply -> + pure $ reply $ Right $ Map.singleton (un PackageSet latestPackageSet).version latestPackageSet + +handlePackageSetRegistryWrite + :: forall r a + . Ref PackageSetUpdateCalls + -> Registry.RegistryWrite a + -> Run (EFFECT + r) a +handlePackageSetRegistryWrite callsRef = case _ of + Registry.WriteManifest _ reply -> + pure $ reply $ Right unit + Registry.DeleteManifest _ _ reply -> + pure $ reply $ Right unit + Registry.WriteMetadata _ _ reply -> + pure $ reply $ Right unit + Registry.WritePackageSet _ _ reply -> do + Run.liftEffect $ Ref.modify_ (\calls -> calls { writes = calls.writes + 1 }) callsRef + pure $ reply $ Right unit + Registry.MirrorPackageSet _ reply -> do + Run.liftEffect $ Ref.modify_ (\calls -> calls { mirrors = calls.mirrors + 1 }) callsRef + pure $ reply $ Right unit + checkBuildPlanToResolutions :: Spec.Spec Unit checkBuildPlanToResolutions = do Spec.it "buildPlanToResolutions produces expected resolutions file format" do diff --git a/foreign/src/Foreign/Octokit.purs b/foreign/src/Foreign/Octokit.purs index 92637620b..3e040e915 100644 --- a/foreign/src/Foreign/Octokit.purs +++ b/foreign/src/Foreign/Octokit.purs @@ -11,6 +11,7 @@ module Registry.Foreign.Octokit , GitHubError(..) , GitHubRoute(..) , GitHubToken(..) + , Issue , IssueNumber(..) , JSArgs(..) , Octokit @@ -22,6 +23,7 @@ module Registry.Foreign.Octokit , atKey , closeIssueRequest , createCommentRequest + , createIssueRequest , decodeBase64Content , getCommitDateRequest , getContentRequest @@ -30,6 +32,7 @@ module Registry.Foreign.Octokit , githubErrorCodec , isPermanentGitHubError , listCommitsSinceRequest + , listIssuesRequest , listTagsRequest , listTeamMembersRequest , CommitSha @@ -40,6 +43,7 @@ module Registry.Foreign.Octokit , rateLimitRequest , request , unsafeToJSArgs + , updateIssueRequest ) where import Prelude @@ -52,6 +56,7 @@ import Data.Array as Array import Data.Bifunctor (lmap) import Data.Codec as Codec import Data.Codec.JSON as CJ +import Data.Codec.JSON.Common as CJ.Common import Data.Codec.JSON.Record as CJ.Record import Data.Codec.JSON.Variant as CJ.Variant import Data.DateTime (DateTime) @@ -123,6 +128,67 @@ newtype IssueNumber = IssueNumber Int instance Newtype IssueNumber Int derive newtype instance Eq IssueNumber +type Issue = + { body :: Maybe String + , isPullRequest :: Boolean + , number :: IssueNumber + , state :: String + , title :: String + } + +issueCodec :: CJ.Codec Issue +issueCodec = Codec.codec' decode (const $ CJ.encode CJ.null unit) + where + decode json = except do + decoded <- CJ.decode issueRepCodec json + pure + { body: decoded.body + , isPullRequest: Maybe.isJust decoded.pull_request + , number: IssueNumber decoded.number + , state: decoded.state + , title: decoded.title + } + + issueRepCodec = CJ.named "Issue" $ CJ.Record.object + { body: CJ.Common.nullable CJ.string + , number: CJ.int + , pull_request: CJ.Record.optional CJ.json + , state: CJ.string + , title: CJ.string + } + +-- | List all issues and pull requests in a repository. +listIssuesRequest :: Address -> Request (Array Issue) +listIssuesRequest address = + { route: GitHubRoute GET [ "repos", address.owner, address.repo, "issues" ] (Map.singleton "state" "all") + , headers: Object.empty + , args: noArgs + , paginate: true + , codec: CJ.array issueCodec + } + +-- | Create an issue. Requires authentication. +createIssueRequest :: { address :: Address, body :: String, title :: String } -> Request Unit +createIssueRequest { address, body, title } = + { route: GitHubRoute POST [ "repos", address.owner, address.repo, "issues" ] Map.empty + , headers: Object.empty + , args: unsafeToJSArgs { body, title } + , paginate: false + , codec: Codec.codec' (\_ -> pure unit) (CJ.encode CJ.null) + } + +-- | Replace an issue's title/body and set its state. Requires authentication. +updateIssueRequest + :: { address :: Address, body :: String, issue :: IssueNumber, state :: String, title :: String } + -> Request Unit +updateIssueRequest { address, body, issue: IssueNumber issue, state, title } = + { route: GitHubRoute PATCH [ "repos", address.owner, address.repo, "issues", Int.toStringAs Int.decimal issue ] Map.empty + , headers: Object.empty + , args: unsafeToJSArgs { body, state, title } + , paginate: false + , codec: Codec.codec' (\_ -> pure unit) (CJ.encode CJ.null) + } + -- | A team within a GitHub organization type Team = { org :: String, team :: String } diff --git a/lib/src/Operation.purs b/lib/src/Operation.purs index 727f0482d..ed92d1342 100644 --- a/lib/src/Operation.purs +++ b/lib/src/Operation.purs @@ -26,6 +26,8 @@ module Registry.Operation , authenticatedCodec , packageName , packageOperationCodec + , packageSetUpdateData + , packageSetUpdateExpectedBaseline , packageSetOperationCodec , packageSetUpdateCodec , packageSetUpdateRequestCodec @@ -45,7 +47,7 @@ import Data.Codec.JSON as CJ import Data.Codec.JSON.Common as CJ.Common import Data.Codec.JSON.Record as CJ.Record import Data.Map (Map) -import Data.Maybe (Maybe) +import Data.Maybe (Maybe(..)) import JSON as JSON import Registry.Internal.Codec as Internal.Codec import Registry.LimitedString (LimitedString) @@ -201,8 +203,13 @@ transferCodec = CJ.named "Transfer" $ CJ.Record.object , newLocation: Location.codec } --- | An operation that affects the package sets. -data PackageSetOperation = PackageSetUpdate PackageSetUpdateData +-- | An operation that affects the package sets. `PackageSetUpdateFrom` binds +-- | the update to the given expected latest package set version, while the +-- | original `PackageSetUpdate` constructor remains available for backwards +-- | compatibility with manually-created operations. +data PackageSetOperation + = PackageSetUpdate PackageSetUpdateData + | PackageSetUpdateFrom Version PackageSetUpdateData derive instance Eq PackageSetOperation @@ -210,8 +217,42 @@ derive instance Eq PackageSetOperation packageSetOperationCodec :: CJ.Codec PackageSetOperation packageSetOperationCodec = CJ.named "PackageSetOperation" $ Codec.codec' decode encode where - decode json = map PackageSetUpdate (Codec.decode packageSetUpdateCodec json) - encode (PackageSetUpdate update) = CJ.encode packageSetUpdateCodec update + decode json = do + update <- Codec.decode packageSetOperationRepCodec json + pure case update.expectedBaseline of + Nothing -> PackageSetUpdate { compiler: update.compiler, packages: update.packages } + Just version -> PackageSetUpdateFrom version { compiler: update.compiler, packages: update.packages } + + encode operation = CJ.encode packageSetOperationRepCodec case operation of + PackageSetUpdate update -> + { expectedBaseline: Nothing, compiler: update.compiler, packages: update.packages } + PackageSetUpdateFrom version update -> + { expectedBaseline: Just version, compiler: update.compiler, packages: update.packages } + + packageSetOperationRepCodec + :: CJ.Codec + { expectedBaseline :: Maybe Version + , compiler :: Maybe Version + , packages :: Map PackageName (Maybe Version) + } + packageSetOperationRepCodec = CJ.Record.object + { expectedBaseline: CJ.Record.optional Version.codec + , compiler: CJ.Record.optional Version.codec + , packages: Internal.Codec.packageMap (CJ.Common.nullable Version.codec) + } + +-- | Retrieve the compiler and package changes from a package set operation. +packageSetUpdateData :: PackageSetOperation -> PackageSetUpdateData +packageSetUpdateData = case _ of + PackageSetUpdate update -> update + PackageSetUpdateFrom _ update -> update + +-- | Retrieve the expected latest package set version, when the operation is +-- | bound to a baseline. +packageSetUpdateExpectedBaseline :: PackageSetOperation -> Maybe Version +packageSetUpdateExpectedBaseline = case _ of + PackageSetUpdate _ -> Nothing + PackageSetUpdateFrom version _ -> Just version -- | Submit a batch update to the most recent package set. -- | @@ -222,7 +263,8 @@ type PackageSetUpdateData = , packages :: Map PackageName (Maybe Version) } --- | A codec for encoding and decoding a `PackageSetUpdate` operation as JSON. +-- | A backwards-compatible codec for unbound `PackageSetUpdate` data. Use +-- | `packageSetOperationCodec` to encode or decode an `expectedBaseline`. packageSetUpdateCodec :: CJ.Codec PackageSetUpdateData packageSetUpdateCodec = CJ.named "PackageSetUpdate" $ CJ.Record.object { compiler: CJ.Record.optional Version.codec diff --git a/lib/test/Registry/Operation.purs b/lib/test/Registry/Operation.purs index 1400e70ee..f7041ed32 100644 --- a/lib/test/Registry/Operation.purs +++ b/lib/test/Registry/Operation.purs @@ -15,6 +15,13 @@ spec = do , { label: "update-full", value: fullPackageSetUpdate } ] + Spec.it "Round-trips package set operations with and without an expected baseline" do + Assert.shouldRoundTrip "Package Set Operation" Operation.packageSetOperationCodec + [ { label: "update-unbound-minimal", value: minimalPackageSetUpdate } + , { label: "update-unbound-full", value: fullPackageSetUpdate } + , { label: "update-baseline-bound", value: baselineBoundPackageSetUpdate } + ] + Spec.it "Round-trips publish fixtures" do Assert.shouldRoundTrip "Publish" Operation.publishCodec [ { label: "publish-minimal", value: minimalPublish } @@ -48,6 +55,17 @@ fullPackageSetUpdate = } }""" +baselineBoundPackageSetUpdate :: String +baselineBoundPackageSetUpdate = + """ +{ + "expectedBaseline": "68.1.1", + "packages": { + "aff": "9.0.0", + "argonaut": "10.0.0" + } +}""" + minimalPublish :: String minimalPublish = """ diff --git a/nix/overlay.nix b/nix/overlay.nix index 54fa965ea..c344a5785 100644 --- a/nix/overlay.nix +++ b/nix/overlay.nix @@ -62,6 +62,10 @@ let module = "Registry.Scripts.PackageTransferrer"; description = "Check for moved packages and submit transfer jobs"; }; + version-check = { + module = "Registry.Scripts.VersionCheck"; + description = "Report registry versions pending a package set update"; + }; verify-integrity = { module = "Registry.Scripts.VerifyIntegrity"; description = "Verify registry and registry-index consistency"; diff --git a/scripts/spago.yaml b/scripts/spago.yaml index a3bdb19f1..f67158722 100644 --- a/scripts/spago.yaml +++ b/scripts/spago.yaml @@ -14,6 +14,7 @@ package: - fetch - foldable-traversable - formatters + - integers - json - node-fs - node-path @@ -25,3 +26,9 @@ package: - registry-lib - run - strings + test: + main: Test.Registry.Scripts.Main + dependencies: + - registry-test-utils + - spec + - spec-node diff --git a/scripts/src/PackageSetPlanner.purs b/scripts/src/PackageSetPlanner.purs new file mode 100644 index 000000000..9ee5ae922 --- /dev/null +++ b/scripts/src/PackageSetPlanner.purs @@ -0,0 +1,762 @@ +-- | Compile-guided planning for package set updates. +-- | +-- | The planner first tries every latest candidate together. If that fails, +-- | manifest dependency *names* split candidates into interaction components; +-- | declared ranges never decide eligibility. Each component is searched +-- | best-first over latest, intermediate, and current choices, preferring more +-- | upgrades and then fresher versions. A failed node branches by stepping one +-- | package to its next choice. Component results are combined best-first, and +-- | every returned automatic payload receives a final exact whole-set compile. +-- | +-- | Both searches have strict probe budgets. Exhausting one marks the result +-- | truncated (possibly non-maximal), but never verified unless its exact +-- | payload compiled. Residual latest updates are probed for the manual lane; +-- | compiler source paths seed reverse-dependency removal closure, and a +-- | failed removal probe can add newly exposed blockers and their reverse +-- | dependants. A removal is called verified only after that exact payload +-- | compiles. +-- | Infrastructure failures are kept separate from compiler incompatibility. +module Registry.Scripts.PackageSetPlanner where + +import Registry.App.Prelude + +import Data.Array as Array +import Data.Foldable as Foldable +import Data.Map as Map +import Data.Set as Set +import Data.String as String +import Registry.App.Effect.PackageSets (PACKAGE_SETS) +import Registry.App.Effect.PackageSets as PackageSets +import Registry.Manifest (Manifest(..)) +import Registry.ManifestIndex (ManifestIndex) +import Registry.ManifestIndex as ManifestIndex +import Registry.Metadata (Metadata(..)) +import Registry.PackageName (PackageName) +import Registry.PackageName as PackageName +import Registry.PackageSet (PackageSet(..)) +import Registry.Version (Version) +import Run (Run) +import Run.Except (EXCEPT) +import Run.Except as Except + +type Candidate = + { current :: Maybe Version + , name :: PackageName + , versions :: Array Version + } + +type Verification = + { error :: Maybe String + , status :: String + } + +type AutomaticPlan = + { attempts :: Int + , packages :: Map PackageName Version + , searchTruncated :: Boolean + , verification :: Verification + } + +type ManualIntervention = + { compilerError :: Maybe String + , directBlockers :: Array PackageName + , packages :: Map PackageName Version + , removals :: Array PackageName + , targets :: Array PackageName + , verification :: Verification + } + +type Plan = + { automatic :: AutomaticPlan + , manualError :: Maybe String + , manualInterventions :: Array ManualIntervention + , manualSearchTruncated :: Boolean + } + +data ProbeResult + = Compiles + | CompilationFailure String + | InfrastructureFailure String + +derive instance Eq ProbeResult + +data ManualRemovalResult + = RemovalVerified Int (Set PackageName) (Set PackageName) (Array String) + | RemovalFailed Int (Set PackageName) (Set PackageName) (Array String) + | RemovalAnalysisFailed Int String + | RemovalSearchTruncated Int + +type Probe r = PackageSet -> PackageSets.ChangeSet -> Run r ProbeResult + +automaticProbeBudget :: Int +automaticProbeBudget = 64 + +componentProbeBudget :: Int +componentProbeBudget = 12 + +aggregateProbeReserve :: Int +aggregateProbeReserve = 8 + +manualProbeBudget :: Int +manualProbeBudget = 32 + +-- | All newer published versions remain available to the planner. Compiler +-- | metadata and manifest ranges are deliberately not eligibility filters. +existingPackageCandidates :: PackageSet -> Map PackageName Metadata -> Array Candidate +existingPackageCandidates (PackageSet packageSet) metadata = Array.mapMaybe toCandidate (Map.toUnfoldable packageSet.packages) + where + toCandidate (Tuple name current) = do + Metadata packageMetadata <- Map.lookup name metadata + let versions = packageMetadata.published # Map.keys # Array.fromFoldable # Array.filter (_ > current) # Array.sort # Array.reverse + guard $ not (Array.null versions) + pure { current: Just current, name, versions } + +-- | Turn a latest-only batch (including recent additions) into planner input. +candidatesFromLatest :: PackageSet -> Map PackageName Version -> Array Candidate +candidatesFromLatest (PackageSet packageSet) latest = do + Tuple name version <- Map.toUnfoldable latest + let current = Map.lookup name packageSet.packages + guard $ maybe true (_ < version) current + pure { current, name, versions: [ version ] } + +planPackageSet + :: forall r + . PackageSet + -> ManifestIndex + -> Array Candidate + -> Run (PACKAGE_SETS + EXCEPT String + r) Plan +planPackageSet = planPackageSetWith probeAtomic + +planAutomatic + :: forall r + . PackageSet + -> ManifestIndex + -> Array Candidate + -> Run (PACKAGE_SETS + EXCEPT String + r) AutomaticPlan +planAutomatic packageSet manifests candidates = _.automatic <$> planAutomaticWith probeAtomic packageSet manifests candidates + +probeAtomic + :: forall r + . Probe (PACKAGE_SETS + EXCEPT String + r) +probeAtomic packageSet changes = + Except.runExcept (PackageSets.upgradeAtomic packageSet (un PackageSet packageSet).compiler changes) >>= case _ of + Left error -> pure $ InfrastructureFailure error + Right (Left error) -> pure $ CompilationFailure error + Right (Right _) -> pure Compiles + +planPackageSetWith + :: forall r + . Probe r + -> PackageSet + -> ManifestIndex + -> Array Candidate + -> Run r Plan +planPackageSetWith probe packageSet manifests candidates = do + let checkedProbe = selfContainedProbe manifests probe + automaticResult <- planAutomaticWithChecked checkedProbe packageSet manifests candidates + let automatic = automaticResult.automatic + manual <- + if automatic.verification.status == "infrastructure-failed" then + pure emptyManualState + else + planManualInterventions checkedProbe packageSet manifests automaticResult.components automatic + pure + { automatic + , manualError: manual.error + , manualInterventions: manual.interventions + , manualSearchTruncated: manual.truncated + } + +type AutomaticResult = + { automatic :: AutomaticPlan + , components :: Array (Array Candidate) + } + +type ComponentPlan = + { packages :: Map PackageName Version } + +planAutomaticWith + :: forall r + . Probe r + -> PackageSet + -> ManifestIndex + -> Array Candidate + -> Run r AutomaticResult +planAutomaticWith probe packageSet manifests candidates = + planAutomaticWithChecked (selfContainedProbe manifests probe) packageSet manifests candidates + +planAutomaticWithChecked + :: forall r + . Probe r + -> PackageSet + -> ManifestIndex + -> Array Candidate + -> Run r AutomaticResult +planAutomaticWithChecked probe packageSet manifests candidates + | Just error <- validateCandidates packageSet candidates = pure + { automatic: + { attempts: 0 + , packages: Map.empty + , searchTruncated: false + , verification: { error: Just error, status: "infrastructure-failed" } + } + , components: [] + } + | Array.null candidates = pure + { automatic: + { attempts: 0 + , packages: Map.empty + , searchTruncated: false + , verification: { error: Nothing, status: "not-needed" } + } + , components: [] + } + | otherwise = do + let latest = latestUpdates candidates + probe packageSet (map PackageSets.Update latest) >>= case _ of + Compiles -> pure + { automatic: + { attempts: 1 + , packages: latest + , searchTruncated: false + , verification: { error: Nothing, status: "verified" } + } + , components: interactionComponents packageSet manifests candidates + } + InfrastructureFailure error -> pure + { automatic: + { attempts: 1 + , packages: Map.empty + , searchTruncated: false + , verification: { error: Just error, status: "infrastructure-failed" } + } + , components: interactionComponents packageSet manifests candidates + } + CompilationFailure _ -> do + let components = interactionComponents packageSet manifests candidates + searched <- searchComponents probe packageSet components + let nonemptyPlans = Array.filter (not <<< Map.isEmpty <<< _.packages) searched.plans + if Array.null nonemptyPlans then do + let + verification = + if searched.truncated then + { error: Just "The bounded compatibility search was truncated; no automatic payload is submission-ready." + , status: "incomplete" + } + else { error: searched.error, status: maybe "not-needed" (const "infrastructure-failed") searched.error } + pure + { automatic: + { attempts: 1 + searched.attempts + , packages: Map.empty + , searchTruncated: searched.truncated + , verification + } + , components + } + else case searched.error of + Just error -> pure + { automatic: + { attempts: 1 + searched.attempts + , packages: Map.empty + , searchTruncated: searched.truncated + , verification: { error: Just error, status: "infrastructure-failed" } + } + , components + } + Nothing -> do + let remaining = automaticProbeBudget - 1 - searched.attempts + aggregate <- searchAggregate probe packageSet nonemptyPlans remaining + let truncated = searched.truncated || aggregate.truncated + pure + { automatic: + { attempts: 1 + searched.attempts + aggregate.attempts + , packages: aggregate.packages + , searchTruncated: truncated + -- Search truncation limits optimality, not correctness: a + -- nonempty aggregate is returned only after this exact + -- whole-set payload compiled successfully. + , verification: aggregate.verification + } + , components + } + +-- | Package sets ignore dependency ranges, but every selected manifest must +-- | have all of its dependency names in the exact selected package map. Reject +-- | malformed search nodes as compatibility failures before invoking the +-- | compiler so validation errors can never be mistaken for infrastructure +-- | failures or returned as verified payloads. +selfContainedProbe :: forall r. ManifestIndex -> Probe r -> Probe r +selfContainedProbe manifests probe packageSet@(PackageSet baseline) changes = + case packageSelectionError manifests baseline.packages of + Just error -> pure $ InfrastructureFailure $ "The current package set is not dependency-name self-contained: " <> error + Nothing -> case packageSelectionError manifests (applyChanges baseline.packages changes) of + Just error -> pure $ CompilationFailure $ "The proposed package set is not dependency-name self-contained: " <> error + Nothing -> probe packageSet changes + +applyChanges :: Map PackageName Version -> PackageSets.ChangeSet -> Map PackageName Version +applyChanges packages changes = foldlWithIndex applyChange packages changes + where + applyChange name selected change = case change of + PackageSets.Remove -> Map.delete name selected + PackageSets.Update version -> Map.insert name version selected + +packageSelectionError :: ManifestIndex -> Map PackageName Version -> Maybe String +packageSelectionError manifests selected = Array.head failures + where + failures = Array.mapMaybe checkManifest (Map.toUnfoldable selected) + + checkManifest (Tuple name version) = case ManifestIndex.lookup name version manifests of + Nothing -> Just $ "No manifest exists for selected package " <> formatPackageVersion name version <> "." + Just (Manifest manifest) -> do + missing <- Set.findMin $ Set.difference (Map.keys manifest.dependencies) (Map.keys selected) + pure $ formatPackageVersion name version <> " requires missing package " <> PackageName.print missing <> "." + +-- | Reject malformed caller input before any compile probe. The automatic +-- | representation is upgrade/add-only, so existing choices must be strictly +-- | newer and every package has a nonempty, unique domain. +validateCandidates :: PackageSet -> Array Candidate -> Maybe String +validateCandidates (PackageSet packageSet) candidates = do + let names = map _.name candidates + let + invalidCurrent candidate = case Map.lookup candidate.name packageSet.packages of + Nothing -> isJust candidate.current + Just current -> candidate.current /= Just current || any (_ <= current) candidate.versions + if Array.length names /= Set.size (Set.fromFoldable names) then Just "Planner candidates contain duplicate package names." + else if any (Array.null <<< _.versions) candidates then Just "Planner candidate domains must not be empty." + else if any invalidCurrent candidates then Just "Existing-package candidate choices must all be strictly newer than the current version." + else Nothing + +type ComponentSearches = + { attempts :: Int + , error :: Maybe String + , plans :: Array ComponentPlan + , truncated :: Boolean + } + +searchComponents + :: forall r + . Probe r + -> PackageSet + -> Array (Array Candidate) + -> Run r ComponentSearches +searchComponents probe packageSet = go + { attempts: 0 + , error: Nothing + , plans: [] + , truncated: false + } + where + go state remaining = case Array.uncons remaining of + Nothing -> pure state + Just { head: component, tail: rest } + | isJust state.error -> pure state + | otherwise -> do + let globallyAvailable = automaticProbeBudget - 1 - aggregateProbeReserve - state.attempts + let available = min componentProbeBudget (max 0 globallyAvailable) + if available <= 0 then + pure $ state + { plans = state.plans <> map (const { packages: Map.empty }) remaining + , truncated = true + } + else do + result <- searchCandidates probe packageSet component available + let + next = state + { attempts = state.attempts + result.attempts + , error = result.infrastructureError + , plans = state.plans <> [ { packages: result.packages } ] + , truncated = state.truncated || result.truncated + } + go next rest + +type CandidateSearch = + { attempts :: Int + , infrastructureError :: Maybe String + , packages :: Map PackageName Version + , truncated :: Boolean + } + +type SearchNode = Array Int + +searchCandidates + :: forall r + . Probe r + -> PackageSet + -> Array Candidate + -> Int + -> Run r CandidateSearch +searchCandidates probe packageSet candidates budget = go [ initial ] (Set.singleton (nodeKey initial)) 0 + where + initial = map (const 0) candidates + + go frontier seen attempts + | attempts >= budget = pure + { attempts + , infrastructureError: Nothing + , packages: Map.empty + , truncated: not (Array.null frontier) + } + | otherwise = case Array.uncons (Array.sortBy (compareNodes candidates) frontier) of + Nothing -> pure + { attempts + , infrastructureError: Nothing + , packages: Map.empty + , truncated: false + } + Just { head: node, tail } -> do + let packages = nodeUpdates candidates node + if Map.isEmpty packages then + pure { attempts, infrastructureError: Nothing, packages: Map.empty, truncated: false } + else + probe packageSet (map PackageSets.Update packages) >>= case _ of + Compiles -> pure { attempts: attempts + 1, infrastructureError: Nothing, packages, truncated: false } + InfrastructureFailure error -> pure + { attempts: attempts + 1 + , infrastructureError: Just error + , packages: Map.empty + , truncated: false + } + CompilationFailure _ -> do + let additions = Array.filter (nodeKey >>> flip (not Set.member) seen) (nodeNeighbours candidates node) + let nextSeen = Foldable.foldl (flip (Set.insert <<< nodeKey)) seen additions + go (tail <> additions) nextSeen (attempts + 1) + +type AggregateSearch = + { attempts :: Int + , packages :: Map PackageName Version + , truncated :: Boolean + , verification :: Verification + } + +searchAggregate + :: forall r + . Probe r + -> PackageSet + -> Array ComponentPlan + -> Int + -> Run r AggregateSearch +searchAggregate probe packageSet plans budget = go [ initial ] (Set.singleton (nodeKey initial)) 0 Nothing + where + initial = map (const 0) plans + + go frontier seen attempts lastError + | attempts >= budget = pure + { attempts + , packages: Map.empty + , truncated: not (Array.null frontier) + , verification: { error: lastError, status: "failed" } + } + | otherwise = case Array.uncons (Array.sortBy compareAggregateNodes frontier) of + Nothing -> pure + { attempts + , packages: Map.empty + , truncated: false + , verification: { error: lastError, status: "failed" } + } + Just { head: node, tail } -> do + let packages = aggregateUpdates plans node + if Map.isEmpty packages then + pure + { attempts + , packages: Map.empty + , truncated: false + , verification: { error: Nothing, status: "not-needed" } + } + else + probe packageSet (map PackageSets.Update packages) >>= case _ of + Compiles -> pure + { attempts: attempts + 1 + , packages + , truncated: false + , verification: { error: Nothing, status: "verified" } + } + InfrastructureFailure error -> pure + { attempts: attempts + 1 + , packages: Map.empty + , truncated: false + , verification: { error: Just error, status: "infrastructure-failed" } + } + CompilationFailure error -> do + let additions = Array.filter (nodeKey >>> flip (not Set.member) seen) (aggregateNeighbours node) + let nextSeen = Foldable.foldl (flip (Set.insert <<< nodeKey)) seen additions + go (tail <> additions) nextSeen (attempts + 1) (Just error) + + compareAggregateNodes a b = compare (aggregateScore plans b) (aggregateScore plans a) + +type ManualState = + { attempts :: Int + , error :: Maybe String + , interventions :: Array ManualIntervention + , truncated :: Boolean + } + +emptyManualState :: ManualState +emptyManualState = + { attempts: 0 + , error: Nothing + , interventions: [] + , truncated: false + } + +planManualInterventions + :: forall r + . Probe r + -> PackageSet + -> ManifestIndex + -> Array (Array Candidate) + -> AutomaticPlan + -> Run r ManualState +planManualInterventions probe packageSet manifests components automatic = go emptyManualState residual + where + residual = Array.mapMaybe residualComponent components + + residualComponent component = do + let latest = latestUpdates component + guard $ any (\(Tuple name version) -> Map.lookup name automatic.packages /= Just version) (Map.toUnfoldable latest :: Array _) + pure latest + + go state remaining = case Array.uncons remaining of + Nothing -> pure state + Just { head: latest, tail: rest } + | state.attempts >= manualProbeBudget -> pure $ state { truncated = true } + | otherwise -> do + let packages = Map.union latest automatic.packages + let changes = map PackageSets.Update packages + probe packageSet changes >>= case _ of + Compiles -> + go (state { attempts = state.attempts + 1 }) rest + InfrastructureFailure error -> + pure $ state + { attempts = state.attempts + 1 + , error = Just error + } + CompilationFailure compilerError -> do + let seeds = compilerFailurePackages packageSet packages compilerError + let proposed = applyUpdates packageSet packages + case reverseDependencyClosure proposed manifests seeds of + Left error -> pure $ state + { attempts = state.attempts + 1 + , error = Just error + } + Right closure -> do + let removals = Set.difference closure (Map.keys packages) + if Set.isEmpty removals then + go + ( state + { attempts = state.attempts + 1 + , interventions = state.interventions <> + [ { compilerError: Just compilerError + , directBlockers: Array.fromFoldable seeds + , packages + , removals: [] + , targets: Array.fromFoldable $ Map.keys latest + , verification: + { error: Just "The compiler failure did not identify an unchanged package with a removable reverse-dependency closure." + , status: "unresolved" + } + } + ] + } + ) + rest + else do + probeManualRemovals probe packageSet manifests packages seeds removals (state.attempts + 1) >>= case _ of + RemovalVerified attempts directBlockers verifiedRemovals additionalEvidence -> + go + ( state + { attempts = attempts + , interventions = state.interventions <> + [ { compilerError: Just $ combineCompilerEvidence compilerError additionalEvidence + , directBlockers: Array.fromFoldable directBlockers + , packages + , removals: Array.fromFoldable verifiedRemovals + , targets: Array.fromFoldable $ Map.keys latest + , verification: { error: Nothing, status: "verified" } + } + ] + } + ) + rest + RemovalFailed attempts directBlockers failedRemovals additionalEvidence -> + go + ( state + { attempts = attempts + , interventions = state.interventions <> + [ { compilerError: Just $ combineCompilerEvidence compilerError additionalEvidence + , directBlockers: Array.fromFoldable directBlockers + , packages + , removals: Array.fromFoldable failedRemovals + , targets: Array.fromFoldable $ Map.keys latest + , verification: { error: Array.last additionalEvidence, status: "failed" } + } + ] + } + ) + rest + RemovalAnalysisFailed attempts error -> + pure $ state + { attempts = attempts + , error = Just error + } + RemovalSearchTruncated attempts -> + pure $ state + { attempts = attempts + , truncated = true + } + +probeManualRemovals + :: forall r + . Probe r + -> PackageSet + -> ManifestIndex + -> Map PackageName Version + -> Set PackageName + -> Set PackageName + -> Int + -> Run r ManualRemovalResult +probeManualRemovals probe packageSet manifests packages = go [] + where + proposed = applyUpdates packageSet packages + + go evidence directBlockers removals attempts + | attempts >= manualProbeBudget = pure $ RemovalSearchTruncated attempts + | otherwise = do + let changes = map PackageSets.Update packages + let removalChanges = Map.union (map (const PackageSets.Remove) (Map.fromFoldable (map (\name -> Tuple name unit) (Array.fromFoldable removals)))) changes + probe packageSet removalChanges >>= case _ of + Compiles -> pure $ RemovalVerified (attempts + 1) directBlockers removals evidence + InfrastructureFailure error -> pure $ RemovalAnalysisFailed (attempts + 1) error + CompilationFailure error -> do + let nextEvidence = evidence <> [ error ] + let remaining = Foldable.foldr Map.delete proposed removals + let seeds = compilerFailurePackages packageSet packages error + let nextDirectBlockers = Set.union directBlockers seeds + case reverseDependencyClosure remaining manifests seeds of + Left analysisError -> pure $ RemovalAnalysisFailed (attempts + 1) analysisError + Right closure -> do + let additions = Set.difference closure (Map.keys packages) + let next = Set.union removals additions + if next == removals then + pure $ RemovalFailed (attempts + 1) nextDirectBlockers removals nextEvidence + else + go nextEvidence nextDirectBlockers next (attempts + 1) + +combineCompilerEvidence :: String -> Array String -> String +combineCompilerEvidence initial additional = + String.joinWith "\n\n--- Next compile probe exposed another blocker ---\n\n" ([ initial ] <> additional) + +latestUpdates :: Array Candidate -> Map PackageName Version +latestUpdates = Map.fromFoldable <<< Array.mapMaybe \candidate -> Tuple candidate.name <$> Array.head candidate.versions + +candidateChoices :: Candidate -> Array (Maybe Version) +candidateChoices candidate = map Just candidate.versions <> [ candidate.current ] + +nodeUpdates :: Array Candidate -> SearchNode -> Map PackageName Version +nodeUpdates candidates node = Map.fromFoldable $ Array.mapMaybe identity do + Tuple candidate offset <- Array.zip candidates node + pure do + selected <- Array.index (candidateChoices candidate) offset >>= identity + guard $ candidate.current /= Just selected + pure $ Tuple candidate.name selected + +nodeNeighbours :: Array Candidate -> SearchNode -> Array SearchNode +nodeNeighbours candidates node = Array.catMaybes $ Array.mapWithIndex step node + where + step index offset = do + candidate <- Array.index candidates index + guard $ offset + 1 < Array.length (candidateChoices candidate) + Array.modifyAt index (_ + 1) node + +compareNodes :: Array Candidate -> SearchNode -> SearchNode -> Ordering +compareNodes candidates a b = compare (nodeScore candidates b) (nodeScore candidates a) + +nodeScore :: Array Candidate -> SearchNode -> Tuple Int Int +nodeScore candidates node = Foldable.foldl add (Tuple 0 0) (Array.zip candidates node) + where + add (Tuple upgrades freshness) (Tuple candidate offset) = case Array.index (candidateChoices candidate) offset of + Just (Just selected) | candidate.current /= Just selected -> Tuple (upgrades + 1) (freshness + Array.length candidate.versions - offset) + _ -> Tuple upgrades freshness + +nodeKey :: SearchNode -> String +nodeKey = String.joinWith "," <<< map show + +aggregateUpdates :: Array ComponentPlan -> SearchNode -> Map PackageName Version +aggregateUpdates plans node = Foldable.foldl Map.union Map.empty do + Tuple plan offset <- Array.zip plans node + [ if offset == 0 then plan.packages else Map.empty ] + +aggregateNeighbours :: SearchNode -> Array SearchNode +aggregateNeighbours node = Array.catMaybes $ Array.mapWithIndex step node + where + step index offset = do + guard $ offset == 0 + Array.modifyAt index (const 1) node + +aggregateScore :: Array ComponentPlan -> SearchNode -> Int +aggregateScore plans node = Foldable.sum do + Tuple plan offset <- Array.zip plans node + [ if offset == 0 then Map.size plan.packages else 0 ] + +interactionComponents :: PackageSet -> ManifestIndex -> Array Candidate -> Array (Array Candidate) +interactionComponents (PackageSet packageSet) manifests candidates = map candidatesInSet (setsFromGraph graph candidateNames) + where + candidateNames = Set.fromFoldable (map _.name candidates) + candidateMap = Map.fromFoldable $ candidates <#> \candidate -> Tuple candidate.name candidate + relevantManifests = Array.catMaybes do + candidate <- candidates + version <- Array.catMaybes ([ candidate.current ] <> map Just candidate.versions) + [ ManifestIndex.lookup candidate.name version manifests ] + baselineManifests = Array.mapMaybe (\(Tuple name version) -> ManifestIndex.lookup name version manifests) (Map.toUnfoldable packageSet.packages) + graph = Foldable.foldl addManifest (Map.fromFoldable $ map (\name -> Tuple name Set.empty) (Array.fromFoldable candidateNames)) (baselineManifests <> relevantManifests) + + addManifest edges (Manifest manifest) = do + let mentioned = Set.intersection candidateNames (Set.insert manifest.name (Map.keys manifest.dependencies)) + mentioned # Foldable.foldl + (\next name -> Map.alter (Just <<< Set.union (Set.delete name mentioned) <<< fromMaybe Set.empty) name next) + edges + + candidatesInSet names = Array.mapMaybe (flip Map.lookup candidateMap) (Array.fromFoldable names) + +setsFromGraph :: Map PackageName (Set PackageName) -> Set PackageName -> Array (Set PackageName) +setsFromGraph graph = go [] + where + go components remaining = case Set.findMin remaining of + Nothing -> components + Just seed -> do + let component = visit Set.empty [ seed ] + go (components <> [ component ]) (Set.difference remaining component) + + visit seen frontier = case Array.uncons frontier of + Nothing -> seen + Just { head: name, tail: rest } + | Set.member name seen -> visit seen rest + | otherwise -> do + let neighbours = Array.fromFoldable $ fromMaybe Set.empty $ Map.lookup name graph + visit (Set.insert name seen) (rest <> neighbours) + +compilerFailurePackages :: PackageSet -> Map PackageName Version -> String -> Set PackageName +compilerFailurePackages (PackageSet packageSet) updates error = Set.fromFoldable $ Array.mapMaybe match (Map.toUnfoldable packageSet.packages) + where + fileLines = Array.filter (String.contains (String.Pattern "File:")) (String.split (String.Pattern "\n") error) + + match (Tuple name version) = do + guard $ not (Map.member name updates) + let path = "packages/" <> formatPackageVersion name version <> "/" + name <$ guard (any (String.contains (String.Pattern path)) fileLines) + +applyUpdates :: PackageSet -> Map PackageName Version -> Map PackageName Version +applyUpdates (PackageSet packageSet) updates = Map.union updates packageSet.packages + +reverseDependencyClosure :: Map PackageName Version -> ManifestIndex -> Set PackageName -> Either String (Set PackageName) +reverseDependencyClosure packages manifests = go + where + go removals = do + dependants <- Set.fromFoldable <<< Array.catMaybes <$> traverse (dependsOn removals) (Map.toUnfoldable packages) + let next = Set.union removals dependants + if next == removals then pure removals else go next + + dependsOn removals (Tuple name version) = do + if Set.member name removals then pure Nothing + else case ManifestIndex.lookup name version manifests of + Nothing -> Left $ "Missing manifest while computing removal closure: " <> formatPackageVersion name version + Just (Manifest manifest) -> pure $ name <$ guard (not $ Set.isEmpty $ Set.intersection removals $ Map.keys manifest.dependencies) diff --git a/scripts/src/PackageSetUpdater.purs b/scripts/src/PackageSetUpdater.purs index d1f833702..83f54666a 100644 --- a/scripts/src/PackageSetUpdater.purs +++ b/scripts/src/PackageSetUpdater.purs @@ -17,6 +17,7 @@ import Codec.JSON.DecodeError as CJ.DecodeError import Data.Array as Array import Data.Codec.JSON as CJ import Data.DateTime as DateTime +import Data.Foldable as Foldable import Data.Map as Map import Data.Time.Duration (Hours(..)) import Effect.Aff as Aff @@ -24,20 +25,31 @@ import Effect.Class.Console as Console import Fetch (Method(..)) import Fetch as Fetch import JSON as JSON +import Node.Path as Path import Node.Process as Process import Registry.API.V1 as V1 import Registry.App.CLI.Git as Git import Registry.App.Effect.Cache as Cache +import Registry.App.Effect.Env (RESOURCE_ENV) import Registry.App.Effect.Env as Env import Registry.App.Effect.Log (LOG) import Registry.App.Effect.Log as Log +import Registry.App.Effect.PackageSets (PACKAGE_SETS) import Registry.App.Effect.PackageSets as PackageSets import Registry.App.Effect.Registry (REGISTRY_READ) import Registry.App.Effect.Registry as Registry +import Registry.App.Effect.Storage (STORAGE) +import Registry.App.Effect.Storage as Storage +import Registry.Foreign.FSExtra as FS.Extra +import Registry.Manifest (Manifest(..)) +import Registry.ManifestIndex (ManifestIndex) +import Registry.ManifestIndex as ManifestIndex +import Registry.Metadata (Metadata(..)) import Registry.Operation (PackageSetOperation(..)) import Registry.Operation as Operation import Registry.PackageName as PackageName import Registry.PackageSet (PackageSet(..)) +import Registry.Scripts.PackageSetPlanner as Planner import Registry.Version as Version import Run (AFF, EFFECT, Run) import Run as Run @@ -48,6 +60,13 @@ data Mode = DryRun | Submit derive instance Eq Mode +-- | Which registry releases should be considered for a package set update. +-- | `AllPending` only reports upgrades to packages already in the set; adding +-- | packages that have never appeared in a package set is a separate concern. +data CandidateSelection + = RecentUploads DateTime.DateTime Hours + | AllPending + parser :: ArgParser Mode parser = Arg.choose "command" [ Arg.flag [ "dry-run" ] @@ -70,6 +89,8 @@ main = launchAff_ do Env.loadEnvFile ".env" resourceEnv <- Env.lookupResourceEnv + let cache = Path.concat [ scratchDir, ".cache" ] + FS.Extra.ensureDirectory cache registryCacheRef <- Cache.newCacheRef debouncer <- Registry.newDebouncer @@ -87,8 +108,11 @@ main = launchAff_ do } runPackageSetUpdater mode resourceEnv.registryApiUrl + # PackageSets.interpret (PackageSets.handle { workdir: scratchDir }) # Except.runExcept # Registry.interpretRead (Registry.handleRead registryEnv) + # Storage.interpret (Storage.handleReadOnly cache) + # Env.runResourceEnv resourceEnv # Log.interpret (Log.handleTerminal Normal) # Run.runBaseAff' >>= case _ of @@ -97,7 +121,7 @@ main = launchAff_ do liftEffect $ Process.exit' 1 Right _ -> pure unit -type PackageSetUpdaterEffects = (REGISTRY_READ + LOG + EXCEPT String + AFF + EFFECT + ()) +type PackageSetUpdaterEffects = (REGISTRY_READ + PACKAGE_SETS + STORAGE + RESOURCE_ENV + LOG + EXCEPT String + AFF + EFFECT + ()) runPackageSetUpdater :: Mode -> URL -> Run PackageSetUpdaterEffects Unit runPackageSetUpdater mode registryApiUrl = do @@ -111,87 +135,154 @@ runPackageSetUpdater mode registryApiUrl = do Just set -> pure (Just set) for_ latestPackageSet \packageSet -> do - let currentPackages = (un PackageSet packageSet).packages - -- Find packages uploaded in the last 24 hours - recentUploads <- findRecentUploads (Hours 24.0) - let - -- Filter out packages already in the set at the same or newer version - newOrUpdated = recentUploads # Map.filterWithKey \name version -> - case Map.lookup name currentPackages of - Nothing -> true -- new package - Just currentVersion -> version > currentVersion -- upgrade - - if Map.isEmpty newOrUpdated then - Log.info "No new packages for package set update." + now <- nowUTC + metadata <- Registry.readAllMetadata + let newOrUpdated = selectPackageSetCandidates (RecentUploads now (Hours 24.0)) packageSet metadata + + Log.info $ "Found " <> show (Map.size newOrUpdated) <> " recent additions or upgrades" + manifestIndex <- Registry.readAllManifests + let candidates = plannerCandidates packageSet metadata manifestIndex newOrUpdated + if Array.null candidates then + Log.info "No package set candidates have usable manifests." else do - Log.info $ "Found " <> show (Map.size newOrUpdated) <> " candidates to validate" + Log.info $ "Compile-planning " <> show (Array.length candidates) <> " package domains" + plan <- Planner.planAutomatic packageSet manifestIndex candidates + Registry.readLatestPackageSet >>= case _ of + Nothing -> Log.warn "The latest package set disappeared before submission; skipping this run." + Just latest -> submitVerifiedPlan mode registryApiUrl packageSet latest plan + +-- | Submit only the exact, verified, nonempty, upgrade-only payload. We still +-- | filter stale and already-applied entries against the latest set, but refuse +-- | to submit if filtering changed the payload because that altered payload was +-- | not the one atomically compiled by the planner. +submitVerifiedPlan + :: forall r + . Mode + -> URL + -> PackageSet + -> PackageSet + -> Planner.AutomaticPlan + -> Run (LOG + EXCEPT String + AFF + r) Unit +submitVerifiedPlan mode registryApiUrl baseline latest plan = do + let applicable = filterApplicableUpgrades latest plan.packages + let samePackageSet = baseline == latest + if not samePackageSet then + Except.throw "The package set changed after planning; refusing to submit or report decisions without replanning." + else if plan.verification.status /= "verified" then + Log.warn $ "Package set plan is not verified (" <> plan.verification.status <> "); not submitting." + else if Map.isEmpty applicable then + Log.info "The verified package set plan is empty or already applied; nothing to submit." + else if applicable /= plan.packages then + Except.throw "Filtering changed the verified package set payload; refusing to submit an altered payload without replanning." + else do + let expectedBaseline = (un PackageSet baseline).version + let + payload :: Operation.PackageSetUpdateData + payload = + { compiler: Nothing + , packages: map Just applicable + } + operation = PackageSetUpdateFrom expectedBaseline payload + case mode of + DryRun -> do + Log.info "[DRY RUN] Would submit verified package set updates:" + for_ (Map.toUnfoldable applicable :: Array _) \(Tuple name version) -> + Log.info $ " - " <> PackageName.print name <> "@" <> Version.print version + Submit -> do + let + rawPayload = JSON.print $ CJ.encode Operation.packageSetOperationCodec operation - -- Pre-validate candidates to filter out packages with missing dependencies - manifestIndex <- Registry.readAllManifests - let candidates = PackageSets.validatePackageSetCandidates manifestIndex packageSet (map Just newOrUpdated) + request :: Operation.PackageSetUpdateRequest + request = + { payload: operation + , rawPayload + , signature: Nothing + } + Log.info "Submitting verified package set update..." + result <- Run.liftAff $ submitPackageSetJob (registryApiUrl <> "/v1/package-sets") request + case result of + Left err -> Except.throw $ "Failed to submit package set job: " <> err + Right { jobId } -> do + Log.info $ "Submitted package set job " <> unwrap jobId <> "; waiting for publication..." + Run.liftAff (pollPackageSetJob registryApiUrl jobId) >>= case _ of + Left err -> Except.throw err + Right _ -> Log.notice $ "Package set job " <> unwrap jobId <> " completed successfully." - unless (Map.isEmpty candidates.rejected) do - Log.info $ "Some packages are not eligible for the package set:\n" <> PackageSets.printRejections candidates.rejected +-- | Drop additions/upgrades that are equal to or older than the latest set. +filterApplicableUpgrades :: PackageSet -> Map PackageName Version -> Map PackageName Version +filterApplicableUpgrades (PackageSet packageSet) = Map.filterWithKey \name version -> + maybe true (_ < version) (Map.lookup name packageSet.packages) - -- Only include accepted packages (filter out removals, keep only updates) - let accepted = Map.catMaybes candidates.accepted +-- | Existing packages contribute every newer release. Recent uploads seed +-- | additions, which are expanded by absent dependency-name closure. Declared +-- | ranges and compiler publication metadata are deliberately not gates. +plannerCandidates :: PackageSet -> Map PackageName Metadata -> ManifestIndex -> Map PackageName Version -> Array Planner.Candidate +plannerCandidates packageSet@(PackageSet set) metadata manifests recent = + existingCandidates <> additionCandidates + where + existingCandidates = Array.mapMaybe withManifestVersions $ Planner.existingPackageCandidates packageSet metadata + existingDependencies = Array.concatMap (\candidate -> dependenciesOf (Tuple candidate.name candidate.versions)) existingCandidates + seeds = map Array.singleton $ Map.filterWithKey (\name _ -> not $ Map.member name set.packages) recent + additions = close seeds + additionCandidates = Map.toUnfoldable additions <#> \(Tuple name versions) -> + { current: Nothing, name, versions } - if Map.isEmpty accepted then - Log.info "No packages passed validation for package set update." - else do - Log.info $ "Validated " <> show (Map.size accepted) <> " packages for package set update" + withManifestVersions candidate = do + let versions = Array.filter (\version -> isJust $ ManifestIndex.lookup candidate.name version manifests) candidate.versions + candidate { versions = versions } <$ guard (not $ Array.null versions) - -- Create a package set update payload - let - payload :: Operation.PackageSetUpdateData - payload = - { compiler: Nothing -- Use current compiler - , packages: map Just accepted -- Just version = add/update - } + close selected = do + let dependencies = existingDependencies <> Array.concatMap dependenciesOf (Map.toUnfoldable selected) + let missing = Array.filter (\name -> not (Map.member name set.packages) && not (Map.member name selected)) dependencies + let next = Foldable.foldl addLatest selected missing + if next == selected then selected else close next + + dependenciesOf (Tuple name versions) = Array.concatMap dependenciesAt versions + where + dependenciesAt selected = case ManifestIndex.lookup name selected manifests of + Nothing -> [] + Just (Manifest manifest) -> Array.fromFoldable $ Map.keys manifest.dependencies + + addLatest selected name = case Map.lookup name metadata of + Nothing -> selected + Just (Metadata packageMetadata) -> do + let manifested = Array.filter (\version -> isJust $ ManifestIndex.lookup name version manifests) (Map.keys packageMetadata.published # Array.fromFoldable) # Array.sort # Array.reverse + if Array.null manifested then selected else Map.insert name manifested selected - case mode of - DryRun -> do - Log.info $ "[DRY RUN] Would submit package set update with packages:" - for_ (Map.toUnfoldable accepted :: Array _) \(Tuple name version) -> - Log.info $ " - " <> PackageName.print name <> "@" <> Version.print version - - Submit -> do - let - rawPayload = JSON.print $ CJ.encode Operation.packageSetUpdateCodec payload - - request :: Operation.PackageSetUpdateRequest - request = - { payload: PackageSetUpdate payload - , rawPayload - , signature: Nothing - } - - Log.info $ "Submitting package set update..." - result <- Run.liftAff $ submitPackageSetJob (registryApiUrl <> "/v1/package-sets") request - case result of - Left err -> do - Log.error $ "Failed to submit package set job: " <> err - Right { jobId } -> do - Log.info $ "Submitted package set job " <> unwrap jobId - --- | Find the latest version of each package uploaded within the time limit -findRecentUploads :: Hours -> Run PackageSetUpdaterEffects (Map PackageName Version) -findRecentUploads limit = do +-- | Find the latest eligible registry version for each package relative to the +-- | current package set. +findPackageSetCandidates + :: forall r + . CandidateSelection + -> PackageSet + -> Run (REGISTRY_READ + EXCEPT String + r) (Map PackageName Version) +findPackageSetCandidates selection packageSet = do allMetadata <- Registry.readAllMetadata - now <- nowUTC + pure $ selectPackageSetCandidates selection packageSet allMetadata +-- | Select package set candidates in one traversal of registry metadata. +selectPackageSetCandidates + :: CandidateSelection + -> PackageSet + -> Map PackageName Metadata + -> Map PackageName Version +selectPackageSetCandidates selection (PackageSet packageSet) = Map.mapMaybeWithKey \name (Metadata metadata) -> do let - getLatestRecentVersion :: Metadata -> Maybe Version - getLatestRecentVersion (Metadata metadata) = do - let - recentVersions = Array.catMaybes $ flip map (Map.toUnfoldable metadata.published) - \(Tuple version { publishedTime }) -> - if (DateTime.diff now publishedTime) <= limit then Just version else Nothing - Array.last $ Array.sort recentVersions - - pure $ Map.fromFoldable $ Array.catMaybes $ flip map (Map.toUnfoldable allMetadata) \(Tuple name metadata) -> - map (Tuple name) $ getLatestRecentVersion metadata + eligibleVersions = Array.mapMaybe + ( \(Tuple version { publishedTime }) -> case selection of + RecentUploads now limit + | DateTime.diff now publishedTime <= limit -> Just version + RecentUploads _ _ -> Nothing + AllPending -> Just version + ) + (Map.toUnfoldable metadata.published) + latestVersion <- Array.last $ Array.sort eligibleVersions + case Map.lookup name packageSet.packages of + Just currentVersion + | latestVersion > currentVersion -> Just latestVersion + Nothing | RecentUploads _ _ <- selection -> Just latestVersion + _ -> Nothing -- | Submit a package set job to the registry API submitPackageSetJob :: String -> Operation.PackageSetUpdateRequest -> Aff (Either String V1.JobCreatedResponse) @@ -212,3 +303,51 @@ submitPackageSetJob url request = do Right r -> pure $ Right r else pure $ Left $ "HTTP " <> show response.status <> ": " <> responseBody + +-- | Wait for the server-side exact recompile and publication to finish. The +-- | workflow must not report success merely because a durable job was queued. +pollPackageSetJob :: String -> V1.JobId -> Aff (Either String Unit) +pollPackageSetJob registryApiUrl jobId = go 1 0 + where + maxAttempts = 720 + maxConsecutiveErrors = 5 + interval = Aff.Milliseconds 5_000.0 + url = registryApiUrl <> "/v1/jobs/" <> unwrap jobId <> "?level=NOTICE" + + go attempt consecutiveErrors + | attempt > maxAttempts = + pure $ Left $ "Package set job " <> unwrap jobId <> " did not finish within 60 minutes." + | otherwise = do + result <- fetchPackageSetJob url + case result of + Left error + | consecutiveErrors + 1 >= maxConsecutiveErrors -> + pure $ Left $ "Could not poll package set job " <> unwrap jobId <> " after " <> show maxConsecutiveErrors <> " consecutive errors: " <> error + | otherwise -> do + Aff.delay interval + go (attempt + 1) (consecutiveErrors + 1) + Right job -> do + let info = V1.jobInfo job + case info.finishedAt of + Nothing -> do + Aff.delay interval + go (attempt + 1) 0 + Just _ | info.success -> + pure $ Right unit + Just _ -> do + let logs = Foldable.foldMap (\line -> "\n" <> line.message) info.logs + pure $ Left $ "Package set job " <> unwrap jobId <> " failed:" <> logs + +fetchPackageSetJob :: String -> Aff (Either String V1.Job) +fetchPackageSetJob url = do + result <- Aff.attempt $ Fetch.fetch url { method: GET } + case result of + Left err -> pure $ Left $ "Network error: " <> Aff.message err + Right response -> do + responseBody <- response.text + if response.status >= 200 && response.status < 300 then + case JSON.parse responseBody >>= \json -> lmap CJ.DecodeError.print (CJ.decode V1.jobCodec json) of + Left err -> pure $ Left $ "Failed to parse package set job: " <> err + Right job -> pure $ Right job + else + pure $ Left $ "HTTP " <> show response.status <> ": " <> responseBody diff --git a/scripts/src/VersionCheck.purs b/scripts/src/VersionCheck.purs new file mode 100644 index 000000000..598947c85 --- /dev/null +++ b/scripts/src/VersionCheck.purs @@ -0,0 +1,911 @@ +-- | Compile pending package versions with the exact current package set +-- | compiler, report an atomically verified automatic plan, and describe +-- | residual updates that need manual intervention. +-- | +-- | Dependency ranges are advisory diagnostics only. Package set compilation +-- | is the compatibility authority. +-- | +-- | Run via Nix: +-- | nix run .#version-check -- --output report.json --markdown report.md +module Registry.Scripts.VersionCheck where + +import Registry.App.Prelude + +import ArgParse.Basic (ArgParser) +import ArgParse.Basic as Arg +import Data.Array as Array +import Data.Codec.JSON as CJ +import Data.Codec.JSON.Common as CJ.Common +import Data.Codec.JSON.Record as CJ.Record +import Data.DateTime (DateTime) +import Data.DateTime as DateTime +import Data.Foldable as Foldable +import Data.Int as Int +import Data.Map as Map +import Data.Set as Set +import Data.String as String +import Data.Time.Duration (Days(..), Hours(..)) +import Effect.Aff as Aff +import Effect.Class.Console as Console +import JSON as JSON +import Node.FS.Aff as FS.Aff +import Node.Path as Path +import Node.Process as Process +import Registry.App.CLI.Git as Git +import Registry.App.Effect.Cache as Cache +import Registry.App.Effect.Env (RESOURCE_ENV) +import Registry.App.Effect.Env as Env +import Registry.App.Effect.Log (LOG) +import Registry.App.Effect.Log as Log +import Registry.App.Effect.PackageSets (PACKAGE_SETS) +import Registry.App.Effect.PackageSets as PackageSets +import Registry.App.Effect.Registry (REGISTRY_READ) +import Registry.App.Effect.Registry as Registry +import Registry.App.Effect.Storage (STORAGE) +import Registry.App.Effect.Storage as Storage +import Registry.App.Legacy.LenientVersion as LenientVersion +import Registry.Foreign.FSExtra as FS.Extra +import Registry.Foreign.Octokit (GitHubToken(..), Octokit) +import Registry.Foreign.Octokit as Octokit +import Registry.Internal.Codec as Internal.Codec +import Registry.Location (Location(..)) +import Registry.Manifest (Manifest(..)) +import Registry.ManifestIndex (ManifestIndex) +import Registry.ManifestIndex as ManifestIndex +import Registry.Metadata (Metadata(..)) +import Registry.Operation as Operation +import Registry.PackageName (PackageName) +import Registry.PackageName as PackageName +import Registry.PackageSet (PackageSet(..)) +import Registry.Range (Range) +import Registry.Range as Range +import Registry.Scripts.PackageSetPlanner as Planner +import Registry.Scripts.PackageSetUpdater as PackageSetUpdater +import Registry.Scripts.VersionCheck.GitHub as VersionCheck.GitHub +import Registry.Sha256 as Sha256 +import Registry.Version (Version) +import Registry.Version as Version +import Run (AFF, EFFECT, Run) +import Run as Run +import Run.Except (EXCEPT) +import Run.Except as Except + +type Options = + { markdown :: Maybe FilePath + , output :: Maybe FilePath + , reconcileIssues :: Boolean + , submit :: Boolean + } + +parser :: ArgParser Options +parser = ado + -- Kept so the existing workflow remains compatible. Compile verification is + -- now intrinsic to planning and is always performed. + _ <- Arg.flag [ "--verify" ] "Compatibility flag; compile-guided planning always verifies the result." # Arg.boolean # Arg.default false + submit <- Arg.flag [ "--submit" ] "Submit the exact verified automatic plan to the registry API." # Arg.boolean # Arg.default false + reconcileIssues <- Arg.flag [ "--reconcile-issues" ] "Update the rolling report and trustee decision issues in purescript/registry-dev." # Arg.boolean # Arg.default false + output <- Arg.argument [ "--output" ] "Write the structured report as JSON." # Arg.optional + markdown <- Arg.argument [ "--markdown" ] "Write the human-readable report as Markdown." # Arg.optional + in { markdown, output, reconcileIssues, submit } + +main :: Effect Unit +main = launchAff_ do + args <- Array.drop 2 <$> liftEffect Process.argv + let description = "Compile, plan, and report registry versions pending a package set update." + options <- case Arg.parseArgs "version-check" description parser args of + Left err -> Console.log (Arg.printArgError err) *> liftEffect (Process.exit' 1) + Right parsed -> pure parsed + + resourceEnv <- Env.lookupResourceEnv + githubToken <- map GitHubToken <$> liftEffect (Process.lookupEnv "GITHUB_TOKEN") + github <- traverse (flip Octokit.newOctokit resourceEnv.githubApiUrl) githubToken + + let cache = Path.concat [ scratchDir, ".cache" ] + FS.Extra.ensureDirectory cache + registryCacheRef <- Cache.newCacheRef + debouncer <- Registry.newDebouncer + + let + registryEnv :: Registry.RegistryEnv + registryEnv = + { jobId: Nothing + , pull: Git.Autostash + , write: Registry.ReadOnly + , repos: Registry.defaultRepos + , workdir: scratchDir + , debouncer + , cacheRef: registryCacheRef + } + + runVersionCheck options.submit github resourceEnv.registryApiUrl + # PackageSets.interpret (PackageSets.handle { workdir: scratchDir }) + # Except.runExcept + # Registry.interpretRead (Registry.handleRead registryEnv) + # Storage.interpret (Storage.handleReadOnly cache) + # Env.runResourceEnv resourceEnv + # Log.interpret (Log.handleTerminal Normal) + # Run.runBaseAff' + >>= case _ of + Left err -> do + Console.error $ "Error: " <> err + liftEffect $ Process.exit' 1 + Right result -> do + let markdown = renderMarkdown result.report + Console.log markdown + for_ options.output \path -> writeJsonFile reportCodec path result.report + for_ options.markdown \path -> FS.Aff.writeTextFile UTF8 path (markdown <> "\n") + reconciliationError <- + if options.reconcileIssues then do + octokit <- case github of + Nothing -> Aff.throwError $ Aff.error "GITHUB_TOKEN is required with --reconcile-issues." + Just value -> pure value + VersionCheck.GitHub.reconcile octokit + { interventions: result.report.manualInterventions <#> \intervention -> + { component: intervention.component + , fingerprint: intervention.fingerprint + , markdownBody: intervention.markdownBody + , payload: JSON.printIndented $ CJ.encode Operation.packageSetOperationCodec intervention.removal.payload + , removalVerified: intervention.removal.verified + , title: intervention.title + } + , markdown + , reconcileDecisions: + result.report.verification.status /= "infrastructure-failed" + && isNothing result.report.manualAnalysis.error + && not result.report.manualAnalysis.searchTruncated + && not result.report.manualInterventionsDeferred + } + else + pure $ Right unit + let + fatalError = case result.submissionError of + Just error -> Just error + Nothing | Left error <- reconciliationError -> Just error + Nothing | result.report.verification.status == "infrastructure-failed" -> + Just $ fromMaybe "Package set planning failed because of an infrastructure error." result.report.verification.error + Nothing | Just error <- result.report.manualAnalysis.error -> Just error + Nothing -> Nothing + for_ fatalError \error -> do + Console.error $ "Error: " <> error + liftEffect $ Process.exit' 1 + +type Incompatibility = + { dependency :: PackageName + , package :: PackageName + , packageDirectDependants :: Int + , packageTransitiveDependants :: Int + , range :: Range + , selectedVersion :: Maybe Version + , version :: Version + } + +type PendingPackage = + { blockedBy :: Array Incompatibility + , blockers :: Array Incompatibility + , candidate :: Version + , candidateCompilerRecorded :: Boolean + , candidatePublished :: DateTime + , current :: Version + , directDependants :: Int + , name :: PackageName + , planned :: Maybe Version + , staleDays :: Int + , staleSince :: DateTime + , transitiveDependants :: Int + } + +type Report = + { compiler :: Version + , generatedAt :: DateTime + , latestRangeMismatches :: Array Incompatibility + , manualAnalysis :: ManualAnalysisReport + , manualInterventions :: Array ManualInterventionReport + , manualInterventionsDeferred :: Boolean + , packageSet :: Version + , pending :: Array PendingPackage + , plan :: PlanReport + , verification :: Planner.Verification + } + +type PlanReport = + { error :: Maybe String + , packages :: Map PackageName Version + , searchTruncated :: Boolean + } + +type ManualAnalysisReport = + { error :: Maybe String + , searchTruncated :: Boolean + } + +type ManualInterventionReport = + { automaticRecoveryPlan :: Maybe ConditionalPlanReport + , bestUpstreamCandidatePlan :: Maybe ConditionalPlanReport + , collateralRemovals :: Array PackageName + , component :: String + , conditionalPlans :: Array ConditionalPlanReport + , conditionalSearchTruncated :: Boolean + , directBlockers :: Array PackageName + , fingerprint :: String + , markdownBody :: String + , recommendedConditionalPlan :: Maybe ConditionalPlanReport + , removal :: { payload :: Operation.PackageSetOperation, verified :: Boolean } + , removalScore :: Int + , targetUpdates :: Map PackageName Version + , title :: String + , upstreamCandidates :: Array UpstreamCandidateReport + } + +type ConditionalPlanReport = + { fixes :: Array PackageName + , projectedRemovals :: Array PackageName + , projectedRemovalScore :: Int + , projectedRescues :: Array PackageName + , rescuedScore :: Int + } + +type UpstreamCandidateReport = + { error :: Maybe String + , name :: PackageName + , releases :: Array UpstreamRelease + } + +type UpstreamRelease = + { ref :: String + , version :: Version + } + +type UpstreamCandidates = Map PackageName { error :: Maybe String, releases :: Array UpstreamRelease } + +incompatibilityCodec :: CJ.Codec Incompatibility +incompatibilityCodec = CJ.named "VersionCheckIncompatibility" $ CJ.Record.object + { dependency: PackageName.codec + , package: PackageName.codec + , packageDirectDependants: CJ.int + , packageTransitiveDependants: CJ.int + , range: Range.codec + , selectedVersion: CJ.Common.nullable Version.codec + , version: Version.codec + } + +pendingPackageCodec :: CJ.Codec PendingPackage +pendingPackageCodec = CJ.named "VersionCheckPendingPackage" $ CJ.Record.object + { blockedBy: CJ.array incompatibilityCodec + , blockers: CJ.array incompatibilityCodec + , candidate: Version.codec + , candidateCompilerRecorded: CJ.boolean + , candidatePublished: Internal.Codec.iso8601DateTime + , current: Version.codec + , directDependants: CJ.int + , name: PackageName.codec + , planned: CJ.Common.nullable Version.codec + , staleDays: CJ.int + , staleSince: Internal.Codec.iso8601DateTime + , transitiveDependants: CJ.int + } + +verificationCodec :: CJ.Codec Planner.Verification +verificationCodec = CJ.named "PackageSetPlannerVerification" $ CJ.Record.object + { error: CJ.Common.nullable CJ.string + , status: CJ.string + } + +planCodec :: CJ.Codec PlanReport +planCodec = CJ.named "PackageSetPlan" $ CJ.Record.object + { error: CJ.Common.nullable CJ.string + , packages: Internal.Codec.packageMap Version.codec + , searchTruncated: CJ.boolean + } + +manualAnalysisCodec :: CJ.Codec ManualAnalysisReport +manualAnalysisCodec = CJ.named "PackageSetManualAnalysis" $ CJ.Record.object + { error: CJ.Common.nullable CJ.string + , searchTruncated: CJ.boolean + } + +conditionalPlanCodec :: CJ.Codec ConditionalPlanReport +conditionalPlanCodec = CJ.named "PackageSetConditionalPlan" $ CJ.Record.object + { fixes: CJ.array PackageName.codec + , projectedRemovals: CJ.array PackageName.codec + , projectedRemovalScore: CJ.int + , projectedRescues: CJ.array PackageName.codec + , rescuedScore: CJ.int + } + +upstreamReleaseCodec :: CJ.Codec UpstreamRelease +upstreamReleaseCodec = CJ.named "PackageSetUpstreamRelease" $ CJ.Record.object + { ref: CJ.string + , version: Version.codec + } + +upstreamCandidateCodec :: CJ.Codec UpstreamCandidateReport +upstreamCandidateCodec = CJ.named "PackageSetUpstreamCandidate" $ CJ.Record.object + { error: CJ.Common.nullable CJ.string + , name: PackageName.codec + , releases: CJ.array upstreamReleaseCodec + } + +manualInterventionCodec :: CJ.Codec ManualInterventionReport +manualInterventionCodec = CJ.named "PackageSetManualIntervention" $ CJ.Record.object + { automaticRecoveryPlan: CJ.Common.nullable conditionalPlanCodec + , bestUpstreamCandidatePlan: CJ.Common.nullable conditionalPlanCodec + , collateralRemovals: CJ.array PackageName.codec + , component: CJ.string + , conditionalPlans: CJ.array conditionalPlanCodec + , conditionalSearchTruncated: CJ.boolean + , directBlockers: CJ.array PackageName.codec + , fingerprint: CJ.string + , markdownBody: CJ.string + , recommendedConditionalPlan: CJ.Common.nullable conditionalPlanCodec + , removal: CJ.Record.object + { payload: Operation.packageSetOperationCodec + , verified: CJ.boolean + } + , removalScore: CJ.int + , targetUpdates: Internal.Codec.packageMap Version.codec + , title: CJ.string + , upstreamCandidates: CJ.array upstreamCandidateCodec + } + +reportCodec :: CJ.Codec Report +reportCodec = CJ.named "VersionCheckReport" $ CJ.Record.object + { compiler: Version.codec + , generatedAt: Internal.Codec.iso8601DateTime + , latestRangeMismatches: CJ.array incompatibilityCodec + , manualAnalysis: manualAnalysisCodec + , manualInterventions: CJ.array manualInterventionCodec + , manualInterventionsDeferred: CJ.boolean + , packageSet: Version.codec + , pending: CJ.array pendingPackageCodec + , plan: planCodec + , verification: verificationCodec + } + +type Candidate = + { candidate :: Version + , candidateCompilerRecorded :: Boolean + , candidatePublished :: DateTime + , current :: Version + , name :: PackageName + , staleSince :: DateTime + } + +type VersionCheckEffects = (REGISTRY_READ + PACKAGE_SETS + STORAGE + RESOURCE_ENV + LOG + EXCEPT String + AFF + EFFECT + ()) + +type VersionCheckResult = + { report :: Report + , submissionError :: Maybe String + } + +runVersionCheck :: Boolean -> Maybe Octokit -> URL -> Run VersionCheckEffects VersionCheckResult +runVersionCheck submit github registryApiUrl = do + Log.info "Registry Version Check: compile-guided planning for pending package set updates..." + packageSet <- Registry.readLatestPackageSet >>= case _ of + Nothing -> Except.throw "No package set found." + Just found -> pure found + metadata <- Registry.readAllMetadata + manifests <- Registry.readAllManifests + generatedAt <- nowUTC + let recent = PackageSetUpdater.selectPackageSetCandidates (PackageSetUpdater.RecentUploads generatedAt (Hours 24.0)) packageSet metadata + let plannerCandidates = PackageSetUpdater.plannerCandidates packageSet metadata manifests recent + planning <- Planner.planPackageSet packageSet manifests plannerCandidates + upstreamCandidates <- discoverUpstreamCandidates github packageSet metadata planning + report <- buildReportWithUpstream upstreamCandidates generatedAt packageSet metadata manifests planning + Log.info $ "Found " <> show (Array.length report.pending) <> " package versions pending a package set update." + let + shouldSubmit = + submit + && planning.automatic.verification.status + == "verified" + && not (Map.isEmpty planning.automatic.packages) + submissionResult <- + if submit then do + Except.runExcept do + latest <- Registry.readLatestPackageSet >>= case _ of + Nothing -> Except.throw "The latest package set disappeared before submission." + Just latestPackageSet -> pure latestPackageSet + PackageSetUpdater.submitVerifiedPlan PackageSetUpdater.Submit registryApiUrl packageSet latest planning.automatic + else + pure $ Right unit + let + submissionError = either Just (const Nothing) submissionResult + finalReport = case submissionResult of + Left error -> report + { plan = report.plan { error = Just $ "Automatic submission failed: " <> error } + , verification = { error: Just error, status: "infrastructure-failed" } + } + Right _ | shouldSubmit -> report + { manualInterventions = [] + , manualInterventionsDeferred = true + } + Right _ -> report + pure { report: finalReport, submissionError } + +discoverUpstreamCandidates + :: forall r + . Maybe Octokit + -> PackageSet + -> Map PackageName Metadata + -> Planner.Plan + -> Run (LOG + AFF + r) UpstreamCandidates +discoverUpstreamCandidates Nothing _ _ _ = do + Log.warn "GITHUB_TOKEN is unavailable; skipping advisory discovery of unregistered upstream tags." + pure Map.empty +discoverUpstreamCandidates (Just octokit) (PackageSet set) metadata planning = do + let blockers = Set.fromFoldable $ Array.concatMap _.directBlockers planning.manualInterventions + entries <- for (Array.fromFoldable blockers) \name -> do + let result error releases = Tuple name { error, releases } + case Tuple (Map.lookup name set.packages) (Map.lookup name metadata) of + Tuple Nothing _ -> pure $ result (Just "The blocker is not present in the package set.") [] + Tuple _ Nothing -> pure $ result (Just "Registry metadata is unavailable for this blocker.") [] + Tuple (Just current) (Just (Metadata packageMetadata)) -> case packageMetadata.location of + Git _ -> pure $ result (Just "Upstream tag discovery currently supports GitHub packages only.") [] + GitHub { owner, repo } -> do + Run.liftAff (Octokit.request octokit $ Octokit.listTagsRequest { owner, repo }) >>= case _ of + Left error -> do + Log.warn $ "Could not discover upstream tags for " <> PackageName.print name <> ": " <> Octokit.printGitHubError error + pure $ result (Just "Upstream tag discovery failed; see the workflow log for details.") [] + Right tags -> do + let known = Set.fromFoldable $ Map.keys packageMetadata.published <> Map.keys packageMetadata.unpublished + pure $ result Nothing (unregisteredUpstreamReleases current known tags) + pure $ Map.fromFoldable entries + +unregisteredUpstreamReleases :: Version -> Set Version -> Array Octokit.Tag -> Array UpstreamRelease +unregisteredUpstreamReleases current known tags = do + let + releases = Map.values $ Map.fromFoldableWith preferStableRef $ Array.mapMaybe + ( \tag -> case LenientVersion.parse tag.name of + Left _ -> Nothing + Right parsed -> do + let version = LenientVersion.version parsed + guard $ version > current && not (Set.member version known) + pure $ Tuple version { ref: tag.name, version } + ) + tags + Array.reverse $ Array.sortWith _.version $ Array.fromFoldable releases + where + preferStableRef a b = if a.ref <= b.ref then a else b + +buildReport :: forall m. MonadEffect m => DateTime -> PackageSet -> Map PackageName Metadata -> ManifestIndex -> Planner.Plan -> m Report +buildReport = buildReportWithUpstream Map.empty + +buildReportWithUpstream :: forall m. MonadEffect m => UpstreamCandidates -> DateTime -> PackageSet -> Map PackageName Metadata -> ManifestIndex -> Planner.Plan -> m Report +buildReportWithUpstream upstreamCandidates generatedAt packageSet@(PackageSet set) metadata manifests planning = do + let candidates = findCandidates set.compiler set.packages metadata + let latest = Map.fromFoldable $ candidates <#> \candidate -> Tuple candidate.name candidate.candidate + let proposed = Map.union latest set.packages + let planned = Map.union planning.automatic.packages set.packages + let latestRangeMismatches = findIncompatibilities set.packages proposed manifests + let + pending = candidates <#> \candidate -> do + let direct = directDependants set.packages manifests candidate.name + let transitive = transitiveDependants set.packages manifests candidate.name + let advisory = findIncompatibilities set.packages (Map.insert candidate.name candidate.candidate planned) manifests + { blockedBy: Array.filter (_.package >>> eq candidate.name) advisory + , blockers: Array.filter (_.dependency >>> eq candidate.name) advisory + , candidate: candidate.candidate + , candidateCompilerRecorded: candidate.candidateCompilerRecorded + , candidatePublished: candidate.candidatePublished + , current: candidate.current + , directDependants: Array.length direct + , name: candidate.name + , planned: Map.lookup candidate.name planning.automatic.packages + , staleDays: daysBetween candidate.staleSince generatedAt + , staleSince: candidate.staleSince + , transitiveDependants: Array.length transitive + } + let automatic = planning.automatic + manualInterventions <- traverse (manualReport packageSet manifests upstreamCandidates) planning.manualInterventions + pure + { compiler: set.compiler + , generatedAt + , latestRangeMismatches + , manualAnalysis: { error: planning.manualError, searchTruncated: planning.manualSearchTruncated } + , manualInterventions + , manualInterventionsDeferred: false + , packageSet: set.version + , pending + , plan: { error: automatic.verification.error, packages: automatic.packages, searchTruncated: automatic.searchTruncated } + , verification: automatic.verification + } + +manualReport :: forall m. MonadEffect m => PackageSet -> ManifestIndex -> UpstreamCandidates -> Planner.ManualIntervention -> m ManualInterventionReport +manualReport (PackageSet set) manifests discoveredUpstream intervention = do + let removals = Map.fromFoldable $ intervention.removals <#> \name -> Tuple name Nothing + let update = { compiler: Nothing, packages: Map.union removals (map Just intervention.packages) } + let payload = Operation.PackageSetUpdateFrom set.version update + let targetUpdates = Map.filterWithKey (\name _ -> Array.elem name intervention.targets) intervention.packages + let affectedNames = Array.sort $ map PackageName.print (Map.keys update.packages # Array.fromFoldable) + let targetNames = Array.sort $ map PackageName.print intervention.targets + let directBlockers = Array.sort intervention.directBlockers + let collateralRemovals = Array.sort $ Array.filter (not <<< flip Array.elem directBlockers) intervention.removals + let proposed = Map.union intervention.packages set.packages + let removalScore = weightedRemovalScore proposed manifests intervention.removals + let conditional = conditionalPlans proposed manifests intervention.packages directBlockers intervention.removals + let recommendedConditionalPlan = conditional.recommended + let + upstreamCandidates = directBlockers <#> \name -> do + let unavailable = { error: Just "Upstream tags were not checked; set GITHUB_TOKEN to enable discovery.", releases: [] } + let candidate = fromMaybe unavailable $ Map.lookup name discoveredUpstream + { error: candidate.error, name, releases: candidate.releases } + let bestUpstreamCandidatePlan = bestPlanWithUpstreamCandidates upstreamCandidates conditional.frontier + componentHash <- Sha256.print <$> Sha256.hashString (String.joinWith "|" targetNames) + let safeComponentHash = componentHash # String.replaceAll (String.Pattern "+") (String.Replacement "-") # String.replaceAll (String.Pattern "/") (String.Replacement "_") # String.replaceAll (String.Pattern "=") (String.Replacement "") + let component = "packages-" <> String.take 72 (String.joinWith "-" targetNames) <> "-" <> String.take 32 safeComponentHash + let verified = intervention.verification.status == "verified" && not (Array.null intervention.removals) + let title = String.trim $ String.take 256 $ "Package set intervention: " <> String.joinWith ", " affectedNames + let + markdownBody = String.joinWith "\n" + [ "The planner tested this component with PureScript `" <> Version.print set.compiler <> "` against package set `" <> Version.print set.version <> "`." + , "" + , "## Recommendation" + , "" + , "Target update: " <> renderUpdatesInline targetUpdates <> "." + , case recommendedConditionalPlan of + Nothing -> if verified then "No conditional release plan rescues collateral packages. Review the compile-verified removal payload below." else "No compile-verified or high-leverage conditional plan is available." + Just plan -> String.joinWith "\n" + [ "Prefer compatible releases for " <> renderPackageNames plan.fixes <> " before accepting the removal payload." + , "This is the highest-leverage conditional plan: it projects rescuing " <> show (Array.length plan.projectedRescues) <> " packages (weighted score " <> show plan.rescuedScore <> ") and leaves these projected removals: " <> renderPackageNames plan.projectedRemovals <> "." + ] + , case conditional.automaticRecoveryPlan of + Nothing -> "No conditional zero-removal path was found from the current dependency graph." + Just plan -> "Zero-removal path: publish/import compatible releases for " <> renderPackageNames plan.fixes <> ". If those releases enter the registry, rerun the planner; only a fresh exact whole-set compile can make the upgrade automatically submit-ready." + , case bestUpstreamCandidatePlan, any (isJust <<< _.error) upstreamCandidates of + Nothing, true -> "A tagged-upstream preservation plan could not be assessed because release discovery was incomplete." + Nothing, false -> "No preservation plan is currently supported by newer unregistered upstream tags." + Just plan, _ -> "Best tagged-upstream path: inspect and import compatible releases for " <> renderPackageNames plan.fixes <> ". On the current graph this projects removals of only " <> renderPackageNames plan.projectedRemovals <> ", but tags are not compatibility or publishability proof." + , "Conditional plans are dependency-graph projections, **not compile-verified payloads**. Release manifests can change the graph, so every option must be replanned after publication/import." + , "" + , "## Why the exact plan removes packages" + , "" + , "Direct compiler blockers: " <> renderPackageNames directBlockers <> "." + , "Collateral reverse dependants: " <> renderPackageNames collateralRemovals <> "." + , "Exact removal impact: " <> show (Array.length intervention.removals) <> " packages, dependency-weighted score " <> show removalScore <> ". For each affected package, the score counts it plus transitive dependants affected by the same plan; this is a deterministic prioritization heuristic, not a measure of ecosystem importance." + , "" + , "## Conditional rescue frontier" + , "" + , if Array.null conditional.plans then "No conditional rescue plan preserves a package from the exact removal closure." + else String.joinWith "\n" $ conditional.plans <#> \plan -> + "- Release " <> renderPackageNames plan.fixes <> ": rescue " <> renderPackageNames plan.projectedRescues <> " (score " <> show plan.rescuedScore <> "); projected removals " <> renderPackageNames plan.projectedRemovals <> " (score " <> show plan.projectedRemovalScore <> ")." + , if conditional.truncated then "\n⚠️ Conditional subset analysis was limited because this component has more than 10 direct blockers." else "" + , "" + , "## Upstream releases not present in the registry" + , "" + , renderUpstreamCandidates upstreamCandidates + , "" + , if verified then "## Compile-verified fallback\n\nThe exact removal-containing payload compiles, but it should be used only if the higher-preservation options above are declined." else "No compile-verified removal is available. The payload and compiler output below are diagnostic only and must not be applied as a verified plan." + , maybe "" (\error -> "\nCompiler evidence:\n```text\n" <> printableEvidence error <> "\n```") intervention.compilerError + , maybe "" (\error -> "\nPlanner evidence:\n```text\n" <> printableEvidence error <> "\n```") intervention.verification.error + ] + let + decision = String.joinWith "|" + [ Version.print set.compiler + , JSON.print (CJ.encode Operation.packageSetOperationCodec payload) + , intervention.verification.status + , markdownBody + ] + decisionHash <- Sha256.print <$> Sha256.hashString decision + pure + { automaticRecoveryPlan: conditional.automaticRecoveryPlan + , bestUpstreamCandidatePlan + , collateralRemovals + , component + , conditionalPlans: conditional.plans + , conditionalSearchTruncated: conditional.truncated + , directBlockers + , fingerprint: decisionHash + , markdownBody + , recommendedConditionalPlan + , removal: { payload, verified } + , removalScore + , targetUpdates + , title + , upstreamCandidates + } + +conditionalPlans + :: Map PackageName Version + -> ManifestIndex + -> Map PackageName Version + -> Array PackageName + -> Array PackageName + -> { automaticRecoveryPlan :: Maybe ConditionalPlanReport + , frontier :: Array ConditionalPlanReport + , plans :: Array ConditionalPlanReport + , recommended :: Maybe ConditionalPlanReport + , truncated :: Boolean + } +conditionalPlans proposed manifests updates directBlockers exactRemovals = do + let blockers = Array.sort $ Array.nub directBlockers + let truncated = Array.length blockers > 10 + let fixSets = if truncated then map Array.singleton blockers <> [ blockers ] else nonEmptySubsets blockers + let plans = Array.mapMaybe project fixSets + let frontier = Array.filter (not <<< flip dominatedBy plans) plans + let automaticRecoveryPlan = Array.find (Array.null <<< _.projectedRemovals) $ Array.sortBy compareConditionalPlans frontier + { automaticRecoveryPlan + , frontier + , plans: Array.take 8 $ Array.sortBy compareConditionalPlans frontier + , recommended: highestLeveragePlan frontier + , truncated + } + where + project fixes = do + let remainingBlockers = Set.difference (Set.fromFoldable directBlockers) (Set.fromFoldable fixes) + closure <- hush $ Planner.reverseDependencyClosure proposed manifests remainingBlockers + guard $ Set.isEmpty $ Set.intersection closure (Map.keys updates) + let projected = closure + guard $ Set.isEmpty $ Set.intersection projected (Set.fromFoldable fixes) + let rescued = Set.difference (Set.fromFoldable exactRemovals) projected + guard $ not $ Set.isEmpty rescued + pure + { fixes: Array.sort fixes + , projectedRemovals: Array.fromFoldable projected + , projectedRemovalScore: weightedRemovalScore proposed manifests (Array.fromFoldable projected) + , projectedRescues: Array.fromFoldable rescued + , rescuedScore: weightedRemovalScore proposed manifests (Array.fromFoldable rescued) + } + + dominatedBy candidate plans = any (dominates candidate) plans + + dominates candidate other = do + let noMoreFixes = Array.length other.fixes <= Array.length candidate.fixes + let noMoreRemovals = Array.length other.projectedRemovals <= Array.length candidate.projectedRemovals + let noMoreRemovalCost = other.projectedRemovalScore <= candidate.projectedRemovalScore + let strictlyBetter = Array.length other.fixes < Array.length candidate.fixes || Array.length other.projectedRemovals < Array.length candidate.projectedRemovals || other.projectedRemovalScore < candidate.projectedRemovalScore + other /= candidate && noMoreFixes && noMoreRemovals && noMoreRemovalCost && strictlyBetter + +compareConditionalPlans :: ConditionalPlanReport -> ConditionalPlanReport -> Ordering +compareConditionalPlans a b = + compare (Array.length a.fixes) (Array.length b.fixes) + <> compare (Array.length a.projectedRemovals) (Array.length b.projectedRemovals) + <> compare a.projectedRemovalScore b.projectedRemovalScore + <> compare b.rescuedScore a.rescuedScore + +highestLeveragePlan :: Array ConditionalPlanReport -> Maybe ConditionalPlanReport +highestLeveragePlan = Foldable.maximumBy compareLeverage <<< Array.filter materiallyImproves + where + materiallyImproves plan = Array.length plan.projectedRescues > Array.length plan.fixes + + compareLeverage a b = + compare + (Array.length a.projectedRescues * Array.length b.fixes) + (Array.length b.projectedRescues * Array.length a.fixes) + <> compare (a.rescuedScore * Array.length b.fixes) (b.rescuedScore * Array.length a.fixes) + <> compare (Array.length b.projectedRemovals) (Array.length a.projectedRemovals) + <> compare b.projectedRemovalScore a.projectedRemovalScore + <> compare (Array.length b.fixes) (Array.length a.fixes) + <> compare (map PackageName.print a.fixes) (map PackageName.print b.fixes) + +bestPlanWithUpstreamCandidates :: Array UpstreamCandidateReport -> Array ConditionalPlanReport -> Maybe ConditionalPlanReport +bestPlanWithUpstreamCandidates upstreamCandidates = Foldable.maximumBy comparePreservation <<< Array.filter isSupported + where + available = Set.fromFoldable $ Array.mapMaybe availableName upstreamCandidates + + availableName candidate = candidate.name <$ guard (isNothing candidate.error && not (Array.null candidate.releases)) + + isSupported plan = all (flip Set.member available) plan.fixes + + comparePreservation a b = + compare (Array.length b.projectedRemovals) (Array.length a.projectedRemovals) + <> compare b.projectedRemovalScore a.projectedRemovalScore + <> compare (Array.length b.fixes) (Array.length a.fixes) + <> compare (map PackageName.print a.fixes) (map PackageName.print b.fixes) + +weightedRemovalScore :: Map PackageName Version -> ManifestIndex -> Array PackageName -> Int +weightedRemovalScore packages manifests removals = Foldable.sum $ map weight removals + where + affected = Set.fromFoldable removals + affectedPackages = Map.filterWithKey (\name _ -> Set.member name affected) packages + + weight name = case Planner.reverseDependencyClosure affectedPackages manifests (Set.singleton name) of + Left _ -> 1 + Right closure -> Set.size closure + +nonEmptySubsets :: forall a. Array a -> Array (Array a) +nonEmptySubsets = Array.filter (not <<< Array.null) <<< go + where + go values = case Array.uncons values of + Nothing -> [ [] ] + Just { head, tail } -> do + let rest = go tail + rest <> map (Array.cons head) rest + +renderPackageNames :: Array PackageName -> String +renderPackageNames names + | Array.null names = "none" + | otherwise = do + let visible = Array.take renderedNameLimit names + let omitted = Array.length names - Array.length visible + String.joinWith ", " (visible <#> \name -> "`" <> PackageName.print name <> "`") + <> if omitted > 0 then " (and " <> show omitted <> " more in the JSON report)" else "" + +renderUpdatesInline :: Map PackageName Version -> String +renderUpdatesInline updates + | Map.isEmpty updates = "none" + | otherwise = do + let allUpdates = Map.toUnfoldable updates :: Array (Tuple PackageName Version) + let visible = Array.take renderedNameLimit allUpdates + let omitted = Array.length allUpdates - Array.length visible + String.joinWith ", " (visible <#> \(Tuple name version) -> "`" <> PackageName.print name <> "@" <> Version.print version <> "`") + <> if omitted > 0 then " (and " <> show omitted <> " more in the JSON report)" else "" + +renderUpstreamCandidates :: Array UpstreamCandidateReport -> String +renderUpstreamCandidates candidates + | Array.null candidates = "No direct compiler blockers were identified." + | otherwise = do + let visible = Array.take renderedNameLimit candidates + let omitted = Array.length candidates - Array.length visible + String.joinWith "\n" + ( visible <#> \candidate -> case candidate.error, candidate.releases of + Just error, _ -> "- `" <> PackageName.print candidate.name <> "`: discovery failed: " <> error + Nothing, [] -> "- `" <> PackageName.print candidate.name <> "`: no newer semantic-version tag was found. A new maintainer release is required." + Nothing, releases -> "- `" <> PackageName.print candidate.name <> "`: unregistered upstream " <> String.joinWith ", " (Array.take 5 releases <#> \release -> "`" <> release.ref <> "` (" <> Version.print release.version <> ")") <> ". Inspect publishability and compatibility before importing." + ) + <> if omitted > 0 then "\n- _" <> show omitted <> " more direct blockers are available in the JSON report._" else "" + +renderedNameLimit :: Int +renderedNameLimit = 20 + +-- Compiler history is retained as a diagnostic, but does not gate candidates. +findCandidates :: Version -> Map PackageName Version -> Map PackageName Metadata -> Array Candidate +findCandidates compiler packages metadata = Array.mapMaybe toCandidate (Map.toUnfoldable packages) + where + toCandidate (Tuple name current) = do + Metadata packageMetadata <- Map.lookup name metadata + let newer = Array.filter (fst >>> (_ > current)) (Map.toUnfoldable packageMetadata.published) + latest@(Tuple candidate candidateMetadata) <- Array.last $ Array.sortBy (comparing fst) newer + let Tuple _ staleMetadata = Foldable.minimumBy (comparing (_.publishedTime <<< snd)) newer # fromMaybe latest + pure + { candidate + , candidateCompilerRecorded: Foldable.elem compiler candidateMetadata.compilers + , candidatePublished: candidateMetadata.publishedTime + , current + , name + , staleSince: staleMetadata.publishedTime + } + +findIncompatibilities :: Map PackageName Version -> Map PackageName Version -> ManifestIndex -> Array Incompatibility +findIncompatibilities baseline selected manifests = do + Tuple package version <- Map.toUnfoldable selected + Manifest manifest <- Array.fromFoldable $ ManifestIndex.lookup package version manifests + Tuple dependency range <- Map.toUnfoldable manifest.dependencies + let selectedVersion = Map.lookup dependency selected + guard $ maybe true (not <<< Range.includes range) selectedVersion + pure + { dependency + , package + , packageDirectDependants: Array.length (directDependants baseline manifests package) + , packageTransitiveDependants: Array.length (transitiveDependants baseline manifests package) + , range + , selectedVersion + , version + } + +directDependants :: Map PackageName Version -> ManifestIndex -> PackageName -> Array PackageName +directDependants packages manifests dependency = Array.mapMaybe isDependant (Map.toUnfoldable packages) + where + isDependant (Tuple name version) = do + Manifest manifest <- ManifestIndex.lookup name version manifests + name <$ guard (Map.member dependency manifest.dependencies) + +transitiveDependants :: Map PackageName Version -> ManifestIndex -> PackageName -> Array PackageName +transitiveDependants packages manifests dependency = Array.fromFoldable $ Set.delete dependency $ go (Set.singleton dependency) [ dependency ] + where + go seen [] = seen + go seen frontier = do + let discovered = Set.fromFoldable (frontier >>= directDependants packages manifests) + let next = Set.difference discovered seen + go (Set.union seen next) (Array.fromFoldable next) + +daysBetween :: DateTime -> DateTime -> Int +daysBetween from to = do + let Days days = DateTime.diff to from + max 0 (Int.floor days) + +renderMarkdown :: Report -> String +renderMarkdown report = String.joinWith "\n" + [ "# Daily package set planning report" + , "" + , "Package set: `" <> Version.print report.packageSet <> "` (PureScript `" <> Version.print report.compiler <> "`)" + , "Generated: `" <> Internal.Codec.formatIso8601 report.generatedAt <> "`" + , "Automatic plan verification: **" <> report.verification.status <> "**" + , renderError "Automatic planning error" report.plan.error + , "" + , "## Verified automatic update" + , "" + , if Map.isEmpty report.plan.packages then "No automatic package updates were planned." + else renderUpdates report.plan.packages + , if report.plan.searchTruncated then "\n⚠️ The automatic search exhausted its probe budget. A payload marked verified still compiled exactly and may be published, but it is only the best verified plan found within the budget." else "" + , "" + , "The automatic lane is upgrade-only: it does not remove packages, downgrade versions, or change the compiler." + , "" + , "## Manual interventions" + , "" + , renderError "Manual-intervention analysis error" report.manualAnalysis.error + , if report.manualAnalysis.searchTruncated then "\n⚠️ Manual-intervention analysis exhausted its probe budget. Existing trustee issues are preserved until a complete run can reconcile them." else "" + , if report.manualInterventionsDeferred then "Residual trustee decisions were deferred because the automatic plan advanced the package-set baseline. They will be recomputed and compile-verified against the new baseline on the next run." + else renderManualInterventions report.manualInterventions + , "" + , "## Advisory range diagnostics" + , "" + , "Declared dependency ranges are shown for maintainers, but never gate compile-guided candidates." + , if Array.null report.latestRangeMismatches then "\nNo range mismatches were found in the all-latest proposal." + else "\nThe all-latest proposal has **" <> show (Array.length report.latestRangeMismatches) <> "** declared range mismatches." + , "" + , "## Pending versions" + , "" + , renderPendingPackages report.pending + ] + where + renderUpdates packages = String.joinWith "\n" do + Tuple name version <- Map.toUnfoldable packages + [ "- `" <> PackageName.print name <> "@" <> Version.print version <> "`" ] + + renderManualInterventions interventions + | Array.null interventions = "No residual manual-intervention payloads were found." + | otherwise = String.joinWith "\n\n" $ Array.mapWithIndex renderManual interventions + + renderManual index intervention = String.joinWith "\n" + [ "### " <> intervention.title + , "" + , (if intervention.removal.verified then "Compile-verified trustee decision" else "Unverified trustee diagnostic") <> " " <> show (index + 1) <> "; fingerprint `" <> intervention.fingerprint <> "`." + , "" + , "- Target update: " <> renderUpdatesInline intervention.targetUpdates + , "- Direct compiler blockers: " <> renderPackageNames intervention.directBlockers + , "- Collateral reverse dependants: " <> renderPackageNames intervention.collateralRemovals + , "- Exact fallback: remove **" <> show (Array.length intervention.directBlockers + Array.length intervention.collateralRemovals) <> "** packages; weighted removal score **" <> show intervention.removalScore <> "**" + , case intervention.recommendedConditionalPlan of + Nothing -> "- Recommended conditional rescue: none with collateral leverage" + Just plan -> "- Highest-leverage rescue: release " <> renderPackageNames plan.fixes <> " to project rescuing " <> show (Array.length plan.projectedRescues) <> " packages (weighted score " <> show plan.rescuedScore <> ")" + , case intervention.automaticRecoveryPlan of + Nothing -> "- Conditional zero-removal path: none found" + Just plan -> "- Conditional zero-removal path: release " <> renderPackageNames plan.fixes <> ", then rerun and compile before automatic submission" + , case intervention.bestUpstreamCandidatePlan of + Nothing -> "- Best tagged-upstream path: none" + Just plan -> "- Best tagged-upstream path: inspect/import " <> renderPackageNames plan.fixes <> "; current-graph projection removes " <> renderPackageNames plan.projectedRemovals + ] + + renderPendingPackages pending + | Array.null pending = "No package versions are pending." + | otherwise = do + let visible = Array.take 25 pending + let omitted = Array.length pending - Array.length visible + String.joinWith "\n\n" (map renderPending visible) + <> if omitted > 0 then "\n\n_" <> show omitted <> " more pending packages are available in the JSON artifact._" else "" + + renderPending pending = String.joinWith "\n" + [ "### `" <> PackageName.print pending.name <> "` " <> Version.print pending.current <> " → " <> Version.print pending.candidate + , "" + , "- Stale for **" <> show pending.staleDays <> " days** (since `" <> Internal.Codec.formatIso8601 pending.staleSince <> "`)" + , "- Dependants in the current set: **" <> show pending.directDependants <> " direct**, **" <> show pending.transitiveDependants <> " transitive**" + , "- Verified automatic version: " <> maybe "none" (\version -> "`" <> Version.print version <> "`") pending.planned + , "- Current compiler appears in candidate publication metadata: **" <> if pending.candidateCompilerRecorded then "yes** (diagnostic only)" else "no** (diagnostic only)" + , renderRelations "Advisory dependant range mismatches" pending.blockers + , renderRelations "Advisory dependency range mismatches" pending.blockedBy + ] + + renderRelations label relations + | Array.null relations = "- " <> label <> ": none" + | otherwise = do + let visible = Array.take 5 relations + let omitted = Array.length relations - Array.length visible + "- " <> label <> ":\n" <> String.joinWith "\n" (map (renderRelation >>> (" - " <> _)) visible) + <> if omitted > 0 then "\n - _" <> show omitted <> " more in the JSON artifact._" else "" + + renderRelation relation = String.joinWith " " + [ "`" <> PackageName.print relation.package <> "@" <> Version.print relation.version <> "` declares" + , "`" <> PackageName.print relation.dependency <> " " <> Range.print relation.range <> "`" + , "while the proposed version is" + , maybe "missing" (\version -> "`" <> Version.print version <> "`") relation.selectedVersion + , "(" <> show relation.packageDirectDependants <> " direct, " <> show relation.packageTransitiveDependants <> " transitive dependants)" + ] + +renderError :: String -> Maybe String -> String +renderError _ Nothing = "" +renderError label (Just error) = "\n" <> label <> ":\n```text\n" <> printableEvidence error <> "\n```" + +printableEvidence :: String -> String +printableEvidence = String.take 4_000 + >>> String.replaceAll + (String.Pattern "" + +decisionMarker :: String +decisionMarker = "" + +componentMarkerPrefix :: String +componentMarkerPrefix = "" + +summaryTitle :: String +summaryTitle = "Package set planning report" + +reconcile :: Octokit -> ReconciliationInput -> Aff (Either String Unit) +reconcile octokit input = + Octokit.request octokit (Octokit.listIssuesRequest registryDev) >>= case _ of + Left error -> pure $ Left $ "Could not list registry-dev issues: " <> Octokit.printGitHubError error + Right allItems -> case planIssueReconciliation (input { reconcileDecisions = false }) allItems of + Left error -> pure $ Left error + Right summaryMutations -> applyMutations summaryMutations >>= case _ of + Left error -> pure $ Left error + Right _ + | not input.reconcileDecisions -> pure $ Right unit + | otherwise -> case planIssueReconciliation input allItems of + Left error -> pure $ Left error + Right mutations -> applyMutations $ Array.filter (not <<< isSummaryMutation) mutations + where + isSummaryMutation = case _ of + CreateIssue issue -> isJust $ String.stripPrefix (String.Pattern summaryMarker) issue.body + UpdateIssue issue -> isJust $ String.stripPrefix (String.Pattern summaryMarker) issue.body + + applyMutations mutations = case Array.uncons mutations of + Nothing -> pure $ Right unit + Just { head: mutation, tail } -> do + result <- case mutation of + CreateIssue issue -> Octokit.request octokit $ Octokit.createIssueRequest + { address: registryDev, body: issue.body, title: issue.title } + UpdateIssue issue -> Octokit.request octokit $ Octokit.updateIssueRequest + { address: registryDev, body: issue.body, issue: issue.issue, state: issue.state, title: issue.title } + case result of + Left error -> pure $ Left $ "Could not reconcile registry-dev issues: " <> Octokit.printGitHubError error + Right _ -> applyMutations tail + +planIssueReconciliation :: ReconciliationInput -> Array Issue -> Either String (Array IssueMutation) +planIssueReconciliation input allItems = do + let markdown = trimTrailingNewlines $ normalize input.markdown + when (hasReservedMarker markdown) $ Left "The generated Markdown contains a reserved automation marker." + let summaryBody = summaryMarker <> "\n\n" <> markdown <> "\n" + when (CodeUnits.length summaryBody > 65_536) $ Left "The rolling report issue body is larger than 65536 characters." + + let allIssues = Array.filter (not <<< _.isPullRequest) allItems + let summaryIssues = Array.filter (flip hasExactMarker summaryMarker) allIssues + when (Array.length summaryIssues > 1) $ Left "Found multiple rolling issues with the exact summary marker." + when (any (hasDuplicateMarker summaryMarker) summaryIssues) $ Left "The rolling issue has duplicate summary markers." + when (any (flip hasExactMarker decisionMarker) summaryIssues) $ Left "An issue contains both summary and decision markers." + + let + summaryMutations = case Array.head summaryIssues of + Nothing -> [ CreateIssue { title: summaryTitle, body: summaryBody } ] + Just issue + | issue.state /= "open" || issue.title /= summaryTitle || normalize (fromMaybe "" issue.body) /= summaryBody -> + [ UpdateIssue { issue: issue.number, title: summaryTitle, body: summaryBody, state: "open" } ] + Just _ -> [] + + if not input.reconcileDecisions then pure summaryMutations + else do + planned <- traverse prepareIntervention input.interventions + let components = map _.component planned + let fingerprints = map _.fingerprint planned + when (Set.size (Set.fromFoldable components) /= Array.length components) $ Left "Manual interventions contain duplicate component identifiers." + when (Set.size (Set.fromFoldable fingerprints) /= Array.length fingerprints) $ Left "Manual interventions contain duplicate fingerprints." + + let decisionIssues = Array.filter (flip hasExactMarker decisionMarker) allIssues + when (any (flip hasExactMarker summaryMarker) decisionIssues) $ Left "An issue contains both summary and decision markers." + indexed <- indexDecisionIssues decisionIssues + + let + activeMutations = planned >>= \intervention -> case Map.lookup intervention.component indexed.byComponent of + Nothing -> [ CreateIssue { title: intervention.title, body: intervention.body } ] + Just issue + | issue.state /= "open" || issue.title /= intervention.title || normalize (fromMaybe "" issue.body) /= intervention.body -> + [ UpdateIssue { issue: issue.number, title: intervention.title, body: intervention.body, state: "open" } ] + Just _ -> [] + + activeComponents = Set.fromFoldable components + resolvedMutations = Array.mapMaybe resolved $ Array.fromFoldable $ Map.values indexed.byComponent + + resolved issue = do + component <- hush $ oneMarker componentMarkerPrefix issue + guard $ issue.state == "open" && not (Set.member component activeComponents) + pure $ UpdateIssue + { body: fromMaybe "" issue.body + , issue: issue.number + , state: "closed" + , title: issue.title + } + + for_ planned \intervention -> case Map.lookup intervention.fingerprint indexed.byFingerprint of + Just owner | Just owner /= Map.lookup intervention.component indexed.byComponent -> + Left $ "Fingerprint " <> intervention.fingerprint <> " belongs to a decision issue for another component." + _ -> pure unit + + pure $ summaryMutations <> activeMutations <> resolvedMutations + +type PreparedIntervention = + { body :: String + , component :: String + , fingerprint :: String + , title :: String + } + +prepareIntervention :: Intervention -> Either String PreparedIntervention +prepareIntervention intervention = do + unless (safeMarkerValue 128 intervention.component) $ Left "A manual intervention has an unsafe component identifier." + unless (safeMarkerValue 200 intervention.fingerprint) $ Left "A manual intervention has an unsafe fingerprint." + when + ( String.trim intervention.title /= intervention.title + || String.contains (String.Pattern "\n") intervention.title + || String.contains (String.Pattern "\r") intervention.title + || CodeUnits.length intervention.title + == 0 + || CodeUnits.length intervention.title + > 256 + ) + $ Left "A manual intervention has an invalid issue title." + when (String.trim intervention.markdownBody == "" || hasReservedMarker intervention.markdownBody) $ + Left "A manual intervention has invalid Markdown." + + let payloadHeading = if intervention.removalVerified then "## Compile-verified removal payload" else "## Diagnostic payload (not compile-verified)" + let + payloadNote = + if intervention.removalVerified then + "The planner atomically verified this package-set payload. A trustee must review it before taking action." + else + "The planner did not find a compile-verified removal for this component. This payload is diagnostic only and must not be applied as a verified plan." + let + body = String.joinWith "\n" + [ decisionMarker + , markerFor componentMarkerPrefix intervention.component + , markerFor fingerprintMarkerPrefix intervention.fingerprint + , "" + , trimTrailingNewlines $ normalize intervention.markdownBody + , "" + , payloadHeading + , "" + , payloadNote + , "" + , "```json" + , intervention.payload + , "```" + ] + when (CodeUnits.length body > 65_536) $ Left "A manual intervention issue body is larger than 65536 characters." + pure { body, component: intervention.component, fingerprint: intervention.fingerprint, title: intervention.title } + +type IndexedIssues = + { byComponent :: Map String Issue + , byFingerprint :: Map String Issue + } + +indexDecisionIssues :: Array Issue -> Either String IndexedIssues +indexDecisionIssues = Foldable.foldM insert { byComponent: Map.empty, byFingerprint: Map.empty } + where + insert indexed issue = do + when (hasDuplicateMarker decisionMarker issue) $ Left "A decision issue has duplicate decision markers." + component <- oneMarker componentMarkerPrefix issue + fingerprint <- oneMarker fingerprintMarkerPrefix issue + unless (safeMarkerValue 128 component && safeMarkerValue 200 fingerprint) $ Left "A decision issue has invalid identity markers." + when (Map.member component indexed.byComponent) $ Left "Multiple decision issues have the same component marker." + when (Map.member fingerprint indexed.byFingerprint) $ Left "Multiple decision issues have the same fingerprint marker." + pure + { byComponent: Map.insert component issue indexed.byComponent + , byFingerprint: Map.insert fingerprint issue indexed.byFingerprint + } + +oneMarker :: String -> Issue -> Either String String +oneMarker prefix issue = case markers prefix issue of + [ value ] | markerFor prefix value `Array.elem` issueLines issue -> pure value + _ -> Left "A decision issue has malformed identity markers." + +markers :: String -> Issue -> Array String +markers prefix issue = Array.mapMaybe extract (issueLines issue) + where + extract line = String.stripPrefix (String.Pattern prefix) line >>= String.stripSuffix (String.Pattern markerSuffix) + +markerFor :: String -> String -> String +markerFor prefix value = prefix <> value <> markerSuffix + +safeMarkerValue :: Int -> String -> Boolean +safeMarkerValue limit value = + CodeUnits.length value > 0 + && CodeUnits.length value + <= limit + && not (String.contains (String.Pattern "\n") value) + && not (String.contains (String.Pattern "\r") value) + && not (String.contains (String.Pattern "") value) + +hasReservedMarker :: String -> Boolean +hasReservedMarker = String.split (String.Pattern "\n") + >>> any (isJust <<< String.stripPrefix (String.Pattern "