Skip to content

Commit c1140d4

Browse files
kdermekderme
committed
Add more rollbacks tests
1 parent 5dc21a4 commit c1140d4

File tree

7 files changed

+240
-5
lines changed

7 files changed

+240
-5
lines changed

‎cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs

Lines changed: 104 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -45,6 +45,7 @@ module Cardano.Mock.Forging.Tx.Babbage
4545
, mkUTxOBabbage
4646
, mkUTxOCollBabbage
4747
, mkTxHash
48+
, mkFullTx
4849
, emptyTxBody
4950
, emptyTx
5051
) where
@@ -65,8 +66,10 @@ import Cardano.Crypto.VRF
6566

6667
import Cardano.Ledger.Address
6768
import Cardano.Ledger.Alonzo.Data
69+
import Cardano.Ledger.Alonzo.Language
6870
import Cardano.Ledger.Alonzo.Scripts
6971
import Cardano.Ledger.Alonzo.TxWitness
72+
import Cardano.Ledger.Babbage.PParams
7073
import Cardano.Ledger.Babbage.Tx
7174
import Cardano.Ledger.Babbage.TxBody
7275
import Cardano.Ledger.BaseTypes
@@ -79,8 +82,9 @@ import Cardano.Ledger.Keys
7982
import Cardano.Ledger.Mary.Value
8083
import Cardano.Ledger.Serialization
8184
import Cardano.Ledger.Shelley.Metadata
82-
import Cardano.Ledger.Shelley.TxBody (DCert (..), DelegCert (..), PoolCert (..),
83-
PoolMetadata (..), PoolParams (..), StakePoolRelay (..), Wdrl (..))
85+
import Cardano.Ledger.Shelley.PParams hiding (emptyPParamsUpdate)
86+
import Cardano.Ledger.Shelley.TxBody (DCert (..), Delegation (..), DelegCert (..), MIRCert (..), MIRPot (..),
87+
PoolCert (..), MIRTarget (..), PoolMetadata (..), PoolParams (..), StakePoolRelay (..), Wdrl (..))
8488
import Cardano.Ledger.ShelleyMA.Timelocks
8589
import Cardano.Ledger.TxIn (TxId, TxIn (..), txid)
8690

@@ -95,6 +99,8 @@ import Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples
9599
import Cardano.Mock.Forging.Tx.Generic
96100
import Cardano.Mock.Forging.Types
97101

102+
import qualified Plutus.V1.Ledger.EvaluationContext as PV1
103+
98104
type BabbageUTxOIndex = UTxOIndex StandardBabbage
99105
type BabbageLedgerState = LedgerState (ShelleyBlock PraosStandard StandardBabbage)
100106

