Close endpoint failure types across service and web boundaries

docs/spec/contracts.md

@@ -51,6 +51,9 @@ non-success decoding policy.
 Upload requests stream `application/octet-stream`, require
 `X-Declared-Size`, `X-Content-SHA256`, `X-CSRF-Token`, and an operation id, and
 return a typed mutation result with the advertised terminal idempotency window.
+Each delete-batch item contains exactly one typed outcome: a mutation result or
+a closed dependency-failure code. Producers and consumers reject items with
+both outcomes or neither outcome.
 Downloads stream through Nuthatch, reject `Range`, use a safe attachment
 filename, and set active-content isolation headers. The compiled application
 page governs its assets with the application content-security policy, and

src/Nuthatch/Api.hs

@@ -30,6 +30,8 @@ module Nuthatch.Api
   , DeletePlanResponse (..)
   , DeleteBatchItem (..)
   , DeleteBatchRequest (..)
+  , DeleteItemFailure (..)
+  , DeleteItemOutcome (..)
   , DeleteItemResponse (..)
   , DeleteBatchResponse (..)
   , UploadResponse (..)
@@ -54,6 +56,7 @@ import           Data.Aeson
   , Value
   , object
   , withObject
+  , withText
   , (.:)
   , (.=)
   )
@@ -450,29 +453,62 @@ instance ToJSON DeleteBatchRequest where
     , "items" .= deleteBatchItems request
     ]
 
+data DeleteItemFailure
+  = DeleteItemDatabaseUnavailable
+  | DeleteItemObjectStoreUnavailable
+  deriving stock (Eq, Generic, Show)
+
+instance ToJSON DeleteItemFailure where
+  toJSON DeleteItemDatabaseUnavailable = "database_unavailable"
+  toJSON DeleteItemObjectStoreUnavailable = "object_store_unavailable"
+
+instance FromJSON DeleteItemFailure where
+  parseJSON = withText "DeleteItemFailure" $ \label ->
+    case label of
+      "database_unavailable" -> pure DeleteItemDatabaseUnavailable
+      "object_store_unavailable" -> pure DeleteItemObjectStoreUnavailable
+      _ -> fail "invalid delete item failure"
+
+data DeleteItemOutcome
+  = DeleteItemCompleted MutationResult
+  | DeleteItemFailed DeleteItemFailure
+  deriving stock (Eq, Show)
+
 data DeleteItemResponse = DeleteItemResponse
   { deleteItemPath        :: RelativePath
   , deleteItemOperationId :: OperationId
-  , deleteItemResult      :: Maybe MutationResult
+  , deleteItemOutcome     :: DeleteItemOutcome
-  , deleteItemError       :: Maybe Text
   }
   deriving stock (Eq, Show)
 
 instance ToJSON DeleteItemResponse where
-  toJSON response = object
+  toJSON response =
+    let (result, failure) =
+          case deleteItemOutcome response of
+            DeleteItemCompleted value -> (Just value, Nothing)
+            DeleteItemFailed value -> (Nothing, Just value)
+    in object
       [ "path" .= unRelativePath (deleteItemPath response)
       , "operation_id" .= deleteItemOperationId response
-    , "result" .= deleteItemResult response
+      , "result" .= result
-    , "error" .= deleteItemError response
+      , "error" .= failure
       ]
 
 instance FromJSON DeleteItemResponse where
-  parseJSON = withObject "DeleteItemResponse" $ \o ->
+  parseJSON = withObject "DeleteItemResponse" $ \o -> do
-    DeleteItemResponse
+    path <- o .: "path"
-      <$> o .: "path"
+    operation <- o .: "operation_id"
-      <*> o .: "operation_id"
+    result <- o .: "result"
-      <*> o .: "result"
+    failure <- o .: "error"
-      <*> o .: "error"
+    outcome <- case (result, failure) of
+      (Just value, Nothing) -> pure (DeleteItemCompleted value)
+      (Nothing, Just value) -> pure (DeleteItemFailed value)
+      _ -> fail "delete item response must contain exactly one outcome"
+    pure DeleteItemResponse
+      { deleteItemPath = path
+      , deleteItemOperationId = operation
+      , deleteItemOutcome = outcome
+      }
 
 newtype DeleteBatchResponse = DeleteBatchResponse
   { deleteBatchResults :: [DeleteItemResponse]

src/Nuthatch/Browse.hs

@@ -7,7 +7,6 @@ module Nuthatch.Browse
 import           Control.Monad (when)
 import           Control.Monad.IO.Class (liftIO)
 import qualified Data.Aeson as A
-import           Data.Bifunctor (first)
 import qualified Data.ByteString.Lazy as BL
 import           Data.Text (Text)
 import qualified Data.Text as T
@@ -26,6 +25,7 @@ import           Nuthatch.Redis
   )
 import           Nuthatch.S3
   ( ListPage (..)
+  , S3Error
   , listObjects
   , renderS3Error
   )
