TODROP: Fix redeemer pointer indexing in the experimental witness machinery

Proposal redeemer pointers were computed against Ord-sorted order
instead of the ledger's OSet insertion order, and certifying pointers
did not count unwitnessed certificates' index slots. Both now follow
the ledger's positional resolution, with regression tests pinning the
behaviour and property tests checking every witnessable category's
pointer against the ledger's own Indexable resolution.

The same fix is applied to the deprecated legacy transaction builder
(createTransactionBody); end-to-end and legacy-bridge regression
properties now cover the deprecated path too.

Also harden getVotes against voter-map gaps, remove the unused
StakeCredential field from the Witnessable WitTxCert constructor, and
correct the redeemer-index ordering documentation.

Author: carbolymer

.changes/20260811_cardano_api_redeemer_pointer_indexing.yml

@@ -0,0 +1,8 @@
+project: cardano-api
+pr: 1288
+kind:
+  - bugfix
+  - breaking
+  - test
+description: |
+  Fix plutus redeemer pointer indexing: proposal pointers now follow the transaction's insertion order and certificate pointers count unwitnessed certificates, in both the experimental and the deprecated transaction builders. Remove the unused StakeCredential field from the WitTxCert constructor. Add property tests checking every redeemer pointer against the ledger's own resolution.

cardano-api/cardano-api.cabal

@@ -368,6 +368,7 @@ test-suite cardano-api-test
     cardano-crypto,
     cardano-crypto-class:{cardano-crypto-class, testlib} ^>=2.3,
     cardano-crypto-wrapper:testlib,
+    cardano-data >=1.0,
     cardano-ledger-alonzo,
     cardano-ledger-api ^>=1.13,
     cardano-ledger-babbage,
@@ -420,6 +421,7 @@ test-suite cardano-api-test
     Test.Cardano.Api.Orphans
     Test.Cardano.Api.RawBytes
     Test.Cardano.Api.Transaction.Autobalance
+    Test.Cardano.Api.Transaction.Body.Plutus.RedeemerIndex
     Test.Cardano.Api.Transaction.Body.Plutus.Scripts
     Test.Cardano.Api.TxBody
     Test.Cardano.Api.Value

cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/IndexedPlutusScriptWitness.hs

@@ -76,7 +76,6 @@ data Witnessable (thing :: WitnessableItem) era where
   WitTxCert
     :: (L.EraTxCert era, L.AlonzoEraScript era)
     => L.TxCert era
-    -> StakeCredential
     -> Witnessable CertItem era
   WitMint
     :: L.AlonzoEraScript era
@@ -108,11 +107,16 @@ compareWitnesses :: Witnessable thing era -> Witnessable thing era -> Ordering
 compareWitnesses a b =
   case (a, b) of
     (WitTxIn txinA, WitTxIn txinB) -> compare txinA txinB
-    (WitTxCert{}, WitTxCert{}) -> LT -- Certificates in the ledger are in an `OSet` therefore we preserve the order.
+    -- Certificates are stored in an `OSet` but resolved positionally, via
+    -- `certsTxBodyL`'s `findIndexL`. `EQ` lets the stable sort in
+    -- `createIndexedPlutusScriptWitnesses` preserve insertion order.
+    (WitTxCert{}, WitTxCert{}) -> EQ
     (WitMint polIdA _, WitMint polIdB _) -> compare polIdA polIdB
     (WitWithdrawal stakeAddrA _, WitWithdrawal stakeAddrB _) -> compare stakeAddrA stakeAddrB
     (WitVote voterA, WitVote voterB) -> compare voterA voterB
-    (WitProposal propA, WitProposal propB) -> compare propA propB
+    -- Proposals are also stored in an `OSet` and resolved positionally
+    -- (`StrictSeq.findIndexL`), same as `WitTxCert` above.
+    (WitProposal{}, WitProposal{}) -> EQ
 
 data WitnessableItem
   = TxInItem

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