@@ -491,3 +497,99 @@ emptyTx = ValidatedTx
491497
, isValid = IsValid True
492498
, auxiliaryData = maybeToStrictMaybe Nothing
493499
}
500+
501+
mkFullTx
502+
:: Int -> Integer -> BabbageLedgerState
503+
-> Either ForgingError (ValidatedTx StandardBabbage)
504+
mkFullTx n m sta = do
505+
inputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) inps
506+
let rdmrs = mapMaybe mkScriptInp $ zip [0..] inputPairs
507+
let witnesses = mkWitnesses rdmrs [(hashData @StandardBabbage plutusDataList, plutusDataList)]
508+
refInputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) refInps
509+
colInput <- Set.singleton . fst . fst <$> resolveUTxOIndex colInps sta
510+
Right $ ValidatedTx
511+
{ body = txBody (mkInps inputPairs) (mkInps refInputPairs) colInput
512+
, wits = witnesses
513+
, isValid = IsValid True
514+
, auxiliaryData = Strict.SJust auxiliaryData'
515+
}
516+
where
517+
mkInps ins = Set.fromList $ fst <$> ins
518+
txBody ins cols ref =
519+
TxBody
520+
ins cols ref (fmap (`Sized` 0) outs) (fmap (`Sized` 0) collOut)
521+
Strict.SNothing (StrictSeq.fromList certs) wthdr (Coin m)
522+
(ValidityInterval Strict.SNothing Strict.SNothing)
523+
(Strict.SJust updates) witKeys minted
524+
Strict.SNothing Strict.SNothing (Strict.SJust Testnet)
525+
inps = [UTxOIndex $ n * 3 + 0]
526+
refInps = [UTxOIndex $ n * 3 + 1]
527+
colInps = UTxOIndex $ n * 3 + 2
528+
policy0 = PolicyID alwaysMintScriptHash
529+
policy1 = PolicyID alwaysSucceedsScriptHash
530+
assets0 = Map.fromList [(Prelude.head assetNames, 5), (assetNames !! 1, 2)]
531+
outValue0 = Value 20 $ Map.fromList [(policy0, assets0), (policy1, assets0)]
532+
addr0 = Addr Testnet (Prelude.head unregisteredAddresses) (StakeRefBase $ Prelude.head unregisteredStakeCredentials)
533+
addr2 = Addr Testnet (ScriptHashObj alwaysFailsScriptHash) (StakeRefBase $ unregisteredStakeCredentials !! 2)
534+
out0, out1, out2 :: TxOut StandardBabbage
535+
out0 = TxOut addr0 outValue0 (DatumHash (hashData @StandardBabbage plutusDataList)) (Strict.SJust alwaysFailsScript)
536+
out1 = TxOut alwaysSucceedsScriptAddr outValue0 (DatumHash (hashData @StandardBabbage plutusDataList)) Strict.SNothing
537+
out2 = TxOut addr2 outValue0 (DatumHash (hashData @StandardBabbage plutusDataList)) (Strict.SJust alwaysFailsScript)
538+
outs = StrictSeq.fromList [out0, out1]
539+
collOut = Strict.SJust out2
540+
assetsMinted0 = Map.fromList [(Prelude.head assetNames, 10), (assetNames !! 1, 4)]
541+
minted = Value 100 $ Map.fromList [(policy0, assetsMinted0), (policy1, assetsMinted0)]
542+
poolParams0 = consPoolParams
543+
(Prelude.head unregisteredPools)
544+
(unregisteredStakeCredentials !! 2)
545+
[unregisteredKeyHash !! 1, unregisteredKeyHash !! 2]
546+
poolParams1 = consPoolParams
547+
(unregisteredPools !! 2)
548+
(unregisteredStakeCredentials !! 2)
549+
[unregisteredKeyHash !! 1, unregisteredKeyHash !! 2]
550+
551+
certs = [ DCertDeleg $ RegKey $ Prelude.head unregisteredStakeCredentials
552+
, DCertPool $ RegPool poolParams0
553+
, DCertPool $ RegPool poolParams1
554+
, DCertPool $ RetirePool (Prelude.head unregisteredPools) (EpochNo 0)
555+
, DCertDeleg $ DeRegKey $ unregisteredStakeCredentials !! 2
556+
, DCertDeleg $ Delegate $ Delegation (unregisteredStakeCredentials !! 1) (unregisteredPools !! 2)
557+
, DCertMir $ MIRCert ReservesMIR (StakeAddressesMIR $ Map.fromList
558+
[ (Prelude.head unregisteredStakeCredentials, DeltaCoin 100)
559+
, (unregisteredStakeCredentials !! 2, DeltaCoin 200)
560+
])
561+
, DCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR $ Map.fromList
562+
[ (Prelude.head unregisteredStakeCredentials, DeltaCoin 100)
563+
, (unregisteredStakeCredentials !! 2, DeltaCoin 200)
564+
])
565+
, DCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR $ Coin 300)
566+
]
567+
568+
wthdr = Wdrl $ Map.fromList
569+
[ (RewardAcnt Testnet (unregisteredStakeCredentials !! 1), Coin 100)
570+
, (RewardAcnt Testnet (unregisteredStakeCredentials !! 1), Coin 100)
571+
]
572+
573+
witKeys = Set.fromList
574+
[ unregisteredWitnessKey !! 1
575+
, unregisteredWitnessKey !! 2
576+
]
577+
578+
auxiliaryData' = AuxiliaryData auxiliaryDataMap auxiliaryDataScripts
579+
auxiliaryDataMap = Map.fromList [(1, List []), (2 , List [])]
580+
auxiliaryDataScripts = StrictSeq.fromList [alwaysFailsScript]
581+
582+
costModels = CostModels $ Map.fromList [(PlutusV2, testingCostModelV2)]
583+
paramsUpdate = emptyPParamsUpdate {_costmdls = Strict.SJust costModels}
584+
proposed :: ProposedPPUpdates StandardBabbage
585+
proposed = ProposedPPUpdates $ Map.fromList
586+
[ (unregisteredGenesisKeys !! 1, paramsUpdate)
587+
, (unregisteredGenesisKeys !! 2, paramsUpdate)
588+
]
589+
updates :: Update StandardBabbage
590+
updates = Update proposed (EpochNo 0)
591+
592+
testingCostModelV2 :: CostModel
593+
testingCostModelV2 =
594+
fromRight (error "testingCostModelV2 is not well-formed") $
595+
mkCostModel PlutusV2 PV1.costModelParamsForTesting -- TODO use PV2 when it exists

