Merge pull request #1288 from IntersectMBO/mgalazyn/fix/experimental-redeemer-pointer-indexing

Fix plutus script redeemer pointer indexing

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

@@ -376,6 +376,7 @@ test-suite cardano-api-test
     cardano-crypto,
     cardano-crypto-class:{cardano-crypto-class, testlib} ^>=2.5,
     cardano-crypto-wrapper:testlib,
+    cardano-data >=1.0,
     cardano-ledger-alonzo,
     cardano-ledger-api ^>=1.14,
     cardano-ledger-babbage,
@@ -432,6 +433,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.Transaction.Collateral
     Test.Cardano.Api.Transaction.Fixtures

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

@@ -15,7 +15,6 @@ module Cardano.Api.Compatible.Tx
   )
 where
 
-import Cardano.Api.Address (StakeCredential)
 import Cardano.Api.Era
 import Cardano.Api.Experimental.AnyScriptWitness
 import Cardano.Api.Experimental.Era (obtainCommonConstraints)
@@ -134,7 +133,7 @@ createCompatibleTx sbe ins outs extraDatums txFee' anyProtocolUpdate anyVote txC
 
         apiScriptWitnesses =
           [ (ix, witness)
-          | (ix, _, Just (_, witness)) <- indexedTxCerts
+          | (ix, _, Just witness) <- indexedTxCerts
           ]
 
     pure
@@ -157,7 +156,7 @@ createCompatibleTx sbe ins outs extraDatums txFee' anyProtocolUpdate anyVote txC
   setRefInputs = do
     let refInputs =
           [ toShelleyTxIn refInput
-          | (_, _, Just (_, wit)) <- indexedTxCerts
+          | (_, _, Just wit) <- indexedTxCerts
           , refInput <- maybeToList $ getAnyWitnessReferenceInput wit
           ]
 
@@ -178,7 +177,7 @@ createCompatibleTx sbe ins outs extraDatums txFee' anyProtocolUpdate anyVote txC
   indexedTxCerts
     :: [ ( ScriptWitnessIndex
          , Exp.Certificate (ShelleyLedgerEra era)
-         , Maybe (StakeCredential, Exp.AnyWitness (ShelleyLedgerEra era))
+         , Maybe (Exp.AnyWitness (ShelleyLedgerEra era))
          )
        ]
   indexedTxCerts = indexTxCertificates txCertificates'
@@ -334,7 +333,7 @@ indexTxCertificates
   :: Exp.TxCertificates (ShelleyLedgerEra era)
   -> [ ( ScriptWitnessIndex
        , Exp.Certificate (ShelleyLedgerEra era)
-       , Maybe (StakeCredential, AnyWitness (ShelleyLedgerEra era))
+       , Maybe (AnyWitness (ShelleyLedgerEra era))
        )
      ]
 indexTxCertificates (Exp.TxCertificates certsWits) =

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

@@ -79,7 +79,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
@@ -111,11 +110,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

