From b768da804681dfe9dc10cf9119041c2ad77de3d8 Mon Sep 17 00:00:00 2001
From: Thomas Honeyman <hello@thomashoneyman.com>
Date: Wed, 22 Jul 2026 15:01:36 +0000
Subject: [PATCH 1/3] Make package publication retries safe

Amp-Thread-ID: https://ampcode.com/threads/T-019f8a43-a415-7373-9d19-72aed17834d0

Co-authored-by: Thomas Honeyman <admin@thomashoneyman.com>
---
 app/src/App/API.purs          | 106 +++++++++++++++++++------
 app/test/App/API.purs         | 142 +++++++++++++++++++++++++++++++++-
 app/test/Test/Assert/Run.purs |  48 +++++++++---
 3 files changed, 258 insertions(+), 38 deletions(-)

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..7dbd77e8 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
@@ -43,12 +44,76 @@ import Test.Spec as Spec
 -- | from the fixtures.
 type PipelineEnv =
   { workdir :: FilePath
+  , failNextManifestWrite :: Ref Boolean
+  , failNextMetadataWrite :: Ref Boolean
   , metadata :: Ref (Map PackageName Metadata)
   , index :: Ref 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
+    , failNextManifestWrite: env.failNextManifestWrite
+    , failNextMetadataWrite: env.failNextMetadataWrite
+    , 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
+
 spec :: Spec.Spec Unit
 spec = do
   Spec.describe "Verifies build plans" do
@@ -65,12 +130,14 @@ 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, failNextManifestWrite, failNextMetadataWrite, index, metadata, storageDir, githubDir } -> do
       logs <- liftEffect (Ref.new [])
 
       let
         testEnv =
           { workdir
+          , failNextManifestWrite
+          , failNextMetadataWrite
           , logs
           , index
           , metadata
@@ -141,6 +208,73 @@ 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.it "Retries after storage upload when metadata writing fails" \env -> do
+      liftEffect $ Ref.write true env.failNextMetadataWrite
+      runPipelineAssertion env do
+        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 }
+
+        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 }
+
+    Spec.it "Retries after metadata writing when manifest writing fails" \env -> do
+      liftEffect $ Ref.write true env.failNextManifestWrite
+      runPipelineAssertion env do
+        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 }
+
+    Spec.it "Rejects an existing tarball that does not match the package source" \env -> do
+      let storedTarballPath = Path.concat [ env.storageDir, "effect-4.0.0.tar.gz" ]
+      FS.Aff.writeTextFile UTF8 storedTarballPath "conflicting tarball"
+      runPipelineAssertion env do
+        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
@@ -194,9 +328,13 @@ spec = do
         # Except.catch (\err -> Run.liftAff (Aff.throwError (Aff.error err)))
         # Run.runBaseAff'
 
+      failNextManifestWrite <- liftEffect $ Ref.new false
+      failNextMetadataWrite <- liftEffect $ Ref.new false
       liftEffect $ Process.chdir workdir
       pure
         { workdir
+        , failNextManifestWrite
+        , failNextMetadataWrite
         , metadata: fixtures.metadata
         , index: fixtures.index
         , storageDir: Path.concat [ testFixtures, "registry-storage" ]
diff --git a/app/test/Test/Assert/Run.purs b/app/test/Test/Assert/Run.purs
index f6572d3e..e770f709 100644
--- a/app/test/Test/Assert/Run.purs
+++ b/app/test/Test/Assert/Run.purs
@@ -98,6 +98,8 @@ type TEST_EFFECTS =
 
 type TestEnv =
   { workdir :: FilePath
+  , failNextManifestWrite :: Ref Boolean
+  , failNextMetadataWrite :: Ref Boolean
   , logs :: Ref (Array (Tuple LogLevel String))
   , metadata :: Ref (Map PackageName Metadata)
   , index :: Ref ManifestIndex
@@ -113,7 +115,14 @@ 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
+            , failNextManifestWrite: env.failNextManifestWrite
+            , failNextMetadataWrite: env.failNextMetadataWrite
+            }
+        )
     # PackageSets.interpret handlePackageSetsMock
     # Storage.interpret (handleStorageMock { storage: env.storage })
     # Source.interpret (handleSourceMock { github: env.github })