@@ -859,6 +859,13 @@ extractWitnessableTxIns tIns =
   obtainCommonConstraints (useEra @era) $
     List.nub [(WitTxIn txin, wit) | (txin, wit) <- tIns]
 
+-- | Wrap every certificate as a 'Witnessable', paired with its witness.
+--
+-- Unwitnessed certificates are included too, paired with
+-- 'AnyKeyWitnessPlaceholder'. An unwitnessed certificate still occupies a
+-- redeemer index slot: the ledger indexes the 'Certifying' purpose by
+-- position in the full certificate sequence, not just the witnessed
+-- subset.
 extractWitnessableCertificates
   :: forall era
    . IsEra era
@@ -867,10 +874,8 @@ extractWitnessableCertificates
 extractWitnessableCertificates txCerts =
   obtainCommonConstraints (useEra @era) $
     List.nub
-      [ ( WitTxCert cert stakeCred
-        , wit
-        )
-      | (Exp.Certificate cert, Just (stakeCred, wit)) <- getCertificates txCerts
+      [ (WitTxCert cert, maybe AnyKeyWitnessPlaceholder snd mCredAndWit)
+      | (Exp.Certificate cert, mCredAndWit) <- getCertificates txCerts
       ]
  where
   getCertificates (TxCertificates txcs) = toList txcs
@@ -918,13 +923,20 @@ extractWitnessableVotes (Just txVoteProc) =
         | (vote, wit) <- getVotes txVoteProc
         ]
  where
+  -- Uses a total 'Map.findWithDefault' (placeholder witness on a miss),
+  -- not a lookup that skips missing voters. A skipped voter would shrink
+  -- this list and shift every later voter's redeemer index.
+  --
+  -- 'mkTxVotingProcedures' builds 'scriptWitnessedVotes' in lockstep with
+  -- 'allVotingProcedures', assuming exactly one voter per merged
+  -- 'L.VotingProcedures' value, so a miss should not normally happen.
   getVotes
     :: TxVotingProcedures (LedgerEra era)
     -> [(L.Voter, AnyWitness (LedgerEra era))]
   getVotes (TxVotingProcedures allVotingProcedures scriptWitnessedVotes) =
     [ (voter, wit)
     | (voter, _) <- toList $ L.unVotingProcedures allVotingProcedures
-    , wit <- maybe [] return (Map.lookup voter scriptWitnessedVotes)
+    , let wit = Map.findWithDefault AnyKeyWitnessPlaceholder voter scriptWitnessedVotes
     ]
 
 extractWitnessableProposals

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

@@ -845,13 +845,13 @@ module Cardano.Api.Tx
   , fromShelleyMetadata
   , toShelleyMetadatum
   , fromShelleyMetadatum
-  -- Exported for testing
-  , extractWitnessableCertificates
+  -- Exported for testing and advanced use
   , extractWitnessableMints
   , extractWitnessableProposals
   , extractWitnessableTxIns
   , extractWitnessableVotes
   , extractWitnessableWithdrawals
+  , extractWitnessableCertificates
   -- Exporting for testing. Deprecate in the future.
   , legacyKeyWitnessEncode
 

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

@@ -830,8 +830,8 @@ mkTxProposalProcedures proposals = do
       fromList $
         map (second pure) proposals
 
--- | Index proposal procedures by their order ('Ord').
--- | and filter out the ones that do not have a witness.
+-- | Index proposal procedures by the order they appear in the transaction,
+-- and filter out the ones that do not have a witness.
 indexTxProposalProcedures
   :: TxProposalProcedures BuildTx era
   -> [(ScriptWitnessIndex, L.ProposalProcedure (ShelleyLedgerEra era), ScriptWitness WitCtxStake era)]
@@ -840,7 +840,7 @@ indexTxProposalProcedures proposals =
   | (proposal, Just (ix, scriptWitness)) <- indexWitnessedTxProposalProcedures proposals
   ]
 
