fixyfix

Author: carbolymer

.changes/20260728_cardano_api_vote_key_witness_count.yml

@@ -4,4 +4,4 @@ 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`. See [issue #722](https://github.com/IntersectMBO/cardano-api/issues/722).
+  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).

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

@@ -1746,12 +1746,13 @@ 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 the ledger computes, so a key acting in
--- several of those roles is counted once.
+-- 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:
@@ -1810,15 +1811,24 @@ estimateTransactionKeyWitnessCount
         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) $
-          Set.fromList
-            [ keyHash
-            | (Exp.Certificate certificate, _) <- toList credWits
-            , Just keyHash <- [L.getVKeyWitnessTxCert certificate]
-            ]
+          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

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

@@ -449,12 +449,13 @@ 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 the ledger computes, so a key acting in
--- several of those roles is counted once.
+-- 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:
@@ -470,6 +471,10 @@ calculateMinTxFee sbe pp utxo txbody keywitcount =
 --   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.
@@ -512,16 +517,24 @@ estimateTransactionKeyWitnessCount
         Set.fromList $
           mapMaybe (\(StakeAddress _ credential, _, _) -> credKeyHashWitness credential) withdrawals
 
-    -- The credential paired with a certificate is derived from the certificate itself,
-    -- so its shape, not the caller-supplied witness, decides who must sign.
+    -- 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 _ credWits ->
-        Set.fromList $
-          mapMaybe
-            (credKeyHashWitness . toShelleyStakeCredential)
-            [credential | (_, BuildTxWith (Just (credential, _))) <- toList credWits]
+      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

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

@@ -26,9 +26,11 @@ 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
 
@@ -43,7 +45,7 @@ import Test.Gen.Cardano.Api.Typed
 
 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
@@ -79,6 +81,9 @@ tests =
         , 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"
@@ -583,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
@@ -603,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
@@ -617,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.
@@ -670,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
@@ -709,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
@@ -798,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
@@ -841,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
@@ -854,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
@@ -867,7 +872,7 @@ 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
@@ -889,7 +894,7 @@ prop_estimateTransactionKeyWitnessCount_counts_vote_key_witnesses = H.property $
         Exp.defaultTxBodyContent
           & Exp.setTxVotingProcedures txVotingProcedures
       keyWitnessCount = Exp.estimateTransactionKeyWitnessCount @Exp.ConwayEra txBodyContent
-  keyWitnessCount H.=== fromIntegral expectedKeyWitnessCount
+  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
@@ -919,11 +924,60 @@ prop_estimateTransactionKeyWitnessCount_dedupes_across_roles = H.property $ do
           & 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)
-    H.=== 2
+    === 2
   -- an unrelated deregistered key: nothing collides
   Exp.estimateTransactionKeyWitnessCount @Exp.ConwayEra
     (contentWithCertFor (Api.StakeCredentialByKey unrelatedStakeKeyHash))
-    H.=== 3
+    === 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
@@ -1042,7 +1096,7 @@ genVotingProceduresWithKeyWitnessCount = do
  where
   votingProcedure = L.VotingProcedure{L.vProcVote = L.VoteYes, L.vProcAnchor = L.SNothing}
 
-  -- \| One entry per action id the voter votes on, witnessed identically each
+  -- 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.
@@ -1064,7 +1118,7 @@ genVotingProceduresWithKeyWitnessCount = do
     (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
+  -- 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

cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs

@@ -16,6 +16,7 @@ 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
@@ -277,6 +278,50 @@ prop_estimateTransactionKeyWitnessCount_dedupes_across_roles = H.property $ do
   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
@@ -297,4 +342,7 @@ tests =
     , testProperty
         "cross-role key witness dedupe"
         prop_estimateTransactionKeyWitnessCount_dedupes_across_roles
+    , testProperty
+        "pool registration counts operator and every owner"
+        prop_estimateTransactionKeyWitnessCount_counts_pool_owners
     ]