ms2k/nuthatch
SHA256
Watch
0
Code Releases Activity

Type protocol persistence around model phases

Browse source
This commit is contained in:
ms2k 2026-07-19 19:13:17 +09:00
commit a31b883516
4 changed files with 607 additions and 258 deletions
Download patch file Download diff file Expand all files Collapse all files

65
test/Integration.hs
View file

@ -38,6 +38,7 @@ main = do
migrate database "sql" config
verifySchema database
verifyAdmission database config
verifyRowDecoder database
store <- newS3 config
verifyStorage config store
putStrLn "Storage foundation integration gate passed"
@ -160,7 +161,8 @@ verifyAdmission database config = do
"bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"))
settled <- withTransaction database $ \connection -> do
applying <- markApplying connection observationRecord
pending <- markExternalPending connection observationRecord 600 90
pending <- markExternalPending
connection observationRecord (DispatchTiming 600 90)
externalSettled <- markExternalSettled connection observationRecord
pure (applying && pending && externalSettled)
assert "observation fixture reached applying/settled" settled
@ -193,7 +195,7 @@ verifyIdempotencyExpiry database = do
let rec = preparedRecord [first]
finalized <- withTransaction database $ \connection -> do
applying <- markApplying connection rec
pending <- markExternalPending connection rec 600 90
pending <- markExternalPending connection rec (DispatchTiming 600 90)
settled <- markExternalSettled connection rec
succeeded <- finalizeSuccess connection rec 10 (Just fixedIdentity)
pure (applying && pending && settled && succeeded)
@ -230,6 +232,40 @@ verifyIdempotencyExpiry database = do
assertEqual "aged active key remains locked" 1 (countRejected [blocked])
assertAuthority database 1 10
verifyRowDecoder :: Db -> IO ()
verifyRowDecoder database = do
resetAuthority database 100
outcome <- admit database "invalid-phase-operation" "invalid-phase-key" 10
let record = preparedRecord [outcome]
roundTripped <- withTransaction database $ \connection ->
lookupMutation
connection
(mrUserId record)
(mrKind record)
(mrOperationId record)
assertEqual "typed mutation row round-trip" (Just record) roundTripped
_ <- Db.execute database
"UPDATE mutations SET external_state = 'pending', \
\dispatch_started_at = now(), request_deadline_at = now(), \
\worker_lease_until = now() \
\WHERE user_id = ? AND kind = ? AND operation_id = ?"
( unUserId (mrUserId record)
, kindLabel (mrKind record)
, unOperationId (mrOperationId record)
)
invalidDecode <-
( try $ withTransaction database $ \connection ->
lookupMutation
connection
(mrUserId record)
(mrKind record)
(mrOperationId record)
) :: IO (Either SomeException (Maybe MutationRecord))
case invalidDecode of
Left _ -> pure ()
Right value ->
fail ("invalid persisted mutation phase decoded as " <> show value)
verifyStorage :: Config -> S3 -> IO ()
verifyStorage config store = do
let fallbackKey = ObjectKey "shared/fallback.bin"
@ -322,16 +358,21 @@ admitWithWindow database operation key size window =
withTransaction database $ \connection ->
admitMutation
connection
(UserId "integration-user")
Put
(OperationId operation)
sharedPool
(ObjectKey ("shared/" <> key))
(RelativePath key)
size
(Just fixedIdentity)
1000
window
AdmissionRequest
{ admissionIdentity =
AdmissionIdentity (UserId "integration-user") Put
(OperationId operation)
, admissionPoolId = sharedPool
, admissionRelativePath = RelativePath key
, admissionFingerprint =
MutationFingerprint
Put
(ObjectKey ("shared/" <> key)) size (Just fixedIdentity)
}
AdmissionLimits
{ admissionMaxObjectBytes = 1000
, admissionIdempotencyWindowSec = window
}
resetAuthority :: Db -> Integer -> IO ()
resetAuthority database limitBytes = do

73
test/ProtocolConformance.hs
View file

