Bind protocol evidence to the TLA+ model
This commit is contained in:
parent
a31b883516
commit
b3c0f6d58a
1 changed files with 1281 additions and 56 deletions
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue