ms2k/nuthatch
SHA256
Watch
0
Code Releases Activity

Close endpoint failure types across service and web boundaries

Browse source
This commit is contained in:
ms2k 2026-07-20 21:34:25 +09:00
commit 390434bed1
14 changed files with 266 additions and 72 deletions
Download patch file Download diff file Expand all files Collapse all files

3
docs/spec/contracts.md
View file

@ -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

58
src/Nuthatch/Api.hs
View file

@ -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
, deleteItemError :: Maybe Text
, deleteItemOutcome :: DeleteItemOutcome
}
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
, "error" .= deleteItemError response
, "result" .= result
, "error" .= failure
]
instance FromJSON DeleteItemResponse where
parseJSON = withObject "DeleteItemResponse" $ \o ->
DeleteItemResponse
<$> o .: "path"
<*> o .: "operation_id"
<*> o .: "result"
<*> o .: "error"
parseJSON = withObject "DeleteItemResponse" $ \o -> do
path <- o .: "path"
operation <- o .: "operation_id"
result <- o .: "result"
failure <- 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]

21
src/Nuthatch/Browse.hs
View file

@ -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

55
src/Nuthatch/Http/Contract.hs
View file

@ -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"
[ property "path" (info @RelativePath)
, property "operation_id" (info @OperationId)
, property "result" (info @(Maybe MutationResult))
, property "error" (info @(Maybe Text))
TypeScriptInfo
"DeleteItemResponse"
( concatMap tsiDefinitions
[ info @RelativePath
, 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
, deleteItemError = Nothing
, deleteItemOutcome = DeleteItemCompleted MutationSucceeded
}
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 path operation Nothing (Just "failed")
[ DeleteItemResponse
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)

36
src/Nuthatch/Http/Server.hs
View file

@ -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"
Right value -> value
failureReason = case deleteAttempt of
Left _ -> "database_unavailable"
Right (Left _) -> "object_store_unavailable"
Right (Right _) -> ""
Left _ -> Left DeleteItemDatabaseUnavailable
Right (Left _) -> Left DeleteItemObjectStoreUnavailable
Right (Right result) -> Right result
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
, deleteItemError = Just message
, deleteItemOutcome = DeleteItemFailed failure
}
Right result -> DeleteItemResponse
{ deleteItemPath = deleteBatchPath item
, deleteItemOperationId = deleteBatchOperationId item
, deleteItemResult = Just result
, deleteItemError = Nothing
, deleteItemOutcome = DeleteItemCompleted result
}
pure (DeleteBatchResponse results)
deleteFailureMessage :: DeleteFailure -> Text
deleteFailureMessage (DeleteDispatchFailed failure) =
renderS3Error failure
deleteItemFailureReason :: DeleteItemFailure -> Text
deleteItemFailureReason DeleteItemDatabaseUnavailable =
"database_unavailable"
deleteItemFailureReason DeleteItemObjectStoreUnavailable =
"object_store_unavailable"

14
src/Nuthatch/Mutation/Service.hs
View file

@ -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

37
test/Nuthatch/Test/HttpContract.hs
View file

@ -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"

2
test/Nuthatch/Test/Product.hs
View file

@ -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

8
test/ProtocolConformance.hs
View file

@ -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'"
()

3
test/WebContractIntegration.hs
View file

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

15
web/src/generated/contract.ts
View file

@ -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;
error: string | null;
result: MutationResult;
error: null;
}
| {
path: RelativePath;
operation_id: OperationId;
result: null;
error: DeleteItemFailure;
};
export interface DeleteBatchResponse {

33
web/src/transport.ts
View file

@ -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 {
path: stringField(object, 'path'),
operation_id: stringField(object, 'operation_id'),
result: nullableMutationResultField(object, 'result'),
error: nullableStringField(object, 'error')
};
const path = stringField(object, 'path');
const operation_id = stringField(object, 'operation_id');
const result = nullableMutationResultField(object, 'result');
const error = nullableDeleteItemFailureField(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> {

2
web/test/mutations.test.mjs
View file

@ -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()

37
web/test/transport.test.mjs
View file

@ -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(