@ -457,7 +457,7 @@ dispatch :: Db -> MutationRecord -> IO ()
dispatch database record = do
ok <- withTransaction database $ \connection -> do
applying <- markApplying connection record
pending <- markExternalPending connection record 10 5
pending <- markExternalPending connection record (DispatchTiming 10 5)
pure (applying && pending)
assert "PrepareEffect/DispatchEffect" ok
coveredAction "PrepareEffect"
@ -498,48 +498,59 @@ admitPut cfg database operation path size identity =
withTransaction database $ \connection ->
admitMutation
connection
protocolUser
Put
(OperationId operation)
sharedPool
(ObjectKey ("shared/" <> path))
(RelativePath path)
size
(Just identity)
(cfgMaxObjectBytes cfg)
(cfgIdempotencyWindowSec cfg)
AdmissionRequest
{ admissionIdentity =
AdmissionIdentity protocolUser Put (OperationId operation)
, admissionPoolId = sharedPool
, admissionRelativePath = RelativePath path
, admissionFingerprint =
MutationFingerprint Put (ObjectKey ("shared/" <> path)) size
(Just identity)
}
AdmissionLimits
{ admissionMaxObjectBytes = cfgMaxObjectBytes cfg
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
}
admitDelete :: Config -> Db -> Text -> Text -> IO AdmitOutcome
admitDelete cfg database operation path =
withTransaction database $ \connection ->
admitMutation
connection
protocolUser
Delete
(OperationId operation)
sharedPool
(ObjectKey ("shared/" <> path))
(RelativePath path)
0
Nothing
(cfgMaxObjectBytes cfg)
(cfgIdempotencyWindowSec cfg)
AdmissionRequest
{ admissionIdentity =
AdmissionIdentity protocolUser Delete (OperationId operation)
, admissionPoolId = sharedPool
, admissionRelativePath = RelativePath path
, admissionFingerprint =
MutationFingerprint Delete (ObjectKey ("shared/" <> path)) 0 Nothing
}
AdmissionLimits
{ admissionMaxObjectBytes = cfgMaxObjectBytes cfg
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
}
admitPersonal :: Config -> Db -> UserId -> Text -> IO AdmitOutcome
admitPersonal cfg database user operation =
withTransaction database $ \connection ->
admitMutation
connection
user
Put
(OperationId operation)
(personalPool user)
(ObjectKey ("users/" <> unUserId user <> "/file.bin"))
(RelativePath "file.bin")
9
(Just identityA)
(cfgMaxObjectBytes cfg)
(cfgIdempotencyWindowSec cfg)
AdmissionRequest
{ admissionIdentity =
AdmissionIdentity user Put (OperationId operation)
, admissionPoolId = personalPool user
, admissionRelativePath = RelativePath "file.bin"
, admissionFingerprint =
MutationFingerprint
Put
(ObjectKey ("users/" <> unUserId user <> "/file.bin"))
9
(Just identityA)
}
AdmissionLimits
{ admissionMaxObjectBytes = cfgMaxObjectBytes cfg
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
}
seedObject :: Db -> S3 -> Text -> BL.ByteString -> IO ()
seedObject database store path body = do

47
test/RecoveryPhase.hs
View file

