ms2k/nuthatch
SHA256
Watch
0
Code Releases Activity

Bind protocol evidence to the TLA+ model

Browse source
This commit is contained in:
ms2k 2026-07-19 19:51:26 +09:00
commit b3c0f6d58a
12 changed files with 1281 additions and 56 deletions
Download patch file Download diff file Expand all files Collapse all files

7
Makefile
View file

@ -1,4 +1,4 @@
.PHONY: test check-dependencies check-fixture-lib check-kind-matrix check-storage-foundation check-auth check-app check-app-boundaries check-streaming check-idempotency check-recovery check-protocol check-product check-runtime check-v1 check-specs app-up app-down test-frontend check-frontend build-frontend .PHONY: test check-dependencies check-fixture-lib check-kind-matrix check-storage-foundation check-auth check-app check-app-boundaries check-streaming check-idempotency check-recovery check-model-correspondence check-protocol check-product check-runtime check-v1 check-specs app-up app-down test-frontend check-frontend build-frontend
test: test:
./tests/run-host-tests.sh ./tests/run-host-tests.sh
@ -33,7 +33,10 @@ check-idempotency:
check-recovery: check-recovery:
./tests/kind/recovery-run.sh ./tests/kind/recovery-run.sh
check-protocol: check-model-correspondence:
./tests/model-correspondence/run.sh
check-protocol: check-model-correspondence
./tests/kind/protocol-conformance-run.sh ./tests/kind/protocol-conformance-run.sh
check-product: test-frontend check-frontend build-frontend check-product: test-frontend check-frontend build-frontend

16
docs/spec/testing.md
View file

@ -13,6 +13,22 @@ examples, and Hedgehog through Tasty Hedgehog for generated properties.
Hedgehog failures include the seed needed to replay the shrunk counterexample. Hedgehog failures include the seed needed to replay the shrunk counterexample.
Generators represent valid and invalid domains with distinct types. Generators represent valid and invalid domains with distinct types.
## Model correspondence
`make check-model-correspondence` runs before the kind protocol-conformance
gate. It uses the typed Haskell protocol evidence executable, Node 24.18.0,
Java 25.0.3, and the TLA+ Tools 2.19 jar whose checksum is pinned in
`tests/model-correspondence/tools.env`. The jar defaults to
`/usr/local/lib/tla2tools.jar`; `TLA2TOOLS_JAR` may name an equivalent file
with the pinned checksum.
The checker discovers executable leaf actions below `Next` from SANY's
semantic graph, executes a minimal TLC configuration, resolves checks named by
every behavioral configuration, and compares them with typed implementation
inventories. Concrete snapshot fixtures are projected into the model
vocabulary without implementing an abstract transition relation. Generated
graphs and TLC state are created in a temporary directory and are not retained.
## Kind dependency fixture ## Kind dependency fixture
Backend integration tests execute inside an isolated kind cluster so they use Backend integration tests execute inside an isolated kind cluster so they use

14
nuthatch.cabal
View file

@ -168,6 +168,8 @@ executable nuthatch-protocol-conformance
import: shared import: shared
main-is: ProtocolConformance.hs main-is: ProtocolConformance.hs
hs-source-dirs: test hs-source-dirs: test
other-modules:
Nuthatch.ModelEvidence
build-depends: build-depends:
, nuthatch , nuthatch
, base , base
@ -181,6 +183,18 @@ executable nuthatch-protocol-conformance
-rtsopts -rtsopts
-with-rtsopts=-N -with-rtsopts=-N
executable nuthatch-model-evidence
import: shared
main-is: ModelEvidenceMain.hs
hs-source-dirs: test
other-modules:
Nuthatch.ModelEvidence
build-depends:
, nuthatch
, aeson
, base
, text
executable nuthatch-runtime-probe executable nuthatch-runtime-probe
import: shared import: shared
main-is: RuntimeProbe.hs main-is: RuntimeProbe.hs

59
test/ModelEvidenceMain.hs Normal file
View file

@ -0,0 +1,59 @@
module Main (main) where
import Data.Aeson (eitherDecodeFileStrict)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Nuthatch.ModelEvidence
import System.Environment (getArgs)
import System.Exit (die)
main :: IO ()
main = do
arguments <- getArgs
case arguments of
["inventory"] -> printInventory
["verify", fixturePath] -> verifyFixtures fixturePath
_ -> die "usage: nuthatch-model-evidence inventory | verify FIXTURES"
printInventory :: IO ()
printInventory = do
mapM_
(\action ->
printFields ["ACTION", actionConstructor action, actionName action])
allModelActions
mapM_
(\check ->
printFields ["CHECK", checkConstructor check, checkName check])
allModelChecks
mapM_
(\ScenarioEvidence{..} ->
printFields
[ "SCENARIO"
, actionConstructor scenarioAction
, actionName scenarioAction
, scenarioPrecondition
, scenarioObservation
, scenarioExpectedPost
])
scenarioEvidence
verifyFixtures :: FilePath -> IO ()
verifyFixtures fixturePath = do
decoded <- eitherDecodeFileStrict fixturePath
fixtures <-
either
(die . ("cannot decode projection fixtures: " <>))
pure
decoded
projected <-
either
(die . T.unpack)
pure
(verifySnapshotFixtures fixtures)
mapM_
(\ProjectedFixture{..} ->
printFields ["SNAPSHOT", projectedName, projectedPhase])
projected
printFields :: [T.Text] -> IO ()
printFields = T.putStrLn . T.intercalate "\t"

405
test/Nuthatch/ModelEvidence.hs Normal file
View file

