diff --git a/.changes/20260728_cardano_api_vote_key_witness_count.yml b/.changes/20260728_cardano_api_vote_key_witness_count.yml new file mode 100644 index 0000000000..eab19c48b1 --- /dev/null +++ b/.changes/20260728_cardano_api_vote_key_witness_count.yml @@ -0,0 +1,7 @@ +project: cardano-api +pr: 1271 +kind: + - bugfix + - compatible +description: | + Fix fee estimation for transactions containing votes: `estimateTransactionKeyWitnessCount` now accounts for the key witnesses required by key-credentialed voters (key-hash DReps, constitutional committee hot keys, and SPOs), so vote-carrying transactions no longer get underestimated fees and fail with `FeeTooSmallUTxO`. Fee estimation also no longer counts the same key twice when it is required by more than one of certificates, withdrawals, extra key witnesses and votes. `estimateTransactionKeyWitnessCount` is now also exported from `Cardano.Api.Experimental`. Pool registration certificates now count one key witness for the operator and each owner. See [issue #722](https://github.com/IntersectMBO/cardano-api/issues/722). diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs index b1bd284297..c7d055be15 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -41,6 +41,7 @@ module Cardano.Api.Experimental , evaluateTransactionFee , collectTxBodyScriptWitnesses , substituteExecutionUnits + , estimateTransactionKeyWitnessCount -- ** Era-related , BabbageEra diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs index f392f03785..07762336ce 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs @@ -20,6 +20,7 @@ module Cardano.Api.Experimental.Tx.Internal.Fee , calcMinFeeRecursive , collectTxBodyScriptWitnesses , estimateBalancedTxBody + , estimateTransactionKeyWitnessCount , evaluateTransaction , TxEvaluationResult (..) , evaluateTransactionExecutionUnits @@ -75,7 +76,8 @@ import Cardano.Ledger.Alonzo.Core qualified as Ledger import Cardano.Ledger.Api qualified as L import Cardano.Ledger.Coin qualified as L import Cardano.Ledger.Conway.Governance qualified as L -import Cardano.Ledger.Credential as Ledger (Credential) +import Cardano.Ledger.Credential as Ledger (Credential, credKeyHashWitness) +import Cardano.Ledger.Keys (asWitness) import Cardano.Ledger.Val qualified as L import Control.Monad @@ -1744,9 +1746,14 @@ handleExUnitsErrors ScriptInvalid failuresMap exUnitsMap | null failuresMap = Left TxBodyScriptBadScriptValidity | otherwise = Right $ Map.map (\_ -> ExecutionUnits 0 0) failuresMap <> exUnitsMap --- | Provide and approximate count of the key witnesses (i.e. signatures) +-- | Provide an approximate count of the key witnesses (i.e. signatures) -- required for a transaction. -- +-- Certificates, withdrawals, extra key witnesses and votes are deduplicated against +-- each other, mirroring the key hash set ledger's @getWitsVKeyNeeded@ computes, so a +-- key acting in several of those roles is counted once. A pool registration +-- certificate counts one key witness for the operator and one for every owner. +-- -- This estimate is not exact and may overestimate the required number of witnesses. -- The function makes conservative assumptions, including: -- @@ -1755,6 +1762,15 @@ handleExUnitsErrors ScriptInvalid failuresMap exUnitsMap -- -- * Assuming regular and collateral inputs are distinct, even though they may overlap. -- +-- * Counting inputs and collateral inputs on top of the deduplicated set rather than +-- against it, because their key hashes are only known from the UTxO. The result stays +-- an upper bound: the number of inputs is at least the number of input key hashes +-- missing from that set. Use 'calculateMinTxFee' with a 'L.UTxO' in hand for an exact +-- count. +-- +-- * Charging one witness per proposal procedure, even though a proposal needs no key +-- witness of its own. +-- -- TODO: Consider implementing a more precise calculation that leverages the UTXO set -- to determine which inputs correspond to distinct addresses. Additionally, the -- estimate can be refined by distinguishing between Shelley and Byron-style witnesses. @@ -1767,25 +1783,62 @@ estimateTransactionKeyWitnessCount , txWithdrawals , txCertificates , txProposalProcedures + , txVotingProcedures } = fromIntegral $ - sum (map estimateTxInWitnesses txIns) + Set.size knowableKeyHashes + + sum (map estimateTxInWitnesses txIns) + length txInsCollateral - + case txExtraKeyWits of - TxExtraKeyWitnesses khs -> - length khs - + case txWithdrawals of - TxWithdrawals withdrawals -> - length [() | (_, _, AnyKeyWitnessPlaceholder) <- withdrawals] - + case txCertificates of - TxCertificates credWits -> - length - [() | (_, Just AnyKeyWitnessPlaceholder) <- toList credWits] + case txProposalProcedures of Just (TxProposalProcedures m) -> OMap.size m Nothing -> 0 where + -- The roles whose key hashes the body already pins down, unioned the way ledger's + -- 'Cardano.Ledger.Conway.UTxO.getConwayWitsVKeyNeeded' unions them. + knowableKeyHashes :: Set (L.KeyHash L.Witness) + knowableKeyHashes = + extraKeyHashes <> withdrawalKeyHashes <> certificateKeyHashes <> voteKeyHashes + + extraKeyHashes :: Set (L.KeyHash L.Witness) + extraKeyHashes = case txExtraKeyWits of + TxExtraKeyWitnesses keyHashes -> + Set.fromList [asWitness $ Api.unPaymentKeyHash keyHash | keyHash <- keyHashes] + + withdrawalKeyHashes :: Set (L.KeyHash L.Witness) + withdrawalKeyHashes = case txWithdrawals of + TxWithdrawals withdrawals -> + Set.fromList $ + mapMaybe (\(StakeAddress _ credential, _, _) -> credKeyHashWitness credential) withdrawals + + -- The certificate itself decides who must sign, mirroring ledger's + -- 'getVKeyWitnessTxCert': a pool registration certificate additionally + -- requires every owner to sign, not just the operator. + certificateKeyHashes :: Set (L.KeyHash L.Witness) + certificateKeyHashes = case txCertificates of + TxCertificates credWits -> + obtainCommonConstraints (useEra @era) $ + let + -- Every owner of a pool registration certificate must also sign. + ownerKeyHashes :: L.TxCert (LedgerEra era) -> Set (L.KeyHash L.Witness) + ownerKeyHashes certificate = case certificate of + L.RegPoolTxCert poolParams -> Set.map asWitness (L.sppOwners poolParams) + _ -> mempty + in + Set.unions + [ maybe mempty Set.singleton (L.getVKeyWitnessTxCert certificate) <> ownerKeyHashes certificate + | (Exp.Certificate certificate, _) <- toList credWits + ] + + voteKeyHashes :: Set (L.KeyHash L.Witness) + voteKeyHashes = case txVotingProcedures of + Nothing -> mempty + Just (TxVotingProcedures procedures _) -> + Map.foldrWithKey' + (\voter _ keyHashes -> maybe keyHashes (`Set.insert` keyHashes) (voterKeyHashWitness voter)) + mempty + (L.unVotingProcedures procedures) + estimateTxInWitnesses :: (TxIn, AnyWitness (LedgerEra era)) -> Int estimateTxInWitnesses (_, AnyKeyWitnessPlaceholder) = 1 estimateTxInWitnesses (_, AnySimpleScriptWitness (SScript (SimpleScript simpleScript))) = @@ -1809,6 +1862,13 @@ estimateTransactionKeyWitnessCount maxWitnessesInSimpleScript (Old.RequireAnyOf simpleScripts) = maximum $ map maxWitnessesInSimpleScript simpleScripts maxWitnessesInSimpleScript (Old.RequireMOf n simpleScripts) = sum $ take n $ sortBy (comparing Down) (map maxWitnessesInSimpleScript simpleScripts) + -- Mirrors ledger's 'Cardano.Ledger.Conway.UTxO.voterWitnesses': a committee or + -- DRep voter needs a VKey witness only when its credential is key-based. + voterKeyHashWitness :: L.Voter -> Maybe (L.KeyHash L.Witness) + voterKeyHashWitness (L.CommitteeVoter credential) = credKeyHashWitness credential + voterKeyHashWitness (L.DRepVoter credential) = credKeyHashWitness credential + voterKeyHashWitness (L.StakePoolVoter poolId) = Just (asWitness poolId) + -- | Estimate the minimum transaction fee by analyzing the transaction structure -- and determining the required number and type of key witnesses. -- diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Fee.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Fee.hs index b3bd2197b7..504cb2d61c 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Fee.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Fee.hs @@ -86,7 +86,8 @@ import Cardano.Ledger.Alonzo.Scripts qualified as Alonzo import Cardano.Ledger.Api qualified as L import Cardano.Ledger.Coin qualified as L import Cardano.Ledger.Conway.Governance qualified as L -import Cardano.Ledger.Credential as Ledger (Credential) +import Cardano.Ledger.Credential as Ledger (Credential, credKeyHashWitness) +import Cardano.Ledger.Keys (asWitness) import Cardano.Ledger.Plutus.Language qualified as Plutus import Data.Bifunctor (bimap, first, second) @@ -448,9 +449,14 @@ calculateMinTxFee sbe pp utxo txbody keywitcount = ShelleyTx _ tx -> L.calcMinFeeTx (toLedgerUTxO sbe utxo) pp tx (fromIntegral keywitcount) --- | Provide and approximate count of the key witnesses (i.e. signatures) +-- | Provide an approximate count of the key witnesses (i.e. signatures) -- required for a transaction. -- +-- Certificates, withdrawals, extra key witnesses and votes are deduplicated against +-- each other, mirroring the key hash set ledger's @getWitsVKeyNeeded@ computes, so a +-- key acting in several of those roles is counted once. A pool registration +-- certificate counts one key witness for the operator and one for every owner. +-- -- This estimate is not exact and may overestimate the required number of witnesses. -- The function makes conservative assumptions, including: -- @@ -459,6 +465,16 @@ calculateMinTxFee sbe pp utxo txbody keywitcount = -- -- * Assuming regular and collateral inputs are distinct, even though they may overlap. -- +-- * Counting inputs and collateral inputs on top of the deduplicated set rather than +-- against it, because their key hashes are only known from the UTxO. The result stays +-- an upper bound: the number of inputs is at least the number of input key hashes +-- missing from that set. Use 'calculateMinTxFee' with a 'UTxO' in hand for an exact +-- count. +-- +-- * Counting one witness per genesis key of a pre-Conway update proposal, on top of +-- the deduplicated set, because the actual signers are the genesis delegate keys, +-- which are only known from ledger state. +-- -- TODO: Consider implementing a more precise calculation that leverages the UTXO set -- to determine which inputs correspond to distinct addresses. Additionally, the -- estimate can be refined by distinguishing between Shelley and Byron-style witnesses. @@ -471,31 +487,64 @@ estimateTransactionKeyWitnessCount , txWithdrawals , txCertificates , txUpdateProposal + , txVotingProcedures } = fromIntegral $ - sum (map estimateTxInWitnesses txIns) + Set.size knowableKeyHashes + + sum (map estimateTxInWitnesses txIns) + case txInsCollateral of TxInsCollateral _ txins -> length txins _ -> 0 - + case txExtraKeyWits of - TxExtraKeyWitnesses _ khs -> - length khs - _ -> 0 - + case txWithdrawals of - TxWithdrawals _ withdrawals -> - length [() | (_, _, BuildTxWith KeyWitness{}) <- withdrawals] - _ -> 0 - + case txCertificates of - TxCertificates _ credWits -> - length - [() | (_, BuildTxWith (Just (_, KeyWitness{}))) <- toList credWits] - _ -> 0 + case txUpdateProposal of TxUpdateProposal _ (UpdateProposal updatePerGenesisKey _) -> Map.size updatePerGenesisKey _ -> 0 where + -- The roles whose key hashes the body already pins down, unioned the way ledger's + -- 'Cardano.Ledger.Conway.UTxO.getConwayWitsVKeyNeeded' unions them. + knowableKeyHashes :: Set (L.KeyHash L.Witness) + knowableKeyHashes = + extraKeyHashes <> withdrawalKeyHashes <> certificateKeyHashes <> voteKeyHashes + + extraKeyHashes :: Set (L.KeyHash L.Witness) + extraKeyHashes = Set.map asWitness $ convExtraKeyWitnesses txExtraKeyWits + + withdrawalKeyHashes :: Set (L.KeyHash L.Witness) + withdrawalKeyHashes = case txWithdrawals of + TxWithdrawalsNone -> mempty + TxWithdrawals _ withdrawals -> + Set.fromList $ + mapMaybe (\(StakeAddress _ credential, _, _) -> credKeyHashWitness credential) withdrawals + + -- The certificate itself decides who must sign, mirroring ledger's + -- 'getVKeyWitnessTxCert': a pool registration certificate additionally + -- requires every owner to sign, not just the operator. + certificateKeyHashes :: Set (L.KeyHash L.Witness) + certificateKeyHashes = case txCertificates of + TxCertificatesNone -> mempty + TxCertificates sbe credWits -> + shelleyBasedEraConstraints sbe $ + Set.unions + [ maybe mempty Set.singleton (L.getVKeyWitnessTxCert certificate) <> ownerKeyHashes certificate + | (Exp.Certificate certificate, _) <- toList credWits + ] + + -- Every owner of a pool registration certificate must also sign. + ownerKeyHashes :: L.EraTxCert ledgerera => L.TxCert ledgerera -> Set (L.KeyHash L.Witness) + ownerKeyHashes certificate = case certificate of + L.RegPoolTxCert poolParams -> Set.map asWitness (L.sppOwners poolParams) + _ -> mempty + + voteKeyHashes :: Set (L.KeyHash L.Witness) + voteKeyHashes = case maybe TxVotingProceduresNone unFeatured txVotingProcedures of + TxVotingProceduresNone -> mempty + TxVotingProcedures votingProcedures _scriptWitnessMap -> + Map.foldrWithKey' + (\voter _ keyHashes -> maybe keyHashes (`Set.insert` keyHashes) (voterKeyHashWitness voter)) + mempty + (L.unVotingProcedures votingProcedures) + estimateTxInWitnesses :: (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era)) -> Int estimateTxInWitnesses (_, BuildTxWith (KeyWitness _)) = 1 estimateTxInWitnesses (_, BuildTxWith (ScriptWitness _ (SimpleScriptWitness _ (SScript simpleScript)))) = maxWitnessesInSimpleScript simpleScript @@ -517,6 +566,13 @@ estimateTransactionKeyWitnessCount maxWitnessesInSimpleScript (RequireAnyOf simpleScripts) = maximum $ map maxWitnessesInSimpleScript simpleScripts maxWitnessesInSimpleScript (RequireMOf n simpleScripts) = sum $ take n $ sortBy (comparing Down) (map maxWitnessesInSimpleScript simpleScripts) + -- Mirrors ledger's 'Cardano.Ledger.Conway.UTxO.voterWitnesses': a committee or + -- DRep voter needs a VKey witness only when its credential is key-based. + voterKeyHashWitness :: L.Voter -> Maybe (L.KeyHash L.Witness) + voterKeyHashWitness (L.CommitteeVoter credential) = credKeyHashWitness credential + voterKeyHashWitness (L.DRepVoter credential) = credKeyHashWitness credential + voterKeyHashWitness (L.StakePoolVoter poolId) = Just (asWitness poolId) + -- ---------------------------------------------------------------------------- -- Script execution units -- diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental/Fee.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental/Fee.hs index 18f36fbe35..264fec517e 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental/Fee.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental/Fee.hs @@ -2,6 +2,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Test.Cardano.Api.Experimental.Fee @@ -25,17 +26,26 @@ import Cardano.Slotting.EpochInfo qualified as Slotting import Cardano.Slotting.Slot qualified as Slotting import Cardano.Slotting.Time qualified as Slotting +import Data.Default (def) import Data.Foldable (toList) import Data.Map.Strict qualified as Map import Data.Sequence.Strict qualified as Seq +import Data.Set qualified as Set import Data.Time.Clock.POSIX qualified as Time import Lens.Micro -import Test.Gen.Cardano.Api.Typed (genAddressInEra, genStakeCredential, genTxIn) +import Test.Gen.Cardano.Api.Typed + ( genAddressInEra + , genScriptHash + , genStakeCredential + , genTxId + , genTxIn + , genVerificationKeyHash + ) import Test.Cardano.Api.Experimental (exampleProtocolParams, exampleProtocolParamsEra) -import Hedgehog (Gen, Property) +import Hedgehog (Gen, Property, (===)) import Hedgehog qualified as H import Hedgehog.Extras qualified as H import Hedgehog.Gen qualified as Gen @@ -63,6 +73,18 @@ tests = "unwitnessed certs produce no script witnesses" prop_collectTxBodyScriptWitnesses_ignores_unwitnessed_certs ] + , testGroup + "estimateTransactionKeyWitnessCount" + [ testProperty + "counts key witnesses required by key-credentialed voters" + prop_estimateTransactionKeyWitnessCount_counts_vote_key_witnesses + , testProperty + "cross-role key witness dedupe" + prop_estimateTransactionKeyWitnessCount_dedupes_across_roles + , testProperty + "pool registration counts operator and every owner" + prop_estimateTransactionKeyWitnessCount_counts_pool_owners + ] , testGroup "createCompatibleTx" [ testProperty @@ -566,7 +588,7 @@ prop_calcMinFeeRecursive_well_funded_succeeds = H.property $ do (const False) utxo (resultLedgerTx ^. L.bodyTxL) - balance H.=== mempty + balance === mempty -- | Like 'prop_calcMinFeeRecursive_well_funded_succeeds' but the UTxO and -- output carry native tokens. Verifies that surplus tokens are correctly @@ -586,7 +608,7 @@ prop_calcMinFeeRecursive_well_funded_multi_asset = H.property $ do (const False) utxo (resultLedgerTx ^. L.bodyTxL) - balance H.=== mempty + balance === mempty -- | 'calcMinFeeRecursive' is idempotent: applying it to its own result -- yields the same 'UnsignedTx'. This confirms the fee has reached a @@ -600,7 +622,7 @@ prop_calcMinFeeRecursive_fee_fixpoint = H.property $ do secondResult <- H.leftFail $ Exp.calcMinFeeRecursive changeAddr resultTx utxo exampleProtocolParams mempty mempty 0 - resultTx H.=== secondResult + resultTx === secondResult -- | When the outputs exceed the UTxO value the function returns -- 'Left (NotEnoughAdaForNewOutput _)' with a negative deficit coin. @@ -653,7 +675,7 @@ prop_calcMinFeeRecursive_no_tx_outs = H.property $ do Exp.calcMinFeeRecursive changeAddr unsignedTx utxo exampleProtocolParams mempty mempty 0 let outs = toList $ resultLedgerTx ^. L.bodyTxL . L.outputsTxBodyL -- The result should have exactly one output (the change output) - length outs H.=== 1 + length outs === 1 -- | When the surplus is just barely enough to cover the initial fee but not -- the higher fee after adding a change output, the change output balance @@ -692,7 +714,7 @@ prop_calcMinFeeRecursive_withdrawal_funded_succeeds = H.property $ do (const False) utxo (resultLedgerTx ^. L.bodyTxL) - balance H.=== mempty + balance === mempty -- | When the input is tiny (below the minimum fee) and the withdrawal only -- covers @output - input@ exactly, 'calcMinFeeRecursive' must fail @@ -781,7 +803,7 @@ prop_evaluateSignedTx_balanced_mempty = H.property $ do mempty utxo signedTx - Exp.txEvalBalance result H.=== mempty + Exp.txEvalBalance result === mempty -- | Evaluate a simple signed transaction, returning the result and UTxO. evalSimpleTx @@ -824,7 +846,7 @@ prop_substituteExecutionUnits_preserves_certs = H.property $ do Exp.defaultTxBodyContent & Exp.setTxCertificates inputCerts result <- H.evalEither $ Exp.substituteExecutionUnits Map.empty txBodyContent - Exp.txCertificates result H.=== inputCerts + Exp.txCertificates result === inputCerts -- | 'collectTxBodyScriptWitnesses' must return exactly the script-witnessed -- certs (1 simple script witness in the generator) and must not include @@ -837,7 +859,7 @@ prop_collectTxBodyScriptWitnesses_ignores_unwitnessed_certs = H.property $ do Exp.defaultTxBodyContent & Exp.setTxCertificates inputCerts scriptWitnesses = Exp.collectTxBodyScriptWitnesses txBodyContent - length scriptWitnesses H.=== 1 + length scriptWitnesses === 1 -- | 'createCompatibleTx' must include every certificate (both witnessed and -- unwitnessed) in the resulting ledger transaction body. This ensures that @@ -850,7 +872,112 @@ prop_createCompatibleTx_preserves_all_certs = H.property $ do Api.ShelleyTx _ ledgerTx <- H.evalEither $ createCompatibleTx sbe [] [] mempty 0 (NoPParamsUpdate sbe) NoVotes inputCerts let bodyCerts = ledgerTx ^. L.bodyTxL . L.certsTxBodyL - Seq.length bodyCerts H.=== expectedCount + Seq.length bodyCerts === expectedCount + +-- | Regression test for: a key-credentialed voter (e.g. a key-hash DRep) +-- requires a VKey witness to satisfy the ledger, but +-- 'estimateTransactionKeyWitnessCount''s record pattern does not destructure +-- 'txVotingProcedures' at all, so a vote witnessed by +-- 'AnyKeyWitnessPlaceholder' contributes zero to the estimate. A transaction +-- containing only a generated mix of key-credentialed and script-credentialed +-- votes (and nothing else) must be estimated to need exactly one key witness +-- per key-credentialed voter - script-credentialed votes must not add to the +-- count. Voters are drawn from a small pool and each one votes on several of +-- a small pool of governance action ids, so the same voter recurs for +-- several action ids; the count must still be one per voter, not one per +-- vote. +prop_estimateTransactionKeyWitnessCount_counts_vote_key_witnesses :: Property +prop_estimateTransactionKeyWitnessCount_counts_vote_key_witnesses = H.property $ do + (voteEntries, expectedKeyWitnessCount) <- H.forAll genVotingProceduresWithKeyWitnessCount + txVotingProcedures <- H.leftFail $ Exp.mkTxVotingProcedures voteEntries + let txBodyContent = + Exp.defaultTxBodyContent + & Exp.setTxVotingProcedures txVotingProcedures + keyWitnessCount = Exp.estimateTransactionKeyWitnessCount @Exp.ConwayEra txBodyContent + keyWitnessCount === fromIntegral expectedKeyWitnessCount + +-- | Cross-role dedupe: a stake key that both withdraws rewards and is +-- deregistered by a certificate in the same transaction needs one key +-- witness, not two, while an unrelated extra key witness still counts +-- separately. A certificate for a different stake key collides with +-- nothing, so all three keys count. +prop_estimateTransactionKeyWitnessCount_dedupes_across_roles :: Property +prop_estimateTransactionKeyWitnessCount_dedupes_across_roles = H.property $ do + withdrawingStakeKeyHash <- H.forAll $ genVerificationKeyHash Api.AsStakeKey + unrelatedStakeKeyHash <- H.forAll $ genVerificationKeyHash Api.AsStakeKey + extraPaymentKeyHash <- H.forAll $ genVerificationKeyHash Api.AsPaymentKey + let stakeCredential = Api.StakeCredentialByKey withdrawingStakeKeyHash + stakeAddress = Api.makeStakeAddress Api.Mainnet stakeCredential + unregistrationCert credential = + Exp.Certificate $ + L.ConwayTxCertDeleg $ + L.ConwayUnRegCert (Api.toShelleyStakeCredential credential) (L.SJust (L.Coin 2_000_000)) + contentWithCertFor credential = + Exp.defaultTxBodyContent + & Exp.setTxWithdrawals + (Exp.TxWithdrawals [(stakeAddress, L.Coin 0, Exp.AnyKeyWitnessPlaceholder)]) + & Exp.setTxCertificates + ( Exp.mkTxCertificates + Exp.ConwayEra + [(unregistrationCert credential, Exp.AnyKeyWitnessPlaceholder)] + ) + & Exp.setTxExtraKeyWits (Exp.TxExtraKeyWitnesses [extraPaymentKeyHash]) + -- the deregistered key is the withdrawing key: counted once, plus the extra key witness + Exp.estimateTransactionKeyWitnessCount @Exp.ConwayEra (contentWithCertFor stakeCredential) + === 2 + -- an unrelated deregistered key: nothing collides + Exp.estimateTransactionKeyWitnessCount @Exp.ConwayEra + (contentWithCertFor (Api.StakeCredentialByKey unrelatedStakeKeyHash)) + === 3 + +-- | A pool registration certificate requires a signature from the operator +-- and from every owner, mirroring ledger's 'getShelleyWitsVKeyNeeded'. An +-- owner who also withdraws rewards in the same transaction still counts once. +prop_estimateTransactionKeyWitnessCount_counts_pool_owners :: Property +prop_estimateTransactionKeyWitnessCount_counts_pool_owners = H.property $ do + operatorKeyHash <- H.forAll $ genVerificationKeyHash Api.AsStakePoolKey + withdrawingStakeKeyHash <- H.forAll $ genVerificationKeyHash Api.AsStakeKey + otherOwnerStakeKeyHash <- H.forAll $ genVerificationKeyHash Api.AsStakeKey + unrelatedOwnerStakeKeyHash <- H.forAll $ genVerificationKeyHash Api.AsStakeKey + Api.VrfKeyHash vrfKeyHash <- H.forAll $ genVerificationKeyHash Api.AsVrfKey + let stakeAddress = Api.makeStakeAddress Api.Mainnet (Api.StakeCredentialByKey withdrawingStakeKeyHash) + poolParamsWithOwners owners = + L.StakePoolParams + { L.sppId = Api.unStakePoolKeyHash operatorKeyHash + , L.sppVrf = L.toVRFVerKeyHash vrfKeyHash + , L.sppPledge = L.Coin 0 + , L.sppCost = L.Coin 0 + , L.sppMargin = minBound + , L.sppAccountAddress = def + , L.sppOwners = owners + , L.sppRelays = mempty + , L.sppMetadata = L.SNothing + } + registrationCertFor owners = + Exp.Certificate $ L.RegPoolTxCert (poolParamsWithOwners owners) + contentWithOwners owners = + Exp.defaultTxBodyContent + & Exp.setTxWithdrawals + (Exp.TxWithdrawals [(stakeAddress, L.Coin 0, Exp.AnyKeyWitnessPlaceholder)]) + & Exp.setTxCertificates + ( Exp.mkTxCertificates + Exp.ConwayEra + [(registrationCertFor owners, Exp.AnyKeyWitnessPlaceholder)] + ) + -- the withdrawing key is also a pool owner: counted once, plus the operator and the other owner + Exp.estimateTransactionKeyWitnessCount @Exp.ConwayEra + ( contentWithOwners + (Set.fromList [Api.unStakeKeyHash withdrawingStakeKeyHash, Api.unStakeKeyHash otherOwnerStakeKeyHash]) + ) + === 3 + -- owners disjoint from the withdrawing key: nothing collides, so all four keys count + Exp.estimateTransactionKeyWitnessCount @Exp.ConwayEra + ( contentWithOwners + ( Set.fromList + [Api.unStakeKeyHash otherOwnerStakeKeyHash, Api.unStakeKeyHash unrelatedOwnerStakeKeyHash] + ) + ) + === 4 -- --------------------------------------------------------------------------- -- Shared cert generators @@ -909,3 +1036,91 @@ genShuffledCertsWithCount = do ] shuffled <- Gen.shuffle allCerts pure (shuffled, length shuffled) + +-- --------------------------------------------------------------------------- +-- Shared vote generators +-- --------------------------------------------------------------------------- + +-- | Generate 'Exp.mkTxVotingProcedures' input mixing key-credentialed voters +-- ('L.DRepVoter'/'L.CommitteeVoter' over a key hash, plus 'L.StakePoolVoter', +-- which is always key-credentialed - all witnessed by +-- 'AnyKeyWitnessPlaceholder') with script-credentialed voters +-- ('L.DRepVoter'/'L.CommitteeVoter' over a script hash, witnessed by a +-- reference-input simple script - 'L.StakePoolVoter' has no +-- script-credentialed form). Each bucket draws its hashes via 'Gen.set', so +-- voters within a bucket never collide as witness-map keys; voters across +-- buckets can never collide either, since they differ in the 'L.Voter' or +-- 'L.Credential' constructor regardless of the underlying hash bytes. +-- +-- Votes are drawn from a small pool of governance action ids: every voter +-- votes on a random non-empty subset of the pool, as one list entry per +-- action id, so a voter voting on several actions becomes several entries +-- that 'Exp.mkTxVotingProcedures' must merge under the same 'L.Voter' key - +-- this is the voter/action-id collision requested in review. Returns the +-- generated entries together with the number of key-credentialed voters, +-- i.e. the key-witness count 'estimateTransactionKeyWitnessCount' must +-- report for a transaction containing only these votes. +genVotingProceduresWithKeyWitnessCount + :: Gen + ( [(L.VotingProcedures (Exp.LedgerEra Exp.ConwayEra), Exp.AnyWitness (Exp.LedgerEra Exp.ConwayEra))] + , Int + ) +genVotingProceduresWithKeyWitnessCount = do + drepKeyHashes <- + Gen.set (Range.linear 0 5) (Api.unDRepKeyHash <$> genVerificationKeyHash Api.AsDRepKey) + committeeKeyHashes <- + Gen.set + (Range.linear 0 5) + (Api.unCommitteeHotKeyHash <$> genVerificationKeyHash Api.AsCommitteeHotKey) + stakePoolKeyHashes <- + Gen.set (Range.linear 0 5) (Api.unStakePoolKeyHash <$> genVerificationKeyHash Api.AsStakePoolKey) + drepScriptHashes <- Gen.set (Range.linear 0 5) (Api.toShelleyScriptHash <$> genScriptHash) + committeeScriptHashes <- Gen.set (Range.linear 0 5) (Api.toShelleyScriptHash <$> genScriptHash) + refTxIn <- genTxIn + govActionIdPool <- toList <$> Gen.set (Range.linear 1 3) genGovActionId + + let keyVoters = + [L.DRepVoter (L.KeyHashObj kh) | kh <- toList drepKeyHashes] + <> [L.CommitteeVoter (L.KeyHashObj kh) | kh <- toList committeeKeyHashes] + <> [L.StakePoolVoter kh | kh <- toList stakePoolKeyHashes] + scriptVoters = + [L.DRepVoter (L.ScriptHashObj sh) | sh <- toList drepScriptHashes] + <> [L.CommitteeVoter (L.ScriptHashObj sh) | sh <- toList committeeScriptHashes] + scriptWitness = Exp.AnySimpleScriptWitness (Exp.SReferenceScript refTxIn) + + keyEntries <- + concat <$> traverse (voterEntries govActionIdPool Exp.AnyKeyWitnessPlaceholder) keyVoters + scriptEntries <- concat <$> traverse (voterEntries govActionIdPool scriptWitness) scriptVoters + + pure (keyEntries <> scriptEntries, length keyVoters) + where + votingProcedure = L.VotingProcedure{L.vProcVote = L.VoteYes, L.vProcAnchor = L.SNothing} + + -- One entry per action id the voter votes on, witnessed identically each + -- time - 'Exp.mkTxVotingProcedures' merges same-voter entries with + -- disjoint action ids and 'Map.union's their (identical) witnesses, so the + -- resulting witness map still has exactly one entry per voter. + voterEntries + :: [L.GovActionId] + -> Exp.AnyWitness (Exp.LedgerEra Exp.ConwayEra) + -> L.Voter + -> Gen + [(L.VotingProcedures (Exp.LedgerEra Exp.ConwayEra), Exp.AnyWitness (Exp.LedgerEra Exp.ConwayEra))] + voterEntries govActionIdPool witness voter = do + votedActionIds <- genVotedActionIds govActionIdPool + pure + [ (L.VotingProcedures (Map.singleton voter (Map.singleton actionId votingProcedure)), witness) + | actionId <- votedActionIds + ] + + genGovActionId :: Gen L.GovActionId + genGovActionId = + (L.GovActionId . Api.toShelleyTxId <$> genTxId) + <*> (L.GovActionIx <$> Gen.word16 (Range.linear 0 5)) + + -- A random non-empty subset of the pool - the source of the same voter + -- voting on several action ids. + genVotedActionIds :: [L.GovActionId] -> Gen [L.GovActionId] + genVotedActionIds actionIdPool = do + count <- Gen.int (Range.linear 1 (length actionIdPool)) + take count <$> Gen.shuffle actionIdPool diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs index d41eb93f92..d4839c32c5 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs @@ -13,8 +13,10 @@ module Test.Cardano.Api.TxBody where import Cardano.Api +import Cardano.Api.Experimental qualified as Exp import Cardano.Api.Ledger qualified as L +import Data.Default (def) import Data.Maybe (isJust) import Data.Set (Set) import Data.Set qualified as Set @@ -33,7 +35,10 @@ import Hedgehog , (===) ) import Hedgehog qualified as H +import Hedgehog.Extras qualified as H import Hedgehog.Gen (shuffle) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) @@ -147,6 +152,176 @@ prop_simple_script_witness_count = H.property $ do satisfyScript (RequireMOf n simpleScripts) = shuffle simpleScripts >>= satisfyScript . RequireAllOf . take n satisfyScript (RequireAnyOf simpleScripts) = satisfyScript (RequireMOf 1 simpleScripts) +-- | Regression test for: a key-credentialed voter (e.g. a key-hash DRep) +-- requires a VKey witness to satisfy the ledger, but the legacy +-- 'estimateTransactionKeyWitnessCount' does not look at 'txVotingProcedures' +-- at all. +-- +-- We isolate the vote contribution rather than asserting an absolute count: +-- 'genValidTxBody' may also populate ins/certs/withdrawals/its own votes +-- randomly, so we compare the estimate for a body carrying our generated +-- votes against the /same/ body with the votes field cleared. Everything +-- else is identical on both sides and cancels out exactly, so the delta +-- must equal exactly the number of key-credentialed voters. +-- +-- Voters are drawn from a small pool and each one votes on several of a +-- small pool of governance action ids, so the same voter recurs for several +-- action ids and 'mkTxVotingProcedures' has to merge the resulting entries - +-- the collision requested in review. +prop_estimateTransactionKeyWitnessCount_counts_vote_key_witnesses :: Property +prop_estimateTransactionKeyWitnessCount_counts_vote_key_witnesses = H.property $ do + let sbe = ShelleyBasedEraConway + ceo = ConwayEraOnwardsConway + (_, baseContent) <- H.forAll $ genValidTxBody sbe + (voteEntries, expectedKeyWitnessCount) <- H.forAll $ genVotingProceduresWithKeyWitnessCount ceo + votingProcedures <- H.leftFail $ mkTxVotingProcedures voteEntries + let contentWithoutVotes = setTxVotingProcedures Nothing baseContent + contentWithVotes = setTxVotingProcedures (Just (Featured ceo votingProcedures)) baseContent + estimateTransactionKeyWitnessCount contentWithVotes + === estimateTransactionKeyWitnessCount contentWithoutVotes + fromIntegral expectedKeyWitnessCount + where + -- Generate a mix of key-credentialed voters (DRep/committee-hot over a + -- key hash, plus stake pool voters, which are always key-credentialed) + -- and script-credentialed voters (DRep/committee-hot over a script hash - + -- stake pool voters have no script-credentialed form). Each bucket draws + -- its hashes via 'Gen.set', so voters within a bucket never collide as + -- 'Map' keys; voters across buckets can never collide either, since they + -- differ in the 'Voter' or 'Credential' constructor regardless of the + -- underlying hash. Every entry is witnessed by 'Nothing': the legacy + -- estimator's vote-counting branch never consults the witness map at all + -- (it only exists for script witnesses, and this function is estimating + -- KEY witnesses), so the witness value is irrelevant here - only the + -- ledger-side 'Voter'/'Credential' constructor drives the count. + -- + -- Votes are drawn from a small pool of governance action ids: every voter + -- votes on a random non-empty subset of the pool, as one list entry per + -- action id, so a voter voting on several actions becomes several entries + -- for the same 'L.Voter' that 'mkTxVotingProcedures' must merge. Returns + -- the voting procedure entries (ready for 'mkTxVotingProcedures') together + -- with the number of key-credentialed voters. + genVotingProceduresWithKeyWitnessCount + :: ConwayEraOnwards era + -> H.Gen ([(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))], Int) + genVotingProceduresWithKeyWitnessCount ceo = do + drepKeyHashes <- Gen.set (Range.linear 0 3) (unDRepKeyHash <$> genVerificationKeyHash AsDRepKey) + committeeKeyHashes <- + Gen.set (Range.linear 0 3) (unCommitteeHotKeyHash <$> genVerificationKeyHash AsCommitteeHotKey) + stakePoolKeyHashes <- + Gen.set (Range.linear 0 3) (unStakePoolKeyHash <$> genVerificationKeyHash AsStakePoolKey) + drepScriptHashes <- Gen.set (Range.linear 0 3) (toShelleyScriptHash <$> genScriptHash) + committeeScriptHashes <- Gen.set (Range.linear 0 3) (toShelleyScriptHash <$> genScriptHash) + govActionIdPool <- toList <$> Gen.set (Range.linear 1 3) genGovActionId + let keyVoters = + [L.DRepVoter (L.KeyHashObj kh) | kh <- toList drepKeyHashes] + <> [L.CommitteeVoter (L.KeyHashObj kh) | kh <- toList committeeKeyHashes] + <> [L.StakePoolVoter kh | kh <- toList stakePoolKeyHashes] + scriptVoters = + [L.DRepVoter (L.ScriptHashObj sh) | sh <- toList drepScriptHashes] + <> [L.CommitteeVoter (L.ScriptHashObj sh) | sh <- toList committeeScriptHashes] + keyEntries <- concat <$> traverse (voterEntries ceo govActionIdPool) keyVoters + scriptEntries <- concat <$> traverse (voterEntries ceo govActionIdPool) scriptVoters + pure (keyEntries <> scriptEntries, length keyVoters) + + votingProcedureValue :: L.VotingProcedure (ShelleyLedgerEra era) + votingProcedureValue = L.VotingProcedure{L.vProcVote = L.VoteYes, L.vProcAnchor = L.SNothing} + + voterEntries + :: ConwayEraOnwards era + -> [L.GovActionId] + -> L.Voter + -> H.Gen [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))] + voterEntries ceo govActionIdPool voter = do + votedActionIds <- genVotedActionIds govActionIdPool + pure + [ (singletonVotingProcedures ceo voter actionId votingProcedureValue, Nothing) + | actionId <- votedActionIds + ] + + genGovActionId :: H.Gen L.GovActionId + genGovActionId = + (L.GovActionId . toShelleyTxId <$> genTxId) + <*> (L.GovActionIx <$> Gen.word16 (Range.linear 0 5)) + + -- A random non-empty subset of the pool - the source of the same voter + -- voting on several action ids. + genVotedActionIds :: [L.GovActionId] -> H.Gen [L.GovActionId] + genVotedActionIds actionIdPool = do + count <- Gen.int (Range.linear 1 (length actionIdPool)) + take count <$> shuffle actionIdPool + +-- | Cross-role dedupe: a stake key that both withdraws rewards and is +-- deregistered by a certificate in the same transaction needs one key +-- witness, not two, while an unrelated extra key witness still counts +-- separately. A certificate for a different stake key collides with +-- nothing, so all three keys count. +prop_estimateTransactionKeyWitnessCount_dedupes_across_roles :: Property +prop_estimateTransactionKeyWitnessCount_dedupes_across_roles = H.property $ do + let sbe = ShelleyBasedEraConway + withdrawingStakeKeyHash <- H.forAll $ genVerificationKeyHash AsStakeKey + unrelatedStakeKeyHash <- H.forAll $ genVerificationKeyHash AsStakeKey + extraPaymentKeyHash <- H.forAll $ genVerificationKeyHash AsPaymentKey + let stakeCredential = StakeCredentialByKey withdrawingStakeKeyHash + stakeAddress = makeStakeAddress Mainnet stakeCredential + unregistrationCert credential = + Exp.Certificate $ + L.ConwayTxCertDeleg $ + L.ConwayUnRegCert (toShelleyStakeCredential credential) (L.SJust (L.Coin 2000000)) + contentWithCertFor credential = + setTxWithdrawals + (TxWithdrawals sbe [(stakeAddress, L.Coin 0, BuildTxWith (KeyWitness KeyWitnessForStakeAddr))]) + . setTxCertificates (mkTxCertificates sbe [(unregistrationCert credential, Nothing)]) + . setTxExtraKeyWits (TxExtraKeyWitnesses AlonzoEraOnwardsConway [extraPaymentKeyHash]) + $ defaultTxBodyContent sbe + -- the deregistered key is the withdrawing key: counted once, plus the extra key witness + estimateTransactionKeyWitnessCount (contentWithCertFor stakeCredential) === 2 + -- an unrelated deregistered key: nothing collides + estimateTransactionKeyWitnessCount (contentWithCertFor (StakeCredentialByKey unrelatedStakeKeyHash)) + === 3 + +-- | A pool registration certificate requires a signature from the operator +-- and from every owner, mirroring ledger's 'getShelleyWitsVKeyNeeded'. An +-- owner who also withdraws rewards in the same transaction still counts once. +prop_estimateTransactionKeyWitnessCount_counts_pool_owners :: Property +prop_estimateTransactionKeyWitnessCount_counts_pool_owners = H.property $ do + let sbe = ShelleyBasedEraConway + operatorKeyHash <- H.forAll $ genVerificationKeyHash AsStakePoolKey + withdrawingStakeKeyHash <- H.forAll $ genVerificationKeyHash AsStakeKey + otherOwnerStakeKeyHash <- H.forAll $ genVerificationKeyHash AsStakeKey + unrelatedOwnerStakeKeyHash <- H.forAll $ genVerificationKeyHash AsStakeKey + VrfKeyHash vrfKeyHash <- H.forAll $ genVerificationKeyHash AsVrfKey + let stakeAddress = makeStakeAddress Mainnet (StakeCredentialByKey withdrawingStakeKeyHash) + poolParamsWithOwners owners = + L.StakePoolParams + { L.sppId = unStakePoolKeyHash operatorKeyHash + , L.sppVrf = L.toVRFVerKeyHash vrfKeyHash + , L.sppPledge = L.Coin 0 + , L.sppCost = L.Coin 0 + , L.sppMargin = minBound + , L.sppAccountAddress = def + , L.sppOwners = owners + , L.sppRelays = mempty + , L.sppMetadata = L.SNothing + } + registrationCertFor owners = + Exp.Certificate $ L.RegPoolTxCert (poolParamsWithOwners owners) + contentWithOwners owners = + setTxWithdrawals + (TxWithdrawals sbe [(stakeAddress, L.Coin 0, BuildTxWith (KeyWitness KeyWitnessForStakeAddr))]) + . setTxCertificates (mkTxCertificates sbe [(registrationCertFor owners, Nothing)]) + $ defaultTxBodyContent sbe + -- the withdrawing key is also a pool owner: counted once, plus the operator and the other owner + estimateTransactionKeyWitnessCount + ( contentWithOwners + (Set.fromList [unStakeKeyHash withdrawingStakeKeyHash, unStakeKeyHash otherOwnerStakeKeyHash]) + ) + === 3 + -- owners disjoint from the withdrawing key: nothing collides, so all four keys count + estimateTransactionKeyWitnessCount + ( contentWithOwners + (Set.fromList [unStakeKeyHash otherOwnerStakeKeyHash, unStakeKeyHash unrelatedOwnerStakeKeyHash]) + ) + === 4 + tests :: TestTree tests = testGroup @@ -161,4 +336,13 @@ tests = , testProperty "simple script witness count" prop_simple_script_witness_count + , testProperty + "vote key witness count" + prop_estimateTransactionKeyWitnessCount_counts_vote_key_witnesses + , testProperty + "cross-role key witness dedupe" + prop_estimateTransactionKeyWitnessCount_dedupes_across_roles + , testProperty + "pool registration counts operator and every owner" + prop_estimateTransactionKeyWitnessCount_counts_pool_owners ]