@@ -58,7 +58,9 @@ handleBrowseRequest env session selectedRoot selectedPrefix search continuation
       found <- searchEntries env user root (unSearchQuery query)
       pure (fmap (\(entries, partial) -> (entries, Nothing, partial)) found)
   (entries, nextContinuation, partial) <- either
-    (throwOperationError status502Error . BrowseObjectStoreFailed)
+    (throwOperationError status502Error
+      . BrowseObjectStoreFailed
+      . renderS3Error)
     pure
     result
   pure BrowseResponse
@@ -117,7 +119,7 @@ listEntries
   -> Root
   -> Text
   -> Maybe Text
-  -> IO (Either Text ([ListEntry], Maybe Text))
+  -> IO (Either S3Error ([ListEntry], Maybe Text))
 listEntries env user root prefix continuation = do
   generation <- cacheGeneration (envRedis env) (suUserId user) root
   let cacheOwner = case root of
@@ -155,7 +157,7 @@ listEntries env user root prefix continuation = do
         continuation
         (cfgBrowsePageSize (cfgProduct (envConfig env)))
       case page of
-        Left err -> pure (Left (renderS3Error err))
+        Left err -> pure (Left err)
         Right listed -> do
           let rootPrefix =
                 case root of
@@ -200,7 +202,7 @@ searchEntries
   -> SessionUser
   -> Root
   -> Text
-  -> IO (Either Text ([ListEntry], Bool))
+  -> IO (Either S3Error ([ListEntry], Bool))
 searchEntries env user root query = do
   let s3Prefix =
         case root of
@@ -239,20 +241,19 @@ collectKeysBounded
   -> Text
   -> Int
   -> Word64
-  -> IO (Either Text ([(Text, Integer)], Bool))
+  -> IO (Either S3Error ([(Text, Integer)], Bool))
 collectKeysBounded env prefix =
   collectKeysBoundedWith
     getMonotonicTimeNSec
     (\continuation limit ->
-      first renderS3Error
+      listObjects (envS3 env) prefix Nothing continuation limit)
-        <$> listObjects (envS3 env) prefix Nothing continuation limit)
 
 collectKeysBoundedWith
   :: IO Word64
-  -> (Maybe Text -> Int -> IO (Either Text ListPage))
+  -> (Maybe Text -> Int -> IO (Either failure ListPage))
   -> Int
   -> Word64
-  -> IO (Either Text ([(Text, Integer)], Bool))
+  -> IO (Either failure ([(Text, Integer)], Bool))
 collectKeysBoundedWith currentTime listPage maxKeys deadline =
   go Nothing [] 0
   where

src/Nuthatch/Http/Contract.hs

@@ -186,14 +186,41 @@ instance TypeScriptType DeleteBatchRequest where
       , property "items" (info @[DeleteBatchItem])
       ]
 
+instance TypeScriptType DeleteItemFailure where
+  typeScriptInfo _ =
+    genericStringEnum @DeleteItemFailure "DeleteItemFailure"
+
 instance TypeScriptType DeleteItemResponse where
   typeScriptInfo _ =