@ -0,0 +1,405 @@
module Nuthatch.ModelEvidence
( ModelAction (..)
, ModelCheck (..)
, ScenarioEvidence (..)
, SnapshotFixture
, ProjectedFixture (..)
, allModelActions
, allModelChecks
, scenarioEvidence
, actionName
, checkName
, actionConstructor
, checkConstructor
, coveredAction
, checkedModel
, verifySnapshotFixtures
) where
import Data.Aeson
( FromJSON (parseJSON)
, (.:)
, withObject
)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Nuthatch.Protocol
( MutationPhase (..)
, TerminalResult (..)
, decodeMutationPhase
, externalState
)
import Nuthatch.Types
data ModelAction
= ActionConflictRequest
| ActionDispatchEffect
| ActionExternalEffectApplied
| ActionExternalEffectNotApplied
| ActionFinalizeFailure
| ActionFinalizeSuccess
| ActionFirstRequest
| ActionLoseObjectStore
| ActionLosePostgres
| ActionLoseUploadBody
| ActionPrepareEffect
| ActionReplayRequest
| ActionRestoreObjectStore
| ActionRestorePostgres
| ActionSettleLostUpload
deriving stock (Bounded, Enum, Eq, Ord, Show)
data ModelCheck
= CheckAccountingAtQuiescence
| CheckActiveObjectConsistent
| CheckExternalStateConsistent
| CheckFingerprintBindsRequest
| CheckLocksConsistent
| CheckLostUploadEventuallyTerminal
| CheckObjectQuotaBound
| CheckObjectStateCovered
| CheckObjectStoreFailureFencesObjects
| CheckObservationConsistent
| CheckPersonalPoolsDisjoint
| CheckPersonalRequestsUseOwnPool
| CheckPostgresFailureFencesDurableState
| CheckQuotaReservationBound
| CheckRecordIdentityConsistent
| CheckRecordsNeverForgotten
| CheckRequestBindingsStable
| CheckReservationsConsistent
| CheckSettledEffectsDoNotMutate
| CheckTerminalRecordsStable
| CheckTypeOK
| CheckUnfinishedEventuallyTerminal
| CheckUploadBodyConsistent
deriving stock (Bounded, Enum, Eq, Ord, Show)
data ScenarioEvidence = ScenarioEvidence
{ scenarioAction :: ModelAction
, scenarioPrecondition :: Text
, scenarioObservation :: Text
, scenarioExpectedPost :: Text
}
deriving stock (Eq, Show)
data ConcreteSnapshot = ConcreteSnapshot
{ concreteIdentity :: Text
, concreteKind :: MutationKind
, concreteDeclaredSize :: Integer
, concreteContent :: Maybe ContentSha256
, concreteRecordState :: MutationState
, concreteExternalState :: ExternalState
, concreteUploadBodyAvailable :: Bool
, concreteKeyOwner :: Maybe Text
, concretePriorObject :: Maybe SnapshotObject
, concreteCurrentObject :: Maybe SnapshotObject
, concreteGrowthBytes :: Integer
, concreteReservedBytes :: Integer
, concreteUsedBytes :: Integer
, concreteLimitBytes :: Integer
, concreteMaxObjectBytes :: Integer
}
deriving stock (Eq, Show)
data SnapshotObject = SnapshotObject
{ snapshotObjectSize :: Integer
, snapshotObjectContent :: ContentSha256
}
deriving stock (Eq, Show)
data SnapshotFixture = SnapshotFixture
{ snapshotName :: Text
, snapshotConcrete :: ConcreteSnapshot
}
deriving stock (Eq, Show)
data AbstractSnapshot = AbstractSnapshot
{ abstractIdentity :: Text
, abstractKind :: MutationKind
, abstractDesiredObject :: Maybe SnapshotObject
, abstractPriorObject :: Maybe SnapshotObject
, abstractCurrentObject :: Maybe SnapshotObject
, abstractPhase :: MutationPhase
, abstractUploadBodyAvailable :: Bool
, abstractKeyOwner :: Maybe Text
, abstractGrowthBytes :: Integer
, abstractReservedBytes :: Integer
, abstractUsedBytes :: Integer
, abstractLimitBytes :: Integer
, abstractMaxObjectBytes :: Integer
}
deriving stock (Eq, Show)
data ProjectedFixture = ProjectedFixture
{ projectedName :: Text
, projectedPhase :: Text
}
deriving stock (Eq, Show)
instance FromJSON SnapshotFixture where
parseJSON = withObject "SnapshotFixture" $ \value ->
SnapshotFixture
<$> value .: "name"
<*> value .: "concrete"
instance FromJSON ConcreteSnapshot where
parseJSON = withObject "ConcreteSnapshot" $ \value -> do
kindText <- value .: "kind"
contentText <- value .: "content"
stateText <- value .: "record_state"
externalText <- value .: "external_state"
kind <- maybe (fail "invalid mutation kind") pure (parseKind kindText)
content <-
traverse
(either (fail . T.unpack) pure . validateContentSha256)
contentText
state <- maybe (fail "invalid mutation state") pure (parseState stateText)
external <-
maybe (fail "invalid external state") pure (parseExternal externalText)
ConcreteSnapshot
<$> value .: "identity"
<*> pure kind
<*> value .: "declared_size"
<*> pure content
<*> pure state
<*> pure external
<*> value .: "upload_body_available"
<*> value .: "key_owner"
<*> value .: "prior_object"
<*> value .: "current_object"
<*> value .: "growth_bytes"
<*> value .: "reserved_bytes"
<*> value .: "used_bytes"
<*> value .: "limit_bytes"
<*> value .: "max_object_bytes"
instance FromJSON SnapshotObject where
parseJSON = withObject "SnapshotObject" $ \value -> do
contentText <- value .: "content"
content <-
either (fail . T.unpack) pure (validateContentSha256 contentText)
SnapshotObject
<$> value .: "size"
<*> pure content
allModelActions :: [ModelAction]
allModelActions = [minBound .. maxBound]
allModelChecks :: [ModelCheck]
allModelChecks = [minBound .. maxBound]
actionName :: ModelAction -> Text
actionName = T.drop 6 . T.pack . show
checkName :: ModelCheck -> Text
checkName = T.drop 5 . T.pack . show
actionConstructor :: ModelAction -> Text
actionConstructor = T.pack . show
checkConstructor :: ModelCheck -> Text
checkConstructor = T.pack . show
coveredAction :: ModelAction -> IO ()
coveredAction action =
T.putStrLn ("protocol action covered: " <> actionName action)
checkedModel :: ModelCheck -> IO ()
checkedModel check =
T.putStrLn ("model check covered: " <> checkName check)
scenarioEvidence :: [ScenarioEvidence]
scenarioEvidence =
[ scenario ActionFirstRequest "postgresUp /\\ NoRecord" "first / pending or rejected" "prepared with lock and reservation iff CanAdmit; otherwise rejected"
, scenario ActionReplayRequest "postgresUp /\\ matching recorded request" "replay / StateResult" "protocol state unchanged"
, scenario ActionConflictRequest "postgresUp /\\ different request fingerprint" "conflict / conflict" "protocol state unchanged"
, scenario ActionPrepareEffect "postgresUp /\\ prepared" "NoObservation" "applying-idle"
, scenario ActionDispatchEffect "postgresUp /\\ objectStoreUp /\\ applying-idle" "NoObservation" "applying-pending without upload body"
, scenario ActionExternalEffectApplied "objectStoreUp /\\ applying-pending" "NoObservation" "applying-settled with desired object"
, scenario ActionExternalEffectNotApplied "objectStoreUp /\\ applying-pending" "NoObservation" "applying-settled with object unchanged"
, scenario ActionFinalizeSuccess "postgresUp /\\ objectStoreUp /\\ applying-settled /\\ object = desired" "NoObservation" "succeeded-idle without lock or reservation"
, scenario ActionFinalizeFailure "postgresUp /\\ objectStoreUp /\\ applying-settled /\\ object = prior" "NoObservation" "failed-idle without lock or reservation"
, scenario ActionLoseUploadBody "active put /\\ external idle /\\ upload body available" "NoObservation" "active-idle without upload body"
, scenario ActionSettleLostUpload "postgresUp /\\ objectStoreUp /\\ applying-idle /\\ upload body unavailable" "NoObservation" "applying-settled"
, scenario ActionLosePostgres "postgresUp /\\ losses below bound" "NoObservation" "postgres down; protocol state unchanged"
, scenario ActionRestorePostgres "~postgresUp" "NoObservation" "postgres up; protocol state unchanged"
, scenario ActionLoseObjectStore "objectStoreUp /\\ losses below bound" "NoObservation" "object store down; protocol state unchanged"
, scenario ActionRestoreObjectStore "~objectStoreUp" "NoObservation" "object store up; protocol state unchanged"
]
where
scenario = ScenarioEvidence
verifySnapshotFixtures
:: [SnapshotFixture]
-> Either Text [ProjectedFixture]
verifySnapshotFixtures fixtures = do
projected <- traverse projectFixture fixtures
let phases = map projectedPhase projected
concrete = map snapshotConcrete fixtures
requireCoverage "prepared" phases
requireCoverage "applying-idle" phases
requireCoverage "applying-pending" phases
requireCoverage "applying-settled" phases
requireCoverage "terminal" phases
requireCoverage "rejected" phases
requireAny "lock" ((/= Nothing) . concreteKeyOwner) concrete
requireAny "reservation" ((> 0) . concreteReservedBytes) concrete
requireAny "prior object" ((/= Nothing) . concretePriorObject) concrete
requireAny "desired object" ((== Put) . concreteKind) concrete
requireAny "object" ((/= Nothing) . concreteCurrentObject) concrete
requireAny "upload body" concreteUploadBodyAvailable concrete
pure projected
projectFixture :: SnapshotFixture -> Either Text ProjectedFixture
projectFixture SnapshotFixture{..} = do
projected <- projectSnapshot snapshotConcrete
validateSnapshot snapshotName projected
pure ProjectedFixture
{ projectedName = snapshotName
, projectedPhase = phaseName (abstractPhase projected)
}
projectSnapshot :: ConcreteSnapshot -> Either Text AbstractSnapshot
projectSnapshot ConcreteSnapshot{..} = do
phase <-
maybe
(Left "ExternalStateConsistent")
Right
(decodeMutationPhase concreteRecordState concreteExternalState)
desired <-
case (concreteKind, concreteDeclaredSize, concreteContent) of
(Put, size, Just content)
| size > 0 ->
Right (Just (SnapshotObject size content))
(Delete, 0, Nothing) -> Right Nothing
_ -> Left "ValidRequest"
pure AbstractSnapshot
{ abstractIdentity = concreteIdentity
, abstractKind = concreteKind
, abstractDesiredObject = desired
, abstractPriorObject = concretePriorObject
, abstractCurrentObject = concreteCurrentObject
, abstractPhase = phase
, abstractUploadBodyAvailable = concreteUploadBodyAvailable
, abstractKeyOwner = concreteKeyOwner
, abstractGrowthBytes = concreteGrowthBytes
, abstractReservedBytes = concreteReservedBytes
, abstractUsedBytes = concreteUsedBytes
, abstractLimitBytes = concreteLimitBytes
, abstractMaxObjectBytes = concreteMaxObjectBytes
}
validateSnapshot :: Text -> AbstractSnapshot -> Either Text ()
validateSnapshot label snapshot = do
let active =
case abstractPhase snapshot of
PhasePrepared -> True
PhaseApplying _ -> True
PhaseTerminal _ -> False
idle = externalState (abstractPhase snapshot) == ExtIdle
priorSize = objectSize (abstractPriorObject snapshot)
desiredSize = objectSize (abstractDesiredObject snapshot)
currentSize = objectSize (abstractCurrentObject snapshot)
expectedGrowth = max 0 (desiredSize - priorSize)
require
(validObject (abstractPriorObject snapshot))
"ObjectValues"
require
(validObject (abstractDesiredObject snapshot))
"ObjectValues"
require
(validObject (abstractCurrentObject snapshot))
"ObjectValues"
require
( all
((<= abstractMaxObjectBytes snapshot) . objectSize)
[ abstractPriorObject snapshot
, abstractDesiredObject snapshot
, abstractCurrentObject snapshot
]
)
"ObjectValues"
require
( not active
|| abstractCurrentObject snapshot
`elem` [abstractPriorObject snapshot, abstractDesiredObject snapshot]
)
"ActiveObjectConsistent"
require
( not (abstractUploadBodyAvailable snapshot)
|| (active && abstractKind snapshot == Put && idle)
)
"UploadBodyConsistent"
require
((abstractKeyOwner snapshot == Just (abstractIdentity snapshot)) == active)
"LocksConsistent"
require
( abstractReservedBytes snapshot
== if active then abstractGrowthBytes snapshot else 0
)
"ReservationsConsistent"
require
(abstractGrowthBytes snapshot == expectedGrowth)
"Reservation"
require
( abstractUsedBytes snapshot + abstractReservedBytes snapshot
<= abstractLimitBytes snapshot
)
"QuotaReservationBound"
require
(currentSize <= abstractUsedBytes snapshot + abstractReservedBytes snapshot)
"ObjectStateCovered"
require
(currentSize <= abstractLimitBytes snapshot)
"ObjectQuotaBound"
require
(active || abstractUsedBytes snapshot == currentSize)
"AccountingAtQuiescence"
case abstractPhase snapshot of
PhaseTerminal TerminalRejected ->
require
( abstractUsedBytes snapshot
+ abstractReservedBytes snapshot
+ abstractGrowthBytes snapshot
> abstractLimitBytes snapshot
)
"CanAdmit"
_ -> Right ()
require (abstractGrowthBytes snapshot >= 0) "growth must be natural"
require (abstractReservedBytes snapshot >= 0) "reservation must be natural"
require (abstractUsedBytes snapshot >= 0) "used bytes must be natural"
require (abstractLimitBytes snapshot >= 0) "limit must be natural"
require (abstractMaxObjectBytes snapshot > 0) "MaxObjectSize"
where
require condition invariant =
if condition then Right () else Left (label <> ": " <> invariant)
objectSize :: Maybe SnapshotObject -> Integer
objectSize = maybe 0 snapshotObjectSize
validObject :: Maybe SnapshotObject -> Bool
validObject Nothing = True
validObject (Just SnapshotObject{..}) = snapshotObjectSize > 0
phaseName :: MutationPhase -> Text
phaseName = \case
PhasePrepared -> "prepared"
PhaseApplying ExtIdle -> "applying-idle"
PhaseApplying ExtPending -> "applying-pending"
PhaseApplying ExtSettled -> "applying-settled"
PhaseTerminal TerminalRejected -> "rejected"
PhaseTerminal _ -> "terminal"
requireCoverage :: Text -> [Text] -> Either Text ()
requireCoverage expected actual =
if expected `elem` actual
then Right ()
else Left ("missing projection coverage: " <> expected)
requireAny :: Text -> (value -> Bool) -> [value] -> Either Text ()
requireAny label predicate values =
if any predicate values
then Right ()
else Left ("missing projection coverage: " <> label)

