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..6793083bf9 --- /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`. `estimateTransactionKeyWitnessCount` is now also exported from `Cardano.Api.Experimental`. 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 79c7297287..b10e300c3a 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 @@ -1789,6 +1790,7 @@ estimateTransactionKeyWitnessCount , txWithdrawals , txCertificates , txProposalProcedures + , txVotingProcedures } = fromIntegral $ sum (map estimateTxInWitnesses txIns) @@ -1807,6 +1809,10 @@ estimateTransactionKeyWitnessCount Just (TxProposalProcedures m) -> OMap.size m Nothing -> 0 + + case txVotingProcedures of + Just (TxVotingProcedures _ voteWits) -> + length [() | AnyKeyWitnessPlaceholder <- Map.elems voteWits] + Nothing -> 0 where estimateTxInWitnesses :: (TxIn, AnyWitness (LedgerEra era)) -> Int estimateTxInWitnesses (_, AnyKeyWitnessPlaceholder) = 1 diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Fee.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Fee.hs index 0c2d2b4fbf..8b92f7346b 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Fee.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Fee.hs @@ -478,6 +478,7 @@ estimateTransactionKeyWitnessCount , txWithdrawals , txCertificates , txUpdateProposal + , txVotingProcedures } = fromIntegral $ sum (map estimateTxInWitnesses txIns) @@ -502,6 +503,12 @@ estimateTransactionKeyWitnessCount TxUpdateProposal _ (UpdateProposal updatePerGenesisKey _) -> Map.size updatePerGenesisKey _ -> 0 + + case maybe TxVotingProceduresNone unFeatured txVotingProcedures of + TxVotingProceduresNone -> 0 + TxVotingProcedures votingProcedures _scriptWitnessMap -> + length $ + filter voterRequiresKeyWitness $ + Map.keys (L.unVotingProcedures votingProcedures) where estimateTxInWitnesses :: (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era)) -> Int estimateTxInWitnesses (_, BuildTxWith (KeyWitness _)) = 1 @@ -524,6 +531,16 @@ 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; a stake pool voter is always key-credentialed. + voterRequiresKeyWitness :: L.Voter -> Bool + voterRequiresKeyWitness (L.CommitteeVoter (L.KeyHashObj _)) = True + voterRequiresKeyWitness (L.CommitteeVoter (L.ScriptHashObj _)) = False + voterRequiresKeyWitness (L.DRepVoter (L.KeyHashObj _)) = True + voterRequiresKeyWitness (L.DRepVoter (L.ScriptHashObj _)) = False + voterRequiresKeyWitness (L.StakePoolVoter _) = True + -- ---------------------------------------------------------------------------- -- 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 6134d3ade8..8cfb9901ca 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 @@ -38,7 +39,13 @@ import Data.Time.Clock.POSIX qualified as Time import GHC.Exts (fromList) import Lens.Micro -import Test.Gen.Cardano.Api.Typed (genAddressInEra, genStakeCredential, genTxIn) +import Test.Gen.Cardano.Api.Typed + ( genAddressInEra + , genScriptHash + , genStakeCredential + , genTxIn + , genVerificationKeyHash + ) import Test.Cardano.Api.Experimental (exampleProtocolParams, exampleProtocolParamsEra) @@ -70,6 +77,12 @@ 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 + ] , testGroup "createCompatibleTx" [ testProperty @@ -1288,6 +1301,24 @@ prop_createCompatibleTx_preserves_all_certs = H.property $ do let bodyCerts = ledgerTx ^. L.bodyTxL . L.certsTxBodyL Seq.length bodyCerts H.=== 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. +prop_estimateTransactionKeyWitnessCount_counts_vote_key_witnesses :: Property +prop_estimateTransactionKeyWitnessCount_counts_vote_key_witnesses = H.property $ do + (txVotingProcedures, expectedKeyWitnessCount) <- H.forAll genVotingProceduresWithKeyWitnessCount + let txBodyContent = + Exp.defaultTxBodyContent + & Exp.setTxVotingProcedures txVotingProcedures + keyWitnessCount = Exp.estimateTransactionKeyWitnessCount @Exp.ConwayEra txBodyContent + keyWitnessCount H.=== fromIntegral expectedKeyWitnessCount + -- --------------------------------------------------------------------------- -- Shared cert generators -- --------------------------------------------------------------------------- @@ -1345,3 +1376,61 @@ genShuffledCertsWithCount = do ] shuffled <- Gen.shuffle allCerts pure (shuffled, length shuffled) + +-- --------------------------------------------------------------------------- +-- Shared vote generators +-- --------------------------------------------------------------------------- + +-- | Generate a 'TxVotingProcedures' whose witness map mixes 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. +-- Returns the generated voting procedures 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 (Exp.TxVotingProcedures (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 + + 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] + + govActionId = + L.GovActionId + (L.TxId (L.unsafeMakeSafeHash "0000000000000000000000000000000000000000000000000000000000000000")) + (L.GovActionIx 0) + votingProcedure = L.VotingProcedure{L.vProcVote = L.VoteYes, L.vProcAnchor = L.SNothing} + scriptWitness = Exp.AnySimpleScriptWitness (Exp.SReferenceScript refTxIn) + allVoters = keyVoters <> scriptVoters + votingProcedures = + L.VotingProcedures $ + Map.fromList [(voter, Map.singleton govActionId votingProcedure) | voter <- allVoters] + witnessMap = + Map.fromList $ + [(voter, Exp.AnyKeyWitnessPlaceholder) | voter <- keyVoters] + <> [(voter, scriptWitness) | voter <- scriptVoters] + + pure (Exp.TxVotingProcedures votingProcedures witnessMap, length keyVoters) 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..c74c5059d6 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 @@ -33,7 +33,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 +150,71 @@ 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. +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. 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) + let govActionId = + L.GovActionId + (L.TxId (L.unsafeMakeSafeHash "0000000000000000000000000000000000000000000000000000000000000000")) + (L.GovActionIx 0) + votingProcedureValue = L.VotingProcedure{L.vProcVote = L.VoteYes, L.vProcAnchor = L.SNothing} + 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] + mkEntry voter = + (singletonVotingProcedures ceo voter govActionId votingProcedureValue, Nothing) + entries = map mkEntry keyVoters <> map mkEntry scriptVoters + pure (entries, length keyVoters) + tests :: TestTree tests = testGroup @@ -161,4 +229,7 @@ tests = , testProperty "simple script witness count" prop_simple_script_witness_count + , testProperty + "vote key witness count" + prop_estimateTransactionKeyWitnessCount_counts_vote_key_witnesses ]