-    interface "DeleteItemResponse"
+    TypeScriptInfo
-      [ property "path" (info @RelativePath)
+      "DeleteItemResponse"
-      , property "operation_id" (info @OperationId)
+      ( concatMap tsiDefinitions
-      , property "result" (info @(Maybe MutationResult))
+          [ info @RelativePath
-      , property "error" (info @(Maybe Text))
+          , info @OperationId
+          , info @MutationResult
+          , info @DeleteItemFailure
           ]
+          <> [ T.unlines
+                [ "export type DeleteItemResponse ="
+                , "  | {"
+                , "      path: RelativePath;"
+                , "      operation_id: OperationId;"
+                , "      result: MutationResult;"
+                , "      error: null;"
+                , "    }"
+                , "  | {"
+                , "      path: RelativePath;"
+                , "      operation_id: OperationId;"
+                , "      result: null;"
+                , "      error: DeleteItemFailure;"
+                , "    };"
+                ]
+             ]
+      )
+      (\value ->
+        case A.fromJSON value :: A.Result DeleteItemResponse of
+          A.Success _ -> True
+          A.Error _ -> False)
 
 instance TypeScriptType DeleteBatchResponse where
   typeScriptInfo _ =
@@ -639,8 +666,7 @@ renderContractFixtures =
     itemResponse = DeleteItemResponse
       { deleteItemPath = path
       , deleteItemOperationId = operation
-      , deleteItemResult = Just MutationSucceeded
+      , deleteItemOutcome = DeleteItemCompleted MutationSucceeded
-      , deleteItemError = Nothing
       }
     fixture = A.object
       [ "session_response" A..= SessionResponse
@@ -735,8 +761,14 @@ wireShapeSamples =
   , samples @DeleteBatchRequest "DeleteBatchRequest"
       [DeleteBatchRequest Shared csrf [batchItem]]
   , samples @DeleteItemResponse "DeleteItemResponse"
-      [ DeleteItemResponse path operation (Just MutationSucceeded) Nothing
+      [ DeleteItemResponse
-      , DeleteItemResponse path operation Nothing (Just "failed")
+          path
+          operation
+          (DeleteItemCompleted MutationSucceeded)
+      , DeleteItemResponse
+          path
+          operation
+          (DeleteItemFailed DeleteItemDatabaseUnavailable)
       ]
   , samples @DeleteBatchResponse "DeleteBatchResponse"
       [DeleteBatchResponse [itemResponse]]
@@ -750,7 +782,10 @@ wireShapeSamples =
     entry = EntryResponse "file.txt" False (Just 7) "folder/file.txt"
     batchItem = DeleteBatchItem path operation
     itemResponse =
-      DeleteItemResponse path operation (Just MutationSucceeded) Nothing
+      DeleteItemResponse
+        path
+        operation
+        (DeleteItemCompleted MutationSucceeded)
     samples
       :: forall value
        . (TypeScriptType value, A.ToJSON value)

src/Nuthatch/Http/Server.hs

@@ -34,6 +34,7 @@ import           Nuthatch.Http.Error
 import           Nuthatch.Mutation.Effects
 import           Nuthatch.Mutation.Service
 import           Nuthatch.Recovery (trySynchronous)
+import           Nuthatch.S3 (renderS3Error)
 import           Nuthatch.Transfer
 import           Nuthatch.Types
 import           Servant
@@ -173,14 +174,15 @@ handleDeleteRequest env session request = do
         (DeleteMutationRejected "database unavailable")
     Right value -> pure value
   result <- case outcome of
-    Left reason -> do
+    Left failure -> do
       liftIO $ audit "delete" "failed"
         (Just (unUserId (suUserId user)))
         ([ ("root", A.toJSON (rootLabel root))
          , ("operation_id", A.toJSON (unOperationId operation))
          , ("reason", A.String "object_store_unavailable")
          ] <> objectKeyAudit (cfgProduct (envConfig env)) (deletePath request))
-      throwOperationError err409 (DeleteMutationRejected reason)
+      throwOperationError err409
+        (DeleteMutationRejected (deleteFailureMessage failure))
     Right value -> pure value
   liftIO $ audit "delete" (mutationAuditResult result)
     (Just (unUserId (suUserId user)))
@@ -224,33 +226,39 @@ handleDeleteBatchRequest env session request = do
         (deleteBatchPath item)
         (deleteBatchOperationId item)
     let outcome = case deleteAttempt of
-          Left _ -> Left "database unavailable"
+          Left _ -> Left DeleteItemDatabaseUnavailable
-          Right value -> value
+          Right (Left _) -> Left DeleteItemObjectStoreUnavailable
-        failureReason = case deleteAttempt of
+          Right (Right result) -> Right result
-          Left _ -> "database_unavailable"
-          Right (Left _) -> "object_store_unavailable"
-          Right (Right _) -> ""
     liftIO $ audit "delete" (either (const "failed") mutationAuditResult outcome)
       (Just (unUserId (suUserId (sessionUser session))))
       ([ ("root", A.toJSON (rootLabel (deleteBatchRoot request)))
        , ("operation_id", A.toJSON
           (unOperationId (deleteBatchOperationId item)))
        ] <> either
-          (const [("reason", A.String failureReason)])
+          (\failure ->
+            [("reason", A.String (deleteItemFailureReason failure))])
           mutationReasonFields
           outcome
         <> objectKeyAudit (cfgProduct (envConfig env)) (deleteBatchPath item))
     pure $ case outcome of
-      Left message -> DeleteItemResponse
+      Left failure -> DeleteItemResponse
         { deleteItemPath = deleteBatchPath item
         , deleteItemOperationId = deleteBatchOperationId item
-        , deleteItemResult = Nothing
+        , deleteItemOutcome = DeleteItemFailed failure
-        , deleteItemError = Just message
         }
       Right result -> DeleteItemResponse
         { deleteItemPath = deleteBatchPath item
         , deleteItemOperationId = deleteBatchOperationId item
-        , deleteItemResult = Just result
+        , deleteItemOutcome = DeleteItemCompleted result
-        , deleteItemError = Nothing
         }
   pure (DeleteBatchResponse results)
+
+deleteFailureMessage :: DeleteFailure -> Text
+deleteFailureMessage (DeleteDispatchFailed failure) =
+  renderS3Error failure
+
+deleteItemFailureReason :: DeleteItemFailure -> Text
+deleteItemFailureReason DeleteItemDatabaseUnavailable =
+  "database_unavailable"
+deleteItemFailureReason DeleteItemObjectStoreUnavailable =
+  "object_store_unavailable"

src/Nuthatch/Mutation/Service.hs

@@ -1,5 +1,6 @@
 module Nuthatch.Mutation.Service
   ( PutFailure (..)
+  , DeleteFailure (..)
   , runPut
   , runDelete
   , dispatchAndFinalize
@@ -13,7 +14,6 @@ import           Control.Exception
   , fromException
   , tryJust
   )
-import           Data.Text (Text)
 import           Database.PostgreSQL.Simple (SqlError)
 import           Nuthatch.App.Env
 import           Nuthatch.Config
@@ -97,13 +97,17 @@ newtype PutFailure
   = PutDispatchFailed PutObjectError
   deriving stock (Eq, Show)
 
+newtype DeleteFailure
+  = DeleteDispatchFailed S3Error
+  deriving stock (Eq, Show)
+
 runDelete
   :: Env
   -> SessionUser
   -> Root
   -> RelativePath
   -> OperationId
-  -> IO (Either Text MutationResult)
+  -> IO (Either DeleteFailure MutationResult)
 runDelete env user root rel op = do
   ensurePersonalPool
     (envDb env)
@@ -136,7 +140,7 @@ runDelete env user root rel op = do
           }
       else pure Nothing
   case admitted of
-    Nothing -> pure (Left "object store unavailable")
+    Nothing -> pure (Left (DeleteDispatchFailed S3TransportError))
     Just outcome ->
       case outcome of
         AdmitConflict -> pure (Right MutationConflict)
@@ -149,9 +153,9 @@ runDelete env user root rel op = do
             user
             root
             record
-            "object request timed out"
+            (DeleteDispatchFailed S3TransportError)
             (deleteObject (envS3 env) key
-              >>= pure . either (Left . renderS3Error) Right)
+              >>= pure . either (Left . DeleteDispatchFailed) Right)
 
 dispatchAndFinalize
   :: Env

test/Nuthatch/Test/HttpContract.hs

@@ -15,6 +15,7 @@ import           Nuthatch.Http.Contract
   , renderTypeScriptContract
   , contractShapeErrors
   )
