fix(file-upload): fail closed when the dedup existence check errors

.changes/020-dedup-no-blind-rewrite.md

@@ -0,0 +1,14 @@
+---
+group: platform
+component: Framework
+impact: compatible
+category: Fixed
+---
+
+## Summary
+
+A duplicate file upload no longer rewrites the existing stored blob when the blob store's existence check returns an error. The upload instead fails with "Failed to verify stored file content. Please retry." Backend details are logged at error level via `Log.critical`. A check that reports the blob present still reuses it; a check that reports it missing still restores the uploaded content. This does not change how the Local backend reports existence-check results.
+
+A concurrent upload that loses a state-store conflict may already have written its own provisional blob. It attempts to delete that provisional blob; it does not rewrite the winner's existing blob when the winner's existence check returns an error. This check does not prevent another actor from removing a blob later.
+
+No code or data changes are needed in applications. To verify locally, run `./dev test "ContentDedup" nhcore-test-service` and confirm `dedup fails closed when the existence check errors` passes.

codemap/api-hot.md

@@ -10,10 +10,10 @@ codemap/signatures/ · type-directed search: ./dev api "<type>"
 
 ## Task
 
-- `yield :: value -> Task w value`  <!-- 602 call sites -->
+- `yield :: value -> Task w value`  <!-- 601 call sites -->
 - `ignoreError :: Task err Unit -> Task w Unit`  <!-- 242 call sites -->
 - `mapError :: (err1 -> err2) -> Task err1 value -> Task err2 value`  <!-- 229 call sites -->
-- `throw :: err -> Task err w`  <!-- 216 call sites -->
+- `throw :: err -> Task err w`  <!-- 217 call sites -->
 - `fromIO :: IO value -> Task w value`  <!-- 131 call sites -->
 - `asResult :: Task err value -> Task err2 (Result err value)`  <!-- 89 call sites -->
 - `when :: Bool -> Task err Unit -> Task err Unit`  <!-- 31 call sites -->
@@ -72,10 +72,10 @@ codemap/signatures/ · type-directed search: ./dev api "<type>"
 ## Log
 
 - `debug :: HasCallStack => Text -> Task w Unit`  <!-- 114 call sites -->
-- `warn :: HasCallStack => Text -> Task w Unit`  <!-- 72 call sites -->
+- `warn :: HasCallStack => Text -> Task w Unit`  <!-- 71 call sites -->
 - `withScope :: Array (Text, Text) -> Task err value -> Task err value`  <!-- 57 call sites -->
 - `info :: HasCallStack => Text -> Task w Unit`  <!-- 35 call sites -->
-- `critical :: HasCallStack => Text -> Task w Unit`  <!-- 11 call sites -->
+- `critical :: HasCallStack => Text -> Task w Unit`  <!-- 12 call sites -->
 
 ## Map
 
@@ -294,19 +294,19 @@ when WRITING TESTS; they are not feature-code frequency signal.
 
 ## Task
 
-- `mapError :: (err1 -> err2) -> Task err1 value -> Task err2 value`  <!-- 828 test call sites -->
-- `yield :: value -> Task w value`  <!-- 483 test call sites -->
-- `asResult :: Task err value -> Task err2 (Result err value)`  <!-- 286 test call sites -->
+- `mapError :: (err1 -> err2) -> Task err1 value -> Task err2 value`  <!-- 829 test call sites -->
+- `yield :: value -> Task w value`  <!-- 484 test call sites -->
+- `asResult :: Task err value -> Task err2 (Result err value)`  <!-- 288 test call sites -->
 - `mapArray :: (element -> Task err output) -> Array element -> Task err (Array output)`  <!-- 127 test call sites -->
-- `throw :: err -> Task err w`  <!-- 124 test call sites -->
+- `throw :: err -> Task err w`  <!-- 126 test call sites -->
 - `andThen :: (input -> Task err output) -> Task err input -> Task err output`  <!-- 92 test call sites -->
 - `fromIO :: IO value -> Task w value`  <!-- 90 test call sites -->
 - `map :: (input -> output) -> Task err input -> Task err output`  <!-- 84 test call sites -->
 
 ## Array
 
-- `length :: Array a -> Int`  <!-- 276 test call sites -->
-- `empty :: Array a`  <!-- 231 test call sites -->
+- `length :: Array a -> Int`  <!-- 277 test call sites -->
+- `empty :: Array a`  <!-- 233 test call sites -->
 - `fromLinkedList :: LinkedList a -> Array a`  <!-- 221 test call sites -->
 - `map :: (a -> b) -> Array a -> Array b`  <!-- 138 test call sites -->
 - `get :: Int -> Array a -> Maybe a`  <!-- 89 test call sites -->
@@ -316,8 +316,8 @@ when WRITING TESTS; they are not feature-code frequency signal.
 
 ## Text
 
-- `contains :: Text -> Text -> Bool`  <!-- 450 test call sites -->
-- `toBytes :: Text -> Bytes`  <!-- 98 test call sites -->
+- `contains :: Text -> Text -> Bool`  <!-- 451 test call sites -->
+- `toBytes :: Text -> Bytes`  <!-- 100 test call sites -->
 - `fromLinkedList :: LinkedList Char -> Text`  <!-- 58 test call sites -->
 - `length :: Text -> Int`  <!-- 41 test call sites -->
 - `repeat :: Int -> Text -> Text`  <!-- 35 test call sites -->
@@ -360,9 +360,9 @@ when WRITING TESTS; they are not feature-code frequency signal.
 
 ## ConcurrentVar
 
-- `containing :: value -> Task w (ConcurrentVar value)`  <!-- 126 test call sites -->
-- `modify :: (value -> value) -> ConcurrentVar value -> Task w Unit`  <!-- 121 test call sites -->
-- `peek :: ConcurrentVar value -> Task w value`  <!-- 104 test call sites -->
+- `containing :: value -> Task w (ConcurrentVar value)`  <!-- 131 test call sites -->
+- `modify :: (value -> value) -> ConcurrentVar value -> Task w Unit`  <!-- 126 test call sites -->
+- `peek :: ConcurrentVar value -> Task w value`  <!-- 110 test call sites -->
 - `get :: ConcurrentVar value -> Task w value`  <!-- 39 test call sites -->
 - `set :: value -> ConcurrentVar value -> Task w ()`  <!-- 15 test call sites -->
 - `new :: forall value w. Task w (ConcurrentVar value)`  <!-- 14 test call sites -->

core/service/Service/FileUpload/Web.hs