--- | Index proposal procedures by their order ('Ord').
+-- | Index proposal procedures by the order they appear in the transaction.
 indexWitnessedTxProposalProcedures
   :: TxProposalProcedures BuildTx era
   -> [ ( L.ProposalProcedure (ShelleyLedgerEra era)
@@ -2419,17 +2419,28 @@ extractWitnessableWithdrawals aeon txWithdrawals =
   getWithdrawals TxWithdrawalsNone = []
   getWithdrawals (TxWithdrawals _ txws) = txws
 
+-- | Convert every certificate to a 'Witnessable', paired with its witness.
+--
+-- Every certificate must stay in the result, witnessed or not: an
+-- unwitnessed certificate still occupies a redeemer index slot, since the
+-- ledger indexes the 'Certifying' purpose by position in the full
+-- certificate sequence, not just the witnessed subset. See
+-- 'indexCertificatesWith' for the same rule applied to the deprecated
+-- indexing path. An unwitnessed certificate is paired with the old API's
+-- inert stake witness, 'KeyWitness' 'KeyWitnessForStakeAddr' (the same
+-- default 'mkTxCertificates' uses), from which
+-- 'legacyWitnessToScriptRequirements' extracts no script requirement.
 extractWitnessableCertificates
   :: AlonzoEraOnwards era
   -> TxCertificates BuildTx era
   -> [(Witnessable CertItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxStake era))]
 extractWitnessableCertificates aeon txCertificates =
   alonzoEraOnwardsConstraints aeon $
     List.nub
-      [ ( WitTxCert cert stakeCred
-        , BuildTxWith wit
+      [ ( WitTxCert cert
+        , BuildTxWith $ maybe (KeyWitness KeyWitnessForStakeAddr) snd mCredAndWit
         )
-      | (Exp.Certificate cert, BuildTxWith (Just (stakeCred, wit))) <- getCertificates txCertificates
+      | (Exp.Certificate cert, BuildTxWith mCredAndWit) <- getCertificates txCertificates
       ]
  where
   getCertificates TxCertificatesNone = []

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

@@ -17,7 +17,11 @@ where
 import Cardano.Api qualified as Api
 import Cardano.Api.Experimental qualified as Exp
 import Cardano.Api.Experimental.AnyScriptWitness
-  ( AnyPlutusScriptWitness (AnyPlutusSpendingScriptWitness)
+  ( AnyPlutusScriptWitness
+      ( AnyPlutusCertifyingScriptWitness
+      , AnyPlutusProposingScriptWitness
+      , AnyPlutusSpendingScriptWitness
+      )
   , PlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV3)
   )
 import Cardano.Api.Experimental.Era (convert)
@@ -30,6 +34,7 @@ import Cardano.Api.Plutus qualified as Script
 import Cardano.Api.Tx (Tx (ShelleyTx))
 
 import Cardano.Ledger.Address qualified as L
+import Cardano.Ledger.Alonzo.TxWits qualified as Alonzo
 import Cardano.Ledger.Api qualified as UnexportedLedger
 import Cardano.Ledger.Babbage.TxBody qualified as L
 import Cardano.Ledger.Conway qualified as L
@@ -55,7 +60,13 @@ import Data.Time.Clock.POSIX qualified as Time
 import Lens.Micro
 
 import Test.Gen.Cardano.Api.Experimental (genAnyScript)
-import Test.Gen.Cardano.Api.Typed (genAddressInEra, genTx, genTxIn)
+import Test.Gen.Cardano.Api.Typed
+  ( genAddressInEra
+  , genProposal
+  , genStakeCredential
+  , genTx
+  , genTxIn
+  )
 
 import Hedgehog (Gen, Property)
 import Hedgehog qualified as H
@@ -100,6 +111,12 @@ tests =
         [ testProperty
             "Plutus scripts without protocol params returns MakeUnsignedTxMissingProtocolParams"
             prop_makeUnsignedTx_plutus_without_pparams
+        , testProperty
+            "Proposal-procedure redeemer pointers follow OMap insertion order, not Ord order"
+            prop_makeUnsignedTx_proposal_redeemer_indices_follow_insertion_order
+        , testProperty
+            "Certifying redeemer indices count unwitnessed certs preceding a plutus-witnessed one"
+            prop_makeUnsignedTx_cert_redeemer_indices_count_unwitnessed_certs
         ]
     , testGroup
         "calcMinFeeRecursive"
@@ -619,6 +636,136 @@ prop_makeUnsignedTx_plutus_without_pparams = H.propertyOnce $ do
   Exp.makeUnsignedTx Exp.ConwayEra txBodyContent
     H.=== Left Exp.MakeUnsignedTxMissingProtocolParams
 
+-- | 'makeUnsignedTx' must index plutus-witnessed governance proposals'
+-- redeemer pointers ('L.ConwayProposing') by insertion order, never by
+-- 'Ord' order. Insertion order is what the ledger's 'OSet'-backed
+-- 'proposalProceduresTxBodyL' stores them in.
+--
+-- 'propA' and 'propB' only differ in 'pProcDeposit' (the first field
+-- 'Ord' compares), chosen so 'propB' sorts before 'propA' by 'Ord' but is
+-- inserted after it. A regression to 'Ord'-sorted indexing would swap
+-- which redeemer lands at which index.
+prop_makeUnsignedTx_proposal_redeemer_indices_follow_insertion_order :: Property
+prop_makeUnsignedTx_proposal_redeemer_indices_follow_insertion_order = H.property $ do
+  scriptTxIn <- H.forAll genTxIn
+  baseA <- H.forAll (genProposal Api.ConwayEraOnwardsConway)
+  baseB <- H.forAll (genProposal Api.ConwayEraOnwardsConway)
+  let propA = baseA{L.pProcDeposit = 2_000_000}
+      propB = baseB{L.pProcDeposit = 1_000_000}
+
+      mkRedeemer :: Integer -> Script.HashableScriptData
+      mkRedeemer n = Script.unsafeHashableScriptData $ Script.ScriptDataConstructor n []
+
+      mkProposingWitness redeemer =
+        Exp.AnyPlutusScriptWitness $
+          AnyPlutusProposingScriptWitness $
+            Exp.PlutusScriptWitness
+              Plutus.SPlutusV3
+              (Exp.PReferenceScript scriptTxIn)
+              Exp.NoScriptDatum
+              redeemer
+              (Script.ExecutionUnits 0 0)
+
+      txBodyContent =
+        Exp.defaultTxBodyContent
+          & Exp.setTxProtocolParams exampleProtocolParams
+          & Exp.setTxProposalProcedures
+            ( Exp.mkTxProposalProcedures
+                [ (propA, mkProposingWitness (mkRedeemer 1))
+                , (propB, mkProposingWitness (mkRedeemer 2))
+                ]
+            )
+          & Exp.setTxFee 0
+
+  Exp.UnsignedTx ledgerTx <- H.evalEither $ Exp.makeUnsignedTx Exp.ConwayEra txBodyContent
+
+  -- Sanity check: the body itself is in insertion order regardless of the
+  -- bug under test (the bug only affects redeemer indexing, not the body).
+  let bodyProposals = toList $ ledgerTx ^. L.bodyTxL . UnexportedLedger.proposalProceduresTxBodyL
+  bodyProposals H.=== [propA, propB]
+
+  -- The redeemer map must key 'propA''s witness to index 0 and 'propB''s
+  -- to index 1 (insertion order). 'Ord'-sorted indexing would give the
+  -- opposite, since 'propB' has the smaller deposit and sorts first.
+  let redeemers = ledgerTx ^. L.witsTxL . Alonzo.rdmrsTxWitsL
+      expectedRedeemers =
+        L.Redeemers $
+          Map.fromList
+            [
+              ( L.ConwayProposing (L.AsIx 0)
+              , (Api.toAlonzoData (mkRedeemer 1), Api.toAlonzoExUnits (Script.ExecutionUnits 0 0))
+              )
+            ,
+              ( L.ConwayProposing (L.AsIx 1)
+              , (Api.toAlonzoData (mkRedeemer 2), Api.toAlonzoExUnits (Script.ExecutionUnits 0 0))
+              )
+            ]
+  redeemers H.=== expectedRedeemers
+
+-- | 'makeUnsignedTx' must index a plutus-witnessed certificate's
+-- 'L.ConwayCertifying' redeemer pointer by its position among all
+-- certificates, witnessed and unwitnessed alike, never just among the
+-- witnessed subset.
+--
+-- 'unwitnessedCert' (a plain stake registration, which the ledger never
+-- requires a witness for) is placed before 'witnessedCert'. If unwitnessed
+-- certs were skipped when assigning indices, 'witnessedCert' would land
+-- at index 0 instead of the correct index 1.
+prop_makeUnsignedTx_cert_redeemer_indices_count_unwitnessed_certs :: Property
+prop_makeUnsignedTx_cert_redeemer_indices_count_unwitnessed_certs = H.property $ do
+  stakeCred1 <- H.forAll genStakeCredential
+  stakeCred2 <- H.forAll genStakeCredential
+  scriptTxIn <- H.forAll genTxIn
+  let shelleyCred1 = Api.toShelleyStakeCredential stakeCred1
+      shelleyCred2 = Api.toShelleyStakeCredential stakeCred2
+
+      -- Unwitnessed: a plain stake registration cert needs no witness.
+      unwitnessedCert =
+        Exp.Certificate $ L.ConwayTxCertDeleg (L.ConwayRegCert shelleyCred1 L.SNothing)
+
+      -- Plutus-witnessed: a stake delegation cert witnessed by a plutus script.
+      witnessedCert =
+        Exp.Certificate $
+          L.ConwayTxCertDeleg (L.ConwayDelegCert shelleyCred2 (L.DelegVote L.DRepAlwaysAbstain))
+
+      redeemer = Script.unsafeHashableScriptData $ Script.ScriptDataConstructor 0 []
+
+      certWitness =
+        Exp.AnyPlutusScriptWitness $
+          AnyPlutusCertifyingScriptWitness $
+            Exp.PlutusScriptWitness
+              Plutus.SPlutusV3
+              (Exp.PReferenceScript scriptTxIn)
+              Exp.NoScriptDatum
+              redeemer
+              (Script.ExecutionUnits 0 0)
+
+      certs =
+        Exp.mkTxCertificates
+          Exp.ConwayEra
+          [ (unwitnessedCert, Exp.AnyKeyWitnessPlaceholder)
+          , (witnessedCert, certWitness)
+          ]
+
+      txBodyContent =
+        Exp.defaultTxBodyContent
+          & Exp.setTxCertificates certs
+          & Exp.setTxProtocolParams exampleProtocolParams
+          & Exp.setTxFee 0
+
+  Exp.UnsignedTx ledgerTx <- H.evalEither $ Exp.makeUnsignedTx Exp.ConwayEra txBodyContent
+
+  let redeemers = ledgerTx ^. L.witsTxL . Alonzo.rdmrsTxWitsL
+      expectedRedeemers =
+        L.Redeemers $
+          Map.fromList
+            [
+              ( L.ConwayCertifying (L.AsIx 1)
+              , (Api.toAlonzoData redeemer, Api.toAlonzoExUnits (Script.ExecutionUnits 0 0))
+              )
+            ]
+  redeemers H.=== expectedRedeemers
+
 -- ---------------------------------------------------------------------------
 -- Property tests for calcMinFeeRecursive
 -- ---------------------------------------------------------------------------