+import           Nuthatch.Types (MutationResult (..))
 import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.HUnit ((@?=), Assertion, assertBool, testCase)
 
@@ -44,6 +45,34 @@ tests = testGroup "Haskell to TypeScript contract"
         (Proxy :: Proxy DeleteBatchResponse)
   , testCase "explicit TypeScript mappings accept the Aeson wire shapes" $
       contractShapeErrors @?= []
+  , testCase "delete item responses contain exactly one typed outcome" $ do
+      let path = "folder/file.txt" :: T.Text
+          operation = "operation-1" :: T.Text
+          decode result failure =
+            A.fromJSON
+              (A.object
+                [ "path" A..= path
+                , "operation_id" A..= operation
+                , "result" A..= result
+                , "error" A..= failure
+                ])
+              :: A.Result DeleteItemResponse
+      assertSuccess
+        (decode
+          (Just MutationSucceeded)
+          (Nothing :: Maybe DeleteItemFailure))
+      assertSuccess
+        (decode
+          (Nothing :: Maybe MutationResult)
+          (Just DeleteItemDatabaseUnavailable))
+      assertFailure
+        (decode
+          (Just MutationSucceeded)
+          (Just DeleteItemDatabaseUnavailable))
+      assertFailure
+        (decode
+          (Nothing :: Maybe MutationResult)
+          (Nothing :: Maybe DeleteItemFailure))
   , testCase "generated error unions cover every fixture error code" $ do
       fixture <- decodeFixture
       errors <- fixtureValue fixture "errors"