@ -112,16 +112,15 @@ preparePut database redis name size identity = do
outcome <- withTransaction database $ \connection ->
admitMutation
connection
recoveryUser
Put
(phaseOperation name)
sharedPool
(phaseKey name)
(RelativePath (name <> ".bin"))
size
(Just identity)
(1024 * 1024 * 1024)
3600
AdmissionRequest
{ admissionIdentity =
AdmissionIdentity recoveryUser Put (phaseOperation name)
, admissionPoolId = sharedPool
, admissionRelativePath = RelativePath (name <> ".bin")
, admissionFingerprint =
MutationFingerprint Put (phaseKey name) size (Just identity)
}
(AdmissionLimits (1024 * 1024 * 1024) 3600)
prepared outcome
prepareDelete :: Config -> Db -> Redis -> S3 -> IO MutationRecord
@ -146,16 +145,18 @@ prepareDelete cfg database redis store = do
outcome <- withTransaction database $ \connection ->
admitMutation
connection
recoveryUser
Delete
(phaseOperation name)
sharedPool
key
(RelativePath (name <> ".bin"))
0
Nothing
(cfgMaxObjectBytes cfg)
(cfgIdempotencyWindowSec cfg)
AdmissionRequest
{ admissionIdentity =
AdmissionIdentity recoveryUser Delete (phaseOperation name)
, admissionPoolId = sharedPool
, admissionRelativePath = RelativePath (name <> ".bin")
, admissionFingerprint =
MutationFingerprint Delete key 0 Nothing
}
AdmissionLimits
{ admissionMaxObjectBytes = cfgMaxObjectBytes cfg
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
}
prepared outcome
beginDispatch :: Config -> Db -> MutationRecord -> IO ()
@ -165,8 +166,10 @@ beginDispatch cfg database rec = do
pending <- markExternalPending
connection
rec
(cfgObjectRequestTimeoutSec cfg * 2)
(cfgRecoveryGraceSec cfg)
DispatchTiming
{ dispatchSettlementBoundSec = cfgObjectRequestTimeoutSec cfg * 2
, dispatchWorkerGraceSec = cfgRecoveryGraceSec cfg
}
pure (applying && pending)
unless started (fail "could not begin dispatch")

91
test/Spec.hs
View file