@@ -6,7 +6,6 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -666,11 +665,12 @@ newtype TxWithdrawals era = TxWithdrawals {unTxWithdrawals :: [(StakeAddress, L.
 
 newtype TxCertificates era
   = TxCertificates
-  {unTxCertificates :: OMap (Exp.Certificate era) (Maybe (StakeCredential, AnyWitness era))}
+  {unTxCertificates :: OMap (Exp.Certificate era) (Maybe (AnyWitness era))}
   deriving (Show, Eq)
 
--- | Create 'TxCertificates'. Note that 'Certificate era' will be deduplicated. Only Certificates with a
--- stake credential will be in the result.
+-- | Create 'TxCertificates'. Note that 'Certificate era' will be deduplicated. Certificates that
+-- require a witness will be stored with 'Just' the caller-supplied witness; those that do not (e.g.
+-- deposit-less stake registration in Conway) will be stored with 'Nothing'.
 --
 -- Note that, when building a transaction in Conway era, a witness is not required for staking credential
 -- registration, but this is only the case during the transitional period of Conway era and only for staking
@@ -686,10 +686,10 @@ mkTxCertificates era certs = TxCertificates . OMap.fromList $ map getStakeCred c
   getStakeCred
     :: (Exp.Certificate (LedgerEra era), AnyWitness (LedgerEra era))
     -> ( Exp.Certificate (LedgerEra era)
-       , Maybe (StakeCredential, AnyWitness (LedgerEra era))
+       , Maybe (AnyWitness (LedgerEra era))
        )
   getStakeCred (c@(Exp.Certificate cert), wit) =
-    (c, (,wit) <$> getTxCertWitness (convert era) (obtainCommonConstraints era cert))
+    (c, wit <$ getTxCertWitness (convert era) (obtainCommonConstraints era cert))
 
 newtype TxMintValue era
   = TxMintValue
@@ -866,21 +866,30 @@ extractWitnessableTxIns tIns =
   obtainCommonConstraints (useEra @era) $
     List.nub [(WitTxIn txin, wit) | (txin, wit) <- tIns]
 
+-- | Wrap every certificate as a 'Witnessable', paired with its witness.
+--
+-- 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, so the result below
+-- keeps one entry per certificate in insertion order.
+--
+-- In the Conway era only, a certificate may legitimately have no witness
+-- (deposit-less stake registration), so a missing witness defaults to
+-- 'AnyKeyWitnessPlaceholder'. From Dijkstra onwards 'mkTxCertificates'
+-- guarantees every entry has a 'Just' witness, so the placeholder is dead
+-- code for those eras.
 extractWitnessableCertificates
   :: forall era
    . IsEra era
   => TxCertificates (LedgerEra era)
   -> [(Witnessable CertItem (LedgerEra era), AnyWitness (LedgerEra era))]
-extractWitnessableCertificates txCerts =
+extractWitnessableCertificates (TxCertificates certs) =
   obtainCommonConstraints (useEra @era) $
     List.nub
-      [ ( WitTxCert cert stakeCred
-        , wit
-        )
-      | (Exp.Certificate cert, Just (stakeCred, wit)) <- getCertificates txCerts
+      [ (WitTxCert cert, wit)
+      | (Exp.Certificate cert, mWit) <- toList certs
+      , let wit = fromMaybe AnyKeyWitnessPlaceholder mWit
       ]
- where
-  getCertificates (TxCertificates txcs) = toList txcs
 
 extractWitnessableMints
   :: forall era
@@ -923,13 +932,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/Experimental/Tx/Internal/Certificate/Compatible.hs

@@ -46,6 +46,8 @@ import Cardano.Api.Plutus.Internal.Script
 
 import Cardano.Ledger.Keys qualified as Ledger
 
+import Control.Applicative
+
 type family Delegatee era where
   Delegatee DijkstraEra = Ledger.Delegatee
   Delegatee ConwayEra = Ledger.Delegatee
@@ -201,9 +203,25 @@ getTxCertWitness
   :: ShelleyBasedEra era
   -> Ledger.TxCert (ShelleyLedgerEra era)
   -> Maybe StakeCredential
-getTxCertWitness sbe ledgerCert = shelleyBasedEraConstraints sbe $
-  case Ledger.getVKeyWitnessTxCert ledgerCert of
-    Just keyHash -> Just $ StakeCredentialByKey $ Api.StakeKeyHash $ Ledger.coerceKeyRole keyHash
-    Nothing ->
-      StakeCredentialByScript . fromShelleyScriptHash
-        <$> Ledger.getScriptWitnessTxCert ledgerCert
+getTxCertWitness sbe ledgerCert = mStakeCredByKey <|> mStakeCredByScript <|> witnessOptionalUpToConway
+ where
+  mStakeCredByKey =
+    shelleyBasedEraConstraints sbe $
+      StakeCredentialByKey . Api.StakeKeyHash . Ledger.coerceKeyRole
+        <$> Ledger.getVKeyWitnessTxCert ledgerCert
+  mStakeCredByScript =
+    shelleyBasedEraConstraints sbe $
+      StakeCredentialByScript . fromShelleyScriptHash <$> Ledger.getScriptWitnessTxCert ledgerCert
+  witnessOptionalUpToConway =
+    case sbe of
+      ShelleyBasedEraShelley -> Nothing
+      ShelleyBasedEraAllegra -> Nothing
+      ShelleyBasedEraMary -> Nothing
+      ShelleyBasedEraAlonzo -> Nothing
+      ShelleyBasedEraBabbage -> Nothing
+      ShelleyBasedEraConway -> Nothing
+      ShelleyBasedEraDijkstra ->
+        error
+          "getTxCertWitness: certificate has no witness in the Dijkstra era. \
+          \From Dijkstra onwards every certificate requires a witness. \
+          \This indicates a bug in the ledger's EraTxCert instance for this certificate type."

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

@@ -1149,18 +1149,14 @@ substituteExecutionUnits
             :: [ ( Exp.Certificate (LedgerEra era)
                  , Either
                      (TxBodyErrorAutoBalance (LedgerEra era))
-                     ( Maybe
-                         ( StakeCredential
-                         , AnyWitness (LedgerEra era)
-                         )
-                     )
+                     (Maybe (AnyWitness (LedgerEra era)))
                  )
                ]
           mappedScriptWitnesses =
             [ case mWit of
                 Nothing -> (cert, Right Nothing)
-                Just (stakeCred, wit) ->
-                  (cert, Just . (stakeCred,) <$> substituteExecUnits ix wit)
+                Just wit ->
+                  (cert, Just <$> substituteExecUnits ix wit)
             | (ix, cert, mWit) <- indexTxCertificates txCerts
             ]
       TxCertificates . fromList <$> traverseScriptWitnesses mappedScriptWitnesses
@@ -1272,14 +1268,16 @@ collectTxBodyScriptWitnesses
         [ (ix, wit)
         | (ix, _, _, Just wit@AnyScriptWitnessPlutus{}) <- fmap toAnyScriptWitness <$> indexTxWithdrawals txw
         ]
-    -- TODO: If this works you need to change the rest!
+    -- Unlike the other categories, this intentionally collects simple script
+    -- witnesses as well as Plutus ones, so that a script-witnessed certificate
+    -- is never reported as unwitnessed.
     scriptWitnessesCertificates
       :: TxCertificates (LedgerEra era)
       -> [(ScriptWitnessIndex, Exp.AnyScriptWitness (LedgerEra era))]
     scriptWitnessesCertificates txc =
       List.nub
         [ (ix, wit)
-        | (ix, _, Just (_, anyWit)) <- indexTxCertificates txc
+        | (ix, _, Just anyWit) <- indexTxCertificates txc
         , Just wit <- [toAnyScriptWitness anyWit]
         ]
 
@@ -1366,7 +1364,7 @@ indexTxCertificates
   :: TxCertificates (LedgerEra era)
   -> [ ( ScriptWitnessIndex
        , Exp.Certificate (LedgerEra era)
-       , Maybe (StakeCredential, AnyWitness (LedgerEra era))
+       , Maybe (AnyWitness (LedgerEra era))
        )
      ]
 indexTxCertificates (TxCertificates certsWits) =
@@ -1782,7 +1780,7 @@ estimateTransactionKeyWitnessCount
         + case txCertificates of
           TxCertificates credWits ->
             length
-              [() | (_, Just (_, AnyKeyWitnessPlaceholder)) <- toList credWits]
+              [() | (_, Just AnyKeyWitnessPlaceholder) <- toList credWits]
         + case txProposalProcedures of
           Just (TxProposalProcedures m) ->
             OMap.size m

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

@@ -846,13 +846,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)
@@ -2465,17 +2465,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 = []