Skip to content

Commit faaebc8

Browse files
carbolymercarbolymer
committed
Budget nested sub-transaction governance generators
1 parent abc33ae commit faaebc8

3 files changed

Lines changed: 208 additions & 5 deletions

File tree

‎cardano-api/cardano-api.cabal‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -334,11 +334,12 @@ library gen
334334
cardano-binary >=1.6 && <1.10,
335335
cardano-crypto-class ^>=2.6,
336336
cardano-crypto-wrapper:testlib ^>=1.8,
337+
cardano-data,
337338
cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib},
338339
cardano-ledger-byron:testlib,
339340
cardano-ledger-conway:testlib,
340341
cardano-ledger-core:{cardano-ledger-core, testlib},
341-
cardano-ledger-dijkstra:testlib,
342+
cardano-ledger-dijkstra:{cardano-ledger-dijkstra, testlib},
342343
cardano-ledger-shelley,
343344
cardano-strict-containers,
344345
containers,

‎cardano-api/gen/Test/Gen/Cardano/Api/Experimental.hs‎

Lines changed: 134 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE FlexibleContexts #-}
23

34
module Test.Gen.Cardano.Api.Experimental
45
( genAnyScript
@@ -11,6 +12,8 @@ module Test.Gen.Cardano.Api.Experimental
1112
, genSimpleScriptInEra
1213
, genUnsignedSubTx
1314
, genSignedSubTx
15+
, genUnsignedSubTxWithGovernance
16+
, genGovernanceActionProposals
1417
)
1518
where
1619

@@ -21,7 +24,15 @@ import Cardano.Api.Experimental.AnyScriptWitness
2124
import Cardano.Api.Experimental.Tx
2225
import Cardano.Api.Ledger qualified as L
2326

27+
import Cardano.Ledger.Core qualified as L
28+
import Cardano.Ledger.Dijkstra.Tx qualified as Dijkstra
29+
import Cardano.Ledger.Dijkstra.TxBody qualified as Dijkstra
30+
31+
import Control.Monad (forM, zipWithM)
2432
import Data.Map.Ordered.Strict qualified as OMap
33+
import Data.Map.Strict qualified as Map
34+
import Data.OSet.Strict qualified as OSet
35+
import Data.Set qualified as Set
2536
import Data.Typeable
2637

2738
import Test.Gen.Cardano.Api.Typed
@@ -32,11 +43,13 @@ import Test.Gen.Cardano.Api.Typed
3243
, genTxIn
3344
)
3445

46+
import Test.Cardano.Ledger.Conway.Arbitrary qualified as Conway
3547
import Test.Cardano.Ledger.Dijkstra.Arbitrary ()
3648

3749
import Hedgehog (Gen)
3850
import Hedgehog.Gen qualified as Gen
3951
import Hedgehog.Gen.QuickCheck qualified as Q
52+
import Test.QuickCheck qualified as QC
4053