88
test/ProtocolConformance.hs
View file

@ -17,7 +17,6 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.Maybe (isNothing) import Data.Maybe (isNothing)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding as TE
import Database.PostgreSQL.Simple (Only (..)) import Database.PostgreSQL.Simple (Only (..))
import GHC.Clock (getMonotonicTimeNSec) import GHC.Clock (getMonotonicTimeNSec)
@ -27,6 +26,7 @@ import Nuthatch.Db
import qualified Nuthatch.Db as Db import qualified Nuthatch.Db as Db
import qualified Nuthatch.Mutation.Service as Mutation import qualified Nuthatch.Mutation.Service as Mutation
import Nuthatch.Mutation.Service (runDelete) import Nuthatch.Mutation.Service (runDelete)
import Nuthatch.ModelEvidence
import Nuthatch.Protocol import Nuthatch.Protocol
import Nuthatch.Redis import Nuthatch.Redis
import Nuthatch.S3 import Nuthatch.S3
@ -92,7 +92,7 @@ verifyConformance cfg database store = do
admissionScenarios cfg database admissionScenarios cfg database
effectScenarios cfg database store effectScenarios cfg database store
targetContract cfg database store targetContract cfg database store
checkedInvariant "TypeOK" checkedModel CheckTypeOK
putStrLn "Protocol conformance passed" putStrLn "Protocol conformance passed"
admissionScenarios :: Config -> Db -> IO () admissionScenarios :: Config -> Db -> IO ()
@ -105,12 +105,12 @@ admissionScenarios cfg database = do
assertEqual "ReplayRequest" MutationPending (replayResult replay) assertEqual "ReplayRequest" MutationPending (replayResult replay)
assert "ConflictRequest" (isConflict conflict) assert "ConflictRequest" (isConflict conflict)
assertAuthority database 1 10 0 assertAuthority database 1 10 0
coveredAction "FirstRequest" coveredAction ActionFirstRequest
coveredAction "ReplayRequest" coveredAction ActionReplayRequest
coveredAction "ConflictRequest" coveredAction ActionConflictRequest
checkedInvariant "RecordIdentityConsistent" checkedModel CheckRecordIdentityConsistent
checkedInvariant "FingerprintBindsRequest" checkedModel CheckFingerprintBindsRequest
checkedInvariant "ObservationConsistent" checkedModel CheckObservationConsistent
resetAuthority database 10 resetAuthority database 10
locked <- admitPut cfg database "locked-a" "locked.bin" 8 identityA locked <- admitPut cfg database "locked-a" "locked.bin" 8 identityA
@ -119,9 +119,9 @@ admissionScenarios cfg database = do
assert "same-key rejection" (isPrepared locked && isRejected rejected) assert "same-key rejection" (isPrepared locked && isRejected rejected)
assert "positive-delta quota rejection" (isRejected quota) assert "positive-delta quota rejection" (isRejected quota)
assertAuthority database 1 8 0 assertAuthority database 1 8 0
checkedInvariant "ReservationsConsistent" checkedModel CheckReservationsConsistent
checkedInvariant "LocksConsistent" checkedModel CheckLocksConsistent
checkedInvariant "QuotaReservationBound" checkedModel CheckQuotaReservationBound
resetAuthority database 100 resetAuthority database 100
let firstUser = UserId "personal-a" let firstUser = UserId "personal-a"
@ -137,8 +137,8 @@ admissionScenarios cfg database = do
\FROM mutations WHERE user_id IN ('personal-a', 'personal-b')" \FROM mutations WHERE user_id IN ('personal-a', 'personal-b')"
:: IO [(Int, Int)] :: IO [(Int, Int)]
assertEqual "personal pool and key separation" [(2, 2)] personalRows assertEqual "personal pool and key separation" [(2, 2)] personalRows
checkedInvariant "PersonalRequestsUseOwnPool" checkedModel CheckPersonalRequestsUseOwnPool
checkedInvariant "PersonalPoolsDisjoint" checkedModel CheckPersonalPoolsDisjoint
effectScenarios :: Config -> Db -> S3 -> IO () effectScenarios :: Config -> Db -> S3 -> IO ()
effectScenarios cfg database store = do effectScenarios cfg database store = do
@ -156,15 +156,15 @@ effectScenarios cfg database store = do
assertEqual "terminal replay result" MutationSucceeded assertEqual "terminal replay result" MutationSucceeded
(replayResult terminalReplay) (replayResult terminalReplay)
assertEqual "terminal replay preserves record" beforeReplay afterReplay assertEqual "terminal replay preserves record" beforeReplay afterReplay
coveredAction "ExternalEffectApplied" coveredAction ActionExternalEffectApplied
checkedInvariant "ActiveObjectConsistent" checkedModel CheckActiveObjectConsistent
checkedInvariant "ExternalStateConsistent" checkedModel CheckExternalStateConsistent
checkedInvariant "ObjectStateCovered" checkedModel CheckObjectStateCovered
checkedInvariant "ObjectQuotaBound" checkedModel CheckObjectQuotaBound
checkedInvariant "AccountingAtQuiescence" checkedModel CheckAccountingAtQuiescence
checkedInvariant "RecordsNeverForgotten" checkedModel CheckRecordsNeverForgotten
checkedInvariant "RequestBindingsStable" checkedModel CheckRequestBindingsStable
checkedInvariant "TerminalRecordsStable" checkedModel CheckTerminalRecordsStable
resetScenario database store "unapplied.bin" resetScenario database store "unapplied.bin"
unapplied <- prepared =<< admitPut cfg database "unapplied" "unapplied.bin" 9 identityA unapplied <- prepared =<< admitPut cfg database "unapplied" "unapplied.bin" 9 identityA
@ -172,7 +172,7 @@ effectScenarios cfg database store = do
settle database unapplied settle database unapplied
finalize database unapplied ObjectAbsent MutationFailed finalize database unapplied ObjectAbsent MutationFailed
assertAuthority database 0 0 0 assertAuthority database 0 0 0
coveredAction "ExternalEffectNotApplied" coveredAction ActionExternalEffectNotApplied
resetScenario database store "body-loss.bin" resetScenario database store "body-loss.bin"
lost <- prepared =<< admitPut cfg database "body-loss" "body-loss.bin" 9 identityA lost <- prepared =<< admitPut cfg database "body-loss" "body-loss.bin" 9 identityA
@ -183,11 +183,11 @@ effectScenarios cfg database store = do
assert "LoseUploadBody/SettleLostUpload" idleSettled assert "LoseUploadBody/SettleLostUpload" idleSettled
finalize database lost ObjectAbsent MutationFailed finalize database lost ObjectAbsent MutationFailed
assertAuthority database 0 0 0 assertAuthority database 0 0 0
coveredAction "LoseUploadBody" coveredAction ActionLoseUploadBody
coveredAction "SettleLostUpload" coveredAction ActionSettleLostUpload
checkedInvariant "UploadBodyConsistent" checkedModel CheckUploadBodyConsistent
checkedInvariant "UnfinishedEventuallyTerminal" checkedModel CheckUnfinishedEventuallyTerminal
checkedInvariant "LostUploadEventuallyTerminal" checkedModel CheckLostUploadEventuallyTerminal
resetScenario database store "replacement.bin" resetScenario database store "replacement.bin"
seedObject database store "replacement.bin" "prior-one" seedObject database store "replacement.bin" "prior-one"
@ -278,7 +278,7 @@ targetContract cfg database store = do
stableForSettlementBound cfg $ do stableForSettlementBound cfg $ do
absent <- expectRight =<< headObject store key absent <- expectRight =<< headObject store key
assertEqual "no mutation after delete settlement" Nothing absent assertEqual "no mutation after delete settlement" Nothing absent
checkedInvariant "SettledEffectsDoNotMutate" checkedModel CheckSettledEffectsDoNotMutate
verifyStoreFence :: Config -> Db -> Redis -> S3 -> IO () verifyStoreFence :: Config -> Db -> Redis -> S3 -> IO ()
verifyStoreFence cfg database redis store = do verifyStoreFence cfg database redis store = do
@ -383,7 +383,7 @@ verifyStoreFence cfg database redis store = do
(Only ("store-down" :: Text)) (Only ("store-down" :: Text))
:: IO [Only Int] :: IO [Only Int]
assertEqual "store-down rejection creates no protocol record" [Only 0] rows assertEqual "store-down rejection creates no protocol record" [Only 0] rows
putStrLn "protocol action covered: LoseObjectStore" coveredAction ActionLoseObjectStore
putStrLn "store-down rejection preserves expired epoch boundary" putStrLn "store-down rejection preserves expired epoch boundary"
putStrLn "store-down rejection creates no protocol record" putStrLn "store-down rejection creates no protocol record"
@ -404,8 +404,8 @@ verifyStoreRestored store = do
$ \key -> do $ \key -> do
absent <- expectRight =<< headObject store (ObjectKey key) absent <- expectRight =<< headObject store (ObjectKey key)
assertEqual "store loss leaves fenced object unchanged" Nothing absent assertEqual "store loss leaves fenced object unchanged" Nothing absent
putStrLn "protocol action covered: RestoreObjectStore" coveredAction ActionRestoreObjectStore
checkedInvariant "ObjectStoreFailureFencesObjects" checkedModel CheckObjectStoreFailureFencesObjects
prepareStoreFence :: Db -> S3 -> IO () prepareStoreFence :: Db -> S3 -> IO ()
prepareStoreFence database store = do prepareStoreFence database store = do
@ -434,7 +434,7 @@ verifyPostgresUnavailable cfg = do
(Db.query_ database "SELECT 1" :: IO [Only Int])) (Db.query_ database "SELECT 1" :: IO [Only Int]))
:: IO (Either SomeException [Only Int]) :: IO (Either SomeException [Only Int])
assert "PostgreSQL lane service is unavailable" (isLeft attempt) assert "PostgreSQL lane service is unavailable" (isLeft attempt)
coveredAction "LosePostgres" coveredAction ActionLosePostgres
verifyPostgresRestored :: Db -> IO () verifyPostgresRestored :: Db -> IO ()
verifyPostgresRestored database = do verifyPostgresRestored database = do
@ -450,8 +450,8 @@ verifyPostgresRestored database = do
assert "restored PostgreSQL advances preserved mutation" applyingAndSettled assert "restored PostgreSQL advances preserved mutation" applyingAndSettled
finalize database record ObjectAbsent MutationFailed finalize database record ObjectAbsent MutationFailed
assertAuthority database 0 0 0 assertAuthority database 0 0 0
coveredAction "RestorePostgres" coveredAction ActionRestorePostgres
checkedInvariant "PostgresFailureFencesDurableState" checkedModel CheckPostgresFailureFencesDurableState
dispatch :: Db -> MutationRecord -> IO () dispatch :: Db -> MutationRecord -> IO ()
dispatch database record = do dispatch database record = do
@ -460,15 +460,14 @@ dispatch database record = do
pending <- markExternalPending connection record (DispatchTiming 10 5) pending <- markExternalPending connection record (DispatchTiming 10 5)
pure (applying && pending) pure (applying && pending)
assert "PrepareEffect/DispatchEffect" ok assert "PrepareEffect/DispatchEffect" ok
coveredAction "PrepareEffect" coveredAction ActionPrepareEffect
coveredAction "DispatchEffect" coveredAction ActionDispatchEffect
settle :: Db -> MutationRecord -> IO () settle :: Db -> MutationRecord -> IO ()
settle database record = do settle database record = do
ok <- withTransaction database $ \connection -> ok <- withTransaction database $ \connection ->
markExternalSettled connection record markExternalSettled connection record
assert "StoreSettlement" ok assert "StoreSettlement" ok
coveredAction "StoreSettlement"
finalize finalize
:: Db :: Db
@ -480,10 +479,9 @@ finalize database record observation expected = do
actual <- withTransaction database $ \connection -> actual <- withTransaction database $ \connection ->
finalizeFromObservation connection record observation finalizeFromObservation connection record observation
assertEqual "FinalizeSuccess/FinalizeFailure" (Just expected) actual assertEqual "FinalizeSuccess/FinalizeFailure" (Just expected) actual
coveredAction "ControllerAdvance"
case expected of case expected of
MutationSucceeded -> coveredAction "FinalizeSuccess" MutationSucceeded -> coveredAction ActionFinalizeSuccess
MutationFailed -> coveredAction "FinalizeFailure" MutationFailed -> coveredAction ActionFinalizeFailure
_ -> fail "terminal finalization expected success or failure" _ -> fail "terminal finalization expected success or failure"
admitPut admitPut
@ -689,14 +687,6 @@ assertEqual label expected actual =
unless (expected == actual) $ unless (expected == actual) $
fail (label <> ": expected " <> show expected <> ", got " <> show actual) fail (label <> ": expected " <> show expected <> ", got " <> show actual)
coveredAction :: Text -> IO ()
coveredAction action =
putStrLn ("protocol action covered: " <> T.unpack action)
checkedInvariant :: Text -> IO ()
checkedInvariant invariant =
putStrLn ("protocol invariant checked: " <> T.unpack invariant)
protocolUser :: UserId protocolUser :: UserId
protocolUser = UserId "protocol-user" protocolUser = UserId "protocol-user"