@@ -142,9 +151,12 @@ 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
+  failNextManifestWrite <- liftEffect $ Ref.new false
+  failNextMetadataWrite <- liftEffect $ Ref.new false
+  operation
+    # Registry.interpret (handleRegistryMock { metadataRef, indexRef, failNextManifestWrite, failNextMetadataWrite })
+    # 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
@@ -209,6 +221,8 @@ handlePursuitMock { excludes, metadataRef } = case _ of
 type RegistryMockEnv =
   { metadataRef :: Ref (Map PackageName Metadata)
   , indexRef :: Ref ManifestIndex
+  , failNextManifestWrite :: Ref Boolean
+  , failNextMetadataWrite :: Ref Boolean
   }
 
 handleRegistryMock :: forall r a. RegistryMockEnv -> Registry a -> Run (AFF + EFFECT + r) a
@@ -218,12 +232,17 @@ 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 <- Run.liftEffect (Ref.read env.failNextManifestWrite)
+    if failWrite then do
+      Run.liftEffect (Ref.write false env.failNextManifestWrite)
+      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 +261,13 @@ 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 <- Run.liftEffect (Ref.read env.failNextMetadataWrite)
+    if failWrite then do
+      Run.liftEffect (Ref.write false env.failNextMetadataWrite)
+      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)

From dd729e6955daae91447d6aadd1711ced4151de0d Mon Sep 17 00:00:00 2001
From: Thomas Honeyman <hello@thomashoneyman.com>
Date: Wed, 22 Jul 2026 15:30:54 +0000
Subject: [PATCH 2/3] Improve publication retry failure tests

Amp-Thread-ID: https://ampcode.com/threads/T-019f8a43-a415-7373-9d19-72aed17834d0

Co-authored-by: Thomas Honeyman <admin@thomashoneyman.com>
---
 app/test/App/API.purs         | 165 ++++++++++++++++++----------------
 app/test/Test/Assert/Run.purs |  53 +++++++----
 2 files changed, 126 insertions(+), 92 deletions(-)

diff --git a/app/test/App/API.purs b/app/test/App/API.purs
index 7dbd77e8..cd3af0a9 100644
--- a/app/test/App/API.purs
+++ b/app/test/App/API.purs
@@ -42,10 +42,13 @@ import Test.Spec as Spec
 
 -- | The environment accessible to each assertion in the test suite, derived
 -- | from the fixtures.
