Fix witness counting for voting transaction

Author: carbolymer

.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).

cardano-api/src/Cardano/Api/Experimental.hs

@@ -41,6 +41,7 @@ module Cardano.Api.Experimental
   , evaluateTransactionFee
   , collectTxBodyScriptWitnesses
   , substituteExecutionUnits
+  , estimateTransactionKeyWitnessCount
 
     -- ** Era-related
   , BabbageEra

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
@@ -1775,6 +1776,7 @@ estimateTransactionKeyWitnessCount
     , txWithdrawals
     , txCertificates
     , txProposalProcedures
+    , txVotingProcedures
     } =
     fromIntegral $
       sum (map estimateTxInWitnesses txIns)
@@ -1793,6 +1795,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

cardano-api/src/Cardano/Api/Tx/Internal/Fee.hs

@@ -474,6 +474,7 @@ estimateTransactionKeyWitnessCount
     , txWithdrawals
     , txCertificates
     , txUpdateProposal
+    , txVotingProcedures
     } =
     fromIntegral $
       sum (map estimateTxInWitnesses txIns)
@@ -498,6 +499,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
@@ -520,6 +527,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
 --

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
@@ -36,7 +37,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)
 
@@ -68,6 +75,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
@@ -1100,6 +1113,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
 -- ---------------------------------------------------------------------------
@@ -1157,3 +1188,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)

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
     ]