diff --git a/app-e2e/spago.yaml b/app-e2e/spago.yaml index fb3804b9..90002234 100644 --- a/app-e2e/spago.yaml +++ b/app-e2e/spago.yaml @@ -21,8 +21,10 @@ package: - registry-app - registry-foreign - registry-lib + - registry-scripts - registry-test-utils - routing-duplex + - run - spec - spec-node - strings diff --git a/app-e2e/src/Test/E2E/Endpoint/PackageSets.purs b/app-e2e/src/Test/E2E/Endpoint/PackageSets.purs index 502853fb..14b85abe 100644 --- a/app-e2e/src/Test/E2E/Endpoint/PackageSets.purs +++ b/app-e2e/src/Test/E2E/Endpoint/PackageSets.purs @@ -16,6 +16,10 @@ spec :: E2ESpec spec = do Spec.describe "Package Sets endpoint" do Spec.it "accepts unauthenticated add/upgrade requests" do + -- First publish unsafe-coerce to create the tarball in storage + { jobId: publishJobId } <- Client.publish Fixtures.unsafeCoercePublishData + _ <- Env.pollJobOrFail publishJobId + -- Now add it to the package set { jobId } <- Client.packageSets Fixtures.packageSetAddRequest job <- Env.pollJobOrFail jobId Assert.shouldSatisfy (V1.jobInfo job).finishedAt isJust @@ -47,6 +51,10 @@ spec = do Assert.shouldSatisfy (V1.jobInfo job).finishedAt isJust Spec.it "returns existing job for duplicate requests" do + -- First publish unsafe-coerce so the package set request is valid + { jobId: publishJobId } <- Client.publish Fixtures.unsafeCoercePublishData + _ <- Env.pollJobOrFail publishJobId + -- Now test that duplicate requests return the same job ID { jobId: firstJobId } <- Client.packageSets Fixtures.packageSetAddRequest { jobId: secondJobId } <- Client.packageSets Fixtures.packageSetAddRequest Assert.shouldEqual firstJobId secondJobId diff --git a/app-e2e/src/Test/E2E/Endpoint/Publish.purs b/app-e2e/src/Test/E2E/Endpoint/Publish.purs index 47e51c95..fcb3e4e3 100644 --- a/app-e2e/src/Test/E2E/Endpoint/Publish.purs +++ b/app-e2e/src/Test/E2E/Endpoint/Publish.purs @@ -59,7 +59,7 @@ spec = do ) allJobs -- The expected compilers are: the publish compiler + all matrix job compilers - expectedCompilers = Set.fromFoldable $ Array.cons Fixtures.effectPublishData.compiler matrixCompilers + expectedCompilers = Set.fromFoldable $ maybe matrixCompilers (\c -> Array.cons c matrixCompilers) Fixtures.effectPublishData.compiler Metadata metadataAfter <- Env.readMetadata Fixtures.effect.name case Map.lookup Fixtures.effect.version metadataAfter.published of diff --git a/app-e2e/src/Test/E2E/Endpoint/Startup.purs b/app-e2e/src/Test/E2E/Endpoint/Startup.purs new file mode 100644 index 00000000..5f91ac30 --- /dev/null +++ b/app-e2e/src/Test/E2E/Endpoint/Startup.purs @@ -0,0 +1,49 @@ +-- | E2E tests for server startup behavior. +-- | +-- | IMPORTANT: These tests must run BEFORE resetTestState is called, since +-- | the jobs are created at server startup and would be cleared. +module Test.E2E.Endpoint.Startup (spec) where + +import Registry.App.Prelude + +import Data.Array as Array +import Data.String as String +import Registry.API.V1 (Job(..)) +import Registry.PackageName as PackageName +import Registry.Test.Assert as Assert +import Registry.Test.Utils as Utils +import Test.E2E.Support.Client as Client +import Test.E2E.Support.Env (E2ESpec) +import Test.Spec as Spec + +spec :: E2ESpec +spec = do + Spec.describe "check if there's a new compiler" do + Spec.it "enqueues matrix jobs for packages with no dependencies when new compiler detected" do + -- The test env has compilers 0.15.10 and 0.15.11 available. + -- prelude@6.0.1 fixture only has compiler 0.15.10 in metadata. + -- So 0.15.11 should be detected as "new" at startup, triggering + -- matrix jobs for packages with no dependencies. + jobs <- Client.getJobs + let + isNewCompilerMatrixJob :: Job -> Boolean + isNewCompilerMatrixJob = case _ of + MatrixJob { compilerVersion } -> + compilerVersion == Utils.unsafeVersion "0.15.11" + _ -> false + + matrixJobs = Array.filter isNewCompilerMatrixJob jobs + + -- Get package names from matrix jobs + matrixPackages = matrixJobs # Array.mapMaybe case _ of + MatrixJob { packageName } -> Just packageName + _ -> Nothing + + -- Should have matrix jobs for packages with no dependencies + -- prelude has no dependencies, so it should get a matrix job + let preludeName = Utils.unsafePackageName "prelude" + unless (Array.elem preludeName matrixPackages) do + Assert.fail $ "Expected matrix job for prelude with compiler 0.15.11, found: " + <> show (Array.length matrixJobs) + <> " matrix jobs for packages: " + <> String.joinWith ", " (map PackageName.print matrixPackages) diff --git a/app-e2e/src/Test/E2E/Scripts.purs b/app-e2e/src/Test/E2E/Scripts.purs new file mode 100644 index 00000000..cf55ce6d --- /dev/null +++ b/app-e2e/src/Test/E2E/Scripts.purs @@ -0,0 +1,257 @@ +-- | End-to-end tests for the cronjob scripts: +-- | - DailyImporter: Detects new package versions via GitHub tags +-- | - PackageSetUpdater: Detects recent uploads for package set inclusion +-- | - PackageTransferrer: Detects packages that moved to new GitHub locations +-- | +-- | These tests verify that the scripts properly enqueue jobs via the API. +module Test.E2E.Scripts (spec) where + +import Registry.App.Prelude + +import Control.Monad.Reader (ask) +import Data.Array as Array +import Data.Map as Map +import Effect.Aff as Aff +import Node.Path as Path +import Node.Process as Process +import Registry.API.V1 (Job(..)) +import Registry.App.CLI.Git as Git +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.Registry as Registry +import Registry.Foreign.Octokit as Octokit +import Registry.Location (Location(..)) +import Registry.Operation (AuthenticatedPackageOperation(..)) +import Registry.Operation as Operation +import Registry.PackageName as PackageName +import Registry.Scripts.DailyImporter as DailyImporter +import Registry.Scripts.PackageSetUpdater as PackageSetUpdater +import Registry.Scripts.PackageTransferrer as PackageTransferrer +import Registry.Test.Assert as Assert +import Registry.Test.Utils as Utils +import Registry.Version as Version +import Run as Run +import Run.Except as Except +import Test.E2E.Support.Client as Client +import Test.E2E.Support.Env (E2E, E2ESpec) +import Test.Spec as Spec + +-- | Constants for repeated package names and versions in tests +typeEqualityName :: PackageName.PackageName +typeEqualityName = Utils.unsafePackageName "type-equality" + +typeEqualityV401 :: Version.Version +typeEqualityV401 = Utils.unsafeVersion "4.0.1" + +typeEqualityV402 :: Version.Version +typeEqualityV402 = Utils.unsafeVersion "4.0.2" + +compiler01510 :: Version.Version +compiler01510 = Utils.unsafeVersion "0.15.10" + +spec :: E2ESpec +spec = do + Spec.describe "DailyImporter" do + Spec.it "enqueues publish jobs for new package versions discovered via GitHub tags" do + runDailyImporterScript + jobs <- Client.getJobs + + -- type-equality has v4.0.1 published but v4.0.2 in tags (per wiremock config) + let + isTypeEqualityPublishJob :: Job -> Boolean + isTypeEqualityPublishJob = case _ of + PublishJob { packageName, packageVersion } -> + packageName == typeEqualityName && packageVersion == typeEqualityV402 + _ -> false + + typeEqualityJob = Array.find isTypeEqualityPublishJob jobs + + case typeEqualityJob of + Just (PublishJob { payload }) -> do + -- Verify compiler is either Nothing (API will discover) or Just 0.15.10 + case payload.compiler of + Nothing -> pure unit + Just c | c /= compiler01510 -> + Assert.fail $ "Expected compiler 0.15.10 or Nothing but got " <> Version.print c + _ -> pure unit + Just _ -> Assert.fail "Expected PublishJob but got different job type" + Nothing -> do + let publishJobs = Array.filter isPublishJob jobs + Assert.fail $ "Expected to find a publish job for type-equality@4.0.2 but found " + <> show (Array.length publishJobs) + <> " publish jobs: " + <> show (map formatPublishJob publishJobs) + + Spec.it "does not enqueue jobs for already-published versions" do + runDailyImporterScript + jobs <- Client.getJobs + + -- type-equality v4.0.1 is already published, should NOT have a new job + let + isDuplicateJob :: Job -> Boolean + isDuplicateJob = case _ of + PublishJob { packageName, packageVersion } -> + packageName == typeEqualityName && packageVersion == typeEqualityV401 + _ -> false + + duplicateJob = Array.find isDuplicateJob jobs + + case duplicateJob of + Nothing -> pure unit -- Good, no duplicate job + Just _ -> Assert.fail "Found unexpected publish job for already-published type-equality@4.0.1" + + Spec.describe "PackageTransferrer" do + Spec.it "enqueues transfer jobs when package location changes" do + runPackageTransferrerScript + -- type-equality metadata says purescript, but tags point to new-owner + jobs <- Client.getJobs + let + isTypeEqualityTransferJob :: Job -> Boolean + isTypeEqualityTransferJob = case _ of + TransferJob { packageName } -> + packageName == typeEqualityName + _ -> false + case Array.find isTypeEqualityTransferJob jobs of + Just (TransferJob { packageName, payload }) -> do + -- Verify packageName + when (packageName /= typeEqualityName) do + Assert.fail $ "Wrong package name: " <> PackageName.print packageName + -- Verify newLocation in payload + case payload.payload of + Transfer { newLocation } -> + case newLocation of + GitHub { owner } -> + when (owner /= "new-owner") do + Assert.fail $ "Expected owner 'new-owner' but got '" <> owner <> "'" + _ -> Assert.fail "Expected GitHub location" + _ -> Assert.fail "Expected Transfer payload" + Just _ -> Assert.fail "Expected TransferJob but got different job type" + Nothing -> do + let transferJobs = Array.filter isTransferJob jobs + Assert.fail $ "Expected to find a transfer job for 'type-equality' but found " + <> show (Array.length transferJobs) + <> " transfer jobs" + + Spec.describe "PackageSetUpdater" do + Spec.it "enqueues package set update for recent uploads not in set" do + runPackageSetUpdaterScript + 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 _ -> Assert.fail "Expected PackageSetJob but got different job type" + Nothing -> Assert.fail "Expected package set job to be enqueued" + +-- | Common environment for running registry scripts in E2E tests +type ScriptSetup = + { privateKey :: String + , resourceEnv :: Env.ResourceEnv + , registryEnv :: Registry.RegistryEnv + , octokit :: Octokit.Octokit + , cache :: FilePath + , githubCacheRef :: Cache.CacheRef + } + +-- | Set up common environment for running registry scripts +setupScript :: E2E ScriptSetup +setupScript = do + { stateDir, privateKey } <- ask + liftEffect $ Process.chdir stateDir + resourceEnv <- liftEffect Env.lookupResourceEnv + token <- liftEffect $ Env.lookupRequired Env.githubToken + githubCacheRef <- liftAff Cache.newCacheRef + registryCacheRef <- liftAff Cache.newCacheRef + let cache = Path.concat [ stateDir, "scratch", ".cache" ] + octokit <- liftAff $ Octokit.newOctokit token resourceEnv.githubApiUrl + debouncer <- liftAff Registry.newDebouncer + let + registryEnv :: Registry.RegistryEnv + registryEnv = + { pull: Git.Autostash + , write: Registry.ReadOnly + , repos: Registry.defaultRepos + , workdir: Path.concat [ stateDir, "scratch" ] + , debouncer + , cacheRef: registryCacheRef + } + pure { privateKey, resourceEnv, registryEnv, octokit, cache, githubCacheRef } + +-- | Run the DailyImporter script in Submit mode +runDailyImporterScript :: E2E Unit +runDailyImporterScript = do + { resourceEnv, registryEnv, octokit, cache, githubCacheRef } <- setupScript + result <- liftAff + $ DailyImporter.runDailyImport DailyImporter.Submit resourceEnv.registryApiUrl + # Except.runExcept + # Registry.interpret (Registry.handle registryEnv) + # GitHub.interpret (GitHub.handle { octokit, cache, ref: githubCacheRef }) + # Log.interpret (Log.handleTerminal Quiet) + # Env.runResourceEnv resourceEnv + # Run.runBaseAff' + case result of + Left err -> liftAff $ Aff.throwError $ Aff.error $ "DailyImporter failed: " <> err + Right _ -> pure unit + +-- | Run the PackageTransferrer script in Submit mode +runPackageTransferrerScript :: E2E Unit +runPackageTransferrerScript = do + { privateKey, resourceEnv, registryEnv, octokit, cache, githubCacheRef } <- setupScript + result <- liftAff + $ PackageTransferrer.runPackageTransferrer PackageTransferrer.Submit (Just privateKey) resourceEnv.registryApiUrl + # Except.runExcept + # Registry.interpret (Registry.handle registryEnv) + # GitHub.interpret (GitHub.handle { octokit, cache, ref: githubCacheRef }) + # Log.interpret (Log.handleTerminal Quiet) + # Env.runResourceEnv resourceEnv + # Run.runBaseAff' + case result of + Left err -> liftAff $ Aff.throwError $ Aff.error $ "PackageTransferrer failed: " <> err + Right _ -> pure unit + +-- | Run the PackageSetUpdater script in Submit mode +runPackageSetUpdaterScript :: E2E Unit +runPackageSetUpdaterScript = do + { resourceEnv, registryEnv, octokit, cache, githubCacheRef } <- setupScript + result <- liftAff + $ PackageSetUpdater.runPackageSetUpdater PackageSetUpdater.Submit resourceEnv.registryApiUrl + # Except.runExcept + # Registry.interpret (Registry.handle registryEnv) + # GitHub.interpret (GitHub.handle { octokit, cache, ref: githubCacheRef }) + # Log.interpret (Log.handleTerminal Quiet) + # Env.runResourceEnv resourceEnv + # Run.runBaseAff' + case result of + Left err -> liftAff $ Aff.throwError $ Aff.error $ "PackageSetUpdater failed: " <> err + Right _ -> pure unit + +-- | Check if a job is a PublishJob +isPublishJob :: Job -> Boolean +isPublishJob = case _ of + PublishJob _ -> true + _ -> false + +-- | Format a PublishJob for debugging output +formatPublishJob :: Job -> String +formatPublishJob = case _ of + PublishJob { packageName, packageVersion } -> + PackageName.print packageName <> "@" <> Version.print packageVersion + _ -> "" + +-- | Check if a job is a TransferJob +isTransferJob :: Job -> Boolean +isTransferJob = case _ of + TransferJob _ -> true + _ -> false + +-- | Check if a job is a PackageSetJob +isPackageSetJob :: Job -> Boolean +isPackageSetJob = case _ of + PackageSetJob _ -> true + _ -> false diff --git a/app-e2e/src/Test/E2E/Support/Env.purs b/app-e2e/src/Test/E2E/Support/Env.purs index 06c8d47b..ca988893 100644 --- a/app-e2e/src/Test/E2E/Support/Env.purs +++ b/app-e2e/src/Test/E2E/Support/Env.purs @@ -16,6 +16,7 @@ module Test.E2E.Support.Env , resetTestState , resetDatabase , resetGitFixtures + , stashGitFixtures , resetLogs , resetGitHubRequestCache , pollJobOrFail @@ -25,6 +26,7 @@ module Test.E2E.Support.Env , gitStatus , isCleanGitStatus , waitForAllMatrixJobs + , waitForAllPendingJobs , isMatrixJobFor , readMetadata , readManifestIndexEntry @@ -99,6 +101,10 @@ runE2E env = flip runReaderT env -- | Resets: database, git fixtures, storage mock, and logs. resetTestState :: E2E Unit resetTestState = do + -- Wait for any pending jobs to complete before clearing state. + -- This is important because startup jobs (like matrix jobs from new compiler + -- detection) may still be running when this is called. + waitForAllPendingJobs resetDatabase resetGitFixtures WireMock.clearStorageRequests @@ -124,9 +130,10 @@ resetDatabase = do -- | Reset the git fixtures to restore original state. -- | This restores metadata files modified by unpublish/transfer operations. -- | --- | Strategy: Reset the origin repos to their initial-fixture tag (created during --- | setup), then delete the server's scratch git clones. The server will --- | re-clone fresh copies on the next operation, ensuring a clean cache state. +-- | Strategy: Reset the origin repos to the `post-startup` tag if it exists (created +-- | by stashGitFixtures after startup jobs complete), otherwise fall back to the +-- | `initial-fixture` tag. Then delete the server's scratch git clones so the +-- | server will re-clone fresh copies on the next operation. resetGitFixtures :: E2E Unit resetGitFixtures = do { stateDir } <- ask @@ -140,13 +147,41 @@ resetGitFixtures = do deleteGitClones scratchDir where resetOrigin dir = do - void $ gitOrFail [ "reset", "--hard", "initial-fixture" ] dir + -- Try to reset to post-startup tag first, fall back to initial-fixture + tag <- hasTag "post-startup" dir + let targetTag = if tag then "post-startup" else "initial-fixture" + void $ gitOrFail [ "reset", "--hard", targetTag ] dir void $ gitOrFail [ "clean", "-fd" ] dir + hasTag tagName dir = do + result <- liftAff $ Git.gitCLI [ "tag", "-l", tagName ] (Just dir) + pure $ case result of + Right output -> String.contains (String.Pattern tagName) output + Left _ -> false + deleteGitClones scratchDir = do liftAff $ FS.Extra.remove $ Path.concat [ scratchDir, "registry" ] liftAff $ FS.Extra.remove $ Path.concat [ scratchDir, "registry-index" ] +-- | Stash the current git fixtures state by creating a `post-startup` tag. +-- | This should be called after startup jobs (like matrix jobs from new compiler +-- | detection) have completed, so that resetGitFixtures can restore to this +-- | state instead of the initial fixtures. +stashGitFixtures :: E2E Unit +stashGitFixtures = do + fixturesDir <- liftEffect $ Env.lookupRequired Env.repoFixturesDir + let + registryOrigin = Path.concat [ fixturesDir, "purescript", "registry" ] + registryIndexOrigin = Path.concat [ fixturesDir, "purescript", "registry-index" ] + createStashTag registryOrigin + createStashTag registryIndexOrigin + Console.log "Stashed git fixtures at post-startup tag" + where + createStashTag dir = do + -- Delete existing tag if present, then create new one at HEAD + void $ liftAff $ Git.gitCLI [ "tag", "-d", "post-startup" ] (Just dir) + void $ gitOrFail [ "tag", "post-startup" ] dir + -- | Clear server log files for test isolation. -- | Deletes *.log files from the scratch/logs directory but preserves the directory itself. resetLogs :: E2E Unit @@ -246,6 +281,26 @@ waitForAllMatrixJobs pkg = go 120 0 liftAff $ Aff.delay (Milliseconds 1000.0) go (attempts - 1) totalCount +-- | Wait for all pending jobs (of any type) to complete. +-- | Useful for ensuring startup jobs finish before running tests that clear the DB. +waitForAllPendingJobs :: E2E Unit +waitForAllPendingJobs = go 300 -- 5 minutes max + where + go :: Int -> E2E Unit + go 0 = liftAff $ Aff.throwError $ Aff.error "Timed out waiting for all jobs to complete" + go attempts = do + jobs <- Client.getJobs + let + pendingJobs = Array.filter (\j -> isNothing (V1.jobInfo j).finishedAt) jobs + pendingCount = Array.length pendingJobs + if pendingCount == 0 then + pure unit + else do + when (attempts `mod` 30 == 0) do + Console.log $ "Waiting for " <> show pendingCount <> " pending jobs to complete..." + liftAff $ Aff.delay (Milliseconds 1000.0) + go (attempts - 1) + -- | Check if a job is a matrix job for the given package. isMatrixJobFor :: PackageFixture -> Job -> Boolean isMatrixJobFor pkg = case _ of diff --git a/app-e2e/src/Test/E2E/Support/Fixtures.purs b/app-e2e/src/Test/E2E/Support/Fixtures.purs index 7fe0b556..961150b1 100644 --- a/app-e2e/src/Test/E2E/Support/Fixtures.purs +++ b/app-e2e/src/Test/E2E/Support/Fixtures.purs @@ -5,9 +5,11 @@ module Test.E2E.Support.Fixtures , effect , console , prelude + , unsafeCoerce , effectPublishData , effectPublishDataDifferentLocation , consolePublishData + , unsafeCoercePublishData , failingTransferData , nonexistentTransferData , trusteeAuthenticatedData @@ -62,7 +64,7 @@ effectPublishData = , subdir: Nothing } , ref: "v4.0.0" - , compiler: Utils.unsafeVersion "0.15.10" + , compiler: Just $ Utils.unsafeVersion "0.15.10" , resolutions: Nothing , version: effect.version } @@ -94,11 +96,27 @@ consolePublishData = , subdir: Nothing } , ref: "v6.1.0" - , compiler: Utils.unsafeVersion "0.15.10" + , compiler: Just $ Utils.unsafeVersion "0.15.10" , resolutions: Nothing , version: console.version } +-- | Publish data for unsafe-coerce@6.0.0, used by package set tests. +-- | Has no dependencies. Published first to create the tarball before adding to package set. +unsafeCoercePublishData :: Operation.PublishData +unsafeCoercePublishData = + { name: unsafeCoerce.name + , location: Just $ GitHub + { owner: "purescript" + , repo: "purescript-unsafe-coerce" + , subdir: Nothing + } + , ref: "v6.0.0" + , compiler: Just $ Utils.unsafeVersion "0.15.10" + , resolutions: Nothing + , version: unsafeCoerce.version + } + -- | Unpublish data for effect@4.0.0, used for publish-then-unpublish tests. effectUnpublishData :: UnpublishData effectUnpublishData = @@ -222,11 +240,11 @@ signTransfer privateKey transferData = do , signature } --- | type-equality@4.0.1 fixture package (exists in registry-index but not in initial package set) -typeEquality :: PackageFixture -typeEquality = { name: Utils.unsafePackageName "type-equality", version: Utils.unsafeVersion "4.0.1" } +-- | unsafe-coerce@6.0.0 fixture package (exists in registry-index but not in package set) +unsafeCoerce :: PackageFixture +unsafeCoerce = { name: Utils.unsafePackageName "unsafe-coerce", version: Utils.unsafeVersion "6.0.0" } --- | Package set request to add type-equality@4.0.1. +-- | Package set request to add unsafe-coerce@6.0.0. -- | This is an unauthenticated request (no signature) since adding packages -- | doesn't require trustee authentication. packageSetAddRequest :: PackageSetUpdateRequest @@ -234,7 +252,7 @@ packageSetAddRequest = let payload = PackageSetUpdate { compiler: Nothing - , packages: Map.singleton typeEquality.name (Just typeEquality.version) + , packages: Map.singleton unsafeCoerce.name (Just unsafeCoerce.version) } rawPayload = JSON.print $ CJ.encode Operation.packageSetOperationCodec payload in diff --git a/app-e2e/src/Test/Main.purs b/app-e2e/src/Test/Main.purs index a5b18d43..a0f88464 100644 --- a/app-e2e/src/Test/Main.purs +++ b/app-e2e/src/Test/Main.purs @@ -6,10 +6,12 @@ import Data.Time.Duration (Milliseconds(..)) import Test.E2E.Endpoint.Jobs as Jobs import Test.E2E.Endpoint.PackageSets as PackageSets import Test.E2E.Endpoint.Publish as Publish +import Test.E2E.Endpoint.Startup as Startup import Test.E2E.Endpoint.Transfer as Transfer import Test.E2E.Endpoint.Unpublish as Unpublish import Test.E2E.GitHubIssue as GitHubIssue -import Test.E2E.Support.Env (assertReposClean, mkTestEnv, resetTestState, runE2E) +import Test.E2E.Scripts as Scripts +import Test.E2E.Support.Env (assertReposClean, mkTestEnv, resetTestState, runE2E, stashGitFixtures, waitForAllPendingJobs) import Test.E2E.Workflow as Workflow import Test.Spec (hoistSpec) import Test.Spec as Spec @@ -21,6 +23,15 @@ main :: Effect Unit main = do env <- mkTestEnv runSpecAndExitProcess' config [ consoleReporter ] $ hoistE2E env do + -- Run startup tests FIRST, before jobs are processed + Spec.describe "Startup" Startup.spec + + -- Then wait for pending jobs and stash the git fixtures + Spec.describe "Setup" do + Spec.it "waits for startup jobs and stashes fixtures" do + waitForAllPendingJobs + stashGitFixtures + Spec.before_ resetTestState $ Spec.after_ assertReposClean $ Spec.describe "E2E Tests" do Spec.describe "Endpoints" do Spec.describe "Publish" Publish.spec @@ -32,6 +43,7 @@ main = do Spec.describe "Workflows" do Spec.describe "GitHubIssue" GitHubIssue.spec Spec.describe "Multi-operation" Workflow.spec + Spec.describe "Scripts" Scripts.spec where hoistE2E env = hoistSpec identity (\_ m -> runE2E env m) config = diff --git a/app/fixtures/github-packages/unsafe-coerce-6.0.0/bower.json b/app/fixtures/github-packages/unsafe-coerce-6.0.0/bower.json new file mode 100644 index 00000000..eb6293c5 --- /dev/null +++ b/app/fixtures/github-packages/unsafe-coerce-6.0.0/bower.json @@ -0,0 +1,21 @@ +{ + "name": "purescript-unsafe-coerce", + "homepage": "https://github.com/purescript/purescript-unsafe-coerce", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "https://github.com/purescript/purescript-unsafe-coerce.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "package.json" + ], + "devDependencies": { + "purescript-console": "^6.0.0" + } +} diff --git a/app/fixtures/github-packages/unsafe-coerce-6.0.0/src/Unsafe/Coerce.js b/app/fixtures/github-packages/unsafe-coerce-6.0.0/src/Unsafe/Coerce.js new file mode 100644 index 00000000..6c7317ae --- /dev/null +++ b/app/fixtures/github-packages/unsafe-coerce-6.0.0/src/Unsafe/Coerce.js @@ -0,0 +1,5 @@ +// module Unsafe.Coerce + +export const unsafeCoerce = function (x) { + return x; +}; diff --git a/app/fixtures/github-packages/unsafe-coerce-6.0.0/src/Unsafe/Coerce.purs b/app/fixtures/github-packages/unsafe-coerce-6.0.0/src/Unsafe/Coerce.purs new file mode 100644 index 00000000..c38fd4be --- /dev/null +++ b/app/fixtures/github-packages/unsafe-coerce-6.0.0/src/Unsafe/Coerce.purs @@ -0,0 +1,26 @@ +module Unsafe.Coerce + ( unsafeCoerce + ) where + +-- | A _highly unsafe_ function, which can be used to persuade the type system that +-- | any type is the same as any other type. When using this function, it is your +-- | (that is, the caller's) responsibility to ensure that the underlying +-- | representation for both types is the same. +-- | +-- | Because this function is extraordinarily flexible, type inference +-- | can greatly suffer. It is highly recommended to define specializations of +-- | this function rather than using it as-is. For example: +-- | +-- | ```purescript +-- | fromBoolean :: Boolean -> Json +-- | fromBoolean = unsafeCoerce +-- | ``` +-- | +-- | This way, you won't have any nasty surprises due to the inferred type being +-- | different to what you expected. +-- | +-- | After the v0.14.0 PureScript release, some of what was accomplished via +-- | `unsafeCoerce` can now be accomplished via `coerce` from +-- | `purescript-safe-coerce`. See that library's documentation for more +-- | context. +foreign import unsafeCoerce :: forall a b. a -> b diff --git a/app/fixtures/registry-storage/type-equality-4.0.2.tar.gz b/app/fixtures/registry-storage/type-equality-4.0.2.tar.gz new file mode 100644 index 00000000..75f4d4ec Binary files /dev/null and b/app/fixtures/registry-storage/type-equality-4.0.2.tar.gz differ diff --git a/app/fixtures/registry-storage/unsafe-coerce-6.0.0.tar.gz b/app/fixtures/registry-storage/unsafe-coerce-6.0.0.tar.gz new file mode 100644 index 00000000..1b91c1a6 Binary files /dev/null and b/app/fixtures/registry-storage/unsafe-coerce-6.0.0.tar.gz differ diff --git a/app/fixtures/registry/metadata/prelude.json b/app/fixtures/registry/metadata/prelude.json index 5d147db1..cba17185 100644 --- a/app/fixtures/registry/metadata/prelude.json +++ b/app/fixtures/registry/metadata/prelude.json @@ -7,8 +7,7 @@ "6.0.1": { "bytes": 31125, "compilers": [ - "0.15.10", - "0.15.11" + "0.15.10" ], "hash": "sha256-XaM78oJFCsdZxjlDbUHj8MnZidwQc4HSnfrLfliXuAc=", "publishedTime": "2022-08-18T20:04:00.000Z", diff --git a/app/src/App/API.purs b/app/src/App/API.purs index bc13300e..7df4bd6f 100644 --- a/app/src/App/API.purs +++ b/app/src/App/API.purs @@ -200,11 +200,18 @@ packageSetUpdate details = do let changeSet = candidates.accepted <#> maybe Remove Update Log.notice "Attempting to build package set update." - PackageSets.upgradeAtomic latestPackageSet (fromMaybe prevCompiler payload.compiler) changeSet >>= case _ of - Left error -> - Except.throw $ "The package set produced from this suggested update does not compile:\n\n" <> error - Right packageSet -> do - let commitMessage = PackageSets.commitMessage latestPackageSet changeSet (un PackageSet packageSet).version + 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 Registry.writePackageSet packageSet commitMessage Log.notice "Built and released a new package set! Now mirroring to the package-sets repo..." Registry.mirrorPackageSet packageSet @@ -311,6 +318,66 @@ authenticated auth = case auth.payload of type PublishEffects r = (RESOURCE_ENV + PURSUIT + REGISTRY + STORAGE + SOURCE + ARCHIVE + GITHUB + COMPILER_CACHE + LEGACY_CACHE + LOG + EXCEPT String + AFF + EFFECT + r) +-- | Resolve both compiler and resolutions for a publish operation. +-- | Will come up with some sort of plan if not provided with a compiler and/or resolutions. +resolveCompilerAndDeps + :: forall r + . CompilerIndex + -> Manifest + -> Maybe Version -- payload.compiler + -> Maybe (Map PackageName Version) -- payload.resolutions + -> Run (REGISTRY + LOG + AFF + EXCEPT String + r) { compiler :: Version, resolutions :: Map PackageName Version } +resolveCompilerAndDeps compilerIndex manifest@(Manifest { dependencies }) maybeCompiler maybeResolutions = do + Log.debug "Resolving compiler and dependencies..." + case maybeCompiler of + -- if we have a compiler we can worry about the rest of the build plan + Just compiler -> do + Log.debug $ "Using provided compiler " <> Version.print compiler + resolutions <- case maybeResolutions of + -- resolutions are provided so we just check them over + Just provided -> do + validateResolutions manifest provided + pure provided + -- no resolutions, invoke the solver with the compiler + dependencies + Nothing -> + case Operation.Validation.validateDependenciesSolve compiler manifest compilerIndex of + Left errors -> Except.throw $ formatSolverErrors errors + Right resolutions -> pure resolutions + pure { compiler, resolutions } + + -- no compiler provided, we can figure it out. We only need one for publishing anyways + Nothing -> do + Log.debug "No compiler provided, solving for compiler and resolutions" + -- If resolutions are provided, validate them against the manifest first + for_ maybeResolutions \provided -> validateResolutions manifest provided + let deps = maybe dependencies (map Range.exact) maybeResolutions + Tuple compiler resolutions <- do + allCompilers <- PursVersions.pursVersions + let + -- we pass in all compilers so the solver can pick one + allCompilersRange = Range.mk + (NonEmptyArray.head allCompilers) + (Version.bumpPatch (NonEmptyArray.last allCompilers)) + case allCompilersRange of + Nothing -> Except.throw "Could not construct compiler range" + Just range -> + case Solver.solveWithCompiler range compilerIndex deps of + Left errors -> Except.throw $ formatSolverErrors errors + Right result -> pure result + + Log.info $ "Discovered compiler " <> Version.print compiler + pure { compiler, resolutions } + where + formatSolverErrors errors = String.joinWith "\n" + [ "Could not produce valid dependencies for manifest." + , "```" + , errors # foldMapWithIndex \index error -> String.joinWith "\n" + [ "[Error " <> show (index + 1) <> "]" + , Solver.printSolverError error + ] + , "```" + ] + -- | Publish a package via the 'publish' operation. If the package has not been -- | published before then it will be registered and the given version will be -- | upload. If it has been published before then the existing metadata will be @@ -319,7 +386,7 @@ type PublishEffects r = (RESOURCE_ENV + PURSUIT + REGISTRY + STORAGE + SOURCE + -- The legacyIndex argument contains the unverified manifests produced by the -- legacy importer; these manifests can be used on legacy packages to conform -- them to the registry rule that transitive dependencies are not allowed. -publish :: forall r. Maybe Solver.TransitivizedRegistry -> PublishData -> Run (PublishEffects + r) (Maybe { dependencies :: Map PackageName Range, version :: Version }) +publish :: forall r. Maybe Solver.TransitivizedRegistry -> PublishData -> Run (PublishEffects + r) (Maybe { compiler :: Version, dependencies :: Map PackageName Range, version :: Version }) publish maybeLegacyIndex payload = do let printedName = PackageName.print payload.name @@ -394,30 +461,15 @@ publish maybeLegacyIndex payload = do Left err -> Except.throw $ Source.printFetchError err - Log.debug $ "Package downloaded to " <> downloadedPackage <> ", verifying it contains a src directory with valid modules..." - Internal.Path.readPursFiles (Path.concat [ downloadedPackage, "src" ]) >>= case _ of + Log.debug $ "Package downloaded to " <> downloadedPackage <> ", verifying it contains a src directory..." + srcPursFiles <- Internal.Path.readPursFiles (Path.concat [ downloadedPackage, "src" ]) >>= case _ of Nothing -> Except.throw $ Array.fold [ "This package has no PureScript files in its `src` directory. " , "All package sources must be in the `src` directory, with any additional " , "sources indicated by the `files` key in your manifest." ] - Just files -> - -- The 'validatePursModules' function uses language-cst-parser, which only - -- supports syntax back to 0.15.0. We'll still try to validate the package - -- but it may fail to parse. - Operation.Validation.validatePursModules files >>= case _ of - Left formattedError | payload.compiler < Purs.minLanguageCSTParser -> do - Log.debug $ "Package failed to parse in validatePursModules: " <> formattedError - Log.debug $ "Skipping check because package is published with a pre-0.15.0 compiler (" <> Version.print payload.compiler <> ")." - Left formattedError -> - Except.throw $ Array.fold - [ "This package has either malformed or disallowed PureScript module names " - , "in its source: " - , formattedError - ] - Right _ -> - Log.debug "Package contains well-formed .purs files in its src directory." + Just files -> pure files -- If the package doesn't have a purs.json we can try to make one - possible scenarios: -- - in case it has a spago.yaml then we know how to read that, and have all the info to move forward @@ -538,81 +590,97 @@ publish maybeLegacyIndex payload = do , "```" ] - case Operation.Validation.isNotPublished (Manifest receivedManifest) (Metadata metadata) of - -- If the package has been published already, then we check whether the published - -- version has made it to Pursuit or not. If it has, then we terminate here. If - -- it hasn't then we publish to Pursuit and then terminate. - Just info -> do - published <- Pursuit.getPublishedVersions receivedManifest.name >>= case _ of - Left error -> Except.throw error - Right versions -> pure versions - - case Map.lookup receivedManifest.version published of - Just url -> do - Except.throw $ String.joinWith "\n" - [ "You tried to upload a version that already exists: " <> Version.print receivedManifest.version - , "" - , "Its metadata is:" - , "```json" - , printJson Metadata.publishedMetadataCodec info - , "```" - , "" - , "and its documentation is available here:" - , url - ] + -- try to terminate early here: if the package is already published AND the docs + -- are on Pursuit, then we can wrap up here + for_ (Operation.Validation.isNotPublished (Manifest receivedManifest) (Metadata metadata)) \info -> do + published <- Pursuit.getPublishedVersions receivedManifest.name >>= case _ of + Left error -> Except.throw error + Right versions -> pure versions + for_ (Map.lookup receivedManifest.version published) \url -> + Except.throw $ String.joinWith "\n" + [ "You tried to upload a version that already exists: " <> Version.print receivedManifest.version + , "" + , "Its metadata is:" + , "```json" + , printJson Metadata.publishedMetadataCodec info + , "```" + , "" + , "and its documentation is available here:" + , url + ] - Nothing | payload.compiler < Purs.minPursuitPublish -> do - Log.notice $ Array.fold - [ "This version has already been published to the registry, but the docs have not been " - , "uploaded to Pursuit. Unfortunately, it is not possible to publish to Pursuit via the " - , "registry using compiler versions prior to " <> Version.print Purs.minPursuitPublish - , ". Please try with a later compiler." - ] - pure Nothing + -- Resolve compiler and resolutions. If compiler was not provided, + -- discover a compatible compiler based on dependencies. + Log.info "Verifying the package build plan..." + compilerIndex <- MatrixBuilder.readCompilerIndex + { compiler, resolutions: validatedResolutions } <- resolveCompilerAndDeps compilerIndex (Manifest receivedManifest) payload.compiler payload.resolutions + Log.info $ "Using compiler " <> Version.print compiler + + -- Validate PureScript module names now that we know the compiler. + -- language-cst-parser only supports syntax back to 0.15.0, so we skip for older compilers. + Operation.Validation.validatePursModules srcPursFiles >>= case _ of + Left formattedError | compiler < Purs.minLanguageCSTParser -> do + Log.debug $ "Package failed to parse in validatePursModules: " <> formattedError + Log.debug $ "Skipping check because package is published with a pre-0.15.0 compiler (" <> Version.print compiler <> ")." + Left formattedError -> + Except.throw $ Array.fold + [ "This package has either malformed or disallowed PureScript module names " + , "in its source: " + , formattedError + ] + Right _ -> + Log.debug "Package contains well-formed .purs files in its src directory." - Nothing -> do - Log.notice $ Array.fold - [ "This version has already been published to the registry, but the docs have not been " - , "uploaded to Pursuit. Skipping registry publishing and retrying Pursuit publishing..." - ] - compilerIndex <- MatrixBuilder.readCompilerIndex - verifiedResolutions <- verifyResolutions compilerIndex payload.compiler (Manifest receivedManifest) payload.resolutions - let installedResolutions = Path.concat [ tmp, ".registry" ] - buildPlan <- MatrixBuilder.resolutionsToBuildPlan verifiedResolutions - MatrixBuilder.installBuildPlan buildPlan installedResolutions - compilationResult <- Run.liftAff $ Purs.callCompiler - { command: Purs.Compile { globs: [ "src/**/*.purs", Path.concat [ installedResolutions, "*/src/**/*.purs" ] ] } - , version: Just payload.compiler - , cwd: Just downloadedPackage - } - case compilationResult of - Left compileFailure -> do - let error = MatrixBuilder.printCompilerFailure payload.compiler compileFailure - Log.error $ "Compilation failed, cannot upload to pursuit: " <> error - Except.throw "Cannot publish to Pursuit because this package failed to compile." + case Operation.Validation.isNotPublished (Manifest receivedManifest) (Metadata metadata) of + -- If the package has been published already but docs for this version are missing + -- from Pursuit (we check earlier if the docs are there, so we end up here if they are not) + -- then upload to Pursuit and terminate + Just _ | compiler < Purs.minPursuitPublish -> do + Log.notice $ Array.fold + [ "This version has already been published to the registry, but the docs have not been " + , "uploaded to Pursuit. Unfortunately, it is not possible to publish to Pursuit via the " + , "registry using compiler versions prior to " <> Version.print Purs.minPursuitPublish + , ". Please try with a later compiler." + ] + pure Nothing + + Just _ -> do + Log.notice $ Array.fold + [ "This version has already been published to the registry, but the docs have not been " + , "uploaded to Pursuit. Skipping registry publishing and retrying Pursuit publishing..." + ] + let installedResolutions = Path.concat [ tmp, ".registry" ] + buildPlan <- MatrixBuilder.resolutionsToBuildPlan validatedResolutions + MatrixBuilder.installBuildPlan buildPlan installedResolutions + compilationResult <- Run.liftAff $ Purs.callCompiler + { command: Purs.Compile { globs: [ "src/**/*.purs", Path.concat [ installedResolutions, "*/src/**/*.purs" ] ] } + , version: Just compiler + , cwd: Just downloadedPackage + } + case compilationResult of + Left compileFailure -> do + let error = MatrixBuilder.printCompilerFailure compiler compileFailure + Log.error $ "Compilation failed, cannot upload to pursuit: " <> error + Except.throw "Cannot publish to Pursuit because this package failed to compile." + Right _ -> do + Log.debug "Uploading to Pursuit" + -- While we have created a manifest from the package source, we + -- still need to ensure a purs.json file exists for 'purs publish'. + unless hadPursJson do + existingManifest <- ManifestIndex.readManifest receivedManifest.name receivedManifest.version + case existingManifest of + Nothing -> Except.throw "Version was previously published, but we could not find a purs.json file in the package source, and no existing manifest was found in the registry." + Just existing -> Run.liftAff $ writeJsonFile Manifest.codec packagePursJson existing + publishToPursuit { source: downloadedPackage, compiler, resolutions: validatedResolutions, installedResolutions } >>= case _ of + Left publishErr -> Except.throw publishErr Right _ -> do - Log.debug "Uploading to Pursuit" - -- While we have created a manifest from the package source, we - -- still need to ensure a purs.json file exists for 'purs publish'. - unless hadPursJson do - existingManifest <- ManifestIndex.readManifest receivedManifest.name receivedManifest.version - case existingManifest of - Nothing -> Except.throw "Version was previously published, but we could not find a purs.json file in the package source, and no existing manifest was found in the registry." - Just existing -> Run.liftAff $ writeJsonFile Manifest.codec packagePursJson existing - publishToPursuit { source: downloadedPackage, compiler: payload.compiler, resolutions: verifiedResolutions, installedResolutions } >>= case _ of - Left publishErr -> Except.throw publishErr - Right _ -> do - FS.Extra.remove tmp - Log.notice "Successfully uploaded package docs to Pursuit! 🎉 🚀" - pure Nothing + FS.Extra.remove tmp + Log.notice "Successfully uploaded package docs to Pursuit! 🎉 🚀" + pure Nothing -- In this case the package version has not been published, so we proceed -- with ordinary publishing. Nothing -> do - Log.info "Verifying the package build plan..." - compilerIndex <- MatrixBuilder.readCompilerIndex - validatedResolutions <- verifyResolutions compilerIndex payload.compiler (Manifest receivedManifest) payload.resolutions - Log.notice "Verifying unused and/or missing dependencies..." -- First we install the resolutions and call 'purs graph' to adjust the @@ -627,7 +695,7 @@ publish maybeLegacyIndex payload = do let pursGraph = Purs.Graph { globs: [ srcGlobs, depGlobs ] } -- We need to use the minimum compiler version that supports 'purs graph'. - let pursGraphCompiler = if payload.compiler >= Purs.minPursGraph then payload.compiler else Purs.minPursGraph + let pursGraphCompiler = if compiler >= Purs.minPursGraph then compiler else Purs.minPursGraph -- In this step we run 'purs graph' to get a graph of the package source -- and installed dependencies and use that to determine if the manifest @@ -681,7 +749,7 @@ publish maybeLegacyIndex payload = do Except.throw $ "Failed to validate unused / missing dependencies: " <> Operation.Validation.printValidateDepsError depError Just legacyIndex -> do Log.info $ "Found fixable dependency errors: " <> Operation.Validation.printValidateDepsError depError - conformLegacyManifest (Manifest receivedManifest) payload.compiler compilerIndex legacyIndex depError + conformLegacyManifest (Manifest receivedManifest) compiler compilerIndex legacyIndex depError -- If the check passes then we can simply return the manifest and -- resolutions. @@ -705,7 +773,7 @@ publish maybeLegacyIndex payload = do -- the package with exactly what is going to be uploaded. Log.notice $ Array.fold [ "Verifying package compiles using compiler " - , Version.print payload.compiler + , Version.print compiler , " and resolutions:\n" , "```json\n" , printJson (Internal.Codec.packageMap Version.codec) resolutions @@ -719,17 +787,17 @@ publish maybeLegacyIndex payload = do MatrixBuilder.installBuildPlan buildPlanForBuild installedResolutions compilationResult <- Run.liftAff $ Purs.callCompiler { command: Purs.Compile { globs: [ Path.concat [ packageSource, "src/**/*.purs" ], Path.concat [ installedResolutions, "*/src/**/*.purs" ] ] } - , version: Just payload.compiler + , version: Just compiler , cwd: Just tmp } case compilationResult of Left compileFailure -> do - let error = MatrixBuilder.printCompilerFailure payload.compiler compileFailure + let error = MatrixBuilder.printCompilerFailure compiler compileFailure Except.throw $ "Publishing failed due to a compiler error:\n\n" <> error Right _ -> do -- Cache the successful compilation so findAllCompilers can reuse it - Cache.put _compilerCache (Compilation manifest resolutions payload.compiler) { target: payload.compiler, result: Right unit } + Cache.put _compilerCache (Compilation manifest resolutions compiler) { target: compiler, result: Right unit } pure unit Log.notice "Package source is verified! Packaging tarball and uploading to the storage backend..." @@ -758,7 +826,7 @@ publish maybeLegacyIndex payload = do Storage.upload (un Manifest manifest).name (un Manifest manifest).version tarballPath Log.debug $ "Adding the new version " <> Version.print (un Manifest manifest).version <> " to the package metadata file." - let newPublishedVersion = { hash, compilers: NonEmptyArray.singleton payload.compiler, publishedTime, bytes } + let newPublishedVersion = { hash, compilers: NonEmptyArray.singleton compiler, publishedTime, bytes } let newMetadata = metadata { published = Map.insert (un Manifest manifest).version newPublishedVersion metadata.published } Registry.writeMetadata (un Manifest manifest).name (Metadata newMetadata) @@ -773,11 +841,11 @@ publish maybeLegacyIndex payload = do Log.notice "Mirrored registry operation to the legacy registry!" Log.debug "Uploading package documentation to Pursuit" - if payload.compiler >= Purs.minPursuitPublish then + if compiler >= Purs.minPursuitPublish then -- TODO: We must use the 'downloadedPackage' instead of 'packageSource' -- because Pursuit requires a git repository, and our tarball directory -- is not one. This should be changed once Pursuit no longer needs git. - publishToPursuit { source: downloadedPackage, compiler: payload.compiler, resolutions, installedResolutions } >>= case _ of + publishToPursuit { source: downloadedPackage, compiler, resolutions, installedResolutions } >>= case _ of Left publishErr -> do Log.error publishErr Log.notice $ "Failed to publish package docs to Pursuit: " <> publishErr @@ -786,25 +854,25 @@ publish maybeLegacyIndex payload = do else do Log.notice $ Array.fold [ "Skipping Pursuit publishing because this package was published with a pre-0.14.7 compiler (" - , Version.print payload.compiler + , Version.print compiler , "). If you want to publish documentation, please try again with a later compiler." ] -- Note: this only runs for the Legacy Importer. In daily circumstances (i.e. -- when running the server) this will be taken care of by followup jobs invoking -- the MatrixBuilder for each compiler version - for_ maybeLegacyIndex \_idx -> do + when (isJust maybeLegacyIndex) do Log.notice "Determining all valid compiler versions for this package..." allCompilers <- PursVersions.pursVersions - { failed: invalidCompilers, succeeded: validCompilers } <- case NonEmptyArray.fromFoldable $ NonEmptyArray.delete payload.compiler allCompilers of - Nothing -> pure { failed: Map.empty, succeeded: NonEmptySet.singleton payload.compiler } + { failed: invalidCompilers, succeeded: validCompilers } <- case NonEmptyArray.fromFoldable $ NonEmptyArray.delete compiler allCompilers of + Nothing -> pure { failed: Map.empty, succeeded: NonEmptySet.singleton compiler } Just try -> do found <- findAllCompilers { source: packageSource , manifest , compilers: try } - pure { failed: found.failed, succeeded: NonEmptySet.cons payload.compiler found.succeeded } + pure { failed: found.failed, succeeded: NonEmptySet.cons compiler found.succeeded } unless (Map.isEmpty invalidCompilers) do Log.debug $ "Some compilers failed: " <> String.joinWith ", " (map Version.print (Set.toUnfoldable (Map.keys invalidCompilers))) @@ -818,33 +886,7 @@ publish maybeLegacyIndex payload = do Log.notice "Wrote completed metadata to the registry!" FS.Extra.remove tmp - pure $ Just { dependencies: (un Manifest manifest).dependencies, version: (un Manifest manifest).version } - --- | Verify the build plan for the package. If the user provided a build plan, --- | we ensure that the provided versions are within the ranges listed in the --- | manifest. If not, we solve their manifest to produce a build plan. -verifyResolutions :: forall r. CompilerIndex -> Version -> Manifest -> Maybe (Map PackageName Version) -> Run (REGISTRY + LOG + AFF + EXCEPT String + r) (Map PackageName Version) -verifyResolutions compilerIndex compiler manifest resolutions = do - Log.debug "Check the submitted build plan matches the manifest" - case resolutions of - Nothing -> do - case Operation.Validation.validateDependenciesSolve compiler manifest compilerIndex of - Left errors -> do - let - printedError = String.joinWith "\n" - [ "Could not produce valid dependencies for manifest." - , "```" - , errors # foldMapWithIndex \index error -> String.joinWith "\n" - [ "[Error " <> show (index + 1) <> "]" - , Solver.printSolverError error - ] - , "```" - ] - Except.throw printedError - Right solved -> pure solved - Just provided -> do - validateResolutions manifest provided - pure provided + pure $ Just { compiler, dependencies: (un Manifest manifest).dependencies, version: (un Manifest manifest).version } validateResolutions :: forall r. Manifest -> Map PackageName Version -> Run (EXCEPT String + r) Unit validateResolutions manifest resolutions = do diff --git a/app/src/App/Main.purs b/app/src/App/Main.purs index e638cc68..8ad4fd7a 100644 --- a/app/src/App/Main.purs +++ b/app/src/App/Main.purs @@ -8,22 +8,21 @@ import Effect.Aff as Aff import Effect.Class.Console as Console import Fetch.Retry as Fetch.Retry import Node.Process as Process -import Registry.App.Server.Env (ServerEnv, createServerEnv) +import Registry.App.Server.Env (createServerEnv) import Registry.App.Server.JobExecutor as JobExecutor import Registry.App.Server.Router as Router main :: Effect Unit -main = do - createServerEnv # Aff.runAff_ case _ of - Left error -> do - Console.log $ "Failed to start server: " <> Aff.message error - Process.exit' 1 - Right env -> do - case env.vars.resourceEnv.healthchecksUrl of - Nothing -> Console.log "HEALTHCHECKS_URL not set, healthcheck pinging disabled" - Just healthchecksUrl -> Aff.launchAff_ $ healthcheck healthchecksUrl - Aff.launchAff_ $ jobExecutor env - Router.runRouter env +main = createServerEnv # Aff.runAff_ case _ of + Left error -> liftEffect do + Console.log $ "Failed to start server: " <> Aff.message error + Process.exit' 1 + Right env -> do + case env.vars.resourceEnv.healthchecksUrl of + Nothing -> Console.log "HEALTHCHECKS_URL not set, healthcheck pinging disabled" + Just healthchecksUrl -> Aff.launchAff_ $ healthcheck healthchecksUrl + Aff.launchAff_ $ withRetryLoop "Job executor" $ JobExecutor.runJobExecutor env + Router.runRouter env where healthcheck :: String -> Aff Unit healthcheck healthchecksUrl = loop limit @@ -63,20 +62,22 @@ main = do Succeeded _ -> do Console.error "Healthchecks returned non-200 status and failure limit reached, will not retry." - jobExecutor :: ServerEnv -> Aff Unit - jobExecutor env = do - loop initialRestartDelay + -- | Run an Aff action in a loop with exponential backoff on failure. + -- | If the action runs for longer than 60 seconds before failing, + -- | the restart delay resets to the initial value (heuristic for stability). + withRetryLoop :: String -> Aff (Either Aff.Error Unit) -> Aff Unit + withRetryLoop name action = loop initialRestartDelay where initialRestartDelay = Milliseconds 100.0 loop restartDelay = do start <- nowUTC - result <- JobExecutor.runJobExecutor env + result <- action end <- nowUTC Console.error case result of - Left error -> "Job executor failed: " <> Aff.message error - Right _ -> "Job executor exited for no reason." + Left error -> name <> " failed: " <> Aff.message error + Right _ -> name <> " exited for no reason." -- This is a heuristic: if the executor keeps crashing immediately, we -- restart with an exponentially increasing delay, but once the executor diff --git a/app/src/App/Server/JobExecutor.purs b/app/src/App/Server/JobExecutor.purs index 4970fa93..3963849a 100644 --- a/app/src/App/Server/JobExecutor.purs +++ b/app/src/App/Server/JobExecutor.purs @@ -106,13 +106,13 @@ executeJob _ = case _ of maybeResult <- API.publish Nothing payload -- The above operation will throw if not successful, and return a map of -- dependencies of the package only if it has not been published before. - for_ maybeResult \{ dependencies, version } -> do + for_ maybeResult \{ compiler, dependencies, version } -> do -- At this point this package has been verified with one compiler only. -- So we need to enqueue compilation jobs for (1) same package, all the other -- compilers, and (2) same compiler, all packages that depend on this one -- TODO here we are building the compiler index, but we should really cache it compilerIndex <- MatrixBuilder.readCompilerIndex - let solverData = { compiler: payload.compiler, name, version, dependencies, compilerIndex } + let solverData = { compiler, name, version, dependencies, compilerIndex } samePackageAllCompilers <- MatrixBuilder.solveForAllCompilers solverData sameCompilerAllDependants <- MatrixBuilder.solveDependantsForCompiler solverData for (Array.fromFoldable $ Set.union samePackageAllCompilers sameCompilerAllDependants) diff --git a/app/test/App/API.purs b/app/test/App/API.purs index d12fe490..e48b6b79 100644 --- a/app/test/App/API.purs +++ b/app/test/App/API.purs @@ -99,7 +99,7 @@ spec = do version = Utils.unsafeVersion "4.0.0" ref = "v4.0.0" publishArgs = - { compiler: Utils.unsafeVersion "0.15.10" + { compiler: Just $ Utils.unsafeVersion "0.15.10" , location: Just $ GitHub { owner: "purescript", repo: "purescript-effect", subdir: Nothing } , name , ref @@ -154,7 +154,9 @@ spec = do Nothing -> Except.throw $ "Expected " <> formatPackageVersion name version <> " to be in metadata." Just published -> do let many' = NonEmptyArray.toArray published.compilers - let expected = map Utils.unsafeVersion [ "0.15.10", "0.15.11" ] + -- Only 0.15.10 is expected because prelude only has 0.15.10 in metadata, + -- so the solver cannot find a solution for 0.15.11 + let expected = map Utils.unsafeVersion [ "0.15.10" ] unless (many' == expected) do Except.throw $ "Expected " <> formatPackageVersion name version <> " to have a compiler matrix of " <> Utils.unsafeStringify (map Version.print expected) <> " but got " <> Utils.unsafeStringify (map Version.print many') @@ -169,7 +171,7 @@ spec = do -- but did not have documentation make it to Pursuit. let pursuitOnlyPublishArgs = - { compiler: Utils.unsafeVersion "0.15.10" + { compiler: Just $ Utils.unsafeVersion "0.15.10" , location: Just $ GitHub { owner: "purescript", repo: "purescript-type-equality", subdir: Nothing } , name: Utils.unsafePackageName "type-equality" , ref: "v4.0.1" @@ -184,7 +186,7 @@ spec = do let transitive = { name: Utils.unsafePackageName "transitive", version: Utils.unsafeVersion "1.0.0" } transitivePublishArgs = - { compiler: Utils.unsafeVersion "0.15.10" + { compiler: Just $ Utils.unsafeVersion "0.15.10" , location: Just $ GitHub { owner: "purescript", repo: "purescript-transitive", subdir: Nothing } , name: transitive.name , ref: "v" <> Version.print transitive.version @@ -203,7 +205,8 @@ spec = do Nothing -> Except.throw $ "Expected " <> formatPackageVersion transitive.name transitive.version <> " to be in metadata." Just published -> do let many' = NonEmptyArray.toArray published.compilers - let expected = map Utils.unsafeVersion [ "0.15.10", "0.15.11" ] + -- Only 0.15.10 is expected because prelude only has 0.15.10 in metadata + let expected = map Utils.unsafeVersion [ "0.15.10" ] unless (many' == expected) do Except.throw $ "Expected " <> formatPackageVersion transitive.name transitive.version <> " to have a compiler matrix of " <> Utils.unsafeStringify (map Version.print expected) <> " but got " <> Utils.unsafeStringify (map Version.print many') @@ -267,6 +270,11 @@ spec = do -- it from scratch and will fail if effect-4.0.0 is already in storage. We have it in storage -- for the separate integration tests. FS.Extra.remove $ Path.concat [ testFixtures, "registry-storage", "effect-4.0.0.tar.gz" ] + -- Similarly, we remove type-equality files since the unit test publishes it from scratch + -- and will fail if type-equality already has metadata or storage. We have these files for + -- the separate integration tests (scheduler transfer tests). + FS.Extra.remove $ Path.concat [ testFixtures, "registry", "metadata", "type-equality.json" ] + FS.Extra.remove $ Path.concat [ testFixtures, "registry-storage", "type-equality-4.0.1.tar.gz" ] let readFixtures = do diff --git a/app/test/App/GitHubIssue.purs b/app/test/App/GitHubIssue.purs index d2c6baf1..6aaa6b3c 100644 --- a/app/test/App/GitHubIssue.purs +++ b/app/test/App/GitHubIssue.purs @@ -33,7 +33,7 @@ decodeEventsToOps = do { name: Utils.unsafePackageName "something" , ref: "v1.2.3" , version: Utils.unsafeVersion "1.2.3" - , compiler: Utils.unsafeVersion "0.15.0" + , compiler: Just $ Utils.unsafeVersion "0.15.0" , resolutions: Just $ Map.fromFoldable [ Utils.unsafePackageName "prelude" /\ Utils.unsafeVersion "1.0.0" ] , location: Nothing } @@ -50,7 +50,7 @@ decodeEventsToOps = do , ref: "v5.0.0" , version: Utils.unsafeVersion "5.0.0" , location: Just $ GitHub { subdir: Nothing, owner: "purescript", repo: "purescript-prelude" } - , compiler: Utils.unsafeVersion "0.15.0" + , compiler: Just $ Utils.unsafeVersion "0.15.0" , resolutions: Just $ Map.fromFoldable [ Utils.unsafePackageName "prelude" /\ Utils.unsafeVersion "1.0.0" ] } @@ -79,7 +79,7 @@ decodeEventsToOps = do , ref: "v5.0.0" , version: Utils.unsafeVersion "5.0.0" , location: Just $ GitHub { subdir: Nothing, owner: "purescript", repo: "purescript-prelude" } - , compiler: Utils.unsafeVersion "0.15.0" + , compiler: Just $ Utils.unsafeVersion "0.15.0" , resolutions: Nothing } diff --git a/db/schema.sql b/db/schema.sql index 65319293..17e06c8d 100644 --- a/db/schema.sql +++ b/db/schema.sql @@ -40,6 +40,8 @@ CREATE TABLE matrix_jobs ( CREATE TABLE package_set_jobs ( jobId TEXT PRIMARY KEY NOT NULL, payload JSON NOT NULL, + rawPayload TEXT NOT NULL, + signature TEXT, FOREIGN KEY (jobId) REFERENCES job_info (jobId) ON DELETE CASCADE ); CREATE TABLE logs ( diff --git a/flake.nix b/flake.nix index bbec4115..55ef5299 100644 --- a/flake.nix +++ b/flake.nix @@ -243,7 +243,7 @@ # E2E test runner script - uses same fixed test environment as test-env (writeShellScriptBin "spago-test-e2e" '' set -euo pipefail - ${testEnv.envToExports testEnv.testEnv} + ${testEnv.testRuntimeExports} exec spago run -p registry-app-e2e '') ]; diff --git a/lib/src/Operation.purs b/lib/src/Operation.purs index 7327001e..83debc9c 100644 --- a/lib/src/Operation.purs +++ b/lib/src/Operation.purs @@ -99,7 +99,7 @@ type PublishData = , location :: Maybe Location , ref :: String , version :: Version - , compiler :: Version + , compiler :: Maybe Version , resolutions :: Maybe (Map PackageName Version) } @@ -110,7 +110,7 @@ publishCodec = CJ.named "Publish" $ CJ.Record.object , location: CJ.Record.optional Location.codec , ref: CJ.string , version: Version.codec - , compiler: Version.codec + , compiler: CJ.Record.optional Version.codec , resolutions: CJ.Record.optional (Internal.Codec.packageMap Version.codec) } diff --git a/nix/overlay.nix b/nix/overlay.nix index 8ec743a3..95876187 100644 --- a/nix/overlay.nix +++ b/nix/overlay.nix @@ -54,6 +54,10 @@ let module = "Registry.Scripts.ArchiveSeeder"; description = "Seed the registry archive with tarballs for deleted GitHub repos"; }; + daily-importer = { + module = "Registry.Scripts.DailyImporter"; + description = "Check for new package versions and submit publish jobs"; + }; legacy-importer = { module = "Registry.Scripts.LegacyImporter"; description = "Import packages from legacy registries (bower, psc-package, etc.)"; @@ -64,11 +68,11 @@ let }; package-set-updater = { module = "Registry.Scripts.PackageSetUpdater"; - description = "Update package sets"; + description = "Check for recent uploads and submit package set update jobs"; }; package-transferrer = { module = "Registry.Scripts.PackageTransferrer"; - description = "Transfer packages between storage backends"; + description = "Check for moved packages and submit transfer jobs"; }; solver = { module = "Registry.Scripts.Solver"; diff --git a/nix/test/config.nix b/nix/test/config.nix index 07917444..e7975a40 100644 --- a/nix/test/config.nix +++ b/nix/test/config.nix @@ -94,6 +94,27 @@ let registryPkgs = pkgs.extend testOverlay; + # Centralized test runtime dependencies - use this in nativeBuildInputs + # to ensure all required binaries are available + testRuntimeInputs = registryPkgs.registry-runtime-deps ++ [ gitMock ]; + + # Centralized test runtime exports - use this in shell scripts to set up + # the complete test environment including PATH and GIT_BINARY. + # This is the single source of truth for test Git overrides. + testRuntimeExports = '' + ${envToExports testEnv} + export PATH="${lib.makeBinPath testRuntimeInputs}:$PATH" + export GIT_BINARY="${pkgs.git}/bin/git" + ''; + + # Complete build inputs for integration tests - combines runtime inputs with + # orchestration scripts. Use this in nativeBuildInputs for test derivations. + testBuildInputs = testRuntimeInputs ++ [ + wiremockStartScript + serverStartScript + setupGitFixtures + ]; + # Helper to create GitHub contents API response, as it returns base64-encoded content base64Response = { @@ -172,6 +193,55 @@ let }; }; + # Unsafe-coerce package helpers (unsafe-coerce@6.0.0) + unsafeCoerceBase64Response = + fileName: + base64Response { + url = "/repos/purescript/purescript-unsafe-coerce/contents/${fileName}?ref=v6.0.0"; + inherit fileName; + filePath = rootPath + "/app/fixtures/github-packages/unsafe-coerce-6.0.0/${fileName}"; + }; + + unsafeCoerce404Response = fileName: { + request = { + method = "GET"; + url = "/repos/purescript/purescript-unsafe-coerce/contents/${fileName}?ref=v6.0.0"; + }; + response = { + status = 404; + headers."Content-Type" = "application/json"; + jsonBody = { + message = "Not Found"; + documentation_url = "https://docs.github.com/rest/repos/contents#get-repository-content"; + }; + }; + }; + + # Type-equality package helpers (type-equality@4.0.2) + # Note: Uses purescript owner (actual location) not old-owner (metadata location) + typeEqualityBase64Response = + fileName: + base64Response { + url = "/repos/purescript/purescript-type-equality/contents/${fileName}?ref=v4.0.2"; + inherit fileName; + filePath = rootPath + "/app/fixtures/github-packages/type-equality-4.0.1/${fileName}"; + }; + + typeEquality404Response = fileName: { + request = { + method = "GET"; + url = "/repos/purescript/purescript-type-equality/contents/${fileName}?ref=v4.0.2"; + }; + response = { + status = 404; + headers."Content-Type" = "application/json"; + jsonBody = { + message = "Not Found"; + documentation_url = "https://docs.github.com/rest/repos/contents#get-repository-content"; + }; + }; + }; + # GitHub API wiremock mappings githubMappings = [ (effectBase64Response "bower.json") @@ -188,6 +258,20 @@ let (console404Response "spago.dhall") (console404Response "purs.json") (console404Response "package.json") + # Unsafe-coerce package (unsafe-coerce@6.0.0) + (unsafeCoerceBase64Response "bower.json") + (unsafeCoerce404Response "LICENSE") + (unsafeCoerce404Response "spago.yaml") + (unsafeCoerce404Response "spago.dhall") + (unsafeCoerce404Response "purs.json") + (unsafeCoerce404Response "package.json") + # Type-equality package (type-equality@4.0.2 for legacy imports test) + (typeEqualityBase64Response "bower.json") + (typeEqualityBase64Response "LICENSE") + (typeEquality404Response "spago.yaml") + (typeEquality404Response "spago.dhall") + (typeEquality404Response "purs.json") + (typeEquality404Response "package.json") { request = { method = "GET"; @@ -205,6 +289,57 @@ let }; }; } + # Tags for prelude package (only v6.0.1 which is already published) + { + request = { + method = "GET"; + url = "/repos/purescript/purescript-prelude/tags"; + }; + response = { + status = 200; + headers."Content-Type" = "application/json"; + jsonBody = [ + { + name = "v6.0.1"; + commit = { + sha = "abc123def456"; + url = "https://api.github.com/repos/purescript/purescript-prelude/commits/abc123def456"; + }; + } + ]; + }; + } + # Tags for type-equality package (used by two scheduler tests): + # 1. Transfer detection: metadata says purescript, commit URLs point to new-owner + # 2. Legacy imports: v4.0.2 is a new version not yet published + { + request = { + method = "GET"; + url = "/repos/purescript/purescript-type-equality/tags"; + }; + response = { + status = 200; + headers."Content-Type" = "application/json"; + jsonBody = [ + { + name = "v4.0.1"; + commit = { + sha = "type-eq-sha-401"; + # Points to new owner - scheduler detects this transfer + url = "https://api.github.com/repos/new-owner/purescript-type-equality/commits/type-eq-sha-401"; + }; + } + { + name = "v4.0.2"; + commit = { + sha = "type-eq-sha-402"; + # New version not yet published - scheduler detects for legacy import + url = "https://api.github.com/repos/new-owner/purescript-type-equality/commits/type-eq-sha-402"; + }; + } + ]; + }; + } # Accept issue comment creation (used by GitHubIssue workflow) { request = { @@ -281,10 +416,21 @@ let ) ); - # Metadata fixtures directory (to determine which packages are "published") + # Metadata fixtures directory (to determine which package versions are "published") metadataFixturesDir = rootPath + "/app/fixtures/registry/metadata"; metadataFiles = builtins.attrNames (builtins.readDir metadataFixturesDir); - publishedPackageNames = map (f: lib.removeSuffix ".json" f) metadataFiles; + + # Parse metadata files to get the actual published versions (not just package names) + # Returns a set like { "prelude-6.0.1" = true; "type-equality-4.0.1" = true; } + publishedVersions = lib.foldl' ( + acc: fileName: + let + packageName = lib.removeSuffix ".json" fileName; + metadata = builtins.fromJSON (builtins.readFile (metadataFixturesDir + "/${fileName}")); + versions = builtins.attrNames (metadata.published or { }); + in + acc // lib.genAttrs (map (v: "${packageName}-${v}") versions) (_: true) + ) { } metadataFiles; # ============================================================================ # UNIFIED STORAGE MAPPINGS WITH WIREMOCK SCENARIOS @@ -298,9 +444,9 @@ let # Scenario design: # - One scenario per package-version (e.g., "effect-4.0.0") # - WireMock scenarios always start at state "Started" - # - Published packages (has metadata): "Started" means Present (tarball available) + # - Published versions (version exists in metadata.published): "Started" means Present # - After DELETE, transitions to "Deleted" state (404 on GET) - # - Unpublished packages (no metadata): "Started" means Absent (tarball 404) + # - Unpublished versions (new version not in metadata): "Started" means Absent (404) # - After PUT upload, transitions to "Present" state # - After DELETE, transitions to "Deleted" state (404 on GET) # @@ -316,7 +462,7 @@ let pkg: let scenario = "${pkg.name}-${pkg.version}"; - isPublished = builtins.elem pkg.name publishedPackageNames; + isPublished = publishedVersions ? "${pkg.name}-${pkg.version}"; tarPath = "/${pkg.name}/${pkg.version}.tar.gz"; in if isPublished then @@ -407,7 +553,7 @@ let pkg: let scenario = "${pkg.name}-${pkg.version}"; - isPublished = builtins.elem pkg.name publishedPackageNames; + isPublished = publishedVersions ? "${pkg.name}-${pkg.version}"; escapedName = lib.replaceStrings [ "-" ] [ "\\-" ] pkg.name; listUrlPattern = "/\\?.*prefix=${escapedName}.*"; presentContents = ''${pkg.name}/${pkg.version}.tar.gz1000"abc123"''; @@ -492,7 +638,7 @@ let pkg: let scenario = "${pkg.name}-${pkg.version}"; - isPublished = builtins.elem pkg.name publishedPackageNames; + isPublished = publishedVersions ? "${pkg.name}-${pkg.version}"; escapedVersion = lib.replaceStrings [ "." ] [ "\\." ] pkg.version; urlPattern = "/${pkg.name}/${escapedVersion}\\.tar\\.gz.*"; in @@ -618,7 +764,7 @@ let pkg: let scenario = "${pkg.name}-${pkg.version}"; - isPublished = builtins.elem pkg.name publishedPackageNames; + isPublished = publishedVersions ? "${pkg.name}-${pkg.version}"; versionsUrl = "/packages/purescript-${pkg.name}/available-versions"; publishedVersionsBody = ''[["${pkg.version}","https://pursuit.purescript.org/packages/purescript-${pkg.name}/${pkg.version}"]]''; in @@ -781,7 +927,10 @@ let # Script to set up git fixtures setupGitFixtures = pkgs.writeShellApplication { name = "setup-git-fixtures"; - runtimeInputs = [ pkgs.git ]; + runtimeInputs = [ + pkgs.git + pkgs.jq + ]; text = '' FIXTURES_DIR="''${1:-${stateDir}/repo-fixtures}" @@ -800,8 +949,19 @@ let cp -r ${rootPath}/app/fixtures/{registry-index,registry,package-sets} "$FIXTURES_DIR/purescript/" cp -r ${rootPath}/app/fixtures/github-packages/effect-4.0.0 "$FIXTURES_DIR/purescript/purescript-effect" cp -r ${rootPath}/app/fixtures/github-packages/console-6.1.0 "$FIXTURES_DIR/purescript/purescript-console" + cp -r ${rootPath}/app/fixtures/github-packages/unsafe-coerce-6.0.0 "$FIXTURES_DIR/purescript/purescript-unsafe-coerce" + cp -r ${rootPath}/app/fixtures/github-packages/type-equality-4.0.1 "$FIXTURES_DIR/purescript/purescript-type-equality" chmod -R u+w "$FIXTURES_DIR/purescript" + # Set type-equality publishedTime to current time for package set update test + # This makes type-equality appear as a "recent upload" so the scheduler will + # detect it and enqueue a package set update job + current_time=$(date -u +"%Y-%m-%dT%H:%M:%S.000Z") + jq --arg time "$current_time" \ + '.published["4.0.1"].publishedTime = $time' \ + "$FIXTURES_DIR/purescript/registry/metadata/type-equality.json" > temp.json && \ + mv temp.json "$FIXTURES_DIR/purescript/registry/metadata/type-equality.json" + for repo in "$FIXTURES_DIR"/purescript/*/; do cd "$repo" git init -b master && git add . @@ -814,6 +974,12 @@ let gitbot -C "$FIXTURES_DIR/purescript/package-sets" tag -m "psc-0.15.9-20230105" psc-0.15.9-20230105 gitbot -C "$FIXTURES_DIR/purescript/purescript-effect" tag -m "v4.0.0" v4.0.0 gitbot -C "$FIXTURES_DIR/purescript/purescript-console" tag -m "v6.1.0" v6.1.0 + gitbot -C "$FIXTURES_DIR/purescript/purescript-unsafe-coerce" tag -m "v6.0.0" v6.0.0 + gitbot -C "$FIXTURES_DIR/purescript/purescript-type-equality" tag -m "v4.0.1" v4.0.1 + # Create a new commit for v4.0.2 so it's on a different commit than v4.0.1 + # (the registry rejects publishing when multiple version tags point to the same commit) + gitbot -C "$FIXTURES_DIR/purescript/purescript-type-equality" commit --allow-empty -m "v4.0.2 release" + gitbot -C "$FIXTURES_DIR/purescript/purescript-type-equality" tag -m "v4.0.2" v4.0.2 ''; }; @@ -858,8 +1024,8 @@ let serverStartScript = pkgs.writeShellScriptBin "start-server" '' set -e - # Set all test environment variables (from envDefaults + mock URLs). - ${envToExports testEnv} + # Set all test environment variables, PATH, and GIT_BINARY + ${testRuntimeExports} # STATE_DIR is required if [ -z "''${STATE_DIR:-}" ]; then @@ -871,18 +1037,12 @@ let export DATABASE_URL="sqlite:$STATE_DIR/db/registry.sqlite3" export REPO_FIXTURES_DIR="$STATE_DIR/repo-fixtures" - # PATH setup for runtime deps and git mock - export PATH="${lib.makeBinPath registryPkgs.registry-runtime-deps}:$PATH" - export PATH="${gitMock}/bin:$PATH" - export GIT_BINARY="${pkgs.git}/bin/git" - mkdir -p "$STATE_DIR/db" - # Set up git fixtures if needed - if [ ! -d "$REPO_FIXTURES_DIR/purescript" ]; then - echo "Setting up git fixtures..." - ${setupGitFixtures}/bin/setup-git-fixtures "$REPO_FIXTURES_DIR" - fi + # Always recreate git fixtures to ensure clean state + # (the setupGitFixtures script handles cleanup internally) + echo "Setting up git fixtures..." + ${setupGitFixtures}/bin/setup-git-fixtures "$REPO_FIXTURES_DIR" # Run database migrations echo "Running database migrations..." @@ -903,15 +1063,16 @@ in stateDir mockUrls testEnv - envToExports - gitMock testOverlay + testRuntimeInputs + testRuntimeExports + testBuildInputs wiremockConfigs combinedWiremockRoot - setupGitFixtures publishPayload wiremockStartScript serverStartScript + setupGitFixtures # For custom wiremock setups githubMappings storageMappings diff --git a/nix/test/integration.nix b/nix/test/integration.nix index 75b6e648..7851a26f 100644 --- a/nix/test/integration.nix +++ b/nix/test/integration.nix @@ -39,13 +39,10 @@ else pkgs.nodejs pkgs.curl pkgs.jq - pkgs.git pkgs.sqlite pkgs.nss_wrapper - testSupport.wiremockStartScript - testSupport.serverStartScript - testSupport.setupGitFixtures - ]; + ] + ++ testSupport.testBuildInputs; NODE_PATH = "${pkgs.registry-package-lock}/node_modules"; # Use nss_wrapper to resolve S3 bucket subdomain in the Nix sandbox. # The AWS SDK uses virtual-hosted style URLs (bucket.endpoint/key), so @@ -62,8 +59,8 @@ else export STATE_DIR=$TMPDIR/state export REPO_FIXTURES_DIR="$STATE_DIR/repo-fixtures" - # Export test environment variables for E2E test runners - ${testSupport.envToExports testSupport.testEnv} + # Export test environment variables, PATH, and GIT_BINARY + ${testSupport.testRuntimeExports} mkdir -p $STATE_DIR diff --git a/nix/test/test-env.nix b/nix/test/test-env.nix index 764d01c4..fbc757c3 100644 --- a/nix/test/test-env.nix +++ b/nix/test/test-env.nix @@ -89,8 +89,6 @@ let processComposeYaml = pkgs.writeText "process-compose.yaml" (builtins.toJSON processComposeConfig); - testEnvExports = testConfig.envToExports testConfig.testEnv; - # The state directory is fixed (not configurable) to avoid mismatch between # the test-env and spago-test-e2e shells. stateDir = testConfig.testEnv.STATE_DIR; @@ -102,8 +100,8 @@ let rm -rf ${stateDir} mkdir -p ${stateDir} - # Export all test environment variables - ${testEnvExports} + # Export all test environment variables, PATH, and GIT_BINARY + ${testConfig.testRuntimeExports} exec ${pkgs.process-compose}/bin/process-compose up \ -f ${processComposeYaml} \ @@ -122,13 +120,15 @@ in ; # Re-export commonly-used items from testConfig for convenience. - # This avoids verbose paths like `testEnv.testConfig.wiremockStartScript`. + # This avoids verbose paths like `testEnv.testConfig.testBuildInputs`. inherit (testConfig) + testEnv + testRuntimeInputs + testRuntimeExports + testBuildInputs wiremockStartScript serverStartScript setupGitFixtures - testEnv - envToExports ; # Full testConfig still available for less common access patterns diff --git a/scripts/src/ArchiveSeeder.purs b/scripts/src/ArchiveSeeder.purs index ef4fc774..8e86ee4f 100644 --- a/scripts/src/ArchiveSeeder.purs +++ b/scripts/src/ArchiveSeeder.purs @@ -96,7 +96,15 @@ main = launchAff_ do runAppEffects <- do debouncer <- Registry.newDebouncer - let registryEnv = { pull: Git.Autostash, write: Registry.ReadOnly, repos: Registry.defaultRepos, workdir: scratchDir, debouncer, cacheRef: registryCacheRef } + let + registryEnv = + { pull: Git.Autostash + , write: Registry.ReadOnly + , repos: Registry.defaultRepos + , workdir: scratchDir + , debouncer + , cacheRef: registryCacheRef + } token <- Env.lookupRequired Env.githubToken s3 <- lift2 { key: _, secret: _ } (Env.lookupRequired Env.spacesKey) (Env.lookupRequired Env.spacesSecret) diff --git a/scripts/src/DailyImporter.purs b/scripts/src/DailyImporter.purs new file mode 100644 index 00000000..1cc19458 --- /dev/null +++ b/scripts/src/DailyImporter.purs @@ -0,0 +1,206 @@ +-- | This script checks for new package versions by fetching GitHub tags for all +-- | packages in the registry. When a new version is discovered (a tag that hasn't +-- | been published or unpublished), it submits a publish job to the registry API. +-- | +-- | Run via Nix: +-- | nix run .#daily-importer -- --dry-run # Log what would be submitted +-- | nix run .#daily-importer -- --submit # Actually submit to the API +-- | +-- | Required environment variables: +-- | GITHUB_TOKEN - GitHub API token for fetching tags +-- | REGISTRY_API_URL - Registry API URL (default: https://registry.purescript.org) +module Registry.Scripts.DailyImporter where + +import Registry.App.Prelude + +import ArgParse.Basic (ArgParser) +import ArgParse.Basic as Arg +import Codec.JSON.DecodeError as CJ.DecodeError +import Data.Array as Array +import Data.Codec.JSON as CJ +import Data.Map as Map +import Data.Set as Set +import Effect.Aff as Aff +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.GitHub (GITHUB) +import Registry.App.Effect.GitHub as GitHub +import Registry.App.Effect.Log (LOG) +import Registry.App.Effect.Log as Log +import Registry.App.Effect.Registry (REGISTRY) +import Registry.App.Effect.Registry as Registry +import Registry.App.Legacy.LenientVersion as LenientVersion +import Registry.Foreign.Octokit as Octokit +import Registry.Location (Location(..)) +import Registry.Operation as Operation +import Registry.PackageName as PackageName +import Run (AFF, EFFECT, Run) +import Run as Run +import Run.Except (EXCEPT) +import Run.Except as Except + +data Mode = DryRun | Submit + +derive instance Eq Mode + +parser :: ArgParser Mode +parser = Arg.choose "command" + [ Arg.flag [ "dry-run" ] + "Log what would be submitted without actually calling the API." + $> DryRun + , Arg.flag [ "submit" ] + "Submit publish jobs to the registry API." + $> Submit + ] + +main :: Effect Unit +main = launchAff_ do + args <- Array.drop 2 <$> liftEffect Process.argv + + let description = "Check for new package versions and submit publish jobs to the registry API." + mode <- case Arg.parseArgs "daily-importer" description parser args of + Left err -> Console.log (Arg.printArgError err) *> liftEffect (Process.exit' 1) + Right command -> pure command + + Env.loadEnvFile ".env" + resourceEnv <- Env.lookupResourceEnv + token <- Env.lookupRequired Env.githubToken + + githubCacheRef <- Cache.newCacheRef + registryCacheRef <- Cache.newCacheRef + let cache = Path.concat [ scratchDir, ".cache" ] + + octokit <- Octokit.newOctokit token resourceEnv.githubApiUrl + debouncer <- Registry.newDebouncer + + let + registryEnv :: Registry.RegistryEnv + registryEnv = + { pull: Git.Autostash + , write: Registry.ReadOnly + , repos: Registry.defaultRepos + , workdir: scratchDir + , debouncer + , cacheRef: registryCacheRef + } + + runDailyImport mode resourceEnv.registryApiUrl + # Except.runExcept + # Registry.interpret (Registry.handle registryEnv) + # GitHub.interpret (GitHub.handle { octokit, cache, ref: githubCacheRef }) + # Log.interpret (Log.handleTerminal Normal) + # Env.runResourceEnv resourceEnv + # Run.runBaseAff' + >>= case _ of + Left err -> do + Console.error $ "Error: " <> err + liftEffect $ Process.exit' 1 + Right _ -> pure unit + +type DailyImportEffects = (REGISTRY + GITHUB + LOG + RESOURCE_ENV + EXCEPT String + AFF + EFFECT + ()) + +runDailyImport :: Mode -> URL -> Run DailyImportEffects Unit +runDailyImport mode registryApiUrl = do + Log.info "Daily Importer: checking for new package versions..." + + allMetadata <- Registry.readAllMetadata + let packages = Map.toUnfoldable allMetadata :: Array (Tuple PackageName Metadata) + + Log.info $ "Checking " <> show (Array.length packages) <> " packages for new versions..." + + submitted <- for packages \(Tuple name (Metadata metadata)) -> do + case metadata.location of + Git _ -> pure 0 -- Skip non-GitHub packages for now + GitHub { owner, repo } -> do + GitHub.listTags { owner, repo } >>= case _ of + Left err -> do + Log.debug $ "Failed to fetch tags for " <> PackageName.print name <> ": " <> Octokit.printGitHubError err + pure 0 + Right tags -> do + let + -- Combine published and unpublished versions into a set + publishedVersions = Set.fromFoldable + $ Map.keys metadata.published + <> Map.keys metadata.unpublished + + -- Parse tags as versions and filter out already published ones + newVersions = Array.catMaybes $ tags <#> \tag -> + case LenientVersion.parse tag.name of + Left _ -> Nothing -- Not a valid version tag + Right result -> + let + version = LenientVersion.version result + in + if Set.member version publishedVersions then Nothing + else Just { version, ref: tag.name } + + -- Submit publish jobs for new versions + count <- for newVersions \{ version, ref } -> do + submitPublishJob mode registryApiUrl name version ref + + pure $ Array.length $ Array.filter identity count + + let totalSubmitted = Array.foldl (+) 0 submitted + Log.info $ "Daily Importer complete. Submitted " <> show totalSubmitted <> " publish jobs." + +-- | Submit a publish job for a new package version. The compiler is not specified; the registry +-- | API will discover the latest compatible compiler based on the package's dependencies. +submitPublishJob :: Mode -> URL -> PackageName -> Version -> String -> Run DailyImportEffects Boolean +submitPublishJob mode registryApiUrl name version ref = do + let formatted = formatPackageVersion name version + + let + payload :: Operation.PublishData + payload = + { name + , version + , location: Nothing -- Use current metadata location at publish time + , ref + , compiler: Nothing -- Let the API discover the latest compatible compiler + , resolutions: Nothing + } + + case mode of + DryRun -> do + Log.info $ "[DRY RUN] Would submit publish job for " <> formatted + pure true + + Submit -> do + Log.info $ "Submitting publish job for " <> formatted + result <- Run.liftAff $ submitJob (registryApiUrl <> "/v1/publish") payload + case result of + Left err -> do + Log.error $ "Failed to submit publish job for " <> formatted <> ": " <> err + pure false + Right { jobId } -> do + Log.info $ "Submitted publish job " <> unwrap jobId <> " for " <> formatted + pure true + +-- | Submit a job to the registry API +submitJob :: String -> Operation.PublishData -> Aff (Either String V1.JobCreatedResponse) +submitJob url payload = do + let body = JSON.print $ CJ.encode Operation.publishCodec payload + result <- Aff.attempt $ Fetch.fetch url + { method: POST + , headers: { "Content-Type": "application/json" } + , body + } + 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.jobCreatedResponseCodec json) of + Left err -> pure $ Left $ "Failed to parse response: " <> err + Right r -> pure $ Right r + else + pure $ Left $ "HTTP " <> show response.status <> ": " <> responseBody diff --git a/scripts/src/LegacyImporter.purs b/scripts/src/LegacyImporter.purs index 0e816edd..d057db1c 100644 --- a/scripts/src/LegacyImporter.purs +++ b/scripts/src/LegacyImporter.purs @@ -211,7 +211,15 @@ main = launchAff_ do -- uploaded and manifests and metadata are written, committed, and pushed. runAppEffects <- do debouncer <- Registry.newDebouncer - let registryEnv pull write = { pull, write, repos: Registry.defaultRepos, workdir: scratchDir, debouncer, cacheRef: registryCacheRef } + let + registryEnv pull write = + { pull + , write + , repos: Registry.defaultRepos + , workdir: scratchDir + , debouncer + , cacheRef: registryCacheRef + } case mode of DryRun -> do token <- Env.lookupRequired Env.githubToken @@ -561,7 +569,7 @@ runLegacyImport logs = do , location: Just manifest.location , ref , version: manifest.version - , compiler + , compiler: Just compiler , resolutions: Just resolutions } Run.Except.runExcept (API.publish (Just legacyIndex) payload) >>= case _ of diff --git a/scripts/src/PackageDeleter.purs b/scripts/src/PackageDeleter.purs index 257a7b1a..61bfca71 100644 --- a/scripts/src/PackageDeleter.purs +++ b/scripts/src/PackageDeleter.purs @@ -247,6 +247,6 @@ deleteVersion arguments name version = do , name: name , ref: manifest.ref , version: version - , compiler: unsafeFromRight $ Version.parse "0.15.4" + , compiler: Just $ unsafeFromRight $ Version.parse "0.15.4" , resolutions: Nothing } diff --git a/scripts/src/PackageSetUpdater.purs b/scripts/src/PackageSetUpdater.purs index 29423cf7..8113a495 100644 --- a/scripts/src/PackageSetUpdater.purs +++ b/scripts/src/PackageSetUpdater.purs @@ -1,192 +1,225 @@ +-- | This script checks for packages recently uploaded to the registry and +-- | submits package set update jobs to add them to the package set. +-- | +-- | Run via Nix: +-- | nix run .#package-set-updater -- --dry-run # Log what would be submitted +-- | nix run .#package-set-updater -- --submit # Actually submit to the API +-- | +-- | Required environment variables: +-- | GITHUB_TOKEN - GitHub API token +-- | REGISTRY_API_URL - Registry API URL (default: https://registry.purescript.org) module Registry.Scripts.PackageSetUpdater where import Registry.App.Prelude import ArgParse.Basic (ArgParser) import ArgParse.Basic as Arg +import Codec.JSON.DecodeError as CJ.DecodeError import Data.Array as Array -import Data.Array.NonEmpty as NonEmptyArray +import Data.Codec.JSON as CJ import Data.DateTime as DateTime -import Data.FoldableWithIndex (foldMapWithIndex) -import Data.Formatter.DateTime as Formatter.DateTime import Data.Map as Map -import Data.Number.Format as Number.Format -import Data.String as String import Data.Time.Duration (Hours(..)) import Effect.Aff as Aff 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.GitHub (GITHUB) import Registry.App.Effect.GitHub as GitHub import Registry.App.Effect.Log (LOG) import Registry.App.Effect.Log as Log -import Registry.App.Effect.PackageSets (Change(..), PACKAGE_SETS) import Registry.App.Effect.PackageSets as PackageSets import Registry.App.Effect.Registry (REGISTRY) 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.Internal.Format as Internal.Format +import Registry.Operation (PackageSetOperation(..)) +import Registry.Operation as Operation +import Registry.PackageName as PackageName +import Registry.PackageSet (PackageSet(..)) import Registry.Version as Version import Run (AFF, EFFECT, Run) import Run as Run import Run.Except (EXCEPT) import Run.Except as Except -data PublishMode = GeneratePackageSet | CommitPackageSet +data Mode = DryRun | Submit -derive instance Eq PublishMode +derive instance Eq Mode -parser :: ArgParser PublishMode +parser :: ArgParser Mode parser = Arg.choose "command" - [ Arg.flag [ "generate" ] - "Generate a new package set without committing the results." - $> GeneratePackageSet - , Arg.flag [ "commit" ] - "Generate a new package set and commit the results." - $> CommitPackageSet + [ Arg.flag [ "dry-run" ] + "Log what would be submitted without actually calling the API." + $> DryRun + , Arg.flag [ "submit" ] + "Submit package set update jobs to the registry API." + $> Submit ] main :: Effect Unit -main = Aff.launchAff_ do +main = launchAff_ do args <- Array.drop 2 <$> liftEffect Process.argv - let description = "A script for updating the package sets." + + let description = "Check for recent uploads and submit package set update jobs to the registry API." mode <- case Arg.parseArgs "package-set-updater" description parser args of Left err -> Console.log (Arg.printArgError err) *> liftEffect (Process.exit' 1) Right command -> pure command - -- Environment - _ <- Env.loadEnvFile ".env" - - { token, write } <- case mode of - GeneratePackageSet -> do - Env.lookupOptional Env.githubToken >>= case _ of - Nothing -> do - token <- Env.lookupRequired Env.pacchettibottiToken - pure { token, write: Registry.ReadOnly } - Just token -> - pure { token, write: Registry.ReadOnly } - CommitPackageSet -> do - token <- Env.lookupRequired Env.pacchettibottiToken - pure { token, write: Registry.CommitAs (Git.pacchettibottiCommitter token) } - - -- Package sets - let packageSetsEnv = { workdir: Path.concat [ scratchDir, "package-set-build" ] } - - -- GitHub + Env.loadEnvFile ".env" resourceEnv <- Env.lookupResourceEnv - octokit <- Octokit.newOctokit token resourceEnv.githubApiUrl + token <- Env.lookupRequired Env.githubToken - -- Caching - let cache = Path.concat [ scratchDir, ".cache" ] - FS.Extra.ensureDirectory cache githubCacheRef <- Cache.newCacheRef registryCacheRef <- Cache.newCacheRef + let cache = Path.concat [ scratchDir, ".cache" ] - -- Registry + octokit <- Octokit.newOctokit token resourceEnv.githubApiUrl debouncer <- Registry.newDebouncer + let registryEnv :: Registry.RegistryEnv registryEnv = - { write - , pull: Git.ForceClean + { pull: Git.Autostash + , write: Registry.ReadOnly , repos: Registry.defaultRepos , workdir: scratchDir , debouncer , cacheRef: registryCacheRef } - -- Logging - now <- nowUTC - let logDir = Path.concat [ scratchDir, "logs" ] - FS.Extra.ensureDirectory logDir - let logFile = "package-set-updater-" <> String.take 19 (Formatter.DateTime.format Internal.Format.iso8601DateTime now) <> ".log" - let logPath = Path.concat [ logDir, logFile ] - - updater - # PackageSets.interpret (PackageSets.handle packageSetsEnv) + runPackageSetUpdater mode resourceEnv.registryApiUrl + # Except.runExcept # Registry.interpret (Registry.handle registryEnv) - # Storage.interpret (Storage.handleReadOnly cache) # GitHub.interpret (GitHub.handle { octokit, cache, ref: githubCacheRef }) - # Except.catch (\msg -> Log.error msg *> Run.liftEffect (Process.exit' 1)) - # Log.interpret (\log -> Log.handleTerminal Normal log *> Log.handleFs Verbose logPath log) + # Log.interpret (Log.handleTerminal Normal) # Env.runResourceEnv resourceEnv # Run.runBaseAff' - -updater :: forall r. Run (REGISTRY + PACKAGE_SETS + LOG + EXCEPT String + AFF + EFFECT + r) Unit -updater = do - prevPackageSet <- Registry.readLatestPackageSet >>= case _ of - Nothing -> Except.throw "No previous package set found, cannot continue." - Just set -> pure set - - PackageSets.validatePackageSet prevPackageSet - - let compiler = (un PackageSet prevPackageSet).compiler - - Log.info $ "Using compiler " <> Version.print compiler - - let uploadHours = 24.0 - recentUploads <- findRecentUploads (Hours uploadHours) - - manifestIndex <- Registry.readAllManifests - let candidates = PackageSets.validatePackageSetCandidates manifestIndex prevPackageSet (map Just recentUploads.eligible) - unless (Map.isEmpty candidates.rejected) do - Log.info $ "Some packages uploaded in the last " <> Number.Format.toString uploadHours <> " hours are not eligible for the automated package sets." - Log.info $ PackageSets.printRejections candidates.rejected - - if Map.isEmpty candidates.accepted then do - Log.info "No eligible additions, updates, or removals to produce a new package set." - else do - -- You can't remove packages via the automatic updater. - let eligible = Map.catMaybes candidates.accepted - let listPackages = foldMapWithIndex \name version -> [ formatPackageVersion name version ] - Log.info $ "Found package versions eligible for inclusion in package set: " <> Array.foldMap (append "\n - ") (listPackages eligible) - PackageSets.upgradeSequential prevPackageSet compiler (map (maybe Remove Update) candidates.accepted) >>= case _ of - Nothing -> do - Log.info "No packages could be added to the set. All packages failed." - Just { failed, succeeded, result } -> do + >>= case _ of + Left err -> do + Console.error $ "Error: " <> err + liftEffect $ Process.exit' 1 + Right _ -> pure unit + +type PackageSetUpdaterEffects = (REGISTRY + GITHUB + LOG + RESOURCE_ENV + EXCEPT String + AFF + EFFECT + ()) + +runPackageSetUpdater :: Mode -> URL -> Run PackageSetUpdaterEffects Unit +runPackageSetUpdater mode registryApiUrl = do + Log.info "Package Set Updater: checking for recent uploads..." + + -- Get the current package set + latestPackageSet <- Registry.readLatestPackageSet >>= case _ of + Nothing -> do + Log.warn "No package set found, skipping package set updates" + pure Nothing + 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." + else do + Log.info $ "Found " <> show (Map.size newOrUpdated) <> " candidates to validate" + + -- Pre-validate candidates to filter out packages with missing dependencies + manifestIndex <- Registry.readAllManifests + let candidates = PackageSets.validatePackageSetCandidates manifestIndex packageSet (map Just newOrUpdated) + + unless (Map.isEmpty candidates.rejected) do + Log.info $ "Some packages are not eligible for the package set:\n" <> PackageSets.printRejections candidates.rejected + + -- Only include accepted packages (filter out removals, keep only updates) + let accepted = Map.catMaybes candidates.accepted + + 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" + + -- Create a package set update payload let - listChanges = foldMapWithIndex \name -> case _ of - Remove -> [] - Update version -> [ formatPackageVersion name version ] - unless (Map.isEmpty failed) do - Log.info $ "Some packages could not be added to the set: " <> Array.foldMap (append "\n - ") (listChanges failed) - Log.info $ "New packages were added to the set: " <> Array.foldMap (append "\n - ") (listChanges succeeded) - -- We only include the successful changes in the commit message. - let commitMessage = PackageSets.commitMessage prevPackageSet succeeded (un PackageSet result).version - Registry.writePackageSet result commitMessage - Log.info "Built and released a new package set! Now mirroring to the package-sets repo..." - Registry.mirrorPackageSet result - Log.info "Mirrored a new legacy package set." - -type RecentUploads = - { eligible :: Map PackageName Version - , ineligible :: Map PackageName (NonEmptyArray Version) - } - -findRecentUploads :: forall r. Hours -> Run (REGISTRY + EXCEPT String + EFFECT + r) RecentUploads + payload :: Operation.PackageSetUpdateData + payload = + { compiler: Nothing -- Use current compiler + , packages: map Just accepted -- Just version = add/update + } + + 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 allMetadata <- Registry.readAllMetadata now <- nowUTC let - uploads = Map.fromFoldable do - Tuple name (Metadata metadata) <- Map.toUnfoldable allMetadata - versions <- Array.fromFoldable $ NonEmptyArray.fromArray do - Tuple version { publishedTime } <- Map.toUnfoldable metadata.published - let diff = DateTime.diff now publishedTime - guard (diff <= limit) - pure version - pure (Tuple name versions) - - deduplicated = uploads # flip foldlWithIndex { ineligible: Map.empty, eligible: Map.empty } \name acc versions -> do - let { init, last } = NonEmptyArray.unsnoc versions - case NonEmptyArray.fromArray init of - Nothing -> acc { eligible = Map.insert name last acc.eligible } - Just entries -> acc { eligible = Map.insert name last acc.eligible, ineligible = Map.insert name entries acc.ineligible } - - pure deduplicated + 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 + +-- | Submit a package set job to the registry API +submitPackageSetJob :: String -> Operation.PackageSetUpdateRequest -> Aff (Either String V1.JobCreatedResponse) +submitPackageSetJob url request = do + let body = JSON.print $ CJ.encode Operation.packageSetUpdateRequestCodec request + result <- Aff.attempt $ Fetch.fetch url + { method: POST + , headers: { "Content-Type": "application/json" } + , body + } + 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.jobCreatedResponseCodec json) of + Left err -> pure $ Left $ "Failed to parse response: " <> err + Right r -> pure $ Right r + else + pure $ Left $ "HTTP " <> show response.status <> ": " <> responseBody diff --git a/scripts/src/PackageTransferrer.purs b/scripts/src/PackageTransferrer.purs index 31e85919..8826dfc2 100644 --- a/scripts/src/PackageTransferrer.purs +++ b/scripts/src/PackageTransferrer.purs @@ -1,21 +1,37 @@ +-- | This script checks for packages that have moved to a new GitHub location +-- | and submits transfer jobs to update their registered location. +-- | +-- | Run via Nix: +-- | nix run .#package-transferrer -- --dry-run # Log what would be submitted +-- | nix run .#package-transferrer -- --submit # Actually submit to the API +-- | +-- | Required environment variables: +-- | GITHUB_TOKEN - GitHub API token for fetching tags +-- | PACCHETTIBOTTI_ED25519 - Private key for signing (only for --submit) +-- | REGISTRY_API_URL - Registry API URL (default: https://registry.purescript.org) module Registry.Scripts.PackageTransferrer where import Registry.App.Prelude +import ArgParse.Basic (ArgParser) +import ArgParse.Basic as Arg +import Codec.JSON.DecodeError as CJ.DecodeError 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.Formatter.DateTime as Formatter.DateTime import Data.Map as Map import Data.String as String -import Effect.Ref as Ref +import Effect.Aff as Aff +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.App.API as API +import Registry.API.V1 as V1 import Registry.App.Auth as Auth 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.GitHub (GITHUB) import Registry.App.Effect.GitHub as GitHub @@ -23,193 +39,197 @@ import Registry.App.Effect.Log (LOG) import Registry.App.Effect.Log as Log import Registry.App.Effect.Registry (REGISTRY) import Registry.App.Effect.Registry as Registry -import Registry.App.Effect.Storage as Storage -import Registry.App.Legacy.LenientVersion as LenientVersion -import Registry.App.Legacy.Types (RawPackageName(..)) -import Registry.Foreign.FSExtra as FS.Extra -import Registry.Foreign.Octokit (Tag) import Registry.Foreign.Octokit as Octokit -import Registry.Internal.Format as Internal.Format -import Registry.Location as Location +import Registry.Location (Location(..)) import Registry.Operation (AuthenticatedPackageOperation(..)) import Registry.Operation as Operation -import Registry.Operation.Validation as Operation.Validation import Registry.PackageName as PackageName -import Registry.Scripts.LegacyImporter as LegacyImporter -import Run (Run) +import Run (AFF, EFFECT, Run) import Run as Run import Run.Except (EXCEPT) import Run.Except as Except -import Run.Except as Run.Except + +data Mode = DryRun | Submit + +derive instance Eq Mode + +parser :: ArgParser Mode +parser = Arg.choose "command" + [ Arg.flag [ "dry-run" ] + "Log what would be submitted without actually calling the API." + $> DryRun + , Arg.flag [ "submit" ] + "Submit transfer jobs to the registry API." + $> Submit + ] main :: Effect Unit main = launchAff_ do + args <- Array.drop 2 <$> liftEffect Process.argv - -- Environment - _ <- Env.loadEnvFile ".env" - token <- Env.lookupRequired Env.pacchettibottiToken - publicKey <- Env.lookupRequired Env.pacchettibottiED25519Pub - privateKey <- Env.lookupRequired Env.pacchettibottiED25519 + let description = "Check for moved packages and submit transfer jobs to the registry API." + mode <- case Arg.parseArgs "package-transferrer" description parser args of + Left err -> Console.log (Arg.printArgError err) *> liftEffect (Process.exit' 1) + Right command -> pure command + + Env.loadEnvFile ".env" resourceEnv <- Env.lookupResourceEnv + token <- Env.lookupRequired Env.githubToken + + -- Only require pacchettibotti keys in submit mode + maybePrivateKey <- case mode of + DryRun -> pure Nothing + Submit -> Just <$> Env.lookupRequired Env.pacchettibottiED25519 - -- Caching - let cache = Path.concat [ scratchDir, ".cache" ] - FS.Extra.ensureDirectory cache githubCacheRef <- Cache.newCacheRef registryCacheRef <- Cache.newCacheRef + let cache = Path.concat [ scratchDir, ".cache" ] - -- GitHub octokit <- Octokit.newOctokit token resourceEnv.githubApiUrl - - -- Registry debouncer <- Registry.newDebouncer + let registryEnv :: Registry.RegistryEnv registryEnv = - { write: Registry.CommitAs (Git.pacchettibottiCommitter token) - , pull: Git.ForceClean + { pull: Git.Autostash + , write: Registry.ReadOnly , repos: Registry.defaultRepos , workdir: scratchDir , debouncer , cacheRef: registryCacheRef } - -- Logging - now <- nowUTC - let logDir = Path.concat [ scratchDir, "logs" ] - FS.Extra.ensureDirectory logDir - let logFile = "package-transferrer-" <> String.take 19 (Formatter.DateTime.format Internal.Format.iso8601DateTime now) <> ".log" - let logPath = Path.concat [ logDir, logFile ] - - transfer + runPackageTransferrer mode maybePrivateKey resourceEnv.registryApiUrl + # Except.runExcept # Registry.interpret (Registry.handle registryEnv) - # Storage.interpret (Storage.handleReadOnly cache) # GitHub.interpret (GitHub.handle { octokit, cache, ref: githubCacheRef }) - # Except.catch (\msg -> Log.error msg *> Run.liftEffect (Process.exit' 1)) - # Log.interpret (\log -> Log.handleTerminal Normal log *> Log.handleFs Verbose logPath log) - # Env.runPacchettiBottiEnv { privateKey, publicKey } + # Log.interpret (Log.handleTerminal Normal) # Env.runResourceEnv resourceEnv # Run.runBaseAff' + >>= case _ of + Left err -> do + Console.error $ "Error: " <> err + liftEffect $ Process.exit' 1 + Right _ -> pure unit -transfer :: forall r. Run (API.AuthenticatedEffects + r) Unit -transfer = do - Log.info "Processing legacy registry..." +type PackageTransferrerEffects = (REGISTRY + GITHUB + LOG + RESOURCE_ENV + EXCEPT String + AFF + EFFECT + ()) + +runPackageTransferrer :: Mode -> Maybe String -> URL -> Run PackageTransferrerEffects Unit +runPackageTransferrer mode maybePrivateKey registryApiUrl = do + Log.info "Package Transferrer: checking for package transfers..." allMetadata <- Registry.readAllMetadata - { bower, new } <- Registry.readLegacyRegistry - let packages = Map.union bower new - Log.info "Reading latest locations for legacy registry packages..." - locations <- latestLocations allMetadata packages - let needsTransfer = Map.catMaybes locations - case Map.size needsTransfer of + + -- Check each package for location changes + transfersNeeded <- Array.catMaybes <$> for (Map.toUnfoldable allMetadata) \(Tuple name (Metadata metadata)) -> + case metadata.location of + Git _ -> pure Nothing -- Skip non-GitHub packages + GitHub registered -> do + -- Fetch tags to see if repo has moved + GitHub.listTags { owner: registered.owner, repo: registered.repo } >>= case _ of + Left _ -> pure Nothing -- Can't fetch tags, skip + Right tags | Array.null tags -> pure Nothing -- No tags, skip + Right tags -> case Array.head tags of + Nothing -> pure Nothing + Just tag -> + -- Parse the tag URL to get actual current location + case tagUrlToRepoUrl tag.url of + Nothing -> pure Nothing + Just actual + | locationsMatch registered actual -> pure Nothing -- No change + | otherwise -> pure $ Just + { name + , newLocation: GitHub { owner: actual.owner, repo: actual.repo, subdir: registered.subdir } + } + + case Array.length transfersNeeded of 0 -> Log.info "No packages require transferring." n -> do - Log.info $ Array.fold [ show n, " packages need transferring: ", printJson (CJ.Common.strMap packageLocationsCodec) needsTransfer ] - _ <- transferAll packages needsTransfer - Log.info "Completed transfers!" - -transferAll :: forall r. Map String String -> Map String PackageLocations -> Run (API.AuthenticatedEffects + r) (Map String String) -transferAll packages packageLocations = do - packagesRef <- liftEffect (Ref.new packages) - forWithIndex_ packageLocations \package locations -> do - let newPackageLocation = locations.tagLocation - transferPackage package newPackageLocation - let url = locationToPackageUrl newPackageLocation - liftEffect $ Ref.modify_ (Map.insert package url) packagesRef - liftEffect $ Ref.read packagesRef - -transferPackage :: forall r. String -> Location -> Run (API.AuthenticatedEffects + r) Unit -transferPackage rawPackageName newLocation = do - name <- case PackageName.parse (stripPureScriptPrefix rawPackageName) of - Left _ -> Except.throw $ "Could not transfer " <> rawPackageName <> " because it is not a valid package name." - Right value -> pure value - - let - payload = { name, newLocation } - rawPayload = stringifyJson Operation.transferCodec payload - - { privateKey } <- Env.askPacchettiBotti - - signature <- case Auth.signPayload { privateKey, rawPayload } of - Left _ -> Except.throw "Error signing transfer." - Right signature -> pure signature + Log.info $ show n <> " packages need transferring" + for_ transfersNeeded \{ name, newLocation } -> + submitTransferJob mode maybePrivateKey registryApiUrl name newLocation + +-- | Parse GitHub API tag URL to extract owner/repo +-- | Example: https://api.github.com/repos/octocat/Hello-World/commits/abc123 +tagUrlToRepoUrl :: String -> Maybe { owner :: String, repo :: String } +tagUrlToRepoUrl url = do + noPrefix <- String.stripPrefix (String.Pattern "https://api.github.com/repos/") url + case Array.take 2 $ String.split (String.Pattern "/") noPrefix of + [ owner, repo ] -> Just { owner, repo: String.toLower repo } + _ -> Nothing + +-- | Case-insensitive comparison of GitHub locations +locationsMatch :: forall r. { owner :: String, repo :: String | r } -> { owner :: String, repo :: String } -> Boolean +locationsMatch loc1 loc2 = + String.toLower loc1.owner == String.toLower loc2.owner + && String.toLower loc1.repo + == String.toLower loc2.repo + +-- | Submit a transfer job for a package that has moved +submitTransferJob + :: Mode + -> Maybe String + -> URL + -> PackageName + -> Location + -> Run PackageTransferrerEffects Unit +submitTransferJob mode maybePrivateKey registryApiUrl name newLocation = do + let formatted = PackageName.print name + + case mode of + DryRun -> do + let + locStr = case newLocation of + GitHub { owner, repo } -> owner <> "/" <> repo + Git { url } -> url + Log.info $ "[DRY RUN] Would submit transfer job for " <> formatted <> " to " <> locStr + + Submit -> do + privateKey <- case maybePrivateKey of + Nothing -> Except.throw "PACCHETTIBOTTI_ED25519 required for --submit mode" + Just pk -> pure pk + + let + payload :: Operation.TransferData + payload = { name, newLocation } + rawPayload = JSON.print $ CJ.encode Operation.transferCodec payload + + -- Sign the payload with pacchettibotti keys + signature <- case Auth.signPayload { privateKey, rawPayload } of + Left err -> Except.throw $ "Error signing transfer for " <> formatted <> ": " <> err + Right sig -> pure sig + + let + authenticatedData :: Operation.AuthenticatedData + authenticatedData = + { payload: Transfer payload + , rawPayload + , signature + } - API.authenticated - { payload: Transfer payload - , rawPayload - , signature + Log.info $ "Submitting transfer job for " <> formatted + result <- Run.liftAff $ submitJob (registryApiUrl <> "/v1/transfer") authenticatedData + case result of + Left err -> do + Log.error $ "Failed to submit transfer job for " <> formatted <> ": " <> err + Right { jobId } -> do + Log.info $ "Submitted transfer job " <> unwrap jobId <> " for " <> formatted + +-- | Submit a transfer job to the registry API +submitJob :: String -> Operation.AuthenticatedData -> Aff (Either String V1.JobCreatedResponse) +submitJob url authData = do + let body = JSON.print $ CJ.encode Operation.authenticatedCodec authData + result <- Aff.attempt $ Fetch.fetch url + { method: POST + , headers: { "Content-Type": "application/json" } + , body } - -type PackageLocations = - { registeredLocation :: Location - , tagLocation :: Location - } - -packageLocationsCodec :: CJ.Codec PackageLocations -packageLocationsCodec = CJ.named "PackageLocations" $ CJ.Record.object - { registeredLocation: Location.codec - , tagLocation: Location.codec - } - -latestLocations :: forall r. Map PackageName Metadata -> Map String String -> Run (REGISTRY + GITHUB + LOG + EXCEPT String + r) (Map String (Maybe PackageLocations)) -latestLocations allMetadata packages = forWithIndex packages \package location -> do - let rawName = RawPackageName (stripPureScriptPrefix package) - Run.Except.runExceptAt LegacyImporter._exceptPackage (LegacyImporter.validatePackage rawName location) >>= case _ of - Left { error: LegacyImporter.PackageURLRedirects { received, registered } } -> do - let newLocation = GitHub { owner: received.owner, repo: received.repo, subdir: Nothing } - Log.info $ "Package " <> package <> " has moved to " <> locationToPackageUrl newLocation - if Operation.Validation.locationIsUnique newLocation allMetadata then do - Log.info "New location is unique; package will be transferred." - pure $ Just - { registeredLocation: GitHub { owner: registered.owner, repo: registered.repo, subdir: Nothing } - , tagLocation: newLocation - } - else do - Log.info "Package will not be transferred! New location is already in use." - pure Nothing - Left _ -> pure Nothing - Right packageResult | Array.null packageResult.tags -> pure Nothing - Right packageResult -> do - Registry.readMetadata packageResult.name >>= case _ of - Nothing -> do - Log.error $ "Cannot verify location of " <> PackageName.print packageResult.name <> " because it has no metadata." - pure Nothing - Just metadata -> case latestPackageLocations packageResult metadata of - Left error -> do - Log.warn $ "Could not verify location of " <> PackageName.print packageResult.name <> ": " <> error - pure Nothing - Right locations - | locationsMatch locations.registeredLocation locations.tagLocation -> pure Nothing - | otherwise -> pure $ Just locations - where - -- The eq instance for locations has case sensitivity, but GitHub doesn't care. - locationsMatch :: Location -> Location -> Boolean - locationsMatch (GitHub location1) (GitHub location2) = - (String.toLower location1.repo == String.toLower location2.repo) - && (String.toLower location1.owner == String.toLower location2.owner) - locationsMatch _ _ = - unsafeCrashWith "Only GitHub locations can be considered in legacy registries." - -latestPackageLocations :: LegacyImporter.PackageResult -> Metadata -> Either String PackageLocations -latestPackageLocations package (Metadata { location, published }) = do - let - isMatchingTag :: Version -> Tag -> Boolean - isMatchingTag version tag = fromMaybe false do - tagVersion <- hush $ LenientVersion.parse tag.name - pure $ version == LenientVersion.version tagVersion - - matchingTag <- do - if Map.isEmpty published then do - note "No repo tags exist" $ Array.head package.tags - else do - Tuple version _ <- note "No published versions" $ Array.last (Map.toUnfoldable published) - note "No versions match repo tags" $ Array.find (isMatchingTag version) package.tags - tagUrl <- note ("Could not parse tag url " <> matchingTag.url) $ LegacyImporter.tagUrlToRepoUrl matchingTag.url - let tagLocation = GitHub { owner: tagUrl.owner, repo: tagUrl.repo, subdir: Nothing } - pure { registeredLocation: location, tagLocation } - -locationToPackageUrl :: Location -> String -locationToPackageUrl = case _ of - GitHub { owner, repo } -> - Array.fold [ "https://github.com/", owner, "/", repo, ".git" ] - Git _ -> - unsafeCrashWith "Git urls cannot be registered." + 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.jobCreatedResponseCodec json) of + Left err -> pure $ Left $ "Failed to parse response: " <> err + Right r -> pure $ Right r + else + pure $ Left $ "HTTP " <> show response.status <> ": " <> responseBody diff --git a/scripts/src/Solver.purs b/scripts/src/Solver.purs index ce615b5a..cd047a1c 100644 --- a/scripts/src/Solver.purs +++ b/scripts/src/Solver.purs @@ -117,7 +117,15 @@ main = launchAff_ do FS.Extra.ensureDirectory cache debouncer <- Registry.newDebouncer - let registryEnv pull write = { pull, write, repos: Registry.defaultRepos, workdir: scratchDir, debouncer, cacheRef: registryCacheRef } + let + registryEnv pull write = + { pull + , write + , repos: Registry.defaultRepos + , workdir: scratchDir + , debouncer + , cacheRef: registryCacheRef + } resourceEnv <- Env.lookupResourceEnv token <- Env.lookupRequired Env.githubToken octokit <- Octokit.newOctokit token resourceEnv.githubApiUrl diff --git a/spago.lock b/spago.lock index ea939dde..840903c3 100644 --- a/spago.lock +++ b/spago.lock @@ -319,8 +319,10 @@ "registry-app", "registry-foreign", "registry-lib", + "registry-scripts", "registry-test-utils", "routing-duplex", + "run", "spec", "spec-node", "strings", @@ -332,6 +334,7 @@ "ansi", "argonaut-codecs", "argonaut-core", + "argparse-basic", "arraybuffer-types", "arrays", "assert", @@ -435,6 +438,7 @@ "registry-app", "registry-foreign", "registry-lib", + "registry-scripts", "registry-test-utils", "routing-duplex", "run",