‎cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs

Lines changed: 21 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,11 @@ module Cardano.Mock.Forging.Tx.Generic
1616
, mkDummyScriptHash
1717
, unregisteredGenesisKeys
1818
, mkDummyHash
19+
, unregisteredKeyHash
20+
, unregisteredWitnessKey
21+
, unregisteredAddresses
22+
, unregisteredStakeCredentials
23+
, unregisteredPools
1924
) where
2025

2126
import Cardano.Prelude hiding (length, (.))
@@ -161,6 +166,20 @@ unregisteredStakeCredentials =
161166
, KeyHashObj $ KeyHash "22236827154873624578632414768234573268457923654973246472"
162167
]
163168

169+
unregisteredKeyHash :: [KeyHash 'Staking StandardCrypto]
170+
unregisteredKeyHash =
171+
[ KeyHash "000131350ac206583290486460934394208654903261221230945870"
172+
, KeyHash "11130293748658946834096854968435096854309685490386453861"
173+
, KeyHash "22236827154873624578632414768234573268457923654973246472"
174+
]
175+
176+
unregisteredWitnessKey :: [KeyHash 'Witness StandardCrypto]
177+
unregisteredWitnessKey =
178+
[ KeyHash "000131350ac206583290486460934394208654903261221230945870"
179+
, KeyHash "11130293748658946834096854968435096854309685490386453861"
180+
, KeyHash "22236827154873624578632414768234573268457923654973246472"
181+
]
182+
164183
unregisteredAddresses :: [PaymentCredential StandardCrypto]
165184
unregisteredAddresses =
166185
[ KeyHashObj $ KeyHash "11121865734872361547862358673245672834567832456783245312"
@@ -171,14 +190,14 @@ unregisteredAddresses =
171190
unregisteredPools :: [KeyHash 'StakePool StandardCrypto]
172191
unregisteredPools =
173192
[ KeyHash "11138475621387465239786593240875634298756324987562352435"
174-
, KeyHash "222462543264795t3298745680239746523897456238974563298348"
193+
, KeyHash "22246254326479503298745680239746523897456238974563298348"
175194
, KeyHash "33323876542397465497834256329487563428975634827956348975"
176195
]
177196

178197
unregisteredGenesisKeys :: [KeyHash 'Genesis StandardCrypto]
179198
unregisteredGenesisKeys =
180199
[ KeyHash "11138475621387465239786593240875634298756324987562352435"
181-
, KeyHash "222462543264795t3298745680239746523897456238974563298348"
200+
, KeyHash "22246254326479503298745680239746523897456238974563298348"
182201
, KeyHash "33323876542397465497834256329487563428975634827956348975"
183202
]
184203

‎cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs

Lines changed: 111 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,7 @@ import Data.Text (Text)
1818

1919
import Ouroboros.Consensus.Cardano.Block hiding (CardanoBlock)
2020

21-
import Ouroboros.Network.Block (blockNo, blockPoint, blockSlot)
21+
import Ouroboros.Network.Block (blockNo, blockPoint, blockSlot, genesisPoint)
2222

2323
import qualified Cardano.Db as DB
2424

@@ -80,6 +80,8 @@ unitTests iom knownMigrations =
8080
, test "lazy rollback on restart" lazyRollbackRestart
8181
, test "rollback while rollbacking" doubleRollback
8282
, test "rollback stake address cache" stakeAddressRollback
83+
, test "rollback change order of txs" rollbackChangeTxOrder
84+
, test "rollback full tx" rollbackFullTx
8385
]
8486
, testGroup "different configs"
8587
[ test "genesis config without pool" configNoPools
@@ -127,6 +129,7 @@ unitTests iom knownMigrations =
127129
, test "failed script fees" failedScriptFees
128130
, test "failed script in same block" failedScriptSameBlock
129131
, test "multiple scripts unlocked" multipleScripts
132+
, test "multiple scripts unlocked rollback" multipleScriptsRollback
130133
, test "multiple scripts unlocked same block" multipleScriptsSameBlock
131134
, test "multiple scripts failed" multipleScriptsFailed
132135
, test "multiple scripts failed same block" multipleScriptsFailedSameBlock
@@ -158,6 +161,7 @@ unitTests iom knownMigrations =
158161
, test "spend reference script" spendRefScript
159162
, test "spend reference script same block" spendRefScriptSameBlock
160163
, test "spend collateral output of invalid tx" spendCollateralOutput
164+
, test "spend collateral output of invalid tx rollback" spendCollateralOutputRollback
161165
, test "spend collateral output of invalid tx same block" spendCollateralOutputSameBlock
162166
, test "reference input to output which is not spent" referenceInputUnspend
163167
, test "supply and run script which is both reference and in witnesses" supplyScriptsTwoWays
@@ -441,6 +445,50 @@ stakeAddressRollback =
441445
where
442446
testLabel = "stakeAddressRollback"
443447

448+
rollbackChangeTxOrder :: IOManager -> [(Text, Text)] -> Assertion
449+
rollbackChangeTxOrder =
450+
withFullConfig babbageConfig testLabel $ \interpreter mockServer dbSync -> do
451+
startDBSync dbSync
452+
blk0 <- forgeNextFindLeaderAndSubmit interpreter mockServer []
453+
st <- getBabbageLedgerState interpreter
454+
let Right tx0 = Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 500 st
455+
let Right tx1 = Babbage.mkPaymentTx (UTxOIndex 2) (UTxOIndex 3) 10000 500 st
456+
let Right tx2 = Babbage.mkPaymentTx (UTxOIndex 4) (UTxOIndex 5) 10000 500 st
457+
458+
void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \_st ->
459+
Right [tx0, tx1]
460+
assertBlockNoBackoff dbSync 2
461+
assertTxCount dbSync 13
462+
rollbackTo interpreter mockServer $ blockPoint blk0
463+
void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \_st ->
464+
Right [tx1, tx0, tx2]
465+
assertBlockNoBackoff dbSync 2
466+
assertTxCount dbSync 14
467+
where
468+
testLabel = "rollbackChangeTxOrder"
469+
470+
rollbackFullTx :: IOManager -> [(Text, Text)] -> Assertion
471+
rollbackFullTx =
472+
withFullConfig babbageConfig testLabel $ \interpreter mockServer dbSync -> do
473+
startDBSync dbSync
474+
blk0 <- forgeNextFindLeaderAndSubmit interpreter mockServer []
475+
void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do
476+
tx0 <- Babbage.mkFullTx 0 100 st
477+
tx1 <- Babbage.mkFullTx 1 200 st
478+
pure [tx0, tx1]
479+
assertBlockNoBackoff dbSync 2
480+
assertTxCount dbSync 13
481+
rollbackTo interpreter mockServer $ blockPoint blk0
482+
void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do
483+
tx0 <- Babbage.mkFullTx 0 100 st
484+
tx1 <- Babbage.mkFullTx 1 200 st
485+
tx2 <- Babbage.mkFullTx 2 200 st
486+
pure [tx1, tx2, tx0]
487+
assertBlockNoBackoff dbSync 2
488+
assertTxCount dbSync 14
489+
where
490+
testLabel = "rollbackFullTx"
491+
444492
configNoPools :: IOManager -> [(Text, Text)] -> Assertion
445493
configNoPools =
446494
withFullConfig "config2" testLabel $ \_ _ dbSync -> do
@@ -1332,6 +1380,36 @@ multipleScripts =
13321380
where
13331381
testLabel = "multipleScripts"
13341382

1383+
multipleScriptsRollback :: IOManager -> [(Text, Text)] -> Assertion
1384+
multipleScriptsRollback =
1385+
withFullConfig babbageConfig testLabel $ \interpreter mockServer dbSync -> do
1386+
startDBSync dbSync
1387+
1388+
tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000
1389+
let utxo = Babbage.mkUTxOBabbage tx0
1390+
pair1 = head utxo
1391+
pair2 = utxo !! 2
1392+
tx1 <- withBabbageLedgerState interpreter $
1393+
Babbage.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500
1394+
1395+
void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1)
1396+
void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx1] (NodeId 1)
1397+
1398+
assertBlockNoBackoff dbSync 2
1399+
assertAlonzoCounts dbSync (1,2,1,1,3,2,0,0)
1400+
1401+
rollbackTo interpreter mockServer genesisPoint
1402+
void $ forgeNextFindLeaderAndSubmit interpreter mockServer []
1403+
1404+
void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1)
1405+
void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx1] (NodeId 1)
1406+
assertBlockNoBackoff dbSync 3
1407+
1408+
assertAlonzoCounts dbSync (1,2,1,1,3,2,0,0)
1409+
where
1410+
testLabel = "multipleScriptsRollback"
1411+
1412+
13351413
multipleScriptsSameBlock :: IOManager -> [(Text, Text)] -> Assertion
13361414
multipleScriptsSameBlock =
13371415
withFullConfig babbageConfig testLabel $ \interpreter mockServer dbSync -> do
@@ -1891,6 +1969,38 @@ spendCollateralOutput =
18911969
where
18921970
testLabel = "spendCollateralOutput"
18931971

1972+
spendCollateralOutputRollback :: IOManager -> [(Text, Text)] -> Assertion
1973+
spendCollateralOutputRollback =
1974+
withFullConfig babbageConfig testLabel $ \interpreter mockServer dbSync -> do
1975+
startDBSync dbSync
1976+
blk0 <- registerAllStakeCreds interpreter mockServer
1977+
action interpreter mockServer dbSync 0
1978+
rollbackTo interpreter mockServer (blockPoint blk0)
1979+
void $ forgeNextFindLeaderAndSubmit interpreter mockServer []
1980+
action interpreter mockServer dbSync 1
1981+
where
1982+
testLabel = "spendCollateralOutputRollback"
1983+
action interpreter mockServer dbSync n = do
1984+
1985+
tx0 <- withBabbageLedgerState interpreter
1986+
$ Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000
1987+
void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx0]
1988+
1989+
-- tx fails so its collateral output become actual output.
1990+
let utxo0 = head (Babbage.mkUTxOBabbage tx0)
1991+
tx1 <- withBabbageLedgerState interpreter $
1992+
Babbage.mkUnlockScriptTxBabbage [UTxOInput (fst utxo0)] (UTxOIndex 1) (UTxOIndex 2) [UTxOPair utxo0] True False 10000 500
1993+
void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx1]
1994+
assertBlockNoBackoff dbSync $ n + 3
1995+
1996+
let utxo1 = head (Babbage.mkUTxOCollBabbage tx1)
1997+
tx2 <- withBabbageLedgerState interpreter $
1998+
Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo1] (UTxOIndex 3) (UTxOIndex 1) [UTxOPair utxo1] False True 10000 500
1999+
void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx2]
2000+
2001+
assertBlockNoBackoff dbSync $ n + 4
2002+
assertBabbageCounts dbSync (1,1,1,1,2,1,1,1,1,1,1,1,1)
2003+
18942004
spendCollateralOutputSameBlock :: IOManager -> [(Text, Text)] -> Assertion
18952005
spendCollateralOutputSameBlock =
18962006
withFullConfig babbageConfig testLabel $ \interpreter mockServer dbSync -> do

‎cardano-chain-gen/test/testfiles/fingerprint/multipleScriptsRollback

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
[8,14,1,8,14]

‎cardano-chain-gen/test/testfiles/fingerprint/rollbackChangeTxOrder

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
[1,3,3]

‎cardano-chain-gen/test/testfiles/fingerprint/rollbackFullTx

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
[1,3,3]

‎cardano-chain-gen/test/testfiles/fingerprint/spendCollateralOutputRollback

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
[1,3,4,7,3,4,7,8]

0 commit comments

Comments
 (0)