11
tests/kind/protocol-conformance-run.sh
View file

@ -139,8 +139,7 @@ verify_mapping() {
local actions=( local actions=(
FirstRequest ReplayRequest ConflictRequest PrepareEffect DispatchEffect FirstRequest ReplayRequest ConflictRequest PrepareEffect DispatchEffect
LoseUploadBody SettleLostUpload ExternalEffectApplied LoseUploadBody SettleLostUpload ExternalEffectApplied
ExternalEffectNotApplied FinalizeSuccess FinalizeFailure ControllerAdvance ExternalEffectNotApplied FinalizeSuccess FinalizeFailure
StoreSettlement
) )
local invariants=( local invariants=(
TypeOK RecordIdentityConsistent PersonalRequestsUseOwnPool TypeOK RecordIdentityConsistent PersonalRequestsUseOwnPool
@ -158,7 +157,7 @@ verify_mapping() {
rg -q "^$name(\\(| ==)" "$ROOT/docs/protocol/Nuthatch.tla" rg -q "^$name(\\(| ==)" "$ROOT/docs/protocol/Nuthatch.tla"
done done
for name in "${invariants[@]}"; do for name in "${invariants[@]}"; do
grep -F "protocol invariant checked: $name" "$log" >/dev/null grep -F "model check covered: $name" "$log" >/dev/null
rg -q "^$name(\\(| ==)" "$ROOT/docs/protocol/Nuthatch.tla" rg -q "^$name(\\(| ==)" "$ROOT/docs/protocol/Nuthatch.tla"
done done
} }
@ -200,7 +199,7 @@ while IFS=$'\t' read -r lane coordination oidc target; do
kube --namespace "$FIXTURE_NAMESPACE" logs "job/protocol-pg-restored-$lane" | kube --namespace "$FIXTURE_NAMESPACE" logs "job/protocol-pg-restored-$lane" |
grep -F "protocol action covered: RestorePostgres" >/dev/null grep -F "protocol action covered: RestorePostgres" >/dev/null
kube --namespace "$FIXTURE_NAMESPACE" logs "job/protocol-pg-restored-$lane" | kube --namespace "$FIXTURE_NAMESPACE" logs "job/protocol-pg-restored-$lane" |
grep -F "protocol invariant checked: PostgresFailureFencesDurableState" \ grep -F "model check covered: PostgresFailureFencesDurableState" \
>/dev/null >/dev/null
rg -q '^LosePostgres(\(| ==)' "$ROOT/docs/protocol/Nuthatch.tla" rg -q '^LosePostgres(\(| ==)' "$ROOT/docs/protocol/Nuthatch.tla"
rg -q '^RestorePostgres(\(| ==)' "$ROOT/docs/protocol/Nuthatch.tla" rg -q '^RestorePostgres(\(| ==)' "$ROOT/docs/protocol/Nuthatch.tla"
@ -215,10 +214,12 @@ while IFS=$'\t' read -r lane coordination oidc target; do
run_mode "$lane" "$profile" restored run_mode "$lane" "$profile" restored
kube --namespace "$FIXTURE_NAMESPACE" logs "job/protocol-fence-$lane" | kube --namespace "$FIXTURE_NAMESPACE" logs "job/protocol-fence-$lane" |
grep -F "store-down rejection creates no protocol record" >/dev/null grep -F "store-down rejection creates no protocol record" >/dev/null
kube --namespace "$FIXTURE_NAMESPACE" logs "job/protocol-fence-$lane" |
grep -F "protocol action covered: LoseObjectStore" >/dev/null
kube --namespace "$FIXTURE_NAMESPACE" logs "job/protocol-restored-$lane" | kube --namespace "$FIXTURE_NAMESPACE" logs "job/protocol-restored-$lane" |
grep -F "protocol action covered: RestoreObjectStore" >/dev/null grep -F "protocol action covered: RestoreObjectStore" >/dev/null
kube --namespace "$FIXTURE_NAMESPACE" logs "job/protocol-restored-$lane" | kube --namespace "$FIXTURE_NAMESPACE" logs "job/protocol-restored-$lane" |
grep -F "protocol invariant checked: ObjectStoreFailureFencesObjects" >/dev/null grep -F "model check covered: ObjectStoreFailureFencesObjects" >/dev/null
rg -q '^LoseObjectStore(\(| ==)' "$ROOT/docs/protocol/Nuthatch.tla" rg -q '^LoseObjectStore(\(| ==)' "$ROOT/docs/protocol/Nuthatch.tla"
rg -q '^RestoreObjectStore(\(| ==)' "$ROOT/docs/protocol/Nuthatch.tla" rg -q '^RestoreObjectStore(\(| ==)' "$ROOT/docs/protocol/Nuthatch.tla"
rg -q '^ObjectStoreFailureFencesObjects(\(| ==)' \ rg -q '^ObjectStoreFailureFencesObjects(\(| ==)' \

21
tests/model-correspondence/NuthatchCorrespondence.cfg Normal file
View file

@ -0,0 +1,21 @@
SPECIFICATION Spec
CHECK_DEADLOCK TRUE
CONSTANTS
Users = {u1}
OperationIds = {op1}
EnabledKinds = {"put"}
PersonalKeyNames = {personalKey}
SharedKeys = {sharedKey}
Contents = {content1}
MaxObjectSize = 1
PersonalLimit = 1
SharedLimit = 1
MaxPostgresLosses = 1
MaxObjectStoreLosses = 1
SharedPool = SharedPool
NoObject = NoObject
NoRecord = NoRecord
NoOwner = NoOwner
NoObservation = NoObservation

158
tests/model-correspondence/concrete-snapshots.json Normal file
View file

@ -0,0 +1,158 @@
[
{
"name": "prepared put",
"concrete": {
"identity": "user-a:put:op-a",
"kind": "put",
"declared_size": 5,
"content": "daeba8f55bf2b80cf87005e3687416f9cffbf23dcd4195bf13dbfbf6d5239a4e",
"record_state": "prepared",
"external_state": "idle",
"upload_body_available": true,
"key_owner": "user-a:put:op-a",
"prior_object": {
"size": 2,
"content": "bc14a1b33190bcb16e59f1c8a6f70dcd138e4e74fbdea4eca4f634780d5d6ccb"
},
"current_object": {
"size": 2,
"content": "bc14a1b33190bcb16e59f1c8a6f70dcd138e4e74fbdea4eca4f634780d5d6ccb"
},
"growth_bytes": 3,
"reserved_bytes": 3,
"used_bytes": 2,
"limit_bytes": 10,
"max_object_bytes": 10
}
},
{
"name": "applying idle put",
"concrete": {
"identity": "user-a:put:op-a",
"kind": "put",
"declared_size": 5,
"content": "daeba8f55bf2b80cf87005e3687416f9cffbf23dcd4195bf13dbfbf6d5239a4e",
"record_state": "applying",
"external_state": "idle",
"upload_body_available": true,
"key_owner": "user-a:put:op-a",
"prior_object": {
"size": 2,
"content": "bc14a1b33190bcb16e59f1c8a6f70dcd138e4e74fbdea4eca4f634780d5d6ccb"
},
"current_object": {
"size": 2,
"content": "bc14a1b33190bcb16e59f1c8a6f70dcd138e4e74fbdea4eca4f634780d5d6ccb"
},
"growth_bytes": 3,
"reserved_bytes": 3,
"used_bytes": 2,
"limit_bytes": 10,
"max_object_bytes": 10
}
},
{
"name": "dispatched put",
"concrete": {
"identity": "user-a:put:op-a",
"kind": "put",
"declared_size": 5,
"content": "daeba8f55bf2b80cf87005e3687416f9cffbf23dcd4195bf13dbfbf6d5239a4e",
"record_state": "applying",
"external_state": "pending",
"upload_body_available": false,
"key_owner": "user-a:put:op-a",
"prior_object": {
"size": 2,
"content": "bc14a1b33190bcb16e59f1c8a6f70dcd138e4e74fbdea4eca4f634780d5d6ccb"
},
"current_object": {
"size": 2,
"content": "bc14a1b33190bcb16e59f1c8a6f70dcd138e4e74fbdea4eca4f634780d5d6ccb"
},
"growth_bytes": 3,
"reserved_bytes": 3,
"used_bytes": 2,
"limit_bytes": 10,
"max_object_bytes": 10
}
},
{
"name": "settled put",
"concrete": {
"identity": "user-a:put:op-a",
"kind": "put",
"declared_size": 5,
"content": "daeba8f55bf2b80cf87005e3687416f9cffbf23dcd4195bf13dbfbf6d5239a4e",
"record_state": "applying",
"external_state": "settled",
"upload_body_available": false,
"key_owner": "user-a:put:op-a",
"prior_object": {
"size": 2,
"content": "bc14a1b33190bcb16e59f1c8a6f70dcd138e4e74fbdea4eca4f634780d5d6ccb"
},
"current_object": {
"size": 5,
"content": "daeba8f55bf2b80cf87005e3687416f9cffbf23dcd4195bf13dbfbf6d5239a4e"
},
"growth_bytes": 3,
"reserved_bytes": 3,
"used_bytes": 2,
"limit_bytes": 10,
"max_object_bytes": 10
}
},
{
"name": "successful put",
"concrete": {
"identity": "user-a:put:op-a",
"kind": "put",
"declared_size": 5,
"content": "daeba8f55bf2b80cf87005e3687416f9cffbf23dcd4195bf13dbfbf6d5239a4e",
"record_state": "succeeded",
"external_state": "idle",
"upload_body_available": false,
"key_owner": null,
"prior_object": {
"size": 2,
"content": "bc14a1b33190bcb16e59f1c8a6f70dcd138e4e74fbdea4eca4f634780d5d6ccb"
},
"current_object": {
"size": 5,
"content": "daeba8f55bf2b80cf87005e3687416f9cffbf23dcd4195bf13dbfbf6d5239a4e"
},
"growth_bytes": 3,
"reserved_bytes": 0,
"used_bytes": 5,
"limit_bytes": 10,
"max_object_bytes": 10
}
},
{
"name": "quota-rejected put",
"concrete": {
"identity": "user-a:put:op-b",
"kind": "put",
"declared_size": 12,
"content": "daeba8f55bf2b80cf87005e3687416f9cffbf23dcd4195bf13dbfbf6d5239a4e",
"record_state": "rejected",
"external_state": "idle",
"upload_body_available": false,
"key_owner": null,
"prior_object": {
"size": 8,
"content": "bc14a1b33190bcb16e59f1c8a6f70dcd138e4e74fbdea4eca4f634780d5d6ccb"
},
"current_object": {
"size": 8,
"content": "bc14a1b33190bcb16e59f1c8a6f70dcd138e4e74fbdea4eca4f634780d5d6ccb"
},
"growth_bytes": 4,
"reserved_bytes": 0,
"used_bytes": 8,
"limit_bytes": 10,
"max_object_bytes": 20
}
}
]

15
tests/model-correspondence/run.sh Executable file
View file

@ -0,0 +1,15 @@
#!/usr/bin/env bash
set -euo pipefail
ROOT="$(cd "$(dirname "${BASH_SOURCE[0]}")/../.." && pwd)"
cd "$ROOT"
cabal build \
--offline \
--build-log="${TMPDIR:-/tmp}/nuthatch-model-evidence-cabal.log" \
exe:nuthatch-model-evidence
export NUTHATCH_MODEL_EVIDENCE
NUTHATCH_MODEL_EVIDENCE="$(
cabal list-bin --offline exe:nuthatch-model-evidence
)"
exec node tests/model-correspondence/verify.mjs

2
tests/model-correspondence/tools.env Normal file
View file

@ -0,0 +1,2 @@
TLA_TOOLS_VERSION=2.19
TLA_TOOLS_SHA256=936a262061c914694dfd669a543be24573c45d5aa0ff20a8b96b23d01e050e88

541
tests/model-correspondence/verify.mjs Normal file
View file

@ -0,0 +1,541 @@
import assert from 'node:assert/strict';
import { spawnSync } from 'node:child_process';
import { createHash } from 'node:crypto';
import {
mkdtemp,
readFile,
rm,
writeFile
} from 'node:fs/promises';
import { tmpdir } from 'node:os';
import { basename, delimiter, dirname, resolve } from 'node:path';
import { fileURLToPath } from 'node:url';
const scriptPath = fileURLToPath(import.meta.url);
const testRoot = resolve(dirname(scriptPath));
const projectRoot = resolve(testRoot, '../..');
const modelDirectory = resolve(projectRoot, 'docs/protocol');
const modelPath = resolve(modelDirectory, 'Nuthatch.tla');
const defaultConfigurationPaths = [
'Nuthatch.cfg',
'NuthatchContentIdentity.cfg',
'NuthatchKinds.cfg',
'NuthatchQuota.cfg',
'NuthatchSequential.cfg'
].map((name) => resolve(modelDirectory, name));
const configurationPaths = process.env.NUTHATCH_MODEL_CONFIGS
? process.env.NUTHATCH_MODEL_CONFIGS.split(delimiter)
: defaultConfigurationPaths;
const actionConfigurationPath = resolve(
testRoot,
'NuthatchCorrespondence.cfg'
);
const fixturePath =
process.env.NUTHATCH_MODEL_FIXTURES ??
resolve(testRoot, 'concrete-snapshots.json');
const evidenceExecutable = process.env.NUTHATCH_MODEL_EVIDENCE;
const toolsJar = process.env.TLA2TOOLS_JAR ?? '/usr/local/lib/tla2tools.jar';
const pins = parseAssignments(
await readFile(resolve(testRoot, 'tools.env'), 'utf8')
);
const workDirectory = await mkdtemp(
resolve(tmpdir(), 'nuthatch-model-correspondence-')
);
assert.ok(evidenceExecutable, 'NUTHATCH_MODEL_EVIDENCE is required');
try {
await verifyToolPin();
const graph = await buildSemanticGraph();
const semanticLeafActions = discoverLeafActions(graph, 'Next');
const executedLeafActions = await executeLeafActions();
assertSetEqual(
executedLeafActions,
semanticLeafActions,
'minimal TLC action coverage'
);
const configurations = await readConfigurations(graph);
const configuredChecks = new Set([
...configurations[0].invariants,
...configurations[0].properties
]);
const inventory = readInventory();
const inventoryActionNames = new Set(inventory.actions.values());
const inventoryCheckNames = new Set(inventory.checks.values());
assertSetEqual(
inventoryActionNames,
semanticLeafActions,
'typed implementation action inventory'
);
assertSetEqual(
inventoryCheckNames,
configuredChecks,
'typed implementation check inventory'
);
await verifyTypedEvidenceUse(inventory);
verifyScenarios(inventory);
const snapshots = await verifyProjection();
if (process.env.NUTHATCH_SKIP_MODEL_MUTATIONS !== '1') {
await verifyNegativeMutations(snapshots);
}
await verifyNoSecondNext();
console.log(
[
`PASS SANY and TLC agree on ${semanticLeafActions.size} executable leaf actions`,
`PASS ${configurations.length} model configurations resolve ${configuredChecks.size} typed checks`,
`PASS ${inventory.scenarios.length} typed scenarios cover every leaf action`,
`PASS ${snapshots.length} concrete snapshots project without a transition oracle`,
'PASS stale, missing, unknown, uncovered, and invalid-projection mutations fail'
].join('\n')
);
} finally {
await rm(workDirectory, { recursive: true, force: true });
}
async function verifyToolPin() {
const jar = await readFile(toolsJar);
const digest = createHash('sha256').update(jar).digest('hex');
assert.equal(digest, pins.TLA_TOOLS_SHA256, 'TLA+ Tools checksum');
const helpResult = spawnSync(
'java',
['-cp', toolsJar, 'tlc2.TLC', '-help'],
{ encoding: 'utf8' }
);
assert.ok(
helpResult.status === 0 || helpResult.status === 1,
`TLA+ Tools version probe failed with ${helpResult.status}`
);
const help = `${helpResult.stdout ?? ''}${helpResult.stderr ?? ''}`;
assert.match(
help,
new RegExp(`Version ${escapeExpression(pins.TLA_TOOLS_VERSION)}\\b`),
'TLA+ Tools version'
);
}
async function buildSemanticGraph() {
run(
'java',
['-cp', toolsJar, 'tla2sany.SANY', '-d', modelPath, 'dot'],
{ cwd: workDirectory }
);
const semanticGraphPath = resolve(workDirectory, 'Nuthatch.dot');
return parseSemanticGraph(await readFile(semanticGraphPath, 'utf8'));
}
async function executeLeafActions() {
const actionGraphPath = resolve(workDirectory, 'actions.dot');
run(
'java',
[
'-cp',
toolsJar,
'tlc2.TLC',
'-cleanup',
'-workers',
'1',
'-metadir',
resolve(workDirectory, 'states'),
'-config',
actionConfigurationPath,
'-dump',
'dot,actionlabels',
actionGraphPath,
basename(modelPath)
],
{ cwd: modelDirectory }
);
return extractActionGraphLabels(await readFile(actionGraphPath, 'utf8'));
}
async function readConfigurations(graph) {
const configurations = await Promise.all(
configurationPaths.map(async (path) => ({
name: basename(path),
...parseConfiguration(await readFile(path, 'utf8'))
}))
);
for (const configuration of configurations) {
for (const symbol of [
...configuration.invariants,
...configuration.properties
]) {
assert.ok(
graph.operatorNames.has(symbol),
`${configuration.name} references unknown model operator ${symbol}`
);
}
}
for (const configuration of configurations.slice(1)) {
assertSetEqual(
configuration.invariants,
configurations[0].invariants,
`${configuration.name} invariants`
);
assertSetEqual(
configuration.properties,
configurations[0].properties,
`${configuration.name} properties`
);
}
return configurations;
}
function readInventory() {
const lines = run(evidenceExecutable, ['inventory']).trim().split('\n');
const actions = new Map();
const checks = new Map();
const scenarios = [];
for (const line of lines) {
const fields = line.split('\t');
switch (fields[0]) {
case 'ACTION':
assert.equal(fields.length, 3, `invalid action inventory line: ${line}`);
assert.ok(!actions.has(fields[1]), `duplicate action ${fields[1]}`);
actions.set(fields[1], fields[2]);
break;
case 'CHECK':
assert.equal(fields.length, 3, `invalid check inventory line: ${line}`);
assert.ok(!checks.has(fields[1]), `duplicate check ${fields[1]}`);
checks.set(fields[1], fields[2]);
break;
case 'SCENARIO':
assert.equal(fields.length, 6, `invalid scenario line: ${line}`);
scenarios.push({
constructor: fields[1],
action: fields[2],
precondition: fields[3],
observation: fields[4],
expectedPost: fields[5]
});
break;
default:
assert.fail(`unknown inventory line: ${line}`);
}
}
switch (process.env.NUTHATCH_INVENTORY_MUTATION) {
case undefined:
break;
case 'stale':
actions.set('ActionRemovedModelAction', 'RemovedModelAction');
break;
case 'missing':
actions.delete('ActionFirstRequest');
break;
case 'uncovered':
return {
actions,
checks,
scenarios: scenarios.filter(
(scenario) => scenario.constructor !== 'ActionFirstRequest'
)
};
default:
assert.fail(
`unknown inventory mutation ${process.env.NUTHATCH_INVENTORY_MUTATION}`
);
}
return { actions, checks, scenarios };
}
async function verifyTypedEvidenceUse(inventory) {
const source = await readFile(
resolve(projectRoot, 'test/ProtocolConformance.hs'),
'utf8'
);
const usedActions = extractConstructors(source, 'coveredAction', 'Action');
const usedChecks = extractConstructors(source, 'checkedModel', 'Check');
assertSetEqual(
usedActions,
new Set(inventory.actions.keys()),
'typed action evidence calls'
);
assertSetEqual(
usedChecks,
new Set(inventory.checks.keys()),
'typed check evidence calls'
);
}
function verifyScenarios(inventory) {
const scenarioConstructors = new Set();
for (const scenario of inventory.scenarios) {
assert.ok(
inventory.actions.has(scenario.constructor),
`unknown scenario action ${scenario.constructor}`
);
assert.equal(
scenario.action,
inventory.actions.get(scenario.constructor),
`${scenario.constructor} scenario name`
);
assert.ok(scenario.precondition, `${scenario.action} precondition`);
assert.ok(scenario.observation, `${scenario.action} observation`);
assert.ok(scenario.expectedPost, `${scenario.action} expected post-state`);
assert.ok(
!scenarioConstructors.has(scenario.constructor),
`duplicate scenario ${scenario.constructor}`
);
scenarioConstructors.add(scenario.constructor);
}
assertSetEqual(
scenarioConstructors,
new Set(inventory.actions.keys()),
'scenario coverage'
);
}
async function verifyProjection() {
run(evidenceExecutable, ['verify', fixturePath]);
return JSON.parse(await readFile(fixturePath, 'utf8'));
}
async function verifyNegativeMutations(snapshots) {
assertCheckerFails(
{ NUTHATCH_INVENTORY_MUTATION: 'stale' },
/RemovedModelAction/,
'stale action'
);
assertCheckerFails(
{ NUTHATCH_INVENTORY_MUTATION: 'missing' },
/FirstRequest/,
'missing action'
);
assertCheckerFails(
{ NUTHATCH_INVENTORY_MUTATION: 'uncovered' },
/FirstRequest/,
'uncovered scenario'
);
const unknownConfigurationPath = resolve(
workDirectory,
'unknown-check.cfg'
);
const firstConfiguration = await readFile(configurationPaths[0], 'utf8');
await writeFile(
unknownConfigurationPath,
`${firstConfiguration}\nINVARIANTS\n UnknownInvariant\n`
);
assertCheckerFails(
{
NUTHATCH_MODEL_CONFIGS: [
unknownConfigurationPath,
...configurationPaths.slice(1)
].join(delimiter)
},
/UnknownInvariant/,
'unknown configured check'
);
const invalidFixtures = structuredClone(snapshots);
invalidFixtures[0].concrete.external_state = 'pending';
const invalidFixturePath = resolve(workDirectory, 'invalid-snapshots.json');
await writeFile(
invalidFixturePath,
`${JSON.stringify(invalidFixtures, null, 2)}\n`
);
assertCheckerFails(
{ NUTHATCH_MODEL_FIXTURES: invalidFixturePath },
/ExternalStateConsistent/,
'invalid projection'
);
}
function assertCheckerFails(environment, expression, label) {
const result = spawnSync(process.execPath, [scriptPath], {
encoding: 'utf8',
maxBuffer: 32 * 1024 * 1024,
env: {
...process.env,
NUTHATCH_SKIP_MODEL_MUTATIONS: '1',
...environment
}
});
assert.notEqual(result.status, 0, `${label} mutation unexpectedly passed`);
assert.match(
`${result.stdout ?? ''}\n${result.stderr ?? ''}`,
expression,
`${label} mutation failure`
);
}
async function verifyNoSecondNext() {
const sourceFiles = run(
'rg',
['--files', 'src', 'test', '-g', '*.hs'],
{ cwd: projectRoot }
)
.trim()
.split('\n')
.filter(Boolean);
for (const sourcePath of sourceFiles) {
const source = await readFile(resolve(projectRoot, sourcePath), 'utf8');
assert.doesNotMatch(source, /\bNext\b/, `${sourcePath} defines model Next`);
assert.doesNotMatch(
source,
/ModelAction\s*->\s*AbstractSnapshot|AbstractSnapshot\s*->\s*ModelAction/,
`${sourcePath} defines an abstract action transition`
);
}
}
function parseSemanticGraph(dot) {
const labels = new Map();
const edges = new Map();
const operatorIds = new Map();
for (const line of dot.split('\n')) {
const operator = line.match(
/^(\d+) \[style=filled,shape=diamond,fillcolor="red",label="([A-Za-z][A-Za-z0-9_]*)"\];$/
);
if (operator) {
const [, id, label] = operator;
operatorIds.set(label, id);
}
const node = line.match(/^(\d+) \[.*label="(.*)"\];$/);
if (node) {
const [, id, label] = node;
const nodeLabels = labels.get(id) ?? new Set();
nodeLabels.add(label);
labels.set(id, nodeLabels);
}
const edge = line.match(/^(\d+) -> (\d+)$/);
if (edge) {
const [, from, to] = edge;
const targets = edges.get(from) ?? new Set();
targets.add(to);
edges.set(from, targets);
}
}
return {
labels,
edges,
operatorIds,
operatorNames: new Set(operatorIds.keys())
};
}
function discoverLeafActions(graph, rootName) {
const memo = new Map();
const visiting = new Set();
const visitOperator = (name) => {
if (memo.has(name)) return memo.get(name);
if (visiting.has(name)) return new Set();
visiting.add(name);
const definition = definitionText(graph, name);
const ownsPrime = /[A-Za-z][A-Za-z0-9_]*'/.test(definition);
let leaves;
if (ownsPrime) {
leaves = new Set([name]);
} else {
leaves = new Set();
const dependencies = new Set(
[...definition.matchAll(/[A-Za-z][A-Za-z0-9_]*/g)]
.map((match) => match[0])
.filter(
(dependency) =>
dependency !== name && graph.operatorNames.has(dependency)
)
);
for (const dependency of dependencies) {
for (const leaf of visitOperator(dependency)) leaves.add(leaf);
}
}
visiting.delete(name);
memo.set(name, leaves);
return leaves;
};
return visitOperator(rootName);
}
function definitionText(graph, operatorName) {
const id = graph.operatorIds.get(operatorName);
assert.ok(id, `missing semantic operator ${operatorName}`);
const candidates = [...(graph.edges.get(id) ?? [])].flatMap(
(target) => [...(graph.labels.get(target) ?? [])]
);
assert.ok(candidates.length > 0, `missing definition body for ${operatorName}`);
return candidates.sort((left, right) => right.length - left.length)[0];
}
function extractActionGraphLabels(dot) {
return new Set(
[...dot.matchAll(/label="([A-Za-z][A-Za-z0-9_]*)"/g)].map(
(match) => match[1]
)
);
}
function parseConfiguration(text) {
const invariants = new Set();
const properties = new Set();
let section = null;
for (const rawLine of text.split('\n')) {
const line = rawLine.replace(/\\\\\*.*/, '').trim();
if (line === 'INVARIANTS' || line === 'PROPERTIES') {
section = line;
continue;
}
if (/^[A-Z_]+(?:\s|$)/.test(line)) {
section = null;
continue;
}
if (!line || !section) continue;
const symbol = line.match(/^([A-Za-z][A-Za-z0-9_]*)$/)?.[1];
assert.ok(symbol, `unsupported ${section} entry: ${line}`);
(section === 'INVARIANTS' ? invariants : properties).add(symbol);
}
return { invariants, properties };
}
function extractConstructors(source, functionName, prefix) {
const expression = new RegExp(
`${functionName}\\s+(${prefix}[A-Za-z][A-Za-z0-9_]*)`,
'g'
);
return new Set([...source.matchAll(expression)].map((match) => match[1]));
}
function parseAssignments(text) {
return Object.fromEntries(
text
.split('\n')
.map((line) => line.trim())
.filter(Boolean)
.map((line) => {
const separator = line.indexOf('=');
assert.ok(separator > 0, `invalid assignment: ${line}`);
return [line.slice(0, separator), line.slice(separator + 1)];
})
);
}
function run(command, arguments_, options = {}) {
const result = spawnSync(command, arguments_, {
encoding: 'utf8',
maxBuffer: 32 * 1024 * 1024,
...options
});
assert.equal(
result.status,
0,
`${command} failed\n${result.stdout ?? ''}\n${result.stderr ?? ''}`
);
return `${result.stdout ?? ''}${result.stderr ?? ''}`;
}
function assertSubset(expected, actual, label) {
const missing = [...expected].filter((value) => !actual.has(value)).sort();
assert.deepEqual(missing, [], `${label}: ${missing.join(', ')}`);
}
function assertSetEqual(actual, expected, label) {
assertSubset(expected, actual, `${label} missing`);
assertSubset(actual, expected, `${label} unexpected`);
}
function escapeExpression(value) {
return value.replace(/[.*+?^${}()|[\]\\]/g, '\\$&');
}