@@ -102,3 +131,11 @@ asProxyType _ = id
 
 toList :: Foldable collection => collection value -> [value]
 toList = foldr (:) []
+
+assertSuccess :: A.Result value -> Assertion
+assertSuccess (A.Success _) = pure ()
+assertSuccess (A.Error message) = fail message
+
+assertFailure :: A.Result value -> Assertion
+assertFailure (A.Error _) = pure ()
+assertFailure (A.Success _) = fail "unexpected successful decode"

test/Nuthatch/Test/Product.hs

@@ -17,7 +17,7 @@ tests = testGroup "product behavior"
         getMonotonicTimeNSec
         (\_ _ -> do
           threadDelay 100000
-          pure (Right (ListPage [] [] Nothing False)))
+          pure (Right (ListPage [] [] Nothing False) :: Either () ListPage))
         100
         (started + 5000000)
       finished <- getMonotonicTimeNSec

test/ProtocolConformance.hs

@@ -305,7 +305,9 @@ verifyStoreFence cfg database redis store = do
     (OperationId "expired-delete-store-down")
   afterExpiredDelete <-
     mutationSnapshot database "expired-delete-store-down"
-  assert "store-down expired delete epoch rejected" (isLeft expiredDeleteResult)
+  assertEqual "store-down expired delete epoch rejected"
+    (Left (Mutation.DeleteDispatchFailed S3TransportError))
+    expiredDeleteResult
   assertEqual "store-down does not start an expired delete epoch"
     beforeExpiredDelete
     afterExpiredDelete
@@ -313,7 +315,9 @@ verifyStoreFence cfg database redis store = do
   freshDeleteResult <- runDelete
     env user Shared (RelativePath "delete-store-down.bin")
     (OperationId "delete-store-down")
-  assert "store-down delete rejected" (isLeft freshDeleteResult)
+  assertEqual "store-down delete rejected"
+    (Left (Mutation.DeleteDispatchFailed S3TransportError))
+    freshDeleteResult
   freshDeleteRows <- Db.query database
     "SELECT count(*) FROM mutations WHERE operation_id = 'delete-store-down'"
     ()

test/WebContractIntegration.hs

@@ -149,8 +149,7 @@ deleteBatchHandler _ request =
     [ DeleteItemResponse
         { deleteItemPath = deleteBatchPath item
         , deleteItemOperationId = deleteBatchOperationId item
-        , deleteItemResult = Just MutationSucceeded
+        , deleteItemOutcome = DeleteItemCompleted MutationSucceeded
-        , deleteItemError = Nothing
         }
     | item <- deleteBatchItems request
     ]