@ -101,12 +101,21 @@ import Nuthatch.Paths
, listCacheAncestorPrefixes
)
import Nuthatch.Protocol
( ExistingDisposition (..)
( AdmissionIdentity (..)
, ExistingDisposition (..)
, MutationFingerprint (..)
, MutationPhase (..)
, MutationRecord (..)
, ObjectObservation (..)
, PriorObject (..)
, TerminalResult (..)
, decodeMutationPhase
, desiredMatches
, encodeMutationPhase
, existingDisposition
, growthBytes
, mrContentSha256
, mrObjectKey
, priorMatches
, quotaAllows
, recoveryEligible
@ -307,20 +316,50 @@ identityTests = testGroup "identities"
protocolTests :: TestTree
protocolTests = testGroup "mutation protocol decisions"
[ testProperty "request fingerprints distinguish every bound field" propFingerprintDistinction
[ testCase "protocol phases round-trip through persisted state labels" $
mapM_
(\phase -> do
let (state, external) = encodeMutationPhase phase
decodeMutationPhase state external @?= Just phase)
[ PhasePrepared
, PhaseApplying ExtIdle
, PhaseApplying ExtPending
, PhaseApplying ExtSettled
, PhaseTerminal TerminalSucceeded
, PhaseTerminal TerminalFailed
, PhaseTerminal TerminalRejected
]
, testCase "invalid persisted protocol phase combinations are rejected" $
mapM_
(\(state, external) ->
decodeMutationPhase state external @?= Nothing)
[ (Prepared, ExtPending)
, (Prepared, ExtSettled)
, (Succeeded, ExtPending)
, (Succeeded, ExtSettled)
, (Failed, ExtPending)
, (Failed, ExtSettled)
, (Rejected, ExtPending)
, (Rejected, ExtSettled)
]
, testProperty "request fingerprints distinguish every bound field" propFingerprintDistinction
, testCase "removed terminal identity starts a new mutation epoch" $ do
let rec = sampleMutation
Put
(ObjectKey "users/u/file")
4
(Just (ContentSha256 "content"))
case existingDisposition Nothing Put (mrObjectKey rec) 4 (mrContentSha256 rec) of
let fingerprint =
MutationFingerprint Put (mrObjectKey rec) 4 (mrContentSha256 rec)
case existingDisposition Nothing fingerprint of
NewMutationEpoch -> pure ()
other -> assertFailure ("expected new epoch, got " <> show other)
case existingDisposition (Just rec) Put (mrObjectKey rec) 4 (mrContentSha256 rec) of
case existingDisposition (Just rec) fingerprint of
ExistingReplay MutationPending _ -> pure ()
other -> assertFailure ("expected replay, got " <> show other)
case existingDisposition (Just rec) Put (mrObjectKey rec) 5 (mrContentSha256 rec) of
case existingDisposition
(Just rec)
(fingerprint { fingerprintDeclaredSize = 5 }) of
ExistingConflict -> pure ()
other -> assertFailure ("expected conflict, got " <> show other)
, testProperty "quota growth and admission preserve the limit" propQuotaInvariant
@ -334,8 +373,8 @@ protocolTests = testGroup "mutation protocol decisions"
, testCase "ambiguous same-size content matches no terminal state" $ do
let rec = (sampleMutation Put (ObjectKey "shared/file") 10
(Just (ContentSha256 "desired")))
{ mrPriorSize = 10
, mrPriorSha256 = Just (ContentSha256 "prior")
{ mrPriorObject =
PriorObject 10 (Just (ContentSha256 "prior"))
}
observation = ObjectPresent 10 (Just (ContentSha256 "other"))
desiredMatches rec observation @?= False
@ -1105,12 +1144,19 @@ propFingerprintDistinction = property $ do
otherPathKey = buildObjectKey Personal uid (RelativePath ("other/" <> raw))
sha = Just (ContentSha256 "content-a")
rec = sampleMutation Put key size sha
assert (sameFingerprint rec Put key size sha)
assert (not (sameFingerprint rec Delete key size sha))
assert (not (sameFingerprint rec Put otherRootKey size sha))
assert (not (sameFingerprint rec Put otherPathKey size sha))
assert (not (sameFingerprint rec Put key (size + 1) sha))
assert (not (sameFingerprint rec Put key size (Just (ContentSha256 "content-b"))))
let fingerprint = MutationFingerprint Put key size sha
assert (sameFingerprint rec fingerprint)
assert (not (sameFingerprint rec
(fingerprint { fingerprintKind = Delete })))
assert (not (sameFingerprint rec
(fingerprint { fingerprintObjectKey = otherRootKey })))
assert (not (sameFingerprint rec
(fingerprint { fingerprintObjectKey = otherPathKey })))
assert (not (sameFingerprint rec
(fingerprint { fingerprintDeclaredSize = size + 1 })))
assert (not (sameFingerprint rec
(fingerprint
{ fingerprintContentSha256 = Just (ContentSha256 "content-b") })))
propQuotaInvariant :: Property
propQuotaInvariant = property $ do
@ -1140,9 +1186,7 @@ propObservations = property $ do
let desiredSha = Just (ContentSha256 "desired")
priorSha = if priorSize == 0 then Nothing else Just (ContentSha256 "prior")
rec = (sampleMutation kind (ObjectKey "users/u/file") desiredSize desiredSha)
{ mrPriorSize = priorSize
, mrPriorSha256 = priorSha
}
{ mrPriorObject = PriorObject priorSize priorSha }
desiredMatches rec observation === modelDesired kind desiredSize desiredSha observation
priorMatches rec observation === modelPrior priorSize priorSha observation
@ -1257,17 +1301,12 @@ sampleMutation
-> Maybe ContentSha256
-> MutationRecord
sampleMutation kind key size sha = MutationRecord
{ mrUserId = UserId "u"
, mrKind = kind
, mrOperationId = OperationId "op"
{ mrAdmissionIdentity =
AdmissionIdentity (UserId "u") kind (OperationId "op")
, mrPoolId = PoolId "personal:u"
, mrObjectKey = key
, mrRelativePath = RelativePath "file"
, mrDeclaredSize = size
, mrContentSha256 = sha
, mrPriorSize = 0
, mrPriorSha256 = Nothing
, mrFingerprint = MutationFingerprint kind key size sha
, mrPriorObject = PriorObject 0 Nothing
, mrGrowth = size
, mrState = Applying
, mrExternal = ExtSettled
, mrPhase = PhaseApplying ExtSettled
}