@@ -420,28 +420,30 @@ normalUploadFlow config blobStore stateStore ownerHash filename contentType cont
 -- | Guard a deduplication match against blob loss (issue #713).
 --
 -- Before returning an existing 'FileRef', verify its blob is still present in
--- the 'BlobStore'; if it is missing — or its presence cannot be confirmed (the
--- existence check itself errored) — re-store the caller's content under the
--- SAME blob key so the returned reference is never dangling. Healing in place
--- (same key, no state-store write) preserves dedup identity and is robust on
--- every backend: unlike falling through to a fresh upload, it cannot collide
--- with the (owner, content_hash) unique constraint and re-return the stale ref.
+-- the 'BlobStore'; only when the store confirms it is missing, re-store the
+-- caller's content under the SAME blob key so the returned reference is never
+-- dangling. Healing in place (same key, no state-store write) preserves dedup
+-- identity and is robust on every backend: unlike falling through to a fresh
+-- upload, it cannot collide with the (owner, content_hash) unique constraint
+-- and re-return the stale ref.
 --
 -- The re-stored bytes are the caller's own content, matched to the existing
 -- entry by the same owner-scoped content hash, so healing never crosses owners
--- or writes different content. 'BlobStore.store' overwrites idempotently, so a
--- redundant re-store (e.g. after a transient existence-check error) is harmless.
+-- or writes different content.
+--
+-- An errored existence check leaves presence unknown: rewriting then would
+-- overwrite a blob we cannot see (and, on S3, pay for the transfer), so the
+-- request fails instead. The real error stays in the server log; the client
+-- sees a generic message (S8).
 ensureBlobPresent :: BlobStore -> BlobKey -> Bytes -> Task Text Unit
 ensureBlobPresent blobStore blobKey content = do
   existsResult <- blobStore.exists blobKey |> Task.asResult
   blobPresent <- case existsResult of
     Ok present -> Task.yield present
     Err existsErr -> do
-      -- Presence unknown: keep the real error in the server log, then treat as
-      -- missing and heal (re-store is idempotent).
-      Log.warn [fmt|Dedup blob existence check errored (#{show existsErr}); treating as missing|]
+      Log.critical [fmt|Dedup blob existence check errored (#{show existsErr}); refusing to rewrite|]
         |> Task.ignoreError
-      Task.yield False
+      Task.throw "Failed to verify stored file content. Please retry."
   Task.unless blobPresent do
       Log.warn "Deduplicated blob unavailable; self-healing by re-storing content"
         |> Task.ignoreError

core/test/Service/FileUpload/ContentDedupSpec.hs

@@ -1,6 +1,8 @@
 module Service.FileUpload.ContentDedupSpec where
 
+import Array qualified
 import Bytes qualified
+import ConcurrentVar qualified
 import Core
 import Data.Char (isDigit)
 import Directory qualified
@@ -228,6 +230,24 @@ spec = do
             response2 <- uploadFile env "owner1" "file.txt" "text/plain" content
             response2.blobKey |> shouldBe response1.blobKey
 
+        it "duplicate upload of a present blob makes no store call" \_ -> do
+          withTestDedupEnv \env -> do
+            let content = "duplicate no-store content" |> Text.toBytes
+            response1 <- uploadFile env "owner1" "file.txt" "text/plain" content
+            storeCalls <- ConcurrentVar.containing (0 :: Int)
+            let observedBlobStore =
+                  (env.blobStore)
+                    { store = \key bytes -> do
+                        ConcurrentVar.modify (\n -> n + 1) storeCalls
+                        env.blobStore.store key bytes
+                    }
+            response2 <-
+              handleUploadImpl env.config observedBlobStore env.stateStore "owner1" "file.txt" "text/plain" content
+            response2.fileRef |> shouldBe response1.fileRef
+            response2.blobKey |> shouldBe response1.blobKey
+            writes <- ConcurrentVar.peek storeCalls
+            writes |> shouldBe 0
+
         it "duplicate upload returns original metadata (filename from first upload)" \_ -> do
           withTestDedupEnv \env -> do
             let content = "duplicate filename content" |> Text.toBytes
@@ -338,10 +358,12 @@ spec = do
       -- Blob Loss Self-Heal (issue #713)
       --
       -- Dedup must never return a FileRef whose blob has been lost. Before
-      -- returning a match, the blob's presence is verified; if it is missing
-      -- (or its presence cannot be confirmed), the content is re-stored under
-      -- the SAME blob key so the reference is healed in place — no new FileRef,
-      -- no state mutation, robust for both in-memory and Postgres backends.
+      -- returning a match, the blob's presence is verified; only if the store
+      -- confirms it is missing is the content re-stored under the SAME blob key
+      -- so the reference is healed in place — no new FileRef, no state
+      -- mutation, robust for both in-memory and Postgres backends. When the
+      -- existence check itself errors, presence is unknown: the upload fails
+      -- closed and nothing is re-stored.
       -- ==========================================================================
       describe "Blob Loss Self-Heal (issue #713)" do
         it "dedup self-heals a missing Pending blob on re-upload" \_ -> do
@@ -387,21 +409,82 @@ spec = do
               |> Task.mapError (\e -> [fmt|retrieve failed: #{show e}|])
             computeContentHash restored |> shouldBe (computeContentHash content)
 
-        it "dedup self-heals when the existence check errors" \_ -> do
+        it "dedup fails closed when the existence check errors" \_ -> do
           withTestDedupEnv \env -> do
-            let content = "self-heal on exists-error content" |> Text.toBytes
+            let content = "fail-closed on exists-error content" |> Text.toBytes
             response1 <- uploadFile env "owner1" "file.txt" "text/plain" content
-            env.blobStore.delete response1.blobKey
-              |> Task.mapError (\e -> [fmt|delete failed: #{show e}|])
-            -- Make the existence check itself fail; heal must still occur
+            -- Presence is unknown, not known-missing: the blob is still there,
+            -- only the check fails. The upload must not rewrite it blindly.
+            storeCalls <- ConcurrentVar.containing (0 :: Int)
             let faultingBlobStore =
                   (env.blobStore)
-                    { exists = \_ -> Task.throw (StorageError "injected exists failure") }
-            response2 <-
+                    { exists = \_ -> Task.throw (StorageError "injected exists failure")
+                    , store = \_ _ -> ConcurrentVar.modify (\n -> n + 1) storeCalls
+                    }
+            result <-
               handleUploadImpl env.config faultingBlobStore env.stateStore "owner1" "file.txt" "text/plain" content
-            blobPresent <- env.blobStore.exists response2.blobKey
-              |> Task.mapError (\e -> [fmt|exists failed: #{show e}|])
-            blobPresent |> shouldBe True
+                |> Task.asResult
+            case result of
+              Ok _ -> fail "expected the upload to fail when blob presence is unknown"
+              Err msg -> do
+                msg |> shouldBe "Failed to verify stored file content. Please retry."
+                (Text.contains "injected" msg) |> shouldBe False
+            rewrites <- ConcurrentVar.peek storeCalls
+            rewrites |> shouldBe 0
+            -- The original blob is untouched and still served.
+            restored <- env.blobStore.retrieve response1.blobKey
+              |> Task.mapError (\e -> [fmt|retrieve failed: #{show e}|])
+            restored |> shouldBe content
+
+        it "dedup conflict retry cleans only its provisional blob when winner check errors" \_ -> do
+          withTestDedupEnv \env -> do
+            let content = "conflict retry winner content" |> Text.toBytes
+            winner <- uploadFile env "owner1" "file.txt" "text/plain" content
+            lookups <- ConcurrentVar.containing (0 :: Int)
+            storedKeys <- ConcurrentVar.containing (Array.empty :: Array BlobKey)
+            deletedKeys <- ConcurrentVar.containing (Array.empty :: Array BlobKey)
+            let racingStateStore =
+                  (env.stateStore)
+                    { findByContentHash = \owner contentHash -> do
+                        count <- ConcurrentVar.peek lookups
+                        ConcurrentVar.modify (\value -> value + 1) lookups
+                        if count == 0
+                          then Task.yield Nothing
+                          else env.stateStore.findByContentHash owner contentHash
+                    , updateState = \_ _ -> Task.throw "injected unique constraint violation (23505)"
+                    }
+            let observedBlobStore =
+                  (env.blobStore)
+                    { exists = \_ -> Task.throw (StorageError "injected winner exists failure")
+                    , store = \key bytes -> do
+                        ConcurrentVar.modify (Array.push key) storedKeys
+                        env.blobStore.store key bytes
+                    , delete = \key -> do
+                        env.blobStore.delete key
+                        ConcurrentVar.modify (Array.push key) deletedKeys
+                    }
+            result <-
+              handleUploadImpl env.config observedBlobStore racingStateStore "owner1" "file.txt" "text/plain" content
+                |> Task.asResult
+            case result of
+              Ok _ -> fail "expected the conflict retry to fail when the winner check errors"
+              Err message -> message |> shouldBe "Failed to verify stored file content. Please retry."
+            lookupCount <- ConcurrentVar.peek lookups
+            lookupCount |> shouldBe 2
+            writes <- ConcurrentVar.peek storedKeys
+            deletes <- ConcurrentVar.peek deletedKeys
+            Array.length writes |> shouldBe 1
+            deletes |> shouldBe writes
+            case Array.first writes of
+              Nothing -> fail "expected a provisional blob key"
+              Just provisionalKey -> do
+                provisionalKey |> shouldNotBe winner.blobKey
+                provisionalPresent <- env.blobStore.exists provisionalKey
+                  |> Task.mapError (\err -> [fmt|exists failed: #{show err}|])
+                provisionalPresent |> shouldBe False
+            winnerContent <- env.blobStore.retrieve winner.blobKey
+              |> Task.mapError (\err -> [fmt|retrieve failed: #{show err}|])
+            winnerContent |> shouldBe content
 
         it "dedup surfaces a generic error (no dangling ref) when re-store fails" \_ -> do
           withTestDedupEnv \env -> do

docs/changes/001-fileupload-dedup-blob-existence-check.md

@@ -8,7 +8,9 @@ content keeps short-circuiting to a `FileRef` whose blob is gone, and every
 downstream read fails permanently with `File blob is missing from storage`.
 This change makes dedup self-healing: before returning a match, verify the blob
 exists and, if it does not, re-store the content under the same blob key so the
-returned reference is never dangling.
+matched blob is restored when the backend reports it missing. This is a
+check-time guarantee, not a promise that no other actor can later remove the
+blob; change 020 separately defines the returned-error boundary.
 
 ```yaml spec
 issue: issue#713                # issue#NNN or adhoc:<slug>
@@ -41,7 +43,7 @@ losing a blob), so the reproductions are `integration`.
 | C1 | Re-uploading content whose deduplicated **Pending** blob was lost returns a `FileRef` whose blob is present again (self-heal), not a dangling ref | `hspec:nhcore-test-service:core/test/Service/FileUpload/ContentDedupSpec.hs#dedup self-heals a missing Pending blob on re-upload` | integration | filesystem:real |
 | C2 | Same self-heal when the dedup match is a **Confirmed** file | `hspec:nhcore-test-service:core/test/Service/FileUpload/ContentDedupSpec.hs#dedup self-heals a missing Confirmed blob on re-upload` | integration | filesystem:real |
 | C3 | Self-heal preserves dedup identity — same `FileRef` and same `blobKey` as the original — and the re-stored blob retrieves the exact uploaded content | `hspec:nhcore-test-service:core/test/Service/FileUpload/ContentDedupSpec.hs#dedup self-heal preserves FileRef/blobKey and restores exact content` | integration | filesystem:real |
-| C4 | When the existence check itself errors, dedup still heals (re-stores) rather than returning a possibly-dangling ref | `hspec:nhcore-test-service:core/test/Service/FileUpload/ContentDedupSpec.hs#dedup self-heals when the existence check errors` | integration | filesystem:real |
+| C4 | When the existence check itself errors, dedup fails closed (no blind re-store, generic client error) — behavior revised by change 020 | `hspec:nhcore-test-service:core/test/Service/FileUpload/ContentDedupSpec.hs#dedup fails closed when the existence check errors` | integration | filesystem:real |
 | C5 | Healthy path preserved — when the blob is present, a duplicate upload still returns the existing `FileRef`/`blobKey` unchanged | `hspec:nhcore-test-service:core/test/Service/FileUpload/ContentDedupSpec.hs#duplicate upload returns same blobKey as original` | integration | filesystem:real |
 
 ## User impact
@@ -74,8 +76,9 @@ missing-blob guard (`ensureBlobPresent`) is applied at **all four** sites that
 return a pre-existing `FileRef` — the two dedup branches (Pending/Confirmed) and
 the two 23505 concurrent-race retry branches in `normalUploadFlow` — since the
 race-retry path returns a stored `blobKey` with the same absent check and is the
-same defect class. The race branches only fire under the Postgres unique
-constraint, so they are covered structurally by the shared helper (proven by
-C1–C4 on the in-memory store) rather than by a separate, non-deterministic
-concurrency criterion. `handleDownloadImpl`'s `File blob is missing from storage`
+same defect class. The real race branches use the Postgres unique
+constraint. Change 020 C4 additionally tests the retry path with an injected
+`23505` result and real filesystem cleanup; it is a deterministic regression,
+not a PostgreSQL concurrency test. The shared helper also provides structural
+coverage across Pending and Confirmed retry states. `handleDownloadImpl`'s `File blob is missing from storage`
 remains a detect-only backstop, unchanged.