+-- |
+-- | `failNext` is shared by the effect mocks and consumed when its matching
+-- | operation runs. This lets a test observe partial state after one injected
+-- | failure and retry against that same state without special production code.
 type PipelineEnv =
   { workdir :: FilePath
-  , failNextManifestWrite :: Ref Boolean
-  , failNextMetadataWrite :: Ref Boolean
+  , failNext :: Ref (Maybe Assert.Run.TestFailure)
   , metadata :: Ref (Map PackageName Metadata)
   , index :: Ref ManifestIndex
   , storageDir :: FilePath
@@ -96,8 +99,7 @@ runPipelineAssertion env action = do
   logs <- liftEffect (Ref.new [])
   result <- Assert.Run.runTestEffects
     { workdir: env.workdir
-    , failNextManifestWrite: env.failNextManifestWrite
-    , failNextMetadataWrite: env.failNextMetadataWrite
+    , failNext: env.failNext
     , logs
     , index: env.index
     , metadata: env.metadata
@@ -130,14 +132,13 @@ spec = do
     copySourceFiles
 
   Spec.describe "API pipelines run correctly" $ Spec.around withCleanEnv do
-    Spec.it "Publish a package successfully" \{ workdir, failNextManifestWrite, failNextMetadataWrite, index, metadata, storageDir, githubDir } -> do
+    Spec.it "Publish a package successfully" \{ workdir, failNext, index, metadata, storageDir, githubDir } -> do
       logs <- liftEffect (Ref.new [])
 
       let
         testEnv =
           { workdir
-          , failNextManifestWrite
-          , failNextMetadataWrite
+          , failNext
           , logs
           , index
           , metadata
@@ -209,72 +210,86 @@ spec = do
           Assert.fail $ "Expected to publish effect@4.0.0 but got error: " <> err
         Right (Right _) -> pure unit
 
-    Spec.it "Retries after storage upload when metadata writing fails" \env -> do
-      liftEffect $ Ref.write true env.failNextMetadataWrite
-      runPipelineAssertion env do
-        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 }
-
-        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 }
-
-    Spec.it "Retries after metadata writing when manifest writing fails" \env -> do
-      liftEffect $ Ref.write true env.failNextManifestWrite
-      runPipelineAssertion env do
-        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 }
-
+    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 a storage upload that succeeds but reports failure" \env -> do
+        liftEffect $ Ref.write (Just Assert.Run.FailStorageUploadAfterWrite) env.failNext
+        runPipelineAssertion env do
+          API.publish effectPublishArgs >>= case _ of
+            Just _ -> pure unit
+            Nothing -> Except.throw "Expected the reconciled upload to report a newly completed publication."
+          assertPublicationState effectName effectVersion { storage: true, metadata: true, manifest: true }
+
+      Spec.it "Retries after storage upload when metadata writing fails" \env -> do
+        liftEffect $ Ref.write (Just Assert.Run.FailMetadataWrite) env.failNext
+        runPipelineAssertion env do
+          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 }
+
+          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 }
+
+      Spec.it "Retries after metadata writing when manifest writing fails" \env -> do
+        liftEffect $ Ref.write (Just Assert.Run.FailManifestWrite) env.failNext
+        runPipelineAssertion env do
+          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 }
+
+      Spec.it "Rejects an existing tarball that does not match the package source" \env -> do
         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 }
-
-    Spec.it "Rejects an existing tarball that does not match the package source" \env -> do
-      let storedTarballPath = Path.concat [ env.storageDir, "effect-4.0.0.tar.gz" ]
-      FS.Aff.writeTextFile UTF8 storedTarballPath "conflicting tarball"
-      runPipelineAssertion env do
-        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 }
+        FS.Aff.writeTextFile UTF8 storedTarballPath "conflicting tarball"
+        runPipelineAssertion env do
+          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
@@ -328,13 +343,11 @@ spec = do
         # Except.catch (\err -> Run.liftAff (Aff.throwError (Aff.error err)))
         # Run.runBaseAff'
 
-      failNextManifestWrite <- liftEffect $ Ref.new false
-      failNextMetadataWrite <- liftEffect $ Ref.new false
+      failNext <- liftEffect $ Ref.new Nothing
       liftEffect $ Process.chdir workdir
       pure
         { workdir
-        , failNextManifestWrite
-        , failNextMetadataWrite
+        , failNext
         , metadata: fixtures.metadata
         , index: fixtures.index
         , storageDir: Path.concat [ testFixtures, "registry-storage" ]
diff --git a/app/test/Test/Assert/Run.purs b/app/test/Test/Assert/Run.purs
index e770f709..848ace68 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
@@ -96,10 +97,28 @@ type TEST_EFFECTS =
       + ()
   )
 