4154
genAnyWitness :: Gen (AnyWitness era)
4255
genAnyWitness =
@@ -153,9 +166,127 @@ genScriptWitnesssedTxVotingProcedures = return $ TxVotingProcedures (L.VotingPro
153166
genScriptWitnessedTxProposals :: Gen (TxProposalProcedures era)
154167
genScriptWitnessedTxProposals = return $ TxProposalProcedures OMap.empty
155168

156-
-- | An arbitrary Dijkstra sub-transaction. May contain key witnesses.
169+
-- | A Dijkstra sub-transaction with shared governance size budgets. May contain key witnesses.
157170
genUnsignedSubTx :: Gen UnsignedSubTx
158-
genUnsignedSubTx = UnsignedSubTx <$> Q.arbitrary
171+
genUnsignedSubTx = UnsignedSubTx <$> Q.quickcheck genBudgetedSubTx
159172

160173
genSignedSubTx :: Gen SignedSubTx
161-
genSignedSubTx = SignedSubTx <$> Q.arbitrary
174+
genSignedSubTx = SignedSubTx <$> Q.quickcheck genBudgetedSubTx
175+
176+
-- | Generate exact governance cardinalities for serialisation boundary cases.
177+
genUnsignedSubTxWithGovernance
178+
:: Int
179+
-- ^ Number of voters.
180+
-> Int
181+
-- ^ Voting entries per voter.
182+
-> Int
183+
-- ^ Number of proposals.
184+
-> Gen UnsignedSubTx
185+
genUnsignedSubTxWithGovernance voterCount voteCount proposalCount =
186+
UnsignedSubTx
187+
<$> Q.quickcheck
188+
( genSubTxWithGovernance
189+
(L.VotingProcedures <$> genDistinctMap voterCount (genDistinctMap voteCount QC.arbitrary))
190+
( QC.suchThat
191+
(OSet.fromFoldable <$> QC.vectorOf proposalCount QC.arbitrary)
192+
((== proposalCount) . length)
193+
)
194+
)
195+
196+
-- | Include every governance action family and distinct treasury coin values.
197+
genGovernanceActionProposals
198+
:: (L.EraPParams era, QC.Arbitrary (L.PParamsHKD L.StrictMaybe era))
199+
=> [L.Coin]
200+
-- ^ Proposal deposits and treasury withdrawal values.
201+
-> Gen (OSet.OSet (L.ProposalProcedure era))
202+
genGovernanceActionProposals coins = Q.quickcheck $ do
203+
actions <-
204+
sequence
205+
[ Conway.genParameterChange
206+
, Conway.genHardForkInitiation
207+
, do
208+
recipients <- genDistinctMap (length coins) $ pure ()
209+
L.TreasuryWithdrawals (Map.fromList $ zip (Map.keys recipients) coins) <$> QC.arbitrary
210+
, Conway.genNoConfidence
211+
, Conway.genUpdateCommittee
212+
, Conway.genNewConstitution
213+
, pure L.InfoAction
214+
]
215+
OSet.fromFoldable
216+
<$> zipWithM
217+
(\coin action -> L.ProposalProcedure coin <$> QC.arbitrary <*> pure action <*> QC.arbitrary)
218+
coins
219+
actions
220+
221+
type TestEra = DijkstraEra
222+
223+
genBudgetedSubTx :: QC.Gen (L.Tx L.SubTx (LedgerEra TestEra))
224+
genBudgetedSubTx = genSubTxWithGovernance genBudgetedVotingProcedures genBudgetedProposals
225+
226+
genSubTxWithGovernance
227+
:: QC.Gen (L.VotingProcedures (LedgerEra TestEra))
228+
-> QC.Gen (OSet.OSet (L.ProposalProcedure (LedgerEra TestEra)))
229+
-> QC.Gen (L.Tx L.SubTx (LedgerEra TestEra))
230+
genSubTxWithGovernance doVotes doProposals = do
231+
body <-
232+
Dijkstra.DijkstraSubTxBody
233+
<$> QC.arbitrary
234+
<*> QC.arbitrary
235+
<*> QC.arbitrary
236+
<*> QC.arbitrary
237+
<*> QC.arbitrary
238+
<*> QC.scale (`div` 15) QC.arbitrary
239+
<*> QC.arbitrary
240+
<*> QC.scale (`div` 15) QC.arbitrary
241+
<*> QC.arbitrary
242+
<*> QC.arbitrary
243+
<*> QC.arbitrary
244+
<*> doVotes
245+
<*> doProposals
246+
<*> QC.arbitrary
247+
<*> QC.arbitrary
248+
<*> QC.arbitrary
249+
<*> QC.arbitrary
250+
<*> QC.arbitrary
251+
Dijkstra.MkDijkstraTx <$> (Dijkstra.DijkstraSubTx body <$> QC.arbitrary <*> QC.arbitrary)
252+
253+
genBudgetedVotingProcedures :: L.Era era => QC.Gen (L.VotingProcedures era)
254+
genBudgetedVotingProcedures = QC.sized $ \budget -> do
255+
voterCount <- QC.chooseInt (0, budget)
256+
-- Every voter has a nonempty map, with at most the outer size in total entries.
257+
let entryBudget = budget `div` max 1 voterCount
258+
L.VotingProcedures
259+
<$> genDistinctMap
260+
voterCount
261+
( do
262+
entryCount <- QC.chooseInt (1, entryBudget)
263+
genDistinctMap entryCount QC.arbitrary
264+
)
265+
266+
genBudgetedProposals
267+
:: (L.EraPParams era, QC.Arbitrary (L.PParamsHKD L.StrictMaybe era))
268+
=> QC.Gen (OSet.OSet (L.ProposalProcedure era))
269+
genBudgetedProposals = QC.sized $ \budget -> do
270+
-- Fixed-cost cost models make proposal counts grow more slowly than payload sizes.
271+
let countBudget = length $ takeWhile (\count -> count <= budget `div` count) [1 .. budget]
272+
proposalCount <- QC.chooseInt (0, countBudget)
273+
-- Divide the QuickCheck size among actions before generating their nested payloads.
274+
let payloadBudget = budget `div` max 1 proposalCount
275+
OSet.fromFoldable
276+
<$> QC.vectorOf
277+
proposalCount
278+
( L.ProposalProcedure
279+
<$> QC.arbitrary
280+
<*> QC.arbitrary
281+
<*> QC.resize payloadBudget QC.arbitrary
282+
<*> QC.arbitrary
283+
)
284+
285+
genDistinctMap :: (Ord k, QC.Arbitrary k) => Int -> QC.Gen v -> QC.Gen (Map.Map k v)
286+
genDistinctMap entryCount doValue = do
287+
keys <-
288+
QC.suchThat
289+
(QC.vectorOf entryCount QC.arbitrary)
290+
((== entryCount) . Set.size . Set.fromList)
291+
entries <- forM keys $ \key -> (,) key <$> doValue
292+
pure $ Map.fromList entries

‎cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs‎

Lines changed: 72 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -64,7 +64,13 @@ import Data.Time qualified as Time
6464
import Data.Time.Clock.POSIX qualified as Time
6565
import Lens.Micro
6666

67-
import Test.Gen.Cardano.Api.Experimental (genAnyScript, genSignedSubTx, genUnsignedSubTx)
67+
import Test.Gen.Cardano.Api.Experimental
68+
( genAnyScript
69+
, genGovernanceActionProposals
70+
, genSignedSubTx
71+
, genUnsignedSubTx
72+
, genUnsignedSubTxWithGovernance
73+
)
6874
import Test.Gen.Cardano.Api.Typed
6975
( genAddressInEra
7076
, genPlutusScriptInEra
@@ -157,6 +163,18 @@ tests =
157163
"Top-level body keeps required top-level guards and starting account balance intervals"
158164
prop_makeUnsignedTx_dijkstra_top_level_only_fields
159165
]
166+
, testGroup "SubTx governance stress" $
167+
[ testProperty ("outer/proposals " <> show count) $
168+
prop_sub_tx_governance_stress count 1 count 5
169+
| count <- [0, 1, 2, 23, 24, 255, 256]
170+
]
171+
<> [ testProperty ("inner votes " <> show count) $
172+
prop_sub_tx_governance_stress 1 count 0 5
173+
| count <- [1, 2, 23, 24, 255, 256]
174+
]
175+
<> [ testProperty "large governance payload" $ prop_sub_tx_governance_stress 34 56 38 99
176+
, testProperty "action families and coin boundaries" prop_sub_tx_governance_actions
177+
]
160178
, testGroup
161179
"makeUnsignedTx"
162180
[ testProperty
@@ -221,6 +239,44 @@ prop_roundtrip_text_envelope_signed_sub_tx = H.property $ do
221239
subTx <- H.forAll genSignedSubTx
222240
H.tripping subTx (Api.serialiseToTextEnvelope Nothing) Api.deserialiseFromTextEnvelope
223241

242+
prop_sub_tx_governance_stress :: Int -> Int -> Int -> Int -> Property
243+
prop_sub_tx_governance_stress voterCount voteCount proposalCount payloadSize = H.propertyOnce $ do
244+
unsigned@(Exp.UnsignedSubTx ledgerTx) <-
245+
H.forAll $
246+
Gen.resize (fromIntegral payloadSize) $
247+
genUnsignedSubTxWithGovernance voterCount voteCount proposalCount
248+
let body = ledgerTx ^. L.bodyTxL
249+
L.VotingProcedures votes = Dijkstra.dstbVotingProcedures body
250+
signed = Exp.SignedSubTx ledgerTx
251+
Map.size votes H.=== voterCount
252+
map Map.size (Map.elems votes) H.=== replicate voterCount voteCount
253+
length (Dijkstra.dstbProposalProcedures body) H.=== proposalCount
254+
H.tripping unsigned Api.serialiseToCBOR (Api.deserialiseFromCBOR Exp.AsUnsignedSubTx)
255+
H.tripping signed Api.serialiseToCBOR (Api.deserialiseFromCBOR Exp.AsSignedSubTx)
256+
H.tripping unsigned (Api.serialiseToTextEnvelope Nothing) Api.deserialiseFromTextEnvelope
257+
H.tripping signed (Api.serialiseToTextEnvelope Nothing) Api.deserialiseFromTextEnvelope
258+
259+
prop_sub_tx_governance_actions :: Property
260+
prop_sub_tx_governance_actions = H.propertyOnce $ do
261+
let coins = L.Coin <$> [0, 1, 23, 24, 255, 256, 65535, 65536, 4294967295, 4294967296]
262+
proposals <- H.forAll $ Gen.resize 99 $ genGovernanceActionProposals coins
263+
Exp.UnsignedSubTx ledgerTx <- H.forAll $ Gen.resize 5 genUnsignedSubTx
264+
let proposalList = toList proposals
265+
actionNames = map (governanceActionName . L.pProcGovAction) proposalList
266+
treasuryValues = concatMap (governanceTreasuryCoins . L.pProcGovAction) proposalList
267+
unsigned =
268+
Exp.UnsignedSubTx $ ledgerTx & L.bodyTxL . UnexportedLedger.proposalProceduresTxBodyL .~ proposals
269+
Exp.UnsignedSubTx withProposals = unsigned
270+
signed = Exp.SignedSubTx withProposals
271+
actionNames
272+
H.=== ["parameters", "hard-fork", "treasury", "no-confidence", "committee", "constitution", "info"]
273+
map L.pProcDeposit proposalList H.=== take 7 coins
274+
treasuryValues H.=== coins
275+
H.tripping unsigned Api.serialiseToCBOR (Api.deserialiseFromCBOR Exp.AsUnsignedSubTx)
276+
H.tripping signed Api.serialiseToCBOR (Api.deserialiseFromCBOR Exp.AsSignedSubTx)
277+
H.tripping unsigned (Api.serialiseToTextEnvelope Nothing) Api.deserialiseFromTextEnvelope
278+
H.tripping signed (Api.serialiseToTextEnvelope Nothing) Api.deserialiseFromTextEnvelope
279+
224280
prop_sub_tx_envelope_types :: Property
225281
prop_sub_tx_envelope_types = H.propertyOnce $ do
226282
Api.textEnvelopeType Exp.AsUnsignedSubTx
@@ -1309,3 +1365,18 @@ prop_calcMinFeeRecursive_no_tx_outs = H.property $ do
13091365
let outs = toList $ resultLedgerTx ^. L.bodyTxL . L.outputsTxBodyL
13101366
-- The result should have exactly one output (the change output)
13111367
length outs H.=== 1
1368+
1369+
governanceActionName :: L.GovAction era -> String
1370+
governanceActionName = \case
1371+
L.ParameterChange{} -> "parameters"
1372+
L.HardForkInitiation{} -> "hard-fork"
1373+
L.TreasuryWithdrawals{} -> "treasury"
1374+
L.NoConfidence{} -> "no-confidence"
1375+
L.UpdateCommittee{} -> "committee"
1376+
L.NewConstitution{} -> "constitution"
1377+
L.InfoAction -> "info"
1378+
1379+
governanceTreasuryCoins :: L.GovAction era -> [L.Coin]
1380+
governanceTreasuryCoins = \case
1381+
L.TreasuryWithdrawals withdrawals _ -> Map.elems withdrawals
1382+
_ -> []

0 commit comments

Comments
 (0)