web/src/generated/contract.ts

@@ -129,12 +129,21 @@ export interface DeleteBatchRequest {
 }
 
 
-export interface DeleteItemResponse {
+export type DeleteItemFailure = 'database_unavailable' | 'object_store_unavailable';
+
+export type DeleteItemResponse =
+  | {
       path: RelativePath;
       operation_id: OperationId;
-  result: MutationResult | null;
+      result: MutationResult;
-  error: string | null;
+      error: null;
-}
+    }
+  | {
+      path: RelativePath;
+      operation_id: OperationId;
+      result: null;
+      error: DeleteItemFailure;
+    };
 
 
 export interface DeleteBatchResponse {

web/src/transport.ts

@@ -10,6 +10,7 @@ import {
   type DeleteBatchResponse,
   type DeleteEndpointRequest,
   type DeleteFailureCode,
+  type DeleteItemFailure,
   type DeleteItemResponse,
   type DeletePlanEndpointRequest,
   type DeletePlanFailureCode,
@@ -457,12 +458,32 @@ function decodeDeleteBatchResponse(value: unknown): DeleteBatchResponse {
 
 function decodeDeleteItemResponse(value: unknown): DeleteItemResponse {
   const object = record(value, 'delete item response');
-  return {
+  const path = stringField(object, 'path');
-    path: stringField(object, 'path'),
+  const operation_id = stringField(object, 'operation_id');
-    operation_id: stringField(object, 'operation_id'),
+  const result = nullableMutationResultField(object, 'result');
-    result: nullableMutationResultField(object, 'result'),
+  const error = nullableDeleteItemFailureField(object, 'error');
-    error: nullableStringField(object, 'error')
+  if (result !== null && error === null) {
-  };
+    return { path, operation_id, result, error };
+  }
+  if (result === null && error !== null) {
+    return { path, operation_id, result, error };
+  }
+  throw new TypeError('delete item response must contain exactly one outcome');
+}
+
+function nullableDeleteItemFailureField(
+  object: Record<string, unknown>,
+  field: string
+): DeleteItemFailure | null {
+  const value = object[field];
+  if (
+    value === null ||
+    value === 'database_unavailable' ||
+    value === 'object_store_unavailable'
+  ) {
+    return value;
+  }
+  throw new TypeError(`${field} must be a declared delete item failure or null`);
 }
 
 function record(value: unknown, label: string): Record<string, unknown> {

web/test/mutations.test.mjs

@@ -51,7 +51,7 @@ test('partial delete recovery preserves only unfinished identities', () => {
         path: 'uncertain',
         operation_id: 'uncertain-id',
         result: null,
-        error: 'transport interrupted'
+        error: 'object_store_unavailable'
       }
     ],
     () => ids.shift()

web/test/transport.test.mjs

@@ -132,6 +132,43 @@ test('shared fixtures decode through every JSON transport method', async () => {
   );
 });
 
+test('delete batch decoding enforces the typed item outcome', async () => {
+  const failureClient = new BrowserProductClient(async () =>
+    jsonResponse({
+      results: [
+        {
+          path: 'folder/file.txt',
+          operation_id: 'operation-1',
+          result: null,
+          error: 'database_unavailable'
+        }
+      ]
+    })
+  );
+  const failure = requireValue(
+    await failureClient.deleteBatch({ body: fixtures.delete_batch_request })
+  );
+  assert.equal(failure.results[0].error, 'database_unavailable');
+
+  const invalidClient = new BrowserProductClient(async () =>
+    jsonResponse({
+      results: [
+        {
+          path: 'folder/file.txt',
+          operation_id: 'operation-1',
+          result: 'succeeded',
+          error: 'object_store_unavailable'
+        }
+      ]
+    })
+  );
+  const invalid = await invalidClient.deleteBatch({
+    body: fixtures.delete_batch_request
+  });
+  assert.equal(invalid.ok, false);
+  assert.equal(invalid.failure.kind, 'unexpected-http');
+});
+
 test('declared, undeclared, and network failures remain distinct without retries', async () => {
   const declaredClient = new BrowserProductClient(async () =>
     jsonResponse(