Bind protocol evidence to the TLA+ model

test/ModelEvidenceMain.hs

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

test/Nuthatch/ModelEvidence.hs

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

test/ProtocolConformance.hs

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