From 4230761cbc09ce4dd31fa489a9558a2d1733946d Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Tue, 11 Aug 2026 14:47:16 +0200 Subject: [PATCH 1/2] Add plutus script support to the compatible transaction API createCompatibleTx now takes a CompatibleTxBodyContent record with per-input AnyWitness values, and computes spending redeemer pointers, witness datums, the script integrity hash, collateral inputs, transaction metadata and the validity upper bound. Witness indexing is shared with the experimental transaction builder. Also export the mkSpendingScriptDatum smart constructor from Cardano.Api.Experimental. --- ...20260807_cardano_api_compatible_plutus.yml | 8 + cardano-api/src/Cardano/Api/Compatible/Tx.hs | 458 +++++++++++++----- cardano-api/src/Cardano/Api/Experimental.hs | 1 + .../src/Cardano/Api/Experimental/Plutus.hs | 1 + .../Plutus/Internal/ScriptWitness.hs | 10 + .../Api/Internal/Orphans/Serialisation.hs | 8 +- .../Test/Cardano/Api/Experimental/Fee.hs | 210 +++++++- 7 files changed, 567 insertions(+), 129 deletions(-) create mode 100644 .changes/20260807_cardano_api_compatible_plutus.yml diff --git a/.changes/20260807_cardano_api_compatible_plutus.yml b/.changes/20260807_cardano_api_compatible_plutus.yml new file mode 100644 index 0000000000..d3363c8752 --- /dev/null +++ b/.changes/20260807_cardano_api_compatible_plutus.yml @@ -0,0 +1,8 @@ +project: cardano-api +pr: 1282 +kind: + - feature + - breaking + - bugfix +description: | + Add plutus spending script support to createCompatibleTx. Breaking: it now takes all transaction content as a single CompatibleTxBodyContent record and fails with the new CompatibleTxError. Export mkSpendingScriptDatum. Fix certificate and proposal script witnesses missing from the witness set, and proposal reference inputs being overwritten. Remove the redundant StakeCredential field from WitTxCert. diff --git a/cardano-api/src/Cardano/Api/Compatible/Tx.hs b/cardano-api/src/Cardano/Api/Compatible/Tx.hs index 8d5541e30c..9d509042ed 100644 --- a/cardano-api/src/Cardano/Api/Compatible/Tx.hs +++ b/cardano-api/src/Cardano/Api/Compatible/Tx.hs @@ -5,30 +5,41 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} --- | This module provides a way to construct a simple transaction over all eras. --- It is exposed for testing purposes only. +-- | This module provides a transaction builder covering all Shelley-based +-- eras, for consumers that still need pre-Conway support (e.g. +-- tx-generator). The experimental API only covers the current and next +-- era. module Cardano.Api.Compatible.Tx ( AnyProtocolUpdate (..) , AnyVote (..) + , CompatibleTxBodyContent (..) + , CompatibleTxError (..) + , defaultCompatibleTxBodyContent , createCompatibleTx , addWitnesses ) where import Cardano.Api.Era -import Cardano.Api.Experimental.AnyScriptWitness +import Cardano.Api.Error (Error (..)) import Cardano.Api.Experimental.Era (obtainCommonConstraints) +import Cardano.Api.Experimental.Era qualified as Exp +import Cardano.Api.Experimental.Plutus + ( Witnessable (..) + , WitnessableItem (..) + , getAnyWitnessRedeemerPointerMap + , obtainAlonzoScriptPurposeConstraints + ) import Cardano.Api.Experimental.Tx qualified as Exp import Cardano.Api.Experimental.Tx.Internal.AnyWitness import Cardano.Api.Experimental.Tx.Internal.AnyWitness qualified as Exp import Cardano.Api.Experimental.Tx.Internal.Certificate qualified as Exp -import Cardano.Api.Plutus.Internal.Script +import Cardano.Api.Monad.Error ((?!)) import Cardano.Api.ProtocolParameters import Cardano.Api.Tx.Internal.Body hiding ( convCertificates - , indexTxCertificates - , indexWitnessedTxProposalProcedures ) +import Cardano.Api.Tx.Internal.Body.Lens qualified as A import Cardano.Api.Tx.Internal.Sign import Cardano.Api.Value.Internal @@ -36,7 +47,11 @@ import Cardano.Ledger.Alonzo.Tx qualified as L import Cardano.Ledger.Alonzo.TxWits qualified as Alonzo import Cardano.Ledger.Api qualified as L import Cardano.Ledger.Core qualified as L +import Cardano.Ledger.TxIn qualified as L +import Cardano.Slotting.Slot (SlotNo) +import Data.List qualified as L +import Data.Map.Ordered.Strict qualified as OMap import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe @@ -44,7 +59,9 @@ import Data.Maybe.Strict import Data.Monoid import Data.OSet.Strict (OSet) import Data.Sequence.Strict qualified as Seq -import GHC.Exts (IsList (..)) +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Exts import Lens.Micro hiding (ix) data AnyProtocolUpdate era where @@ -67,26 +84,84 @@ data AnyVote era where -> AnyVote era NoVotes :: AnyVote era +-- | The content of a transaction 'createCompatibleTx' builds. +data CompatibleTxBodyContent era = CompatibleTxBodyContent + { compatibleTxIns :: [(TxIn, Exp.AnyWitness (ShelleyLedgerEra era))] + -- ^ Inputs with witnesses. Key-witnessed inputs must use 'Exp.AnyKeyWitnessPlaceholder', or redeemer pointers shift. + , compatibleTxOuts :: [Exp.TxOut (ShelleyLedgerEra era)] + -- ^ Transaction outputs. + , compatibleTxSupplementalDatums :: Map L.DataHash (L.Data (ShelleyLedgerEra era)) + -- ^ Supplemental datums to include in the witness set. + , compatibleTxFee :: Lovelace + -- ^ Fee. + , compatibleTxProtocolUpdate :: AnyProtocolUpdate era + -- ^ Era-appropriate protocol update: Shelley-Babbage proposal, Conway-onwards proposal procedure, or none. + , compatibleTxVotingProcedures :: AnyVote era + -- ^ Governance votes, Conway onwards; 'NoVotes' otherwise. + , compatibleTxCertificates :: Exp.TxCertificates (ShelleyLedgerEra era) + -- ^ Certificates, witnessed or not. + , compatibleTxInsCollateral :: [TxIn] + -- ^ Collateral inputs. Meaningful only Alonzo onwards; supply non-empty only when using plutus spending witnesses. + , compatibleTxProtocolParams :: Maybe (L.PParams (ShelleyLedgerEra era)) + -- ^ Needed to compute the script integrity hash when plutus witnesses are present. + -- 'Nothing' is only safe when there are none; see 'CompatibleTxMissingScriptIntegrityPParams'. + , compatibleTxMetadata :: TxMetadataInEra era + -- ^ Transaction metadata to embed, or 'TxMetadataNone' for none. + , compatibleTxValidityUpperBound :: Maybe SlotNo + -- ^ Last slot the transaction can be included in, or 'Nothing' for unbounded. + } + +-- | 'CompatibleTxBodyContent' with everything empty: no inputs, outputs, +-- certificates, votes, protocol update, collateral, protocol parameters, +-- metadata or validity upper bound. +-- +-- The 'ShelleyBasedEra' witness is only needed to build the default +-- 'NoPParamsUpdate'. +defaultCompatibleTxBodyContent :: ShelleyBasedEra era -> CompatibleTxBodyContent era +defaultCompatibleTxBodyContent sbe = + CompatibleTxBodyContent + { compatibleTxIns = [] + , compatibleTxOuts = [] + , compatibleTxSupplementalDatums = mempty + , compatibleTxFee = 0 + , compatibleTxProtocolUpdate = NoPParamsUpdate sbe + , compatibleTxVotingProcedures = NoVotes + , compatibleTxCertificates = Exp.TxCertificates OMap.empty + , compatibleTxInsCollateral = [] + , compatibleTxProtocolParams = Nothing + , compatibleTxMetadata = TxMetadataNone + , compatibleTxValidityUpperBound = Nothing + } + +-- | Errors that can occur while assembling a 'Tx' with 'createCompatibleTx'. +data CompatibleTxError + = -- | The supplied protocol parameters could not be converted to the + -- ledger representation needed to compute the script integrity hash. + CompatibleTxProtocolParametersConversionError ProtocolParametersConversionError + | -- | Plutus script witnesses are present (non-empty redeemers, datums + -- or plutus languages), but 'compatibleTxProtocolParams' is + -- 'Nothing', so the ledger's required script integrity hash cannot + -- be computed. + CompatibleTxMissingScriptIntegrityPParams + deriving Show + +instance Error CompatibleTxError where + prettyError err = + case err of + CompatibleTxProtocolParametersConversionError e -> prettyError e + CompatibleTxMissingScriptIntegrityPParams -> + "Plutus script witnesses are present but no protocol parameters were supplied " + <> "to compute the script integrity hash." + -- | Create a transaction in any shelley based era createCompatibleTx :: forall era . ShelleyBasedEra era - -> [TxIn] - -> [Exp.TxOut (ShelleyLedgerEra era)] - -> Map L.DataHash (L.Data (ShelleyLedgerEra era)) - -- ^ Supplemental datums to include in the witness set. Use 'mempty' if - -- none are required. The legacy 'TxOut CtxTx era' bundled supplemental - -- datums inside outputs; 'Exp.TxOut' only carries the datum hash, so - -- callers thread the full datum bodies in here explicitly. - -> Lovelace - -- ^ Fee - -> AnyProtocolUpdate era - -> AnyVote era - -> Exp.TxCertificates (ShelleyLedgerEra era) - -> Either ProtocolParametersConversionError (Tx era) -createCompatibleTx sbe ins outs extraDatums txFee' anyProtocolUpdate anyVote txCertificates' = + -> CompatibleTxBodyContent era + -> Either CompatibleTxError (Tx era) +createCompatibleTx sbe bodyContent = shelleyBasedEraConstraints sbe $ do - (updateTxBody, extraScriptWitnesses) <- + (updateTxBody, proposalWitnesses) <- case anyProtocolUpdate of ProtocolUpdate shelleyToBabbageEra updateProposal -> do let ledgerPParamsUpdate = toLedgerUpdate sbe updateProposal @@ -102,11 +177,14 @@ createCompatibleTx sbe ins outs extraDatums txFee' anyProtocolUpdate anyVote txC let Exp.TxProposalProcedures propMap = proposalProcedures proposals :: OSet (L.ProposalProcedure (ShelleyLedgerEra era)) = fromList $ fst <$> shelleyBasedEraConstraints sbe (toList propMap) + -- Order must stay OMap insertion order; the shared + -- Witnessable-based indexing (via 'extractWitnessableProposals') preserves it. + proposalWitnesses + :: [(Witnessable ProposalItem (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))] proposalWitnesses = - [ (ix, witness) - | (_, (ix, witness)) <- - indexWitnessedTxProposalProcedures conwayOnwards proposalProcedures - ] + Exp.obtainCommonConstraints (convert conwayOnwards) $ + Exp.extractWitnessableProposals $ + Just proposalProcedures referenceInputs = [ toShelleyTxIn txIn | (_, wit) <- proposalWitnesses @@ -121,9 +199,34 @@ createCompatibleTx sbe ins outs extraDatums txFee' anyProtocolUpdate anyVote txC pure (updateTxBody, proposalWitnesses) + let + -- Flat witnesses from all three script-witnessable categories + -- (certificates, proposals, inputs), for 'setScriptIntegrityHash' + -- and 'setScriptWitnesses' to collect datums, scripts and plutus + -- languages from. Only the redeemer pointer map (built inside + -- 'convScriptData'') needs per-category indexing. + allWitnesses :: [AnyWitness (ShelleyLedgerEra era)] + allWitnesses = witnessedCertWitnesses <> map snd proposalWitnesses <> map snd ins + + sData :: Maybe (L.TxDats (ShelleyLedgerEra era), L.Redeemers (ShelleyLedgerEra era)) + sData = convScriptData' sbe ins txCertificates' proposalWitnesses allWitnesses extraDatums + + txAuxData :: Maybe (L.TxAuxData (ShelleyLedgerEra era)) + txAuxData = toAuxiliaryData sbe (compatibleTxMetadata bodyContent) TxAuxScriptsNone + + integrityHashUpdate <- setScriptIntegrityHash sData allWitnesses + let txbody = - createCommonTxBody sbe ins outs txFee' - & appEndos [setCerts, setRefInputs, updateTxBody] + createCommonTxBody sbe ledgerTxIns outs txFee' + & appEndos + [ setCerts + , setRefInputs + , updateTxBody + , setCollateralIns + , setValidityUpperBound + , setMetadataHash txAuxData + , integrityHashUpdate + ] updateVotingProcedures = case anyVote of @@ -131,39 +234,149 @@ createCompatibleTx sbe ins outs extraDatums txFee' anyProtocolUpdate anyVote txC VotingProcedures conwayOnwards (Exp.TxVotingProcedures procedures _) -> overwriteVotingProcedures conwayOnwards procedures - apiScriptWitnesses = - [ (ix, witness) - | (ix, _, Just witness) <- indexedTxCerts - ] - pure . ShelleyTx sbe $ L.mkBasicTx txbody & L.witsTxL - %~ setScriptWitnesses (apiScriptWitnesses <> extraScriptWitnesses) + %~ setScriptWitnesses sData allWitnesses & updateVotingProcedures + & L.auxDataTxL + .~ maybeToStrictMaybe txAuxData where era = toCardanoEra sbe appEndos = appEndo . mconcat + -- Local synonyms for bodyContent's fields, used throughout below. + ins = compatibleTxIns bodyContent + outs = compatibleTxOuts bodyContent + extraDatums = compatibleTxSupplementalDatums bodyContent + txFee' = compatibleTxFee bodyContent + anyProtocolUpdate = compatibleTxProtocolUpdate bodyContent + anyVote = compatibleTxVotingProcedures bodyContent + txCertificates' = compatibleTxCertificates bodyContent + + -- The final set of ledger inputs, in ascending 'Ord' order ('Data.Set'). + -- This is the order the ledger serialises tx inputs in, and the order + -- it resolves 'Spending' redeemer pointers against. + -- + -- Spending redeemer pointers (built by 'dedupInputsByTxIn' inside + -- 'convScriptData'', via 'WitTxIn''s 'compareWitnesses') MUST use this + -- same order, never the order 'ins' was supplied in. + ledgerTxIns :: Set L.TxIn + ledgerTxIns = fromList $ map (toShelleyTxIn . fst) ins + + -- The witness of every witnessed certificate in 'txCertificates''. + -- Unwitnessed certs contribute nothing here: no reference input, datum, + -- script or language. They only matter for redeemer indexing, which + -- 'convScriptData'' handles separately with a placeholder witness. + witnessedCertWitnesses :: [AnyWitness (ShelleyLedgerEra era)] + witnessedCertWitnesses = + [wit | (_, Just wit) <- toList certsWits] + where + Exp.TxCertificates certsWits = txCertificates' + setCerts :: Endo (L.TxBody L.TopTx (ShelleyLedgerEra era)) setCerts = shelleyBasedEraConstraints sbe $ Endo $ L.certsTxBodyL .~ convCertificates txCertificates' + -- Uses '%~ (<>)', not '.~', so it does not clobber reference inputs + -- already appended by 'updateTxBody' (the 'ProposalProcedures' case + -- above). Reference inputs collected here come from both witnessed + -- certificates and witnessed spending inputs. setRefInputs :: Endo (L.TxBody L.TopTx (ShelleyLedgerEra era)) setRefInputs = do let refInputs = [ toShelleyTxIn refInput - | (_, _, Just wit) <- indexedTxCerts + | wit <- witnessedCertWitnesses , refInput <- maybeToList $ getAnyWitnessReferenceInput wit ] + ++ [ toShelleyTxIn refInput + | (_, wit) <- ins + , refInput <- maybeToList $ getAnyWitnessReferenceInput wit + ] monoidForEraInEon era $ \beo -> babbageEraOnwardsConstraints beo $ Endo $ - L.referenceInputsTxBodyL .~ fromList refInputs + L.referenceInputsTxBodyL %~ (<> fromList refInputs) + + -- Alonzo onwards only; a no-op below that. The list is expected to be + -- empty pre-Alonzo anyway, since collateral only matters for plutus + -- spending. + setCollateralIns :: Endo (L.TxBody L.TopTx (ShelleyLedgerEra era)) + setCollateralIns = + monoidForEraInEon era $ \aeo -> + alonzoEraOnwardsConstraints aeo $ + Endo $ + L.collateralInputsTxBodyL + .~ (fromList . map toShelleyTxIn $ compatibleTxInsCollateral bodyContent) + + -- Compatibility lens over 'ttlTxBodyL' (Shelley) and 'vldtTxBodyL' + -- (Allegra onwards), preserving the validity interval's lower bound. + setValidityUpperBound :: Endo (L.TxBody L.TopTx (ShelleyLedgerEra era)) + setValidityUpperBound = + Endo $ \txb -> + A.unTxBody $ + A.LedgerTxBody txb + & A.invalidHereAfterTxBodyL sbe + .~ compatibleTxValidityUpperBound bodyContent + + -- Only the body-side auxiliary data hash; the auxiliary data itself is + -- set on the 'L.Tx' via 'L.auxDataTxL' in the main function body. + setMetadataHash + :: Maybe (L.TxAuxData (ShelleyLedgerEra era)) + -> Endo (L.TxBody L.TopTx (ShelleyLedgerEra era)) + setMetadataHash txAuxData = + shelleyBasedEraConstraints sbe $ + Endo $ + L.auxDataHashTxBodyL + .~ maybe SNothing (SJust . L.hashTxAuxData) txAuxData + + -- The hash is only computed when there is something for it to cover. + -- It is an error to have something to cover without protocol + -- parameters to compute it with. + -- + -- Follows ledger's own script integrity hash computation; ledger has + -- no reusable function for this (see + -- 'Cardano.Api.Tx.Internal.Body.convPParamsToScriptIntegrityHash' for + -- the legacy API's equivalent). + setScriptIntegrityHash + :: Maybe (L.TxDats (ShelleyLedgerEra era), L.Redeemers (ShelleyLedgerEra era)) + -> [AnyWitness (ShelleyLedgerEra era)] + -> Either CompatibleTxError (Endo (L.TxBody L.TopTx (ShelleyLedgerEra era))) + setScriptIntegrityHash scriptData allWitnesses = + monoidForEraInEonA era $ \aeo -> + alonzoEraOnwardsConstraints aeo $ do + let + (datums, redeemers) = fromMaybe mempty scriptData + + languages :: Set L.Language + languages = fromList $ mapMaybe getAnyWitnessPlutusLanguage allWitnesses + + shouldCalculateHash = + not $ + null (redeemers ^. L.unRedeemersL) + && null (datums ^. L.unTxDatsL) + && null languages + + if not shouldCalculateHash + then pure mempty + else do + protocolParams <- + compatibleTxProtocolParams bodyContent + ?! CompatibleTxMissingScriptIntegrityPParams + pure $ + Endo $ + L.scriptIntegrityHashTxBodyL + .~ SJust + ( L.hashScriptIntegrity $ + L.ScriptIntegrity + redeemers + datums + (Set.map (L.getLanguageView protocolParams) languages) + ) overwriteVotingProcedures :: ConwayEraOnwards era @@ -174,50 +387,58 @@ createCompatibleTx sbe ins outs extraDatums txFee' anyProtocolUpdate anyVote txC obtainCommonConstraints (convert conwayOnwards) $ (L.bodyTxL . L.votingProceduresTxBodyL) .~ votingProcedures - indexedTxCerts - :: [ ( ScriptWitnessIndex - , Exp.Certificate (ShelleyLedgerEra era) - , Maybe (Exp.AnyWitness (ShelleyLedgerEra era)) - ) - ] - indexedTxCerts = indexTxCertificates txCertificates' - setScriptWitnesses - :: [(ScriptWitnessIndex, AnyWitness (ShelleyLedgerEra era))] + :: Maybe (L.TxDats (ShelleyLedgerEra era), L.Redeemers (ShelleyLedgerEra era)) + -> [AnyWitness (ShelleyLedgerEra era)] -> L.TxWits (ShelleyLedgerEra era) -> L.TxWits (ShelleyLedgerEra era) - setScriptWitnesses scriptWitnesses = + setScriptWitnesses sData scriptWitnesses = appEndos [ monoidForEraInEon era - ( \aeo -> alonzoEraOnwardsConstraints aeo $ Endo $ do - let sData = convScriptData' sbe extraDatums scriptWitnesses - let (datums, redeemers) = case sData of - TxBodyScriptData _ ds rs -> (ds, rs) - TxBodyNoScriptData -> (mempty, L.Redeemers mempty) - (L.datsTxWitsL .~ datums) . (L.rdmrsTxWitsL %~ (<> redeemers)) + ( \aeo -> + alonzoEraOnwardsConstraints aeo $ + obtainAlonzoScriptPurposeConstraints aeo $ + Endo $ do + let (datums, redeemers) = + fromMaybe mempty sData + :: (L.TxDats (ShelleyLedgerEra era), L.Redeemers (ShelleyLedgerEra era)) + -- 'getAnyWitnessScript' covers both plutus and simple + -- scripts. The simple ones overlap harmlessly (same + -- hash, same script) with the allegra-onwards branch + -- below, which is still needed for pre-Alonzo eras + -- that this branch does not run in. + let plutusAndSimpleScripts = + mapMaybe getAnyWitnessScript scriptWitnesses + (L.datsTxWitsL .~ datums) + . (L.rdmrsTxWitsL %~ (<> redeemers)) + . ( L.scriptTxWitsL + %~ (<> Map.fromList [(L.hashScript sw, sw) | sw <- plutusAndSimpleScripts]) + ) ) , monoidForEraInEon era ( \aeo -> allegraEraOnwardsConstraints aeo $ Endo $ do let ledgerScripts = convSimpleScripts sbe scriptWitnesses L.scriptTxWitsL - .~ Map.fromList - [ (L.hashScript sw, sw) - | sw <- ledgerScripts - ] + %~ ( <> + Map.fromList + [ (L.hashScript sw, sw) + | sw <- ledgerScripts + ] + ) ) ] convSimpleScripts :: ShelleyLedgerEra era ~ ledgerera => ShelleyBasedEra era - -> [(ScriptWitnessIndex, Exp.AnyWitness (ShelleyLedgerEra era))] + -> [Exp.AnyWitness (ShelleyLedgerEra era)] -> [L.Script ledgerera] convSimpleScripts sbe scriptWitnesses = catMaybes [ shelleyBasedEraConstraints sbe $ Exp.getAnyWitnessSimpleScript anywit - | (_, anywit) <- scriptWitnesses + | anywit <- scriptWitnesses ] convCertificates @@ -228,55 +449,78 @@ convCertificates (Exp.TxCertificates cs) = convScriptData' :: ShelleyBasedEra era + -> [(TxIn, Exp.AnyWitness (ShelleyLedgerEra era))] + -> Exp.TxCertificates (ShelleyLedgerEra era) + -> [(Witnessable ProposalItem (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))] + -> [AnyWitness (ShelleyLedgerEra era)] -> Map L.DataHash (L.Data (ShelleyLedgerEra era)) - -> [(ScriptWitnessIndex, AnyWitness (ShelleyLedgerEra era))] - -> TxBodyScriptData era -convScriptData' sbe extraDatums scriptWitnesses = + -> Maybe (L.TxDats (ShelleyLedgerEra era), L.Redeemers (ShelleyLedgerEra era)) +convScriptData' sbe ins txCertificates' proposalWits allWitnesses extraDatums = forEraInEon (convert sbe) - TxBodyNoScriptData + Nothing ( \w -> - alonzoEraOnwardsConstraints w $ - let redeemers = getAnyPlutusScriptWitnessRedeemerPointerMap w scriptWitnesses - datums = mconcat [getAnyWitnessScriptData wit | (_, wit) <- scriptWitnesses] - supplementalDatums = Alonzo.TxDats extraDatums - in TxBodyScriptData w (datums <> supplementalDatums) redeemers + alonzoEraOnwardsConstraints w $ do + let + -- Three disjoint per-category redeemer maps merged into one. + -- Ledger 'L.PlutusPurpose' tags (Spending/Certifying/Proposing) + -- never collide across categories, so '<>' below cannot drop + -- or overwrite an entry. + -- + -- All three share the Witnessable-based indexing that + -- 'Cardano.Api.Experimental.Tx.Internal.BodyContent.New.makeUnsignedTx' + -- uses, via 'getAnyWitnessRedeemerPointerMap'. + certRedeemers = getAnyWitnessRedeemerPointerMap $ witnessableCerts txCertificates' + inputRedeemers = getAnyWitnessRedeemerPointerMap $ witnessableTxIns ins + proposalRedeemers = getAnyWitnessRedeemerPointerMap proposalWits + redeemers = certRedeemers <> inputRedeemers <> proposalRedeemers + + datums = mconcat [getAnyWitnessScriptData wit | wit <- allWitnesses] + supplementalDatums = Alonzo.TxDats extraDatums + Just (datums <> supplementalDatums, redeemers) ) -getAnyPlutusScriptWitnessRedeemerPointerMap - :: AlonzoEraOnwards era - -> [(ScriptWitnessIndex, Exp.AnyWitness (ShelleyLedgerEra era))] - -> L.Redeemers (ShelleyLedgerEra era) -getAnyPlutusScriptWitnessRedeemerPointerMap w wits = - alonzoEraOnwardsConstraints w $ - Alonzo.Redeemers $ - fromList - [ ( i - , - ( toAlonzoData $ getAnyPlutusScriptWitnessRedeemer pswit - , toAlonzoExUnits $ getAnyPlutusScriptWitnessExecutionUnits pswit - ) - ) - | ( idx - , AnyPlutusScriptWitness pswit - ) <- - wits - , Just i <- [fromScriptWitnessIndex w idx] - ] +-- | Copy of an experimental extractWitnessableTxIns not requiring 'IsEra era' +witnessableTxIns + :: L.AlonzoEraScript ledgerera + => [(TxIn, AnyWitness ledgerera)] + -> [(Witnessable TxInItem ledgerera, AnyWitness ledgerera)] +witnessableTxIns txIns' = L.nub [(WitTxIn txIn, wit) | (txIn, wit) <- txIns'] + +-- Every certificate, witnessed or not, wrapped as a 'Witnessable'. +-- +-- Unwitnessed certs MUST be included, paired with +-- 'AnyKeyWitnessPlaceholder'. The ledger resolves 'Certifying' indices +-- against the full 'certsTxBodyL' sequence, not just the witnessed +-- subset, so dropping an unwitnessed cert here would shift every later +-- index. +-- +-- Mirrors +-- 'Cardano.Api.Experimental.Tx.Internal.BodyContent.New.extractWitnessableCertificates'. +witnessableCerts + :: L.AlonzoEraScript ledgerera + => L.EraTxCert ledgerera + => Exp.TxCertificates ledgerera + -> [(Witnessable CertItem ledgerera, AnyWitness ledgerera)] +witnessableCerts (Exp.TxCertificates certsWits) = + [ (WitTxCert cert, fromMaybe AnyKeyWitnessPlaceholder mWit) + | (Exp.Certificate cert, mWit) <- toList certsWits + ] createCommonTxBody :: ShelleyBasedEra era - -> [TxIn] + -> Set L.TxIn + -- ^ The final set of ledger inputs, in ascending 'Ord' order. See + -- 'ledgerTxIns' at the 'createCompatibleTx' call site. -> [Exp.TxOut (ShelleyLedgerEra era)] -> Lovelace -> L.TxBody L.TopTx (ShelleyLedgerEra era) -createCommonTxBody era ins outs txFee' = +createCommonTxBody era ledgerTxIns outs txFee' = shelleyBasedEraConstraints era $ - let txIns' = map toShelleyTxIn ins - txOuts' = map (\(Exp.TxOut o) -> o) outs + let txOuts' = map (\(Exp.TxOut o) -> o) outs in L.mkBasicTxBody & L.inputsTxBodyL - .~ fromList txIns' + .~ ledgerTxIns & L.outputsTxBodyL .~ Seq.fromList txOuts' & L.feeTxBodyL @@ -308,33 +552,3 @@ addWitnesses witnesses (ShelleyTx sbe tx) = %~ (<> fromList [w | ShelleyBootstrapWitness _ w <- witnesses]) ) ) - --- | Index proposal procedures by their order ('Ord'). -indexWitnessedTxProposalProcedures - :: forall era - . ConwayEraOnwards era - -> Exp.TxProposalProcedures (ShelleyLedgerEra era) - -> [ ( L.ProposalProcedure (ShelleyLedgerEra era) - , (ScriptWitnessIndex, AnyWitness (ShelleyLedgerEra era)) - ) - ] -indexWitnessedTxProposalProcedures cOnwards (Exp.TxProposalProcedures proposals) = do - let allProposalsList = zip [0 ..] $ obtainCommonConstraints (convert cOnwards) $ toList proposals - [ (proposal, (ScriptWitnessIndexProposing ix, anyWitness)) - | (ix, (proposal, anyWitness)) <- allProposalsList - ] - --- | Index certificates by the order they appear in the transaction, including --- both witnessed and unwitnessed certs. See 'indexCertificatesWith' for which --- certificate types are unwitnessed. --- --- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf -indexTxCertificates - :: Exp.TxCertificates (ShelleyLedgerEra era) - -> [ ( ScriptWitnessIndex - , Exp.Certificate (ShelleyLedgerEra era) - , Maybe (AnyWitness (ShelleyLedgerEra era)) - ) - ] -indexTxCertificates (Exp.TxCertificates certsWits) = - indexCertificatesWith $ toList certsWits diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs index b1bd284297..54f9c76852 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -84,6 +84,7 @@ module Cardano.Api.Experimental , PlutusScriptPurpose (..) , PlutusScriptDatum (..) , NoScriptDatum + , mkSpendingScriptDatum -- ** Certificate related , Certificate (..) diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus.hs index 4ecba2aad6..b46384f942 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus.hs @@ -31,6 +31,7 @@ module Cardano.Api.Experimental.Plutus , PlutusScriptPurpose (..) , PlutusScriptDatum (..) , NoScriptDatum + , mkSpendingScriptDatum , getPlutusScriptWitnessLanguage -- ** Constuct an indexed plutus script witness. diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs index 6bdcfdeae1..44fdef219c 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs @@ -21,6 +21,7 @@ module Cardano.Api.Experimental.Plutus.Internal.ScriptWitness , PlutusScriptPurpose (..) , PlutusScriptDatum (..) , NoScriptDatum + , mkSpendingScriptDatum -- * Helpers , getSpendingPlutusWitnessData @@ -219,6 +220,15 @@ data PlutusScriptDatum (lang :: L.Language) (purpose :: PlutusScriptPurpose) whe NoScriptDatum :: PlutusScriptDatum lang purpose +-- | Construct the datum of a spending-purpose Plutus script witness from a +-- plain 'HashableScriptData'. +mkSpendingScriptDatum + :: L.SLanguage lang -> HashableScriptData -> PlutusScriptDatum lang SpendingScript +mkSpendingScriptDatum L.SPlutusV1 datum = SpendingScriptDatum datum +mkSpendingScriptDatum L.SPlutusV2 datum = SpendingScriptDatum datum +mkSpendingScriptDatum L.SPlutusV3 datum = SpendingScriptDatum (Just datum) +mkSpendingScriptDatum L.SPlutusV4 datum = SpendingScriptDatum (Just datum) + instance Eq (PlutusScriptDatumF lang SpendingScript) => Eq (PlutusScriptDatum lang SpendingScript) where (==) (SpendingScriptDatum d1) (SpendingScriptDatum d2) = d1 == d2 (==) InlineDatum InlineDatum = True diff --git a/cardano-api/src/Cardano/Api/Internal/Orphans/Serialisation.hs b/cardano-api/src/Cardano/Api/Internal/Orphans/Serialisation.hs index 9507cce3a5..9a47a58166 100644 --- a/cardano-api/src/Cardano/Api/Internal/Orphans/Serialisation.hs +++ b/cardano-api/src/Cardano/Api/Internal/Orphans/Serialisation.hs @@ -288,14 +288,14 @@ deriving via Show (L.ConwayLedgerPredFailure ledgerera) => ToJSON (L.ConwayLedgerPredFailure ledgerera) deriving via - ShowOf (L.DijkstraMempoolPredFailure ledgerera) + ShowOf (L.DijkstraLedgerPredFailure ledgerera) instance - Show (L.DijkstraMempoolPredFailure ledgerera) => ToJSON (L.DijkstraMempoolPredFailure ledgerera) + Show (L.DijkstraLedgerPredFailure ledgerera) => ToJSON (L.DijkstraLedgerPredFailure ledgerera) deriving via - ShowOf (L.DijkstraLedgerPredFailure ledgerera) + ShowOf (L.DijkstraMempoolPredFailure ledgerera) instance - Show (L.DijkstraLedgerPredFailure ledgerera) => ToJSON (L.DijkstraLedgerPredFailure ledgerera) + Show (L.DijkstraMempoolPredFailure ledgerera) => ToJSON (L.DijkstraMempoolPredFailure ledgerera) deriving via ShowOf (L.ShelleyDelegsPredFailure ledgerera) 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 18f36fbe35..31c42a22d7 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 @@ -10,16 +10,28 @@ module Test.Cardano.Api.Experimental.Fee where import Cardano.Api qualified as Api -import Cardano.Api.Compatible.Tx (AnyProtocolUpdate (..), AnyVote (..), createCompatibleTx) +import Cardano.Api.Compatible.Tx + ( CompatibleTxBodyContent (..) + , CompatibleTxError (..) + , createCompatibleTx + , defaultCompatibleTxBodyContent + ) import Cardano.Api.Experimental qualified as Exp +import Cardano.Api.Experimental.AnyScriptWitness + ( AnyPlutusScriptWitness (AnyPlutusSpendingScriptWitness) + , PlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV3) + ) import Cardano.Api.Experimental.Era (convert) +import Cardano.Api.Experimental.Plutus (plutusScriptInEraToScript) import Cardano.Api.Experimental.Tx qualified as Exp import Cardano.Api.Ledger qualified as L import Cardano.Api.Monad.Error (failEitherWith) +import Cardano.Ledger.Alonzo.TxWits qualified as Alonzo import Cardano.Ledger.Api qualified as UnexportedLedger import Cardano.Ledger.Core qualified as L import Cardano.Ledger.Mary.Value qualified as Mary +import Cardano.Ledger.Plutus.Language qualified as Plutus import Cardano.Ledger.Tools qualified as L (calcMinFeeTx) import Cardano.Slotting.EpochInfo qualified as Slotting import Cardano.Slotting.Slot qualified as Slotting @@ -27,11 +39,18 @@ import Cardano.Slotting.Time qualified as Slotting import Data.Foldable (toList) import Data.Map.Strict qualified as Map +import Data.Maybe (isJust) import Data.Sequence.Strict qualified as Seq +import Data.Set qualified as Set import Data.Time.Clock.POSIX qualified as Time import Lens.Micro -import Test.Gen.Cardano.Api.Typed (genAddressInEra, genStakeCredential, genTxIn) +import Test.Gen.Cardano.Api.Typed + ( genAddressInEra + , genPlutusScriptInEra + , genStakeCredential + , genTxIn + ) import Test.Cardano.Api.Experimental (exampleProtocolParams, exampleProtocolParamsEra) @@ -68,6 +87,18 @@ tests = [ testProperty "all certs (witnessed and unwitnessed) appear in the ledger tx" prop_createCompatibleTx_preserves_all_certs + , testProperty + "spending redeemer indices follow sorted input order, not argument order" + prop_createCompatibleTx_redeemer_indices_follow_sorted_inputs + , testProperty + "an inline plutus spending script witness lands in the tx witness set" + prop_createCompatibleTx_inline_plutus_script_in_witness_set + , testProperty + "plutus witnesses without protocol parameters are rejected" + prop_createCompatibleTx_missing_pparams_with_plutus_witness + , testProperty + "collateral, validity upper bound and metadata are threaded through" + prop_createCompatibleTx_extra_content_is_threaded_through ] , testGroup "calcMinFeeRecursive" @@ -848,10 +879,183 @@ prop_createCompatibleTx_preserves_all_certs = H.property $ do let sbe = convert Exp.ConwayEra inputCerts = Exp.mkTxCertificates Exp.ConwayEra allCerts Api.ShelleyTx _ ledgerTx <- - H.evalEither $ createCompatibleTx sbe [] [] mempty 0 (NoPParamsUpdate sbe) NoVotes inputCerts + H.evalEither $ + createCompatibleTx sbe (defaultCompatibleTxBodyContent sbe){compatibleTxCertificates = inputCerts} let bodyCerts = ledgerTx ^. L.bodyTxL . L.certsTxBodyL Seq.length bodyCerts H.=== expectedCount +-- | 'createCompatibleTx' must index spending redeemer pointers by the +-- input's position in the final, sorted ledger input set, never by the +-- order the caller supplied inputs in. The ledger stores tx inputs in a +-- 'Data.Set.Set', not a list, so swapping the argument order of two +-- plutus-witnessed inputs must not change which redeemer lands at which +-- index. +prop_createCompatibleTx_redeemer_indices_follow_sorted_inputs :: Property +prop_createCompatibleTx_redeemer_indices_follow_sorted_inputs = H.property $ do + txIn1@(Api.TxIn txId (Api.TxIx txIx)) <- H.forAll genTxIn + let txIn2 = Api.TxIn txId (Api.TxIx (txIx + 1)) + + sbe = convert Exp.ConwayEra + + mkRedeemer :: Integer -> Api.HashableScriptData + mkRedeemer n = Api.unsafeHashableScriptData $ Api.ScriptDataConstructor n [] + + mkSpendingWitness redeemer = + Exp.AnyPlutusScriptWitness $ + AnyPlutusSpendingScriptWitness $ + PlutusSpendingScriptWitnessV3 $ + Exp.PlutusScriptWitness + Plutus.SPlutusV3 + (Exp.PReferenceScript txIn1) + Exp.NoScriptDatum + redeemer + (Api.ExecutionUnits 0 0) + + ins = + [ (txIn1, mkSpendingWitness (mkRedeemer 1)) + , (txIn2, mkSpendingWitness (mkRedeemer 2)) + ] + + baseContent = + (defaultCompatibleTxBodyContent sbe) + { compatibleTxProtocolParams = Just exampleProtocolParams + , compatibleTxCertificates = Exp.mkTxCertificates Exp.ConwayEra [] + } + + build orderedIns = createCompatibleTx sbe baseContent{compatibleTxIns = orderedIns} + + Api.ShelleyTx _ forwardTx <- H.evalEither $ build ins + Api.ShelleyTx _ reversedTx <- H.evalEither $ build (reverse ins) + + let forwardRedeemers = forwardTx ^. L.witsTxL . Alonzo.rdmrsTxWitsL + reversedRedeemers = reversedTx ^. L.witsTxL . Alonzo.rdmrsTxWitsL + + -- Order-invariance is the core claim: if indices were derived from + -- argument-list position instead of sorted 'TxIn' order, reversing the + -- argument order would swap which redeemer lands at which index. + forwardRedeemers H.=== reversedRedeemers + + -- Pin down the exact mapping too, so a different bug (e.g. always + -- indexing everything to 0) cannot slip through the check above. + -- + -- 'txIn1' and 'txIn2' share a 'TxId' and only differ by 'TxIx' ('ix' vs + -- 'ix + 1'), so 'txIn1' sorts first: its redeemer must land at index 0, + -- 'txIn2''s at index 1. + let expectedRedeemers = + L.Redeemers $ + Map.fromList + [ + ( L.ConwaySpending (L.AsIx 0) + , (Api.toAlonzoData (mkRedeemer 1), Api.toAlonzoExUnits (Api.ExecutionUnits 0 0)) + ) + , + ( L.ConwaySpending (L.AsIx 1) + , (Api.toAlonzoData (mkRedeemer 2), Api.toAlonzoExUnits (Api.ExecutionUnits 0 0)) + ) + ] + + forwardRedeemers H.=== expectedRedeemers + +-- | An inline (non-reference) plutus spending script witness must land in +-- the resulting ledger transaction's witness set ('L.scriptTxWitsL'). +prop_createCompatibleTx_inline_plutus_script_in_witness_set :: Property +prop_createCompatibleTx_inline_plutus_script_in_witness_set = H.property $ do + txIn <- H.forAll genTxIn + scriptInEra <- H.forAll genPlutusScriptInEra + let sbe = convert Exp.ConwayEra + + redeemer = Api.unsafeHashableScriptData $ Api.ScriptDataConstructor 0 [] + + witness = + Exp.AnyPlutusScriptWitness $ + AnyPlutusSpendingScriptWitness $ + PlutusSpendingScriptWitnessV3 $ + Exp.PlutusScriptWitness + Plutus.SPlutusV3 + (Exp.PScript scriptInEra) + Exp.NoScriptDatum + redeemer + (Api.ExecutionUnits 0 0) + + Api.ShelleyTx _ ledgerTx <- + H.evalEither $ + createCompatibleTx sbe $ + (defaultCompatibleTxBodyContent sbe) + { compatibleTxIns = [(txIn, witness)] + , compatibleTxProtocolParams = Just exampleProtocolParams + , compatibleTxCertificates = Exp.mkTxCertificates Exp.ConwayEra [] + } + + let scriptWits = ledgerTx ^. L.witsTxL . L.scriptTxWitsL + expectedHash = L.hashScript $ plutusScriptInEraToScript scriptInEra + + H.assertWith scriptWits (not . null) + H.assertWith scriptWits (Map.member expectedHash) + +-- | 'createCompatibleTx' must reject plutus script witnesses when no +-- protocol parameters were supplied, since those are required to compute +-- the script integrity hash. +prop_createCompatibleTx_missing_pparams_with_plutus_witness :: Property +prop_createCompatibleTx_missing_pparams_with_plutus_witness = H.property $ do + txIn <- H.forAll genTxIn + let sbe = convert Exp.ConwayEra + + redeemer = Api.unsafeHashableScriptData $ Api.ScriptDataConstructor 0 [] + + witness = + Exp.AnyPlutusScriptWitness $ + AnyPlutusSpendingScriptWitness $ + PlutusSpendingScriptWitnessV3 $ + Exp.PlutusScriptWitness + Plutus.SPlutusV3 + (Exp.PReferenceScript txIn) + Exp.NoScriptDatum + redeemer + (Api.ExecutionUnits 0 0) + + case createCompatibleTx sbe $ + (defaultCompatibleTxBodyContent sbe) + { compatibleTxIns = [(txIn, witness)] + , compatibleTxCertificates = Exp.mkTxCertificates Exp.ConwayEra [] + } of + Left CompatibleTxMissingScriptIntegrityPParams -> H.success + Left err -> H.annotateShow err >> H.failure + Right _ -> + H.annotate "Expected CompatibleTxMissingScriptIntegrityPParams but tx was built successfully" + >> H.failure + +-- | 'createCompatibleTx' must thread the collateral inputs, the validity +-- interval's upper bound, and metadata parts of 'CompatibleTxBodyContent' +-- into the resulting transaction (both the aux data hash on the body and +-- the aux data itself on the tx). +prop_createCompatibleTx_extra_content_is_threaded_through :: Property +prop_createCompatibleTx_extra_content_is_threaded_through = H.property $ do + collateralTxIn <- H.forAll genTxIn + let sbe = convert Exp.ConwayEra + + upperBound = Slotting.SlotNo 100 + + metadata = Api.TxMetadata $ Map.fromList [(1, Api.TxMetaText "createCompatibleTx")] + + Api.ShelleyTx _ ledgerTx <- + H.evalEither $ + createCompatibleTx sbe $ + (defaultCompatibleTxBodyContent sbe) + { compatibleTxInsCollateral = [collateralTxIn] + , compatibleTxValidityUpperBound = Just upperBound + , compatibleTxMetadata = Api.TxMetadataInEra sbe metadata + , compatibleTxCertificates = Exp.mkTxCertificates Exp.ConwayEra [] + } + + let ledgerBody = ledgerTx ^. L.bodyTxL + + ledgerBody ^. UnexportedLedger.collateralInputsTxBodyL + H.=== Set.singleton (Api.toShelleyTxIn collateralTxIn) + ledgerBody ^. UnexportedLedger.vldtTxBodyL . UnexportedLedger.invalidHereAfterL + H.=== L.SJust upperBound + H.assertWith (ledgerBody ^. UnexportedLedger.auxDataHashTxBodyL) (isJust . L.strictMaybeToMaybe) + H.assertWith (ledgerTx ^. UnexportedLedger.auxDataTxL) (isJust . L.strictMaybeToMaybe) + -- --------------------------------------------------------------------------- -- Shared cert generators -- --------------------------------------------------------------------------- From d2c152c6c66b35655df2b17d8835ec193f210d3a Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Tue, 1 Sep 2026 16:58:23 +0200 Subject: [PATCH 2/2] Address review comments in the compatible transaction API - Include vote script witnesses in createCompatibleTx: voting redeemers, scripts, script integrity hash contribution and reference inputs, with a regression test - Remove the unreachable CompatibleTxProtocolParametersConversionError constructor - Simplify createCompatibleTx: hoist the pure bindings out of the Either block, collapse setRefInputs into a single comprehension, rewrite setScriptWitnesses without Endo - Correct the stale dedupInputsByTxIn reference in the redeemer pointer ordering comment --- ...20260807_cardano_api_compatible_plutus.yml | 2 +- cardano-api/src/Cardano/Api/Compatible/Tx.hs | 228 +++++++++--------- .../Test/Cardano/Api/Experimental/Fee.hs | 67 ++++- 3 files changed, 185 insertions(+), 112 deletions(-) diff --git a/.changes/20260807_cardano_api_compatible_plutus.yml b/.changes/20260807_cardano_api_compatible_plutus.yml index d3363c8752..a4b9ffad46 100644 --- a/.changes/20260807_cardano_api_compatible_plutus.yml +++ b/.changes/20260807_cardano_api_compatible_plutus.yml @@ -5,4 +5,4 @@ kind: - breaking - bugfix description: | - Add plutus spending script support to createCompatibleTx. Breaking: it now takes all transaction content as a single CompatibleTxBodyContent record and fails with the new CompatibleTxError. Export mkSpendingScriptDatum. Fix certificate and proposal script witnesses missing from the witness set, and proposal reference inputs being overwritten. Remove the redundant StakeCredential field from WitTxCert. + Add plutus spending script support to createCompatibleTx. Breaking: it now takes all transaction content as a single CompatibleTxBodyContent record and fails with the new CompatibleTxError. Export mkSpendingScriptDatum. Fix certificate, proposal and vote script witnesses missing from the witness set, and proposal reference inputs being overwritten. Remove the redundant StakeCredential field from WitTxCert. diff --git a/cardano-api/src/Cardano/Api/Compatible/Tx.hs b/cardano-api/src/Cardano/Api/Compatible/Tx.hs index 9d509042ed..5ca8ffd4af 100644 --- a/cardano-api/src/Cardano/Api/Compatible/Tx.hs +++ b/cardano-api/src/Cardano/Api/Compatible/Tx.hs @@ -135,10 +135,7 @@ defaultCompatibleTxBodyContent sbe = -- | Errors that can occur while assembling a 'Tx' with 'createCompatibleTx'. data CompatibleTxError - = -- | The supplied protocol parameters could not be converted to the - -- ledger representation needed to compute the script integrity hash. - CompatibleTxProtocolParametersConversionError ProtocolParametersConversionError - | -- | Plutus script witnesses are present (non-empty redeemers, datums + = -- | Plutus script witnesses are present (non-empty redeemers, datums -- or plutus languages), but 'compatibleTxProtocolParams' is -- 'Nothing', so the ledger's required script integrity hash cannot -- be computed. @@ -148,7 +145,6 @@ data CompatibleTxError instance Error CompatibleTxError where prettyError err = case err of - CompatibleTxProtocolParametersConversionError e -> prettyError e CompatibleTxMissingScriptIntegrityPParams -> "Plutus script witnesses are present but no protocol parameters were supplied " <> "to compute the script integrity hash." @@ -161,59 +157,6 @@ createCompatibleTx -> Either CompatibleTxError (Tx era) createCompatibleTx sbe bodyContent = shelleyBasedEraConstraints sbe $ do - (updateTxBody, proposalWitnesses) <- - case anyProtocolUpdate of - ProtocolUpdate shelleyToBabbageEra updateProposal -> do - let ledgerPParamsUpdate = toLedgerUpdate sbe updateProposal - updateTxBody :: Endo (L.TxBody L.TopTx (ShelleyLedgerEra era)) = - shelleyToBabbageEraConstraints shelleyToBabbageEra $ - Endo $ \txb -> - txb & L.updateTxBodyL .~ SJust ledgerPParamsUpdate - - pure (updateTxBody, []) - NoPParamsUpdate _ -> - pure (mempty, []) - ProposalProcedures conwayOnwards proposalProcedures -> do - let Exp.TxProposalProcedures propMap = proposalProcedures - proposals :: OSet (L.ProposalProcedure (ShelleyLedgerEra era)) = fromList $ fst <$> shelleyBasedEraConstraints sbe (toList propMap) - - -- Order must stay OMap insertion order; the shared - -- Witnessable-based indexing (via 'extractWitnessableProposals') preserves it. - proposalWitnesses - :: [(Witnessable ProposalItem (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))] - proposalWitnesses = - Exp.obtainCommonConstraints (convert conwayOnwards) $ - Exp.extractWitnessableProposals $ - Just proposalProcedures - referenceInputs = - [ toShelleyTxIn txIn - | (_, wit) <- proposalWitnesses - , txIn <- maybeToList $ getAnyWitnessReferenceInput wit - ] - -- append proposal reference inputs & set proposal procedures - updateTxBody :: Endo (L.TxBody L.TopTx (ShelleyLedgerEra era)) = - obtainCommonConstraints (convert conwayOnwards) $ - Endo $ - (L.referenceInputsTxBodyL %~ (<> fromList referenceInputs)) - . (L.proposalProceduresTxBodyL .~ proposals) - - pure (updateTxBody, proposalWitnesses) - - let - -- Flat witnesses from all three script-witnessable categories - -- (certificates, proposals, inputs), for 'setScriptIntegrityHash' - -- and 'setScriptWitnesses' to collect datums, scripts and plutus - -- languages from. Only the redeemer pointer map (built inside - -- 'convScriptData'') needs per-category indexing. - allWitnesses :: [AnyWitness (ShelleyLedgerEra era)] - allWitnesses = witnessedCertWitnesses <> map snd proposalWitnesses <> map snd ins - - sData :: Maybe (L.TxDats (ShelleyLedgerEra era), L.Redeemers (ShelleyLedgerEra era)) - sData = convScriptData' sbe ins txCertificates' proposalWitnesses allWitnesses extraDatums - - txAuxData :: Maybe (L.TxAuxData (ShelleyLedgerEra era)) - txAuxData = toAuxiliaryData sbe (compatibleTxMetadata bodyContent) TxAuxScriptsNone - integrityHashUpdate <- setScriptIntegrityHash sData allWitnesses let txbody = @@ -255,13 +198,72 @@ createCompatibleTx sbe bodyContent = anyVote = compatibleTxVotingProcedures bodyContent txCertificates' = compatibleTxCertificates bodyContent + -- Order must stay OMap insertion order; the shared Witnessable-based + -- indexing (via 'extractWitnessableProposals') preserves it. + proposalWitnesses + :: [(Witnessable ProposalItem (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))] + proposalWitnesses = + case anyProtocolUpdate of + ProtocolUpdate{} -> [] + NoPParamsUpdate{} -> [] + ProposalProcedures conwayOnwards proposalProcedures -> + Exp.obtainCommonConstraints (convert conwayOnwards) $ + Exp.extractWitnessableProposals $ + Just proposalProcedures + + updateTxBody :: Endo (L.TxBody L.TopTx (ShelleyLedgerEra era)) + updateTxBody = + case anyProtocolUpdate of + ProtocolUpdate shelleyToBabbageEra updateProposal -> + let ledgerPParamsUpdate = toLedgerUpdate sbe updateProposal + in shelleyToBabbageEraConstraints shelleyToBabbageEra $ + Endo $ \txb -> + txb & L.updateTxBodyL .~ SJust ledgerPParamsUpdate + NoPParamsUpdate _ -> mempty + ProposalProcedures conwayOnwards proposalProcedures -> + shelleyBasedEraConstraints sbe $ + let Exp.TxProposalProcedures propMap = proposalProcedures + proposals :: OSet (L.ProposalProcedure (ShelleyLedgerEra era)) + proposals = fromList $ fst <$> toList propMap + -- append proposal reference inputs & set proposal procedures + referenceInputs = + [ toShelleyTxIn txIn + | (_, wit) <- proposalWitnesses + , txIn <- maybeToList $ getAnyWitnessReferenceInput wit + ] + in obtainCommonConstraints (convert conwayOnwards) $ + Endo $ + (L.referenceInputsTxBodyL %~ (<> fromList referenceInputs)) + . (L.proposalProceduresTxBodyL .~ proposals) + + -- Flat witnesses from all four script-witnessable categories + -- (certificates, proposals, votes, inputs), for + -- 'setScriptIntegrityHash' and 'setScriptWitnesses' to collect + -- datums, scripts and plutus languages from. Only the redeemer + -- pointer map (built inside 'convScriptData'') needs per-category + -- indexing. + allWitnesses :: [AnyWitness (ShelleyLedgerEra era)] + allWitnesses = + witnessedCertWitnesses + <> map snd proposalWitnesses + <> map snd voteWitnesses + <> map snd ins + + sData :: Maybe (L.TxDats (ShelleyLedgerEra era), L.Redeemers (ShelleyLedgerEra era)) + sData = convScriptData' sbe ins txCertificates' proposalWitnesses voteWitnesses allWitnesses extraDatums + + txAuxData :: Maybe (L.TxAuxData (ShelleyLedgerEra era)) + txAuxData = toAuxiliaryData sbe (compatibleTxMetadata bodyContent) TxAuxScriptsNone + -- The final set of ledger inputs, in ascending 'Ord' order ('Data.Set'). -- This is the order the ledger serialises tx inputs in, and the order -- it resolves 'Spending' redeemer pointers against. -- - -- Spending redeemer pointers (built by 'dedupInputsByTxIn' inside - -- 'convScriptData'', via 'WitTxIn''s 'compareWitnesses') MUST use this - -- same order, never the order 'ins' was supplied in. + -- Spending redeemer pointers are indexed against this same order: + -- 'witnessableTxIns' nubs duplicate (TxIn, witness) pairs, and the + -- shared Witnessable indexing machinery sorts 'WitTxIn' entries by + -- 'TxIn' ('compareWitnesses') to match this 'Set' order. Never index + -- against the order 'ins' was supplied in. ledgerTxIns :: Set L.TxIn ledgerTxIns = fromList $ map (toShelleyTxIn . fst) ins @@ -275,6 +277,18 @@ createCompatibleTx sbe bodyContent = where Exp.TxCertificates certsWits = txCertificates' + -- The witness of every vote in 'anyVote', witnessed or not (unwitnessed + -- votes get 'AnyKeyWitnessPlaceholder'). Mirrors 'proposalWitnesses'. + voteWitnesses + :: [(Witnessable VoterItem (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))] + voteWitnesses = + case anyVote of + NoVotes -> [] + VotingProcedures conwayOnwards votingProcedures -> + Exp.obtainCommonConstraints (convert conwayOnwards) $ + Exp.extractWitnessableVotes $ + Just votingProcedures + setCerts :: Endo (L.TxBody L.TopTx (ShelleyLedgerEra era)) setCerts = shelleyBasedEraConstraints sbe $ @@ -283,19 +297,15 @@ createCompatibleTx sbe bodyContent = -- Uses '%~ (<>)', not '.~', so it does not clobber reference inputs -- already appended by 'updateTxBody' (the 'ProposalProcedures' case - -- above). Reference inputs collected here come from both witnessed - -- certificates and witnessed spending inputs. + -- above). Reference inputs collected here come from witnessed + -- certificates, witnessed votes and witnessed spending inputs. setRefInputs :: Endo (L.TxBody L.TopTx (ShelleyLedgerEra era)) setRefInputs = do let refInputs = [ toShelleyTxIn refInput - | wit <- witnessedCertWitnesses + | wit <- witnessedCertWitnesses <> map snd voteWitnesses <> map snd ins , refInput <- maybeToList $ getAnyWitnessReferenceInput wit ] - ++ [ toShelleyTxIn refInput - | (_, wit) <- ins - , refInput <- maybeToList $ getAnyWitnessReferenceInput wit - ] monoidForEraInEon era $ \beo -> babbageEraOnwardsConstraints beo $ @@ -328,11 +338,11 @@ createCompatibleTx sbe bodyContent = setMetadataHash :: Maybe (L.TxAuxData (ShelleyLedgerEra era)) -> Endo (L.TxBody L.TopTx (ShelleyLedgerEra era)) - setMetadataHash txAuxData = + setMetadataHash auxData = shelleyBasedEraConstraints sbe $ Endo $ L.auxDataHashTxBodyL - .~ maybe SNothing (SJust . L.hashTxAuxData) txAuxData + .~ maybe SNothing (SJust . L.hashTxAuxData) auxData -- The hash is only computed when there is something for it to cover. -- It is an error to have something to cover without protocol @@ -346,14 +356,14 @@ createCompatibleTx sbe bodyContent = :: Maybe (L.TxDats (ShelleyLedgerEra era), L.Redeemers (ShelleyLedgerEra era)) -> [AnyWitness (ShelleyLedgerEra era)] -> Either CompatibleTxError (Endo (L.TxBody L.TopTx (ShelleyLedgerEra era))) - setScriptIntegrityHash scriptData allWitnesses = + setScriptIntegrityHash scriptData witnesses = monoidForEraInEonA era $ \aeo -> alonzoEraOnwardsConstraints aeo $ do let (datums, redeemers) = fromMaybe mempty scriptData languages :: Set L.Language - languages = fromList $ mapMaybe getAnyWitnessPlutusLanguage allWitnesses + languages = fromList $ mapMaybe getAnyWitnessPlutusLanguage witnesses shouldCalculateHash = not $ @@ -392,43 +402,43 @@ createCompatibleTx sbe bodyContent = -> [AnyWitness (ShelleyLedgerEra era)] -> L.TxWits (ShelleyLedgerEra era) -> L.TxWits (ShelleyLedgerEra era) - setScriptWitnesses sData scriptWitnesses = - appEndos - [ monoidForEraInEon - era - ( \aeo -> - alonzoEraOnwardsConstraints aeo $ - obtainAlonzoScriptPurposeConstraints aeo $ - Endo $ do - let (datums, redeemers) = - fromMaybe mempty sData - :: (L.TxDats (ShelleyLedgerEra era), L.Redeemers (ShelleyLedgerEra era)) - -- 'getAnyWitnessScript' covers both plutus and simple - -- scripts. The simple ones overlap harmlessly (same - -- hash, same script) with the allegra-onwards branch - -- below, which is still needed for pre-Alonzo eras - -- that this branch does not run in. - let plutusAndSimpleScripts = - mapMaybe getAnyWitnessScript scriptWitnesses - (L.datsTxWitsL .~ datums) - . (L.rdmrsTxWitsL %~ (<> redeemers)) - . ( L.scriptTxWitsL - %~ (<> Map.fromList [(L.hashScript sw, sw) | sw <- plutusAndSimpleScripts]) - ) - ) - , monoidForEraInEon - era - ( \aeo -> allegraEraOnwardsConstraints aeo $ Endo $ do - let ledgerScripts = convSimpleScripts sbe scriptWitnesses - L.scriptTxWitsL + setScriptWitnesses scriptData scriptWitnesses = plutusAdditions . simpleScriptAdditions + where + plutusAdditions :: L.TxWits (ShelleyLedgerEra era) -> L.TxWits (ShelleyLedgerEra era) + plutusAdditions = + forEraInEon era id $ \aeo -> + alonzoEraOnwardsConstraints aeo $ + obtainAlonzoScriptPurposeConstraints aeo $ + let + (datums, redeemers) = + fromMaybe mempty scriptData + :: (L.TxDats (ShelleyLedgerEra era), L.Redeemers (ShelleyLedgerEra era)) + -- 'getAnyWitnessScript' covers both plutus and simple + -- scripts. The simple ones overlap harmlessly (same + -- hash, same script) with the allegra-onwards branch + -- below, which is still needed for pre-Alonzo eras + -- that this branch does not run in. + plutusAndSimpleScripts = + mapMaybe getAnyWitnessScript scriptWitnesses + in + (L.datsTxWitsL .~ datums) + . (L.rdmrsTxWitsL %~ (<> redeemers)) + . ( L.scriptTxWitsL + %~ (<> Map.fromList [(L.hashScript sw, sw) | sw <- plutusAndSimpleScripts]) + ) + + simpleScriptAdditions :: L.TxWits (ShelleyLedgerEra era) -> L.TxWits (ShelleyLedgerEra era) + simpleScriptAdditions = + forEraInEon era id $ \aeo -> + allegraEraOnwardsConstraints aeo $ + let ledgerScripts = convSimpleScripts sbe scriptWitnesses + in L.scriptTxWitsL %~ ( <> Map.fromList [ (L.hashScript sw, sw) | sw <- ledgerScripts ] ) - ) - ] convSimpleScripts :: ShelleyLedgerEra era ~ ledgerera @@ -452,28 +462,30 @@ convScriptData' -> [(TxIn, Exp.AnyWitness (ShelleyLedgerEra era))] -> Exp.TxCertificates (ShelleyLedgerEra era) -> [(Witnessable ProposalItem (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))] + -> [(Witnessable VoterItem (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))] -> [AnyWitness (ShelleyLedgerEra era)] -> Map L.DataHash (L.Data (ShelleyLedgerEra era)) -> Maybe (L.TxDats (ShelleyLedgerEra era), L.Redeemers (ShelleyLedgerEra era)) -convScriptData' sbe ins txCertificates' proposalWits allWitnesses extraDatums = +convScriptData' sbe ins txCertificates' proposalWits voteWits allWitnesses extraDatums = forEraInEon (convert sbe) Nothing ( \w -> alonzoEraOnwardsConstraints w $ do let - -- Three disjoint per-category redeemer maps merged into one. - -- Ledger 'L.PlutusPurpose' tags (Spending/Certifying/Proposing) + -- Four disjoint per-category redeemer maps merged into one. + -- Ledger 'L.PlutusPurpose' tags (Spending/Certifying/Voting/Proposing) -- never collide across categories, so '<>' below cannot drop -- or overwrite an entry. -- - -- All three share the Witnessable-based indexing that + -- All four share the Witnessable-based indexing that -- 'Cardano.Api.Experimental.Tx.Internal.BodyContent.New.makeUnsignedTx' -- uses, via 'getAnyWitnessRedeemerPointerMap'. certRedeemers = getAnyWitnessRedeemerPointerMap $ witnessableCerts txCertificates' inputRedeemers = getAnyWitnessRedeemerPointerMap $ witnessableTxIns ins proposalRedeemers = getAnyWitnessRedeemerPointerMap proposalWits - redeemers = certRedeemers <> inputRedeemers <> proposalRedeemers + voteRedeemers = getAnyWitnessRedeemerPointerMap voteWits + redeemers = certRedeemers <> inputRedeemers <> voteRedeemers <> proposalRedeemers datums = mconcat [getAnyWitnessScriptData wit | wit <- allWitnesses] supplementalDatums = Alonzo.TxDats extraDatums 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 31c42a22d7..ff64c188f8 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 @@ -11,14 +11,15 @@ where import Cardano.Api qualified as Api import Cardano.Api.Compatible.Tx - ( CompatibleTxBodyContent (..) + ( AnyVote (..) + , CompatibleTxBodyContent (..) , CompatibleTxError (..) , createCompatibleTx , defaultCompatibleTxBodyContent ) import Cardano.Api.Experimental qualified as Exp import Cardano.Api.Experimental.AnyScriptWitness - ( AnyPlutusScriptWitness (AnyPlutusSpendingScriptWitness) + ( AnyPlutusScriptWitness (AnyPlutusSpendingScriptWitness, AnyPlutusVotingScriptWitness) , PlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV3) ) import Cardano.Api.Experimental.Era (convert) @@ -40,6 +41,7 @@ import Cardano.Slotting.Time qualified as Slotting import Data.Foldable (toList) import Data.Map.Strict qualified as Map import Data.Maybe (isJust) +import Data.Maybe.Strict (StrictMaybe (SNothing)) import Data.Sequence.Strict qualified as Seq import Data.Set qualified as Set import Data.Time.Clock.POSIX qualified as Time @@ -50,6 +52,7 @@ import Test.Gen.Cardano.Api.Typed , genPlutusScriptInEra , genStakeCredential , genTxIn + , genVerificationKeyHash ) import Test.Cardano.Api.Experimental (exampleProtocolParams, exampleProtocolParamsEra) @@ -93,6 +96,9 @@ tests = , testProperty "an inline plutus spending script witness lands in the tx witness set" prop_createCompatibleTx_inline_plutus_script_in_witness_set + , testProperty + "an inline plutus vote script witness lands in the tx witness set" + prop_createCompatibleTx_inline_plutus_vote_script_in_witness_set , testProperty "plutus witnesses without protocol parameters are rejected" prop_createCompatibleTx_missing_pparams_with_plutus_witness @@ -992,6 +998,62 @@ prop_createCompatibleTx_inline_plutus_script_in_witness_set = H.property $ do H.assertWith scriptWits (not . null) H.assertWith scriptWits (Map.member expectedHash) +-- | A plutus-witnessed vote's script must land in the resulting ledger +-- transaction's witness set, just like a plutus-witnessed certificate or +-- spending input does. Regression test: 'createCompatibleTx' used to +-- discard 'AnyVote''s witness map entirely, so a script-witnessed vote's +-- script never made it into the tx. +prop_createCompatibleTx_inline_plutus_vote_script_in_witness_set :: Property +prop_createCompatibleTx_inline_plutus_vote_script_in_witness_set = H.property $ do + scriptInEra <- H.forAll genPlutusScriptInEra + voterKeyHash <- H.forAll $ Api.unDRepKeyHash <$> genVerificationKeyHash Api.AsDRepKey + L.TxIn govActionTxId _ <- Api.toShelleyTxIn <$> H.forAll genTxIn + let sbe = convert Exp.ConwayEra + + voter = L.DRepVoter (L.KeyHashObj voterKeyHash) + govActionId = L.GovActionId govActionTxId (L.GovActionIx 0) + votingProcedure = L.VotingProcedure L.VoteYes SNothing + votingProcedures = L.VotingProcedures (Map.singleton voter (Map.singleton govActionId votingProcedure)) + + redeemer = Api.unsafeHashableScriptData $ Api.ScriptDataConstructor 0 [] + + witness = + Exp.AnyPlutusScriptWitness $ + AnyPlutusVotingScriptWitness $ + Exp.PlutusScriptWitness + Plutus.SPlutusV3 + (Exp.PScript scriptInEra) + Exp.NoScriptDatum + redeemer + (Api.ExecutionUnits 0 0) + + txVotingProcedures <- + H.leftFail $ Exp.mkTxVotingProcedures [(votingProcedures, witness)] + + Api.ShelleyTx _ ledgerTx <- + H.evalEither $ + createCompatibleTx sbe $ + (defaultCompatibleTxBodyContent sbe) + { compatibleTxVotingProcedures = VotingProcedures Api.ConwayEraOnwardsConway txVotingProcedures + , compatibleTxProtocolParams = Just exampleProtocolParams + } + + let scriptWits = ledgerTx ^. L.witsTxL . L.scriptTxWitsL + expectedHash = L.hashScript $ plutusScriptInEraToScript scriptInEra + redeemers = ledgerTx ^. L.witsTxL . Alonzo.rdmrsTxWitsL + expectedRedeemers = + L.Redeemers $ + Map.singleton + (L.ConwayVoting (L.AsIx 0)) + (Api.toAlonzoData redeemer, Api.toAlonzoExUnits (Api.ExecutionUnits 0 0)) + + H.assertWith scriptWits (not . null) + H.assertWith scriptWits (Map.member expectedHash) + redeemers H.=== expectedRedeemers + H.assertWith + (ledgerTx ^. L.bodyTxL . UnexportedLedger.scriptIntegrityHashTxBodyL) + (isJust . L.strictMaybeToMaybe) + -- | 'createCompatibleTx' must reject plutus script witnesses when no -- protocol parameters were supplied, since those are required to compute -- the script integrity hash. @@ -1019,7 +1081,6 @@ prop_createCompatibleTx_missing_pparams_with_plutus_witness = H.property $ do , compatibleTxCertificates = Exp.mkTxCertificates Exp.ConwayEra [] } of Left CompatibleTxMissingScriptIntegrityPParams -> H.success - Left err -> H.annotateShow err >> H.failure Right _ -> H.annotate "Expected CompatibleTxMissingScriptIntegrityPParams but tx was built successfully" >> H.failure