+-- | A one-shot failure injected into an effect mock. The matching handler
+-- | consumes the failure before returning its error, so one test can run a
+-- | failed publication and its retry against the same mock state.
+data TestFailure
+  = FailStorageUploadAfterWrite
+  | FailMetadataWrite
+  | FailManifestWrite
+
+derive instance Eq TestFailure
+
+consumeFailure :: forall m. MonadEffect m => TestFailure -> Ref (Maybe TestFailure) -> m Boolean
+consumeFailure expected ref = liftEffect do
+  actual <- Ref.read ref
+  if actual == Just expected then do
+    Ref.write Nothing ref
+    pure true
+  else
+    pure false
+
 type TestEnv =
   { workdir :: FilePath
-  , failNextManifestWrite :: Ref Boolean
-  , failNextMetadataWrite :: Ref Boolean
+  , failNext :: Ref (Maybe TestFailure)
   , logs :: Ref (Array (Tuple LogLevel String))
   , metadata :: Ref (Map PackageName Metadata)
   , index :: Ref ManifestIndex
@@ -119,12 +138,11 @@ runTestEffects env operation = Aff.attempt do
         ( handleRegistryMock
             { metadataRef: env.metadata
             , indexRef: env.index
-            , failNextManifestWrite: env.failNextManifestWrite
-            , failNextMetadataWrite: env.failNextMetadataWrite
+            , failNext: env.failNext
             }
         )
     # PackageSets.interpret handlePackageSetsMock
-    # Storage.interpret (handleStorageMock { storage: env.storage })
+    # Storage.interpret (handleStorageMock { storage: env.storage, failNext: env.failNext })
     # Source.interpret (handleSourceMock { github: env.github })
     # GitHub.interpret (handleGitHubMock { github: env.github })
     -- Environments
@@ -152,10 +170,9 @@ 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 operation = do
-  failNextManifestWrite <- liftEffect $ Ref.new false
-  failNextMetadataWrite <- liftEffect $ Ref.new false
+  failNext <- liftEffect $ Ref.new Nothing
   operation
-    # Registry.interpret (handleRegistryMock { metadataRef, indexRef, failNextManifestWrite, failNextMetadataWrite })
+    # Registry.interpret (handleRegistryMock { metadataRef, indexRef, failNext })
     # runBaseEffects
 
 runGitHubCacheMemory :: forall r a. CacheRef -> Run (GITHUB_CACHE + LOG + EFFECT + r) a -> Run (LOG + EFFECT + r) a
@@ -221,8 +238,7 @@ handlePursuitMock { excludes, metadataRef } = case _ of
 type RegistryMockEnv =
   { metadataRef :: Ref (Map PackageName Metadata)
   , indexRef :: Ref ManifestIndex
-  , failNextManifestWrite :: Ref Boolean
-  , failNextMetadataWrite :: Ref Boolean
+  , failNext :: Ref (Maybe TestFailure)
   }
 
 handleRegistryMock :: forall r a. RegistryMockEnv -> Registry a -> Run (AFF + EFFECT + r) a
@@ -232,9 +248,8 @@ handleRegistryMock env = case _ of
     pure $ reply $ Right $ ManifestIndex.lookup name version index
 
   WriteManifest manifest reply -> do
-    failWrite <- Run.liftEffect (Ref.read env.failNextManifestWrite)
+    failWrite <- consumeFailure FailManifestWrite env.failNext
     if failWrite then do
-      Run.liftEffect (Ref.write false env.failNextManifestWrite)
       pure $ reply $ Left "Injected manifest write failure."
     else do
       index <- Run.liftEffect (Ref.read env.indexRef)
@@ -261,9 +276,8 @@ handleRegistryMock env = case _ of
     pure $ reply $ Right $ Map.lookup name metadata
 
   WriteMetadata name metadata reply -> do
-    failWrite <- Run.liftEffect (Ref.read env.failNextMetadataWrite)
+    failWrite <- consumeFailure FailMetadataWrite env.failNext
     if failWrite then do
-      Run.liftEffect (Ref.write false env.failNextMetadataWrite)
       pure $ reply $ Left "Injected metadata write failure."
     else do
       Run.liftEffect (Ref.modify_ (Map.insert name metadata) env.metadataRef)
@@ -298,7 +312,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
+  , failNext :: Ref (Maybe TestFailure)
+  }
 
 -- We handle the storage effect by copying files to/from the provided
 -- upload/download directories, and listing versions based on the filenames.
@@ -309,7 +326,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.failNext
+        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
 

From 5bf6360cc1b5344fcf24371bc2eaca4d64ca0022 Mon Sep 17 00:00:00 2001
From: Thomas Honeyman <hello@thomashoneyman.com>
Date: Wed, 22 Jul 2026 15:50:54 +0000
Subject: [PATCH 3/3] Speed up publication retry tests

Amp-Thread-ID: https://ampcode.com/threads/T-019f8a43-a415-7373-9d19-72aed17834d0

Co-authored-by: Thomas Honeyman <admin@thomashoneyman.com>
---
 app/test/App/API.purs         | 69 +++++++++++++++--------------
 app/test/Test/Assert/Run.purs | 81 +++++++++++------------------------
 2 files changed, 62 insertions(+), 88 deletions(-)

diff --git a/app/test/App/API.purs b/app/test/App/API.purs
index cd3af0a9..0db7135d 100644
--- a/app/test/App/API.purs
+++ b/app/test/App/API.purs
@@ -43,14 +43,16 @@ import Test.Spec as Spec
 -- | The environment accessible to each assertion in the test suite, derived
 -- | from the fixtures.
 -- |
--- | `failNext` is shared by the effect mocks and consumed when its matching
--- | operation runs. This lets a test observe partial state after one injected
--- | failure and retry against that same state without special production code.
+-- | `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
-  , failNext :: Ref (Maybe Assert.Run.TestFailure)
+  , failurePlan :: Ref (Array Assert.Run.TestFailure)
   , metadata :: Ref (Map PackageName Metadata)
+  , initialMetadata :: Map PackageName Metadata
   , index :: Ref ManifestIndex
+  , initialIndex :: ManifestIndex
   , storageDir :: FilePath
   , githubDir :: FilePath
   }
@@ -99,7 +101,7 @@ runPipelineAssertion env action = do
   logs <- liftEffect (Ref.new [])
   result <- Assert.Run.runTestEffects
     { workdir: env.workdir
-    , failNext: env.failNext
+    , failurePlan: env.failurePlan
     , logs
     , index: env.index
     , metadata: env.metadata
@@ -116,6 +118,14 @@ runPipelineAssertion env action = do
       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
@@ -132,13 +142,13 @@ spec = do
     copySourceFiles
 
   Spec.describe "API pipelines run correctly" $ Spec.around withCleanEnv do
-    Spec.it "Publish a package successfully" \{ workdir, failNext, 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
-          , failNext
+          , failurePlan
           , logs
           , index
           , metadata
@@ -216,17 +226,17 @@ spec = do
       -- 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 a storage upload that succeeds but reports failure" \env -> do
-        liftEffect $ Ref.write (Just Assert.Run.FailStorageUploadAfterWrite) env.failNext
-        runPipelineAssertion env do
-          API.publish effectPublishArgs >>= case _ of
-            Just _ -> pure unit
-            Nothing -> Except.throw "Expected the reconciled upload to report a newly completed publication."
-          assertPublicationState effectName effectVersion { storage: true, metadata: true, manifest: true }
-
-      Spec.it "Retries after storage upload when metadata writing fails" \env -> do
-        liftEffect $ Ref.write (Just Assert.Run.FailMetadataWrite) env.failNext
+      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
@@ -234,14 +244,8 @@ spec = do
 
           assertPublicationState effectName effectVersion { storage: true, metadata: false, manifest: false }
 
-          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 }
-
-      Spec.it "Retries after metadata writing when manifest writing fails" \env -> do
-        liftEffect $ Ref.write (Just Assert.Run.FailManifestWrite) env.failNext
-        runPipelineAssertion env do
+          -- 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
@@ -279,11 +283,10 @@ spec = do
             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
 
-      Spec.it "Rejects an existing tarball that does not match the package source" \env -> do
-        let storedTarballPath = Path.concat [ env.storageDir, "effect-4.0.0.tar.gz" ]
-        FS.Aff.writeTextFile UTF8 storedTarballPath "conflicting tarball"
-        runPipelineAssertion env do
+          -- 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
@@ -336,20 +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'
 
-      failNext <- liftEffect $ Ref.new Nothing
+      failurePlan <- liftEffect $ Ref.new []
       liftEffect $ Process.chdir workdir
       pure
         { workdir
-        , failNext
+        , 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 848ace68..82aa1385 100644
--- a/app/test/Test/Assert/Run.purs
+++ b/app/test/Test/Assert/Run.purs
@@ -13,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)
@@ -97,9 +96,9 @@ type TEST_EFFECTS =
       + ()
   )
 
--- | A one-shot failure injected into an effect mock. The matching handler
--- | consumes the failure before returning its error, so one test can run a
--- | failed publication and its retry against the same mock state.
+-- | 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
@@ -107,18 +106,19 @@ data TestFailure
 
 derive instance Eq TestFailure
 
-consumeFailure :: forall m. MonadEffect m => TestFailure -> Ref (Maybe TestFailure) -> m Boolean
+consumeFailure :: forall m. MonadEffect m => TestFailure -> Ref (Array TestFailure) -> m Boolean
 consumeFailure expected ref = liftEffect do
-  actual <- Ref.read ref
-  if actual == Just expected then do
-    Ref.write Nothing ref
-    pure true
-  else
-    pure false
+  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
-  , failNext :: Ref (Maybe TestFailure)
+  , failurePlan :: Ref (Array TestFailure)
   , logs :: Ref (Array (Tuple LogLevel String))
   , metadata :: Ref (Map PackageName Metadata)
   , index :: Ref ManifestIndex
@@ -138,20 +138,21 @@ runTestEffects env operation = Aff.attempt do
         ( handleRegistryMock
             { metadataRef: env.metadata
             , indexRef: env.index
-            , failNext: env.failNext
+            , failurePlan: env.failurePlan
             }
         )
     # PackageSets.interpret handlePackageSetsMock
-    # Storage.interpret (handleStorageMock { storage: env.storage, failNext: env.failNext })
+    # 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)
@@ -170,46 +171,14 @@ 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 operation = do
-  failNext <- liftEffect $ Ref.new Nothing
+  failurePlan <- liftEffect $ Ref.new []
   operation
-    # Registry.interpret (handleRegistryMock { metadataRef, indexRef, failNext })
+    # 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)
@@ -238,7 +207,7 @@ handlePursuitMock { excludes, metadataRef } = case _ of
 type RegistryMockEnv =
   { metadataRef :: Ref (Map PackageName Metadata)
   , indexRef :: Ref ManifestIndex
-  , failNext :: Ref (Maybe TestFailure)
+  , failurePlan :: Ref (Array TestFailure)
   }
 
 handleRegistryMock :: forall r a. RegistryMockEnv -> Registry a -> Run (AFF + EFFECT + r) a
@@ -248,7 +217,7 @@ handleRegistryMock env = case _ of
     pure $ reply $ Right $ ManifestIndex.lookup name version index
 
   WriteManifest manifest reply -> do
-    failWrite <- consumeFailure FailManifestWrite env.failNext
+    failWrite <- consumeFailure FailManifestWrite env.failurePlan
     if failWrite then do
       pure $ reply $ Left "Injected manifest write failure."
     else do
@@ -276,7 +245,7 @@ handleRegistryMock env = case _ of
     pure $ reply $ Right $ Map.lookup name metadata
 
   WriteMetadata name metadata reply -> do
-    failWrite <- consumeFailure FailMetadataWrite env.failNext
+    failWrite <- consumeFailure FailMetadataWrite env.failurePlan
     if failWrite then do
       pure $ reply $ Left "Injected metadata write failure."
     else do
@@ -314,7 +283,7 @@ handlePackageSetsMock = case _ of
 
 type StorageMockEnv =
   { storage :: FilePath
-  , failNext :: Ref (Maybe TestFailure)
+  , failurePlan :: Ref (Array TestFailure)
   }
 
 -- We handle the storage effect by copying files to/from the provided
@@ -326,7 +295,7 @@ 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 }
-        failUpload <- consumeFailure FailStorageUploadAfterWrite env.failNext
+        failUpload <- consumeFailure FailStorageUploadAfterWrite env.failurePlan
         if failUpload then
           pure $ reply $ Left "Injected storage upload failure after writing the tarball."
         else