diff --git a/app/src/App/API.purs b/app/src/App/API.purs index bdd91d39..d8d80e77 100644 --- a/app/src/App/API.purs +++ b/app/src/App/API.purs @@ -669,25 +669,45 @@ publish payload = do , "```" ] - -- 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 -> + let existingPublishedVersion = Operation.Validation.isNotPublished (Manifest receivedManifest) (Metadata metadata) + existingManifest <- Registry.readManifest receivedManifest.name receivedManifest.version + for_ existingManifest \manifest -> + unless (manifest == Manifest receivedManifest) do Except.throw $ String.joinWith "\n" - [ "You tried to upload a version that already exists: " <> Version.print receivedManifest.version + [ "Cannot publish " <> formatPackageVersion receivedManifest.name receivedManifest.version <> " because a different manifest already exists in the registry index." , "" - , "Its metadata is:" + , "Existing manifest:" , "```json" - , printJson Metadata.publishedMetadataCodec info + , printJson Manifest.codec manifest , "```" , "" - , "and its documentation is available here:" - , url + , "Submitted manifest:" + , "```json" + , printJson Manifest.codec (Manifest receivedManifest) + , "```" ] + -- Try to terminate early if metadata and a manifest are present and the docs + -- are on Pursuit. Metadata without a manifest is an incomplete publication + -- which must continue so the missing registry-index state can be repaired. + for_ existingPublishedVersion \info -> + when (isJust existingManifest) 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 + ] + -- Resolve compiler and resolutions. If compiler was not provided, -- discover a compatible compiler based on dependencies. Log.info "Verifying the package build plan..." @@ -710,23 +730,50 @@ publish payload = do Right _ -> Log.debug "Package contains well-formed .purs files in its src directory." - 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 + let + reconcileExistingPublication info = do + let storedPackageDirname = PackageName.print receivedManifest.name <> "-" <> Version.print receivedManifest.version + let storedTarballPath = Path.concat [ tmp, "stored-" <> storedPackageDirname <> ".tar.gz" ] + Storage.download receivedManifest.name receivedManifest.version storedTarballPath { hash: info.hash, bytes: info.bytes } + when (isNothing existingManifest) do + Tar.extract { cwd: tmp, archive: storedTarballPath } + storedManifest <- Run.liftAff (readJsonFile Manifest.codec (Path.concat [ tmp, storedPackageDirname, "purs.json" ])) >>= case _ of + Left error -> Except.throw $ "Could not verify the manifest in the existing tarball for " <> formatPackageVersion receivedManifest.name receivedManifest.version <> ": " <> error + Right manifest -> pure manifest + unless (storedManifest == Manifest receivedManifest) do + Except.throw $ "Cannot resume publishing " <> formatPackageVersion receivedManifest.name receivedManifest.version <> " because its source manifest differs from the manifest in the existing tarball. The published ref may have changed since the first attempt." + -- Re-issue both Git writes even when the local checkout already contains + -- them. A failed push can leave a local commit ahead of its remote; the + -- idempotent write will then retry that push instead of treating local + -- state as a completed publication. + Registry.writeMetadata receivedManifest.name (Metadata metadata) + Registry.writeManifest (Manifest receivedManifest) + Log.notice "Verified the existing package tarball and reconciled its registry metadata and manifest." + + reconciledResult = + if isNothing existingManifest then + Just { compiler, dependencies: receivedManifest.dependencies, version: receivedManifest.version } + else + Nothing + + case existingPublishedVersion of + -- If metadata already contains this version, first reconcile storage and + -- both Git repositories, then retry any missing Pursuit documentation. + Just info | compiler < Purs.minPursuitPublish -> do + reconcileExistingPublication info 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 + pure reconciledResult - Just _ -> do + Just info -> do + reconcileExistingPublication info 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..." + , "uploaded to Pursuit. Retrying Pursuit publishing..." ] let installedResolutions = Path.concat [ tmp, ".registry" ] buildPlan <- MatrixBuilder.resolutionsToBuildPlan validatedResolutions @@ -747,8 +794,8 @@ publish payload = do -- still need to ensure a purs.json file exists for 'purs publish'. when (manifestOrigin /= FromPursJson) do let packagePursJson = Path.concat [ downloadedPackage, "purs.json" ] - existingManifest <- ManifestIndex.readManifest receivedManifest.name receivedManifest.version - case existingManifest of + indexedManifest <- ManifestIndex.readManifest receivedManifest.name receivedManifest.version + case indexedManifest 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 @@ -756,7 +803,7 @@ publish payload = do Right _ -> do FS.Extra.remove tmp Log.notice "Successfully uploaded package docs to Pursuit! 🎉 🚀" - pure Nothing + pure reconciledResult -- In this case the package version has not been published, so we proceed -- with ordinary publishing. @@ -918,7 +965,18 @@ publish payload = do Log.info $ "Tarball size of " <> show bytes <> " bytes is acceptable." Log.info $ "Tarball hash: " <> Sha256.print hash - Storage.upload receivedManifest.name receivedManifest.version tarballPath + Except.runExcept (Storage.upload receivedManifest.name receivedManifest.version tarballPath) >>= case _ of + Right _ -> pure unit + Left uploadError -> do + Except.runExcept (Storage.query receivedManifest.name) >>= case _ of + Right storedVersions | Set.member receivedManifest.version storedVersions -> do + let storedTarballPath = tarballPath <> ".stored" + Except.runExcept (Storage.download receivedManifest.name receivedManifest.version storedTarballPath { hash, bytes }) >>= case _ of + Left error -> + Except.throw $ "Cannot resume publishing " <> formatPackageVersion receivedManifest.name receivedManifest.version <> " because the existing tarball in storage could not be verified against the package source: " <> error + Right _ -> + Log.info $ "Verified that the existing tarball for " <> formatPackageVersion receivedManifest.name receivedManifest.version <> " matches the package source; reusing it." + _ -> Except.throw uploadError Log.debug $ "Adding the new version " <> Version.print receivedManifest.version <> " to the package metadata file." -- NOTE: The `ref` field is DEPRECATED and will be removed after 2027-01-31. -- We always write `Just ""` for backwards compatibility with older package managers. diff --git a/app/test/App/API.purs b/app/test/App/API.purs index d6374636..0db7135d 100644 --- a/app/test/App/API.purs +++ b/app/test/App/API.purs @@ -8,7 +8,7 @@ import Data.Map as Map import Data.Set as Set import Data.String as String import Data.String.NonEmpty as NonEmptyString -import Data.String.Pattern (Pattern(..)) +import Data.String.Pattern (Pattern(..), Replacement(..)) import Effect.Aff as Aff import Effect.Class.Console as Console import Effect.Ref as Ref @@ -29,6 +29,7 @@ import Registry.Foreign.FastGlob as FastGlob import Registry.Foreign.Tmp as Tmp import Registry.License as License import Registry.Location (Location(..)) +import Registry.Operation (PublishData) import Registry.PackageName as PackageName import Registry.Test.Assert as Assert import Registry.Test.Assert.Run as Assert.Run @@ -41,14 +42,90 @@ import Test.Spec as Spec -- | The environment accessible to each assertion in the test suite, derived -- | from the fixtures. +-- | +-- | `failurePlan` is shared by the effect mocks and consumed in order as its +-- | matching operations run. This lets a test observe each partial state while +-- | retrying against the same environment without special production code. type PipelineEnv = { workdir :: FilePath + , failurePlan :: Ref (Array Assert.Run.TestFailure) , metadata :: Ref (Map PackageName Metadata) + , initialMetadata :: Map PackageName Metadata , index :: Ref ManifestIndex + , initialIndex :: ManifestIndex , storageDir :: FilePath , githubDir :: FilePath } +effectName :: PackageName +effectName = Utils.unsafePackageName "effect" + +effectVersion :: Version +effectVersion = Utils.unsafeVersion "4.0.0" + +effectPublishArgs :: PublishData +effectPublishArgs = + { compiler: Just $ Utils.unsafeVersion "0.15.10" + , location: Just $ GitHub { owner: "purescript", repo: "purescript-effect", subdir: Nothing } + , name: effectName + , ref: "v4.0.0" + , version: effectVersion + , resolutions: Nothing + } + +assertPublicationState + :: forall r + . PackageName + -> Version + -> { manifest :: Boolean, metadata :: Boolean, storage :: Boolean } + -> Run (Registry.REGISTRY + Storage.STORAGE + Except.EXCEPT String + r) Unit +assertPublicationState name version expected = do + storedVersions <- Storage.query name + maybeMetadata <- Registry.readMetadata name + maybeManifest <- Registry.readManifest name version + let + actualStorage = Set.member version storedVersions + actualMetadata = case maybeMetadata of + Nothing -> false + Just (Metadata { published }) -> Map.member version published + actualManifest = isJust maybeManifest + unless (actualStorage == expected.storage) do + Except.throw $ "Expected storage presence to be " <> show expected.storage <> " but got " <> show actualStorage + unless (actualMetadata == expected.metadata) do + Except.throw $ "Expected metadata presence to be " <> show expected.metadata <> " but got " <> show actualMetadata + unless (actualManifest == expected.manifest) do + Except.throw $ "Expected manifest presence to be " <> show expected.manifest <> " but got " <> show actualManifest + +runPipelineAssertion :: PipelineEnv -> Run Assert.Run.TEST_EFFECTS Unit -> Aff Unit +runPipelineAssertion env action = do + logs <- liftEffect (Ref.new []) + result <- Assert.Run.runTestEffects + { workdir: env.workdir + , failurePlan: env.failurePlan + , logs + , index: env.index + , metadata: env.metadata + , pursuitExcludes: Set.empty + , username: "jon" + , storage: env.storageDir + , github: env.githubDir + } + action + case result of + Left exn -> do + recorded <- liftEffect (Ref.read logs) + Console.error $ String.joinWith "\n" (map (\(Tuple _ msg) -> msg) recorded) + Assert.fail $ "Got an Aff exception! " <> Aff.message exn + Right _ -> pure unit + +resetPublicationState :: forall m. MonadAff m => MonadEffect m => PipelineEnv -> m Unit +resetPublicationState env = do + liftAff $ FS.Extra.remove $ Path.concat [ env.storageDir, "effect-4.0.0.tar.gz" ] + liftEffect do + Ref.write [] env.failurePlan + Ref.write env.initialMetadata env.metadata + Ref.write env.initialIndex env.index + spec :: Spec.Spec Unit spec = do Spec.describe "Verifies build plans" do @@ -65,12 +142,13 @@ spec = do copySourceFiles Spec.describe "API pipelines run correctly" $ Spec.around withCleanEnv do - Spec.it "Publish a package successfully" \{ workdir, index, metadata, storageDir, githubDir } -> do + Spec.it "Publish a package successfully" \{ workdir, failurePlan, index, metadata, storageDir, githubDir } -> do logs <- liftEffect (Ref.new []) let testEnv = { workdir + , failurePlan , logs , index , metadata @@ -141,6 +219,80 @@ spec = do Console.error $ String.joinWith "\n" (map (\(Tuple _ msg) -> msg) recorded) Assert.fail $ "Expected to publish effect@4.0.0 but got error: " <> err Right (Right _) -> pure unit + + Spec.describe "Publication retry reconciliation" do + -- Storage, metadata, and the manifest index are the only durable writes in + -- the publication pipeline. Failures before storage leave no state to + -- reconcile; failures after the manifest happen after core publication is + -- complete. These cases cover each partial durable state plus an upload + -- whose write succeeds but whose response is ambiguous. + Spec.it "Reconciles every partial durable publication state" \env -> do + runPipelineAssertion env do + Run.liftEffect $ Ref.write + [ Assert.Run.FailStorageUploadAfterWrite + , Assert.Run.FailMetadataWrite + , Assert.Run.FailManifestWrite + ] + env.failurePlan + + -- The upload becomes durable before reporting failure. Publication + -- verifies it and continues until the planned metadata failure. + Except.runExcept (API.publish effectPublishArgs) >>= case _ of + Left error | String.contains (Pattern "Injected metadata write failure") error -> pure unit + Left error -> Except.throw $ "Expected an injected metadata failure but got: " <> error + Right _ -> Except.throw "Expected metadata writing to fail." + + assertPublicationState effectName effectVersion { storage: true, metadata: false, manifest: false } + + -- The first retry reuses storage and repairs metadata, then encounters + -- the planned manifest failure at the next durable boundary. + Except.runExcept (API.publish effectPublishArgs) >>= case _ of + Left error | String.contains (Pattern "Injected manifest write failure") error -> pure unit + Left error -> Except.throw $ "Expected an injected manifest failure but got: " <> error + Right _ -> Except.throw "Expected manifest writing to fail." + + assertPublicationState effectName effectVersion { storage: true, metadata: true, manifest: false } + + let storedTarballPath = Path.concat [ env.storageDir, "effect-4.0.0.tar.gz" ] + storedTarball <- Run.liftAff $ FS.Aff.readFile storedTarballPath + Run.liftAff $ FS.Aff.writeTextFile UTF8 storedTarballPath "corrupted tarball" + Except.runExcept (API.publish effectPublishArgs) >>= case _ of + Left error | String.contains (Pattern "Integrity check failed") error -> pure unit + Left error -> Except.throw $ "Expected an existing tarball integrity failure but got: " <> error + Right _ -> Except.throw "Expected retrying with a corrupted stored tarball to fail." + assertPublicationState effectName effectVersion { storage: true, metadata: true, manifest: false } + Run.liftAff $ FS.Aff.writeFile storedTarballPath storedTarball + + let sourceDir = Path.concat [ env.githubDir, "effect-4.0.0" ] + let bowerPath = Path.concat [ sourceDir, "bower.json" ] + let licensePath = Path.concat [ sourceDir, "LICENSE" ] + originalBower <- Run.liftAff $ FS.Aff.readTextFile UTF8 bowerPath + originalLicense <- Run.liftAff $ FS.Aff.readTextFile UTF8 licensePath + mitLicense <- Run.liftAff $ FS.Aff.readTextFile UTF8 (Path.concat [ env.githubDir, "slug-3.0.0", "LICENSE" ]) + Run.liftAff $ FS.Aff.writeTextFile UTF8 bowerPath $ String.replace (Pattern "BSD-3-Clause") (Replacement "MIT") originalBower + Run.liftAff $ FS.Aff.writeTextFile UTF8 licensePath mitLicense + Except.runExcept (API.publish effectPublishArgs) >>= case _ of + Left error | String.contains (Pattern "source manifest differs from the manifest in the existing tarball") error -> pure unit + Left error -> Except.throw $ "Expected a changed source manifest failure but got: " <> error + Right _ -> Except.throw "Expected retrying from a changed source manifest to fail." + assertPublicationState effectName effectVersion { storage: true, metadata: true, manifest: false } + + Run.liftAff $ FS.Aff.writeTextFile UTF8 bowerPath originalBower + Run.liftAff $ FS.Aff.writeTextFile UTF8 licensePath originalLicense + API.publish effectPublishArgs >>= case _ of + Just _ -> pure unit + Nothing -> Except.throw "Expected retrying the incomplete publication to report a newly completed publication." + assertPublicationState effectName effectVersion { storage: true, metadata: true, manifest: true } + resetPublicationState env + + -- Pre-existing, unverifiable storage must never be overwritten. + Run.liftAff $ FS.Aff.writeTextFile UTF8 storedTarballPath "conflicting tarball" + Except.runExcept (API.publish effectPublishArgs) >>= case _ of + Left error | String.contains (Pattern "existing tarball in storage could not be verified") error -> pure unit + Left error -> Except.throw $ "Expected an existing tarball verification failure but got: " <> error + Right _ -> Except.throw "Expected publishing with a conflicting tarball to fail." + + assertPublicationState effectName effectVersion { storage: true, metadata: false, manifest: false } where withCleanEnv :: (PipelineEnv -> Aff Unit) -> Aff Unit withCleanEnv action = do @@ -187,18 +339,22 @@ spec = do metadata <- liftEffect $ Ref.new initialMetadata initialIndex <- Registry.readManifestIndexFromDisk $ Path.concat [ testFixtures, "registry-index" ] index <- liftEffect $ Ref.new initialIndex - pure { metadata, index } + pure { initialMetadata, metadata, initialIndex, index } fixtures <- readFixtures # Log.interpret (\(Log.Log _ _ next) -> pure next) # Except.catch (\err -> Run.liftAff (Aff.throwError (Aff.error err))) # Run.runBaseAff' + failurePlan <- liftEffect $ Ref.new [] liftEffect $ Process.chdir workdir pure { workdir + , failurePlan , metadata: fixtures.metadata + , initialMetadata: fixtures.initialMetadata , index: fixtures.index + , initialIndex: fixtures.initialIndex , storageDir: Path.concat [ testFixtures, "registry-storage" ] , githubDir: Path.concat [ testFixtures, "github-packages" ] } diff --git a/app/test/Test/Assert/Run.purs b/app/test/Test/Assert/Run.purs index f6572d3e..82aa1385 100644 --- a/app/test/Test/Assert/Run.purs +++ b/app/test/Test/Assert/Run.purs @@ -2,6 +2,7 @@ -- | the various registry effects and fixtures for a minimal registry. module Registry.Test.Assert.Run ( TEST_EFFECTS + , TestFailure(..) , runBaseEffects , runRegistryMock , runTestEffects @@ -12,7 +13,6 @@ module Registry.Test.Assert.Run import Registry.App.Prelude import Data.Array as Array -import Data.Exists as Exists import Data.Foldable (class Foldable) import Data.Foldable as Foldable import Data.FunctorWithIndex (mapWithIndex) @@ -96,8 +96,29 @@ type TEST_EFFECTS = + () ) +-- | A failure injected into an effect mock. Matching handlers consume failures +-- | from the front of a plan, allowing one test to fail successive publication +-- | retries at each durable boundary while preserving their shared state. +data TestFailure + = FailStorageUploadAfterWrite + | FailMetadataWrite + | FailManifestWrite + +derive instance Eq TestFailure + +consumeFailure :: forall m. MonadEffect m => TestFailure -> Ref (Array TestFailure) -> m Boolean +consumeFailure expected ref = liftEffect do + failures <- Ref.read ref + case Array.uncons failures of + Just { head, tail } | head == expected -> do + Ref.write tail ref + pure true + _ -> + pure false + type TestEnv = { workdir :: FilePath + , failurePlan :: Ref (Array TestFailure) , logs :: Ref (Array (Tuple LogLevel String)) , metadata :: Ref (Map PackageName Metadata) , index :: Ref ManifestIndex @@ -113,18 +134,25 @@ runTestEffects env operation = Aff.attempt do githubCache <- liftEffect Cache.newCacheRef operation # Pursuit.interpret (handlePursuitMock { metadataRef: env.metadata, excludes: env.pursuitExcludes }) - # Registry.interpret (handleRegistryMock { metadataRef: env.metadata, indexRef: env.index }) + # Registry.interpret + ( handleRegistryMock + { metadataRef: env.metadata + , indexRef: env.index + , failurePlan: env.failurePlan + } + ) # PackageSets.interpret handlePackageSetsMock - # Storage.interpret (handleStorageMock { storage: env.storage }) + # Storage.interpret (handleStorageMock { storage: env.storage, failurePlan: env.failurePlan }) # Source.interpret (handleSourceMock { github: env.github }) # GitHub.interpret (handleGitHubMock { github: env.github }) -- Environments # Env.runGitHubEventEnv { username: env.username, issue: IssueNumber 1 } # Env.runPacchettiBottiEnv { publicKey: "Unimplemented", privateKey: "Unimplemented" } # Env.runResourceEnv resourceEnv - -- Caches - # runCompilerCacheMock - # runPursGraphCacheMock + -- Use the production cache interpreter so retries in one assertion reuse + -- successful graph and compilation results instead of rerunning compilers. + # Cache.interpret API._compilerCache (Cache.handleFs env.workdir) + # Cache.interpret API._pursGraphCache (Cache.handleFs env.workdir) # runGitHubCacheMemory githubCache -- Other effects # Log.interpret (\(Log level msg next) -> Run.liftEffect (Ref.modify_ (_ <> [ Tuple level (Dodo.print Dodo.plainText Dodo.twoSpaces msg) ]) env.logs) *> pure next) @@ -142,45 +170,15 @@ runBaseEffects = do -- | For testing Run functions that only need the REGISTRY effect. runRegistryMock :: forall a. Ref (Map PackageName Metadata) -> Ref ManifestIndex -> Run (EXCEPT String + LOG + REGISTRY + AFF + EFFECT + ()) a -> Aff a -runRegistryMock metadataRef indexRef = - Registry.interpret (handleRegistryMock { metadataRef, indexRef }) - >>> runBaseEffects +runRegistryMock metadataRef indexRef operation = do + failurePlan <- liftEffect $ Ref.new [] + operation + # Registry.interpret (handleRegistryMock { metadataRef, indexRef, failurePlan }) + # runBaseEffects runGitHubCacheMemory :: forall r a. CacheRef -> Run (GITHUB_CACHE + LOG + EFFECT + r) a -> Run (LOG + EFFECT + r) a runGitHubCacheMemory = Cache.interpret GitHub._githubCache <<< Cache.handleMemory -runCompilerCacheMock :: forall r a. Run (COMPILER_CACHE + LOG + r) a -> Run (LOG + r) a -runCompilerCacheMock = Cache.interpret API._compilerCache case _ of - Cache.Get key -> Exists.runExists getImpl (Cache.encodeFs key) - Cache.Put _ next -> pure next - Cache.Delete key -> Exists.runExists deleteImpl (Cache.encodeFs key) - where - getImpl :: forall x z. Cache.FsEncoding Cache.Reply x z -> Run _ x - getImpl = case _ of - Cache.AsBuffer _ (Cache.Reply reply) -> pure $ reply Nothing - Cache.AsJson _ _ (Cache.Reply reply) -> pure $ reply Nothing - - deleteImpl :: forall x z. Cache.FsEncoding Cache.Ignore x z -> Run _ x - deleteImpl = case _ of - Cache.AsBuffer _ (Cache.Ignore next) -> pure next - Cache.AsJson _ _ (Cache.Ignore next) -> pure next - -runPursGraphCacheMock :: forall r a. Run (PURS_GRAPH_CACHE + LOG + r) a -> Run (LOG + r) a -runPursGraphCacheMock = Cache.interpret API._pursGraphCache case _ of - Cache.Get key -> Exists.runExists getImpl (Cache.encodeFs key) - Cache.Put _ next -> pure next - Cache.Delete key -> Exists.runExists deleteImpl (Cache.encodeFs key) - where - getImpl :: forall x z. Cache.FsEncoding Cache.Reply x z -> Run _ x - getImpl = case _ of - Cache.AsBuffer _ (Cache.Reply reply) -> pure $ reply Nothing - Cache.AsJson _ _ (Cache.Reply reply) -> pure $ reply Nothing - - deleteImpl :: forall x z. Cache.FsEncoding Cache.Ignore x z -> Run _ x - deleteImpl = case _ of - Cache.AsBuffer _ (Cache.Ignore next) -> pure next - Cache.AsJson _ _ (Cache.Ignore next) -> pure next - type PursuitMockEnv = { excludes :: Set PackageName , metadataRef :: Ref (Map PackageName Metadata) @@ -209,6 +207,7 @@ handlePursuitMock { excludes, metadataRef } = case _ of type RegistryMockEnv = { metadataRef :: Ref (Map PackageName Metadata) , indexRef :: Ref ManifestIndex + , failurePlan :: Ref (Array TestFailure) } handleRegistryMock :: forall r a. RegistryMockEnv -> Registry a -> Run (AFF + EFFECT + r) a @@ -218,12 +217,16 @@ handleRegistryMock env = case _ of pure $ reply $ Right $ ManifestIndex.lookup name version index WriteManifest manifest reply -> do - index <- Run.liftEffect (Ref.read env.indexRef) - case ManifestIndex.insert ManifestIndex.ConsiderRanges manifest index of - Left err -> pure $ reply $ Left $ "Failed to insert manifest:\n" <> Utils.unsafeStringify manifest <> " due to an error:\n" <> Utils.unsafeStringify err - Right index' -> do - Run.liftEffect (Ref.write index' env.indexRef) - pure $ reply $ Right unit + failWrite <- consumeFailure FailManifestWrite env.failurePlan + if failWrite then do + pure $ reply $ Left "Injected manifest write failure." + else do + index <- Run.liftEffect (Ref.read env.indexRef) + case ManifestIndex.insert ManifestIndex.ConsiderRanges manifest index of + Left err -> pure $ reply $ Left $ "Failed to insert manifest:\n" <> Utils.unsafeStringify manifest <> " due to an error:\n" <> Utils.unsafeStringify err + Right index' -> do + Run.liftEffect (Ref.write index' env.indexRef) + pure $ reply $ Right unit DeleteManifest name version reply -> do index <- Run.liftEffect (Ref.read env.indexRef) @@ -242,8 +245,12 @@ handleRegistryMock env = case _ of pure $ reply $ Right $ Map.lookup name metadata WriteMetadata name metadata reply -> do - Run.liftEffect (Ref.modify_ (Map.insert name metadata) env.metadataRef) - pure $ reply $ Right unit + failWrite <- consumeFailure FailMetadataWrite env.failurePlan + if failWrite then do + pure $ reply $ Left "Injected metadata write failure." + else do + Run.liftEffect (Ref.modify_ (Map.insert name metadata) env.metadataRef) + pure $ reply $ Right unit ReadAllMetadata reply -> do metadata <- Run.liftEffect (Ref.read env.metadataRef) @@ -274,7 +281,10 @@ handlePackageSetsMock = case _ of UpgradeSequential packageSet _compilerVersion changeSet reply -> pure $ reply $ Right $ Just { failed: changeSet, succeeded: changeSet, result: packageSet } -type StorageMockEnv = { storage :: FilePath } +type StorageMockEnv = + { storage :: FilePath + , failurePlan :: Ref (Array TestFailure) + } -- We handle the storage effect by copying files to/from the provided -- upload/download directories, and listing versions based on the filenames. @@ -285,7 +295,11 @@ handleStorageMock env = case _ of Run.liftAff (Aff.attempt (FS.Aff.stat destinationPath)) >>= case _ of Left _ -> do Run.liftAff $ FS.Extra.copy { from: sourcePath, to: destinationPath, preserveTimestamps: true } - pure $ reply $ Right unit + failUpload <- consumeFailure FailStorageUploadAfterWrite env.failurePlan + if failUpload then + pure $ reply $ Left "Injected storage upload failure after writing the tarball." + else + pure $ reply $ Right unit Right _ -> pure $ reply $ Left $ "Cannot upload " <> formatPackageVersion name version <> " because it already exists in storage at path " <> destinationPath