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/.changes/20260811_cardano_api_redeemer_pointer_indexing.yml b/.changes/20260811_cardano_api_redeemer_pointer_indexing.yml new file mode 100644 index 0000000000..89427890e9 --- /dev/null +++ b/.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. diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index e1ea28870c..ff1bfe154f 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -375,6 +375,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, @@ -430,6 +431,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 diff --git a/cardano-api/src/Cardano/Api/Compatible/Tx.hs b/cardano-api/src/Cardano/Api/Compatible/Tx.hs index b18ea339e7..dfac9ed235 100644 --- a/cardano-api/src/Cardano/Api/Compatible/Tx.hs +++ b/cardano-api/src/Cardano/Api/Compatible/Tx.hs @@ -5,30 +5,40 @@ {-# 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.Address (StakeCredential) import Cardano.Api.Era -import Cardano.Api.Experimental.AnyScriptWitness +import Cardano.Api.Error (Error (..)) +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 +46,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 +58,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 +83,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 +176,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 +198,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 +233,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 +386,58 @@ createCompatibleTx sbe ins outs extraDatums txFee' anyProtocolUpdate anyVote txC conwayEraOnwardsConstraints conwayOnwards $ (L.bodyTxL . L.votingProceduresTxBodyL) .~ votingProcedures - indexedTxCerts - :: [ ( ScriptWitnessIndex - , Exp.Certificate (ShelleyLedgerEra era) - , Maybe (StakeCredential, 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 +448,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, maybe AnyKeyWitnessPlaceholder snd mCredAndWit) + | (Exp.Certificate cert, mCredAndWit) <- 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 +551,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 ..] $ conwayEraOnwardsConstraints 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 (StakeCredential, 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/IndexedPlutusScriptWitness.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/IndexedPlutusScriptWitness.hs index 0925b19f17..177d2589de 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/IndexedPlutusScriptWitness.hs +++ b/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 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/Experimental/Tx/Internal/BodyContent/New.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs index 3d80128174..4172adf914 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs +++ b/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 diff --git a/cardano-api/src/Cardano/Api/Internal/Orphans/Serialisation.hs b/cardano-api/src/Cardano/Api/Internal/Orphans/Serialisation.hs index 524cd9dfb3..9a47a58166 100644 --- a/cardano-api/src/Cardano/Api/Internal/Orphans/Serialisation.hs +++ b/cardano-api/src/Cardano/Api/Internal/Orphans/Serialisation.hs @@ -287,6 +287,11 @@ deriving via instance Show (L.ConwayLedgerPredFailure ledgerera) => ToJSON (L.ConwayLedgerPredFailure ledgerera) +deriving via + ShowOf (L.DijkstraLedgerPredFailure ledgerera) + instance + Show (L.DijkstraLedgerPredFailure ledgerera) => ToJSON (L.DijkstraLedgerPredFailure ledgerera) + deriving via ShowOf (L.DijkstraMempoolPredFailure ledgerera) instance diff --git a/cardano-api/src/Cardano/Api/Tx.hs b/cardano-api/src/Cardano/Api/Tx.hs index 297f56946e..afcc797a65 100644 --- a/cardano-api/src/Cardano/Api/Tx.hs +++ b/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 diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs index 1821706a3c..2d420d9a54 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs +++ b/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) @@ -2430,6 +2430,17 @@ 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 @@ -2437,10 +2448,10 @@ extractWitnessableCertificates 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 = [] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs index 0c4720fbd9..679e9a4bdf 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs +++ b/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 @@ -59,7 +64,9 @@ import Test.Gen.Cardano.Api.Experimental (genAnyScript) import Test.Gen.Cardano.Api.Typed ( genAddressInEra , genPlutusScriptInEra + , genProposal , genSimpleScript + , genStakeCredential , genTx , genTxIn ) @@ -122,6 +129,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" @@ -673,6 +686,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 -- --------------------------------------------------------------------------- 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 -- --------------------------------------------------------------------------- diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/RedeemerIndex.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/RedeemerIndex.hs new file mode 100644 index 0000000000..ee96d9473a --- /dev/null +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/RedeemerIndex.hs @@ -0,0 +1,801 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +-- | Checks that the redeemer pointer index the API assigns to a +-- plutus-witnessed item agrees with the ledger's own resolution of that +-- index. +-- +-- Each property builds the real ledger container for its category (a +-- 'Set', 'StrictSeq', 'OSet' or 'Map', via +-- 'Cardano.Ledger.Alonzo.TxBody.Indexable') and compares against it +-- directly. +-- +-- Unlike 'prop_extractAllIndexedPlutusScriptWitnesses' in +-- "Test.Cardano.Api.Transaction.Body.Plutus.Scripts", which just counts +-- extracted witnesses, these go through the real +-- 'Cardano.Api.Experimental.Tx.mkTxCertificates' / +-- 'mkTxProposalProcedures' / 'mkTxVotingProcedures' and matching +-- @extractWitnessable*@ / @extractWitnessableCertificates@ functions. +-- +-- 'prop_oldApiCertRedeemerIndexMatchesLedgerIndexable', +-- 'prop_oldApiProposalRedeemerIndexMatchesLedgerIndexable' and +-- 'prop_oldApiVoteRedeemerIndexMatchesLedgerIndexable' instead drive the +-- deprecated old API path, via 'Cardano.Api.Tx.mkTxCertificates' / +-- 'mkTxProposalProcedures' / 'mkTxVotingProcedures' and matching +-- @extractWitnessable*@ / @extractWitnessableCertificates@ functions from +-- "Cardano.Api.Tx.Internal.Body". +-- +-- 'prop_createTransactionBody_redeemer_pointers_match_ledger' checks the +-- same fix end-to-end: it builds a real 'Cardano.Api.TxBody' via the +-- deprecated 'Cardano.Api.createTransactionBody' and asks the ledger's +-- own 'Cardano.Ledger.Alonzo.TxBody.redeemerPointer' where each +-- plutus-witnessed certificate landed, rather than comparing against a +-- hand-built oracle. +module Test.Cardano.Api.Transaction.Body.Plutus.RedeemerIndex + ( tests + ) +where + +import Cardano.Api (TxIn) +import Cardano.Api qualified as Api +import Cardano.Api.Experimental +import Cardano.Api.Experimental.AnyScriptWitness +import Cardano.Api.Experimental.Plutus hiding (AnyPlutusScript (..)) +import Cardano.Api.Experimental.Tx qualified as Exp +import Cardano.Api.Ledger qualified as L +import Cardano.Api.Plutus qualified as Script + +import Cardano.Ledger.Alonzo.Scripts (AsItem (..)) +import Cardano.Ledger.Alonzo.TxBody (Indexable (..)) +import Cardano.Ledger.Keys (coerceKeyRole) +import Cardano.Ledger.Plutus.Language qualified as L + +import Prelude + +import Data.Foldable (for_) +import Data.Function ((&)) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Maybe.Strict (StrictMaybe (SJust, SNothing)) +import Data.OSet.Strict qualified as OSet +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set qualified as Set +import Data.Word (Word32) + +import Test.Gen.Cardano.Api.Typed + ( genAddressInEra + , genPolicyAssets + , genPolicyId + , genProposal + , genStakeAddress + , genStakeCredential + , genTxIn + ) + +import Test.Cardano.Api.Orphans () + +import Hedgehog +import Hedgehog.Extras qualified as H +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +tests :: TestTree +tests = + testGroup + "Test.Cardano.Api.Transaction.Body.Plutus.RedeemerIndex" + [ testProperty + "Input redeemer index matches ledger Indexable oracle" + prop_txInRedeemerIndexMatchesLedgerIndexable + , testProperty + "Certificate redeemer index matches ledger Indexable oracle" + prop_certRedeemerIndexMatchesLedgerIndexable + , testProperty + "Old API certificate redeemer index matches ledger Indexable oracle" + prop_oldApiCertRedeemerIndexMatchesLedgerIndexable + , testProperty + "createTransactionBody redeemer pointers match the ledger's own resolution" + prop_createTransactionBody_redeemer_pointers_match_ledger + , testProperty + "Proposal redeemer index matches ledger Indexable oracle" + prop_proposalRedeemerIndexMatchesLedgerIndexable + , testProperty + "Old API proposal redeemer index matches ledger Indexable oracle" + prop_oldApiProposalRedeemerIndexMatchesLedgerIndexable + , testProperty + "Withdrawal redeemer index matches ledger Indexable oracle" + prop_withdrawalRedeemerIndexMatchesLedgerIndexable + , testProperty + "Vote redeemer index matches ledger Indexable oracle" + prop_voteRedeemerIndexMatchesLedgerIndexable + , testProperty + "Old API vote redeemer index matches ledger Indexable oracle" + prop_oldApiVoteRedeemerIndexMatchesLedgerIndexable + , testProperty + "Mint redeemer index matches ledger Indexable oracle" + prop_mintRedeemerIndexMatchesLedgerIndexable + ] + +-- --------------------------------------------------------------------------- +-- Inputs: oracle container is a 'Set' of ledger 'L.TxIn', Ord-ranked. +-- --------------------------------------------------------------------------- + +prop_txInRedeemerIndexMatchesLedgerIndexable :: Property +prop_txInRedeemerIndexMatchesLedgerIndexable = property $ do + n <- forAll $ Gen.int (Range.linear 2 6) + txIns <- + take n + <$> forAll (Gen.filter ((>= n) . length) $ List.nub <$> Gen.list (Range.singleton (n + 3)) genTxIn) + referenceTxIn <- forAll genTxIn + flags <- forAll $ Gen.list (Range.singleton n) Gen.bool + pairs <- forAll $ Gen.shuffle (zip txIns flags) + + cover 20 "at least one witnessed input" $ any snd pairs + cover 20 "at least one unwitnessed input" $ not (all snd pairs) + + let toWit witnessed = if witnessed then sharedSpendingWitness referenceTxIn else Exp.AnyKeyWitnessPlaceholder + apiInputs = [(txIn, toWit witnessed) | (txIn, witnessed) <- pairs] + oracle = Set.fromList $ map (Api.toShelleyTxIn . fst) pairs + extracted = Exp.extractWitnessableTxIns @ConwayEra apiInputs + indexed = createIndexedPlutusScriptWitnesses extracted + + length indexed === length (filter snd pairs) + assertRedeemerMapSize extracted (length indexed) + + for_ indexed $ \(AnyIndexedPlutusScriptWitness (IndexedPlutusScriptWitness witnessable purpose _)) -> + case witnessable of + WitTxIn txIn -> do + idx <- H.nothingFail $ asSpendingIndex purpose + indexOf (AsItem (Api.toShelleyTxIn txIn)) oracle === SJust (L.AsIx idx) + _ -> do + annotate "impossible: WitTxIn always produces a ConwaySpending purpose" + failure :: PropertyT IO () + +-- --------------------------------------------------------------------------- +-- Certificates: oracle container is a 'StrictSeq' of ledger 'L.TxCert', positional +-- (insertion order), matching 'certsTxBodyL'. +-- --------------------------------------------------------------------------- + +-- | Certs are laid out as an unwitnessed prefix followed by a witnessed +-- suffix. Dropping unwitnessed certs in 'extractWitnessableCertificates' +-- would then deterministically shift the witnessed certs' indices, not +-- just occasionally. +prop_certRedeemerIndexMatchesLedgerIndexable :: Property +prop_certRedeemerIndexMatchesLedgerIndexable = property $ do + unwitnessedCount <- forAll $ Gen.int (Range.constant 0 4) + witnessedCount <- forAll $ Gen.int (Range.constant 1 4) + let total = unwitnessedCount + witnessedCount + creds <- + take total + <$> forAll + ( Gen.filter ((>= total) . length) $ + List.nub <$> Gen.list (Range.singleton (total + 3)) genStakeCredential + ) + shuffledCreds <- forAll $ Gen.shuffle creds + referenceTxIn <- forAll genTxIn + + let (unwitnessedCreds, witnessedCreds) = List.splitAt unwitnessedCount shuffledCreds + -- A plain stake registration without a deposit never carries a + -- witness ('getTxCertWitness' returns 'Nothing' for it): the + -- "unwitnessed" half. + mkUnwitnessedCert cred = L.ConwayTxCertDeleg $ L.ConwayRegCert (Api.toShelleyStakeCredential cred) SNothing + -- A stake delegation always carries a (possibly placeholder) + -- witness: the "witnessed" half. + mkWitnessedCert cred = + L.ConwayTxCertDeleg $ + L.ConwayDelegCert (Api.toShelleyStakeCredential cred) (L.DelegVote L.DRepAlwaysAbstain) + unwitnessedCerts = map mkUnwitnessedCert unwitnessedCreds + witnessedCerts = map mkWitnessedCert witnessedCreds + orderedCerts = unwitnessedCerts ++ witnessedCerts + + cover 20 "at least two witnessed certs" $ length witnessedCerts >= 2 + cover 20 "at least two unwitnessed certs" $ length unwitnessedCerts >= 2 + + let apiCerts = + [(Certificate cert, Exp.AnyKeyWitnessPlaceholder) | cert <- unwitnessedCerts] + ++ [(Certificate cert, sharedCertifyingWitness referenceTxIn) | cert <- witnessedCerts] + txCertificates = Exp.mkTxCertificates ConwayEra apiCerts + extracted = Exp.extractWitnessableCertificates @ConwayEra txCertificates + indexed = createIndexedPlutusScriptWitnesses extracted + oracle = StrictSeq.fromList orderedCerts + + length indexed === length witnessedCerts + assertRedeemerMapSize extracted (length indexed) + + for_ indexed $ \(AnyIndexedPlutusScriptWitness (IndexedPlutusScriptWitness witnessable purpose _)) -> + case witnessable of + WitTxCert cert -> do + idx <- H.nothingFail $ asCertifyingIndex purpose + indexOf (AsItem cert) oracle === SJust (L.AsIx idx) + _ -> do + annotate "impossible: WitTxCert always produces a ConwayCertifying purpose" + failure :: PropertyT IO () + +-- | Regression test for the deprecated old API path. Drives +-- 'Cardano.Api.Tx.mkTxCertificates' and 'extractWitnessableCertificates' +-- directly, rather than their experimental counterparts used by +-- 'prop_certRedeemerIndexMatchesLedgerIndexable' above. Certs are laid out +-- the same way, an unwitnessed prefix followed by a witnessed suffix, so +-- dropping the unwitnessed prefix shifts every witnessed cert's index. +prop_oldApiCertRedeemerIndexMatchesLedgerIndexable :: Property +prop_oldApiCertRedeemerIndexMatchesLedgerIndexable = property $ do + unwitnessedCount <- forAll $ Gen.int (Range.constant 0 4) + witnessedCount <- forAll $ Gen.int (Range.constant 1 4) + let total = unwitnessedCount + witnessedCount + creds <- + take total + <$> forAll + ( Gen.filter ((>= total) . length) $ + List.nub <$> Gen.list (Range.singleton (total + 3)) genStakeCredential + ) + shuffledCreds <- forAll $ Gen.shuffle creds + referenceTxIn <- forAll genTxIn + + let (unwitnessedCreds, witnessedCreds) = List.splitAt unwitnessedCount shuffledCreds + -- Same rule as 'prop_certRedeemerIndexMatchesLedgerIndexable': a plain + -- stake registration without a deposit never carries a witness. + mkUnwitnessedCert cred = L.ConwayTxCertDeleg $ L.ConwayRegCert (Api.toShelleyStakeCredential cred) SNothing + mkWitnessedCert cred = + L.ConwayTxCertDeleg $ + L.ConwayDelegCert (Api.toShelleyStakeCredential cred) (L.DelegVote L.DRepAlwaysAbstain) + unwitnessedCerts = map mkUnwitnessedCert unwitnessedCreds + witnessedCerts = map mkWitnessedCert witnessedCreds + orderedCerts = unwitnessedCerts ++ witnessedCerts + + cover 20 "at least two witnessed certs" $ length witnessedCerts >= 2 + cover 20 "at least two unwitnessed certs" $ length unwitnessedCerts >= 2 + + let apiCerts = + [(Certificate cert, Nothing) | cert <- unwitnessedCerts] + ++ [(Certificate cert, Just (oldApiStakeWitness referenceTxIn)) | cert <- witnessedCerts] + txCertificates = Api.mkTxCertificates Api.ShelleyBasedEraConway apiCerts + extracted = Api.extractWitnessableCertificates Api.AlonzoEraOnwardsConway txCertificates + oracle = StrictSeq.fromList orderedCerts + + indexed <- indexOldApiWitnessed Api.AlonzoEraOnwardsConway extracted + + length indexed === length witnessedCerts + + for_ indexed $ \(AnyIndexedPlutusScriptWitness (IndexedPlutusScriptWitness witnessable purpose _)) -> + case witnessable of + WitTxCert cert -> do + idx <- H.nothingFail $ asCertifyingIndex purpose + indexOf (AsItem cert) oracle === SJust (L.AsIx idx) + _ -> do + annotate "impossible: WitTxCert always produces a ConwayCertifying purpose" + failure :: PropertyT IO () + +-- | End-to-end regression test for the deprecated old API path, one level +-- up from 'prop_oldApiCertRedeemerIndexMatchesLedgerIndexable': instead of +-- calling 'Api.extractWitnessableCertificates' directly, this drives it through +-- the real 'Cardano.Api.createTransactionBody' and asks the resulting +-- ledger 'L.TxBody' where each plutus-witnessed certificate's redeemer +-- landed via 'L.redeemerPointer', the ledger's own inverse of the indexing +-- this module tests. This catches a mismatch between the extractor and the +-- rest of body construction, not just a bug in the extractor itself. +prop_createTransactionBody_redeemer_pointers_match_ledger :: Property +prop_createTransactionBody_redeemer_pointers_match_ledger = property $ do + unwitnessedCount <- forAll $ Gen.int (Range.constant 0 4) + witnessedCount <- forAll $ Gen.int (Range.constant 1 4) + let total = unwitnessedCount + witnessedCount + creds <- + take total + <$> forAll + ( Gen.filter ((>= total) . length) $ + List.nub <$> Gen.list (Range.singleton (total + 3)) genStakeCredential + ) + shuffledCreds <- forAll $ Gen.shuffle creds + referenceTxIn <- forAll genTxIn + srcTxIn <- forAll genTxIn + destAddress <- forAll $ genAddressInEra Api.ShelleyBasedEraConway + + let (unwitnessedCreds, witnessedCreds) = List.splitAt unwitnessedCount shuffledCreds + -- Same rule as 'prop_certRedeemerIndexMatchesLedgerIndexable': a plain + -- stake registration without a deposit never carries a witness. + mkUnwitnessedCert cred = L.ConwayTxCertDeleg $ L.ConwayRegCert (Api.toShelleyStakeCredential cred) SNothing + mkWitnessedCert cred = + L.ConwayTxCertDeleg $ + L.ConwayDelegCert (Api.toShelleyStakeCredential cred) (L.DelegVote L.DRepAlwaysAbstain) + unwitnessedCerts = map mkUnwitnessedCert unwitnessedCreds + witnessedCerts = map mkWitnessedCert witnessedCreds + + cover 20 "at least two witnessed certs" $ length witnessedCerts >= 2 + cover 20 "at least two unwitnessed certs" $ length unwitnessedCerts >= 2 + + let + -- Every witnessed cert gets its own redeemer, tagged by its position + -- in 'witnessedCerts'. Unlike the shared 'oldApiStakeWitness' used + -- elsewhere in this module (whose content never matters, since those + -- properties only check index arithmetic), distinct redeemers here + -- let the assertion below pin each cert to *its own* map entry, not + -- merely to some entry: a hypothetical pointer swap between two + -- certs would go undetected with a shared redeemer, since both + -- entries would be identical. + mkRedeemer :: Integer -> Script.HashableScriptData + mkRedeemer tag = Script.unsafeHashableScriptData $ Script.ScriptDataConstructor tag [] + executionUnits = Script.ExecutionUnits 0 0 + mkWitness tag = + Script.PlutusScriptWitness + Script.PlutusScriptV3InConway + Script.PlutusScriptV3 + (Script.PReferenceScript referenceTxIn) + Script.NoScriptDatumForStake + (mkRedeemer tag) + executionUnits + witnessedCertsWithTags = zip witnessedCerts [0 ..] + + let apiCerts = + [(Certificate cert, Nothing) | cert <- unwitnessedCerts] + ++ [(Certificate cert, Just (mkWitness tag)) | (cert, tag) <- witnessedCertsWithTags] + txBodyContent = + Api.defaultTxBodyContent Api.ShelleyBasedEraConway + & Api.setTxIns [(srcTxIn, Api.BuildTxWith (Api.KeyWitness Api.KeyWitnessForSpending))] + & Api.setTxOuts + [ Api.TxOut + destAddress + (Api.lovelaceToTxOutValue Api.ShelleyBasedEraConway 10_000_000) + Api.TxOutDatumNone + Script.ReferenceScriptNone + ] + & Api.setTxFee (Api.TxFeeExplicit Api.ShelleyBasedEraConway 2_000_000) + & Api.setTxCertificates (Api.mkTxCertificates Api.ShelleyBasedEraConway apiCerts) + + Api.ShelleyTxBody _ builtLedgerBody _ builtScriptData _ _ <- + evalEither $ Api.createTransactionBody Api.ShelleyBasedEraConway txBodyContent + + case builtScriptData of + Api.TxBodyScriptData _ _ (L.Redeemers redeemerMap) -> do + Map.size redeemerMap === length witnessedCerts + + for_ witnessedCertsWithTags $ \(cert, tag) -> do + let expectedRedeemerPair = (Api.toAlonzoData (mkRedeemer tag), Api.toAlonzoExUnits executionUnits) + case L.redeemerPointer builtLedgerBody (L.mkCertifyingPurpose (AsItem cert)) of + SJust purposeIx -> Map.lookup purposeIx redeemerMap === Just expectedRedeemerPair + SNothing -> annotate "redeemerPointer returned Nothing for a plutus-witnessed cert" >> failure + Api.TxBodyNoScriptData -> + annotate + "impossible: Conway is Alonzo-onwards, createTransactionBody always attaches TxBodyScriptData" + >> failure + +-- --------------------------------------------------------------------------- +-- Proposals: oracle container is an 'OSet' of ledger 'L.ProposalProcedure', positional +-- (insertion order), matching 'proposalProceduresTxBodyL'. +-- --------------------------------------------------------------------------- + +-- | Insertion order is forced to be the exact reverse of 'Ord' order. +-- 'pProcDeposit' is the first field 'Ord' compares; making it strictly +-- decrease as each proposal is inserted guarantees every generated case +-- disagrees with Ord-based indexing, not just some of them. +prop_proposalRedeemerIndexMatchesLedgerIndexable :: Property +prop_proposalRedeemerIndexMatchesLedgerIndexable = property $ do + n <- forAll $ Gen.int (Range.linear 2 6) + baseProposals <- forAll $ Gen.list (Range.singleton n) (genProposal Api.ConwayEraOnwardsConway) + referenceTxIn <- forAll genTxIn + flags <- forAll $ Gen.list (Range.singleton n) Gen.bool + + let orderedProposals = + [ proposal{L.pProcDeposit = L.Coin (fromIntegral (n - i) * 1_000_000)} + | (i, proposal) <- zip [0 :: Int ..] baseProposals + ] + + cover 20 "at least one witnessed proposal" $ or flags + cover 20 "at least one unwitnessed proposal" $ not (and flags) + + let toWit witnessed = if witnessed then sharedProposingWitness referenceTxIn else Exp.AnyKeyWitnessPlaceholder + apiProposals = zipWith (\proposal witnessed -> (proposal, toWit witnessed)) orderedProposals flags + txProposals = Exp.mkTxProposalProcedures @ConwayEra apiProposals + extracted = Exp.extractWitnessableProposals @ConwayEra (Just txProposals) + indexed = createIndexedPlutusScriptWitnesses extracted + oracle = OSet.fromList orderedProposals + + length indexed === length (filter id flags) + assertRedeemerMapSize extracted (length indexed) + + for_ indexed $ \(AnyIndexedPlutusScriptWitness (IndexedPlutusScriptWitness witnessable purpose _)) -> + case witnessable of + WitProposal proposal -> do + idx <- H.nothingFail $ asProposingIndex purpose + indexOf (AsItem proposal) oracle === SJust (L.AsIx idx) + _ -> do + annotate "impossible: WitProposal always produces a ConwayProposing purpose" + failure :: PropertyT IO () + +-- | Regression test for the deprecated old API path. Drives +-- 'Cardano.Api.Tx.mkTxProposalProcedures' and +-- 'Cardano.Api.Tx.Internal.Body.extractWitnessableProposals' directly, +-- rather than their experimental counterparts used by +-- 'prop_proposalRedeemerIndexMatchesLedgerIndexable' above. Same insertion +-- order trick, with a mix of witnessed and unwitnessed proposals. +prop_oldApiProposalRedeemerIndexMatchesLedgerIndexable :: Property +prop_oldApiProposalRedeemerIndexMatchesLedgerIndexable = property $ do + n <- forAll $ Gen.int (Range.linear 2 6) + baseProposals <- forAll $ Gen.list (Range.singleton n) (genProposal Api.ConwayEraOnwardsConway) + referenceTxIn <- forAll genTxIn + flags <- forAll $ Gen.list (Range.singleton n) Gen.bool + + let orderedProposals = + [ proposal{L.pProcDeposit = L.Coin (fromIntegral (n - i) * 1_000_000)} + | (i, proposal) <- zip [0 :: Int ..] baseProposals + ] + + cover 20 "at least one witnessed proposal" $ or flags + cover 20 "at least one unwitnessed proposal" $ not (and flags) + + let toWit witnessed = if witnessed then Just (oldApiStakeWitness referenceTxIn) else Nothing + apiProposals = zipWith (\proposal witnessed -> (proposal, toWit witnessed)) orderedProposals flags + txProposals = Api.mkTxProposalProcedures @ConwayEra apiProposals + extracted = + Api.extractWitnessableProposals + Api.ConwayEraOnwardsConway + (Just (Api.Featured Api.ConwayEraOnwardsConway txProposals)) + oracle = OSet.fromList orderedProposals + + indexed <- indexOldApiWitnessed Api.AlonzoEraOnwardsConway extracted + + length indexed === length (filter id flags) + + for_ indexed $ \(AnyIndexedPlutusScriptWitness (IndexedPlutusScriptWitness witnessable purpose _)) -> + case witnessable of + WitProposal proposal -> do + idx <- H.nothingFail $ asProposingIndex purpose + indexOf (AsItem proposal) oracle === SJust (L.AsIx idx) + _ -> do + annotate "impossible: WitProposal always produces a ConwayProposing purpose" + failure :: PropertyT IO () + +-- --------------------------------------------------------------------------- +-- Withdrawals: oracle container is a 'Map' of ledger reward accounts, Ord-ranked, +-- matching 'unWithdrawals' of 'withdrawalsTxBodyL'. +-- --------------------------------------------------------------------------- + +prop_withdrawalRedeemerIndexMatchesLedgerIndexable :: Property +prop_withdrawalRedeemerIndexMatchesLedgerIndexable = property $ do + n <- forAll $ Gen.int (Range.linear 2 6) + addrs <- + take n + <$> forAll + (Gen.filter ((>= n) . length) $ List.nub <$> Gen.list (Range.singleton (n + 3)) genStakeAddress) + coins <- forAll $ Gen.list (Range.singleton n) (L.Coin <$> Gen.integral (Range.linear 1 10_000_000)) + referenceTxIn <- forAll genTxIn + flags <- forAll $ Gen.list (Range.singleton n) Gen.bool + shuffled <- forAll $ Gen.shuffle (zip3 addrs coins flags) + + cover 20 "at least one witnessed withdrawal" $ any (\(_, _, w) -> w) shuffled + cover 20 "at least one unwitnessed withdrawal" $ any (\(_, _, w) -> not w) shuffled + + let toWit witnessed = if witnessed then sharedWithdrawingWitness referenceTxIn else Exp.AnyKeyWitnessPlaceholder + apiWithdrawals = Exp.TxWithdrawals [(addr, coin, toWit w) | (addr, coin, w) <- shuffled] + extracted = Exp.extractWitnessableWithdrawals @ConwayEra apiWithdrawals + indexed = createIndexedPlutusScriptWitnesses extracted + oracle = Map.fromList [(Api.toShelleyStakeAddr addr, coin) | (addr, coin, _) <- shuffled] + + length indexed === length (filter (\(_, _, w) -> w) shuffled) + assertRedeemerMapSize extracted (length indexed) + + for_ indexed $ \(AnyIndexedPlutusScriptWitness (IndexedPlutusScriptWitness witnessable purpose _)) -> + case witnessable of + WitWithdrawal addr _coin -> do + idx <- H.nothingFail $ asRewardingIndex purpose + indexOf (AsItem (Api.toShelleyStakeAddr addr)) oracle === SJust (L.AsIx idx) + _ -> do + annotate "impossible: WitWithdrawal always produces a ConwayRewarding purpose" + failure :: PropertyT IO () + +-- --------------------------------------------------------------------------- +-- Votes: oracle container is a ledger 'L.VotingProcedures' (Map-derived), Ord-ranked on +-- the voter, matching the 'Indexable Voter (VotingProcedures era)' instance. +-- --------------------------------------------------------------------------- + +prop_voteRedeemerIndexMatchesLedgerIndexable :: Property +prop_voteRedeemerIndexMatchesLedgerIndexable = property $ do + n <- forAll $ Gen.int (Range.linear 2 6) + voters <- + take n + <$> forAll (Gen.filter ((>= n) . length) $ List.nub <$> Gen.list (Range.singleton (n + 3)) genVoter) + referenceTxIn <- forAll genTxIn + govActionId <- forAll genGovActionId + flags <- forAll $ Gen.list (Range.singleton n) Gen.bool + shuffled <- forAll $ Gen.shuffle (zip voters flags) + + cover 20 "at least one witnessed vote" $ any snd shuffled + cover 20 "at least one unwitnessed vote" $ not (all snd shuffled) + + let toWit witnessed = if witnessed then sharedVotingWitness referenceTxIn else Exp.AnyKeyWitnessPlaceholder + votingProcedure = L.VotingProcedure L.VoteYes SNothing + votingProcedurePairs = + [ (L.VotingProcedures (Map.singleton voter (Map.singleton govActionId votingProcedure)), toWit w) + | (voter, w) <- shuffled + ] + + txVotingProcedures <- + H.leftFail $ Exp.mkTxVotingProcedures @(LedgerEra ConwayEra) votingProcedurePairs + + let extracted = Exp.extractWitnessableVotes @ConwayEra (Just txVotingProcedures) + indexed = createIndexedPlutusScriptWitnesses extracted + oracle = + L.VotingProcedures $ + Map.fromList [(voter, Map.singleton govActionId votingProcedure) | (voter, _) <- shuffled] + + length indexed === length (filter snd shuffled) + assertRedeemerMapSize extracted (length indexed) + + for_ indexed $ \(AnyIndexedPlutusScriptWitness (IndexedPlutusScriptWitness witnessable purpose _)) -> + case witnessable of + WitVote voter -> do + idx <- H.nothingFail $ asVotingIndex purpose + indexOf (AsItem voter) oracle === SJust (L.AsIx idx) + _ -> do + annotate "impossible: WitVote always produces a ConwayVoting purpose" + failure :: PropertyT IO () + +-- | Regression test for the deprecated old API path. Drives +-- 'Cardano.Api.Tx.mkTxVotingProcedures' and +-- 'Cardano.Api.Tx.Internal.Body.extractWitnessableVotes' directly, rather +-- than their experimental counterparts used by +-- 'prop_voteRedeemerIndexMatchesLedgerIndexable' above. Same witness map +-- with some voters missing. +prop_oldApiVoteRedeemerIndexMatchesLedgerIndexable :: Property +prop_oldApiVoteRedeemerIndexMatchesLedgerIndexable = property $ do + n <- forAll $ Gen.int (Range.linear 2 6) + voters <- + take n + <$> forAll (Gen.filter ((>= n) . length) $ List.nub <$> Gen.list (Range.singleton (n + 3)) genVoter) + referenceTxIn <- forAll genTxIn + govActionId <- forAll genGovActionId + flags <- forAll $ Gen.list (Range.singleton n) Gen.bool + shuffled <- forAll $ Gen.shuffle (zip voters flags) + + cover 20 "at least one witnessed vote" $ any snd shuffled + cover 20 "at least one unwitnessed vote" $ not (all snd shuffled) + + let votingProcedure = L.VotingProcedure L.VoteYes SNothing + toWit witnessed = if witnessed then Just (oldApiStakeWitness referenceTxIn) else Nothing + votingProcedurePairs = + [ ( Api.VotingProcedures + (L.VotingProcedures (Map.singleton voter (Map.singleton govActionId votingProcedure))) + , toWit w + ) + | (voter, w) <- shuffled + ] + + txVotingProcedures <- + H.leftFail $ Api.mkTxVotingProcedures @Api.BuildTx @ConwayEra votingProcedurePairs + + let extracted = + Api.extractWitnessableVotes + Api.ConwayEraOnwardsConway + (Just (Api.Featured Api.ConwayEraOnwardsConway txVotingProcedures)) + oracle = + L.VotingProcedures $ + Map.fromList [(voter, Map.singleton govActionId votingProcedure) | (voter, _) <- shuffled] + + indexed <- indexOldApiWitnessed Api.AlonzoEraOnwardsConway extracted + + length indexed === length (filter snd shuffled) + + for_ indexed $ \(AnyIndexedPlutusScriptWitness (IndexedPlutusScriptWitness witnessable purpose _)) -> + case witnessable of + WitVote voter -> do + idx <- H.nothingFail $ asVotingIndex purpose + indexOf (AsItem voter) oracle === SJust (L.AsIx idx) + _ -> do + annotate "impossible: WitVote always produces a ConwayVoting purpose" + failure :: PropertyT IO () + +-- --------------------------------------------------------------------------- +-- Mint: oracle container is a 'Set' of ledger 'L.PolicyID', Ord-ranked, +-- matching 'mintedTxBodyF'. Minting has no key-witness placeholder: every +-- policy is witnessed by some script, so "unwitnessed" here means +-- simple-script-witnessed, not plutus-witnessed. +-- --------------------------------------------------------------------------- + +prop_mintRedeemerIndexMatchesLedgerIndexable :: Property +prop_mintRedeemerIndexMatchesLedgerIndexable = property $ do + n <- forAll $ Gen.int (Range.linear 2 6) + policyIds <- + take n + <$> forAll (Gen.filter ((>= n) . length) $ List.nub <$> Gen.list (Range.singleton (n + 3)) genPolicyId) + assetsList <- forAll $ Gen.list (Range.singleton n) genPolicyAssets + referenceTxIn <- forAll genTxIn + flags <- forAll $ Gen.list (Range.singleton n) Gen.bool + shuffled <- forAll $ Gen.shuffle (zip3 policyIds assetsList flags) + + cover 20 "at least one plutus-witnessed policy" $ any (\(_, _, w) -> w) shuffled + cover 20 "at least one simple-script-witnessed policy" $ any (\(_, _, w) -> not w) shuffled + + let toWit witnessed = + if witnessed + then sharedMintingWitness referenceTxIn + else AnyScriptWitnessSimple (SReferenceScript referenceTxIn) + mintValue = Exp.TxMintValue $ Map.fromList [(pid, (assets, toWit w)) | (pid, assets, w) <- shuffled] + extractedRaw = Exp.extractWitnessableMints @ConwayEra mintValue + extracted = [(wit, anyScriptWitnessToAnyWitness sw) | (wit, sw) <- extractedRaw] + indexed = createIndexedPlutusScriptWitnesses extracted + oracle = Set.fromList [toLedgerPolicyID pid | (pid, _, _) <- shuffled] + + length indexed === length (filter (\(_, _, w) -> w) shuffled) + assertRedeemerMapSize extracted (length indexed) + + for_ indexed $ \(AnyIndexedPlutusScriptWitness (IndexedPlutusScriptWitness witnessable purpose _)) -> + case witnessable of + WitMint policyId _assets -> do + idx <- H.nothingFail $ asMintingIndex purpose + indexOf (AsItem (toLedgerPolicyID policyId)) oracle === SJust (L.AsIx idx) + _ -> do + annotate "impossible: WitMint always produces a ConwayMinting purpose" + failure :: PropertyT IO () + +-- --------------------------------------------------------------------------- +-- Purpose index extraction (pure, one per category) +-- --------------------------------------------------------------------------- + +-- TODO: replace these projections with toPlutusScriptPurposeIndex (added on master in +-- 284d0bd5dd, after this branch's fork point) when the branch is rebased. + +-- | Each function matches one expected 'L.ConwayPlutusPurpose' constructor +-- and falls back to 'Nothing' for the rest (statically unreachable, but +-- not provably so to GHC). Same defensive-wildcard pattern as elsewhere +-- in the ledger/api integration; see AGENTS.md's GADT gotchas. +asSpendingIndex + , asCertifyingIndex + , asProposingIndex + , asRewardingIndex + , asVotingIndex + , asMintingIndex + :: L.PlutusPurpose L.AsIx (LedgerEra ConwayEra) -> Maybe Word32 +asSpendingIndex (L.ConwaySpending (L.AsIx idx)) = Just idx +asSpendingIndex _ = Nothing +asCertifyingIndex (L.ConwayCertifying (L.AsIx idx)) = Just idx +asCertifyingIndex _ = Nothing +asProposingIndex (L.ConwayProposing (L.AsIx idx)) = Just idx +asProposingIndex _ = Nothing +asRewardingIndex (L.ConwayRewarding (L.AsIx idx)) = Just idx +asRewardingIndex _ = Nothing +asVotingIndex (L.ConwayVoting (L.AsIx idx)) = Just idx +asVotingIndex _ = Nothing +asMintingIndex (L.ConwayMinting (L.AsIx idx)) = Just idx +asMintingIndex _ = Nothing + +-- | Run the shared old-API legacy-witness pipeline: convert extracted +-- witnessable/witness pairs into indexed plutus script witnesses, and +-- check the redeemer map has exactly one entry per indexed witness. +-- +-- Shared by every old-API regression property above +-- ('prop_oldApiCertRedeemerIndexMatchesLedgerIndexable', +-- 'prop_oldApiProposalRedeemerIndexMatchesLedgerIndexable', +-- 'prop_oldApiVoteRedeemerIndexMatchesLedgerIndexable') to avoid a +-- three-way copy of the "convert, index, assert-size" glue between the +-- cert, proposal and vote twins. +indexOldApiWitnessed + :: (MonadTest m, L.AlonzoEraScript (Api.ShelleyLedgerEra era)) + => Api.AlonzoEraOnwards era + -> [ ( Witnessable witnessable (Api.ShelleyLedgerEra era) + , Api.BuildTxWith Api.BuildTx (Script.Witness ctx era) + ) + ] + -> m [AnyIndexedPlutusScriptWitness (Api.ShelleyLedgerEra era)] +indexOldApiWitnessed aeon extracted = do + converted <- H.leftFail $ legacyWitnessConversion aeon extracted + let indexed = createIndexedPlutusScriptWitnesses converted + assertRedeemerMapSize converted (length indexed) + pure indexed + +-- | Sanity check: the redeemer map's size must equal exactly the count of +-- plutus-witnessed items extracted (nothing extra, nothing missing). +assertRedeemerMapSize + :: (MonadTest m, L.AlonzoEraScript era) + => [(Witnessable witnessable era, Exp.AnyWitness era)] + -> Int + -> m () +assertRedeemerMapSize extracted expectedCount = do + let L.Redeemers redeemerMap = getAnyWitnessRedeemerPointerMap extracted + Map.size redeemerMap === expectedCount + +-- --------------------------------------------------------------------------- +-- Shared witness/redeemer fixtures +-- --------------------------------------------------------------------------- + +-- | The single Plutus witness reused for every plutus-witnessed item in +-- this module. +-- +-- Witness content (redeemer, execution units, reference script) has no +-- bearing on redeemer indexing. Only the witnessed item's identity and +-- whether it is witnessed at all matter, so one shared witness suffices. +sharedPlutusScriptWitness + :: TxIn -> PlutusScriptWitness L.PlutusV3 purpose (LedgerEra ConwayEra) +sharedPlutusScriptWitness referenceTxIn = + PlutusScriptWitness + L.SPlutusV3 + (PReferenceScript referenceTxIn) + NoScriptDatum + sharedRedeemer + sharedExecutionUnits + where + sharedRedeemer = Script.unsafeHashableScriptData $ Script.ScriptDataConstructor 0 [] + sharedExecutionUnits = Script.ExecutionUnits 0 0 + +sharedSpendingWitness :: TxIn -> Exp.AnyWitness (LedgerEra ConwayEra) +sharedSpendingWitness referenceTxIn = + Exp.AnyPlutusScriptWitness $ + AnyPlutusSpendingScriptWitness $ + PlutusSpendingScriptWitnessV3 (sharedPlutusScriptWitness referenceTxIn) + +sharedCertifyingWitness :: TxIn -> Exp.AnyWitness (LedgerEra ConwayEra) +sharedCertifyingWitness referenceTxIn = + Exp.AnyPlutusScriptWitness $ + AnyPlutusCertifyingScriptWitness (sharedPlutusScriptWitness referenceTxIn) + +sharedProposingWitness :: TxIn -> Exp.AnyWitness (LedgerEra ConwayEra) +sharedProposingWitness referenceTxIn = + Exp.AnyPlutusScriptWitness $ + AnyPlutusProposingScriptWitness (sharedPlutusScriptWitness referenceTxIn) + +sharedWithdrawingWitness :: TxIn -> Exp.AnyWitness (LedgerEra ConwayEra) +sharedWithdrawingWitness referenceTxIn = + Exp.AnyPlutusScriptWitness $ + AnyPlutusWithdrawingScriptWitness (sharedPlutusScriptWitness referenceTxIn) + +sharedVotingWitness :: TxIn -> Exp.AnyWitness (LedgerEra ConwayEra) +sharedVotingWitness referenceTxIn = + Exp.AnyPlutusScriptWitness $ AnyPlutusVotingScriptWitness (sharedPlutusScriptWitness referenceTxIn) + +sharedMintingWitness :: TxIn -> AnyScriptWitness (LedgerEra ConwayEra) +sharedMintingWitness referenceTxIn = + AnyScriptWitnessPlutus $ AnyPlutusMintingScriptWitness (sharedPlutusScriptWitness referenceTxIn) + +-- | The old API's counterpart to 'sharedCertifyingWitness' / +-- 'sharedProposingWitness' / 'sharedVotingWitness'. Unlike the experimental +-- API, the old API has no separate witness type per purpose: certificates, +-- proposals and votes are all witnessed under 'Script.WitCtxStake', so one +-- shared witness value covers all three old-API regression properties +-- ('prop_oldApiCertRedeemerIndexMatchesLedgerIndexable', +-- 'prop_oldApiProposalRedeemerIndexMatchesLedgerIndexable', +-- 'prop_oldApiVoteRedeemerIndexMatchesLedgerIndexable'). Witness content has +-- no bearing on redeemer indexing (see 'sharedPlutusScriptWitness'), so this +-- is built directly rather than shared with the experimental fixtures above. +oldApiStakeWitness :: TxIn -> Script.ScriptWitness Script.WitCtxStake ConwayEra +oldApiStakeWitness referenceTxIn = + Script.PlutusScriptWitness + Script.PlutusScriptV3InConway + Script.PlutusScriptV3 + (Script.PReferenceScript referenceTxIn) + Script.NoScriptDatumForStake + sharedRedeemer + sharedExecutionUnits + where + sharedRedeemer = Script.unsafeHashableScriptData $ Script.ScriptDataConstructor 0 [] + sharedExecutionUnits = Script.ExecutionUnits 0 0 + +-- --------------------------------------------------------------------------- +-- Small generators not already provided by Test.Gen.Cardano.Api.Typed +-- --------------------------------------------------------------------------- + +-- | 'genStakeCredential' only ever produces 'StakeCredentialByKey', so converting to +-- ledger and coercing the key role never actually fails the pattern match below. +genVoter :: Gen L.Voter +genVoter = do + cred <- Api.toShelleyStakeCredential <$> genStakeCredential + case cred of + L.KeyHashObj keyHash -> + Gen.element + [ L.CommitteeVoter (L.KeyHashObj (coerceKeyRole keyHash)) + , L.DRepVoter (L.KeyHashObj (coerceKeyRole keyHash)) + , L.StakePoolVoter (coerceKeyRole keyHash) + ] + L.ScriptHashObj{} -> Gen.discard + +-- | The governance action a vote targets has no bearing on redeemer indexing (only the +-- voter's identity does), so one fixed action id shared by every generated vote is fine. +genGovActionId :: Gen L.GovActionId +genGovActionId = do + L.TxIn txId _ <- Api.toShelleyTxIn <$> genTxIn + pure $ L.GovActionId txId (L.GovActionIx 0) + +toLedgerPolicyID :: Api.PolicyId -> L.PolicyID +toLedgerPolicyID (Api.PolicyId scriptHash) = L.PolicyID (Script.toShelleyScriptHash scriptHash) diff --git a/cardano-api/test/cardano-api-test/cardano-api-test.hs b/cardano-api/test/cardano-api-test/cardano-api-test.hs index adb0a82bf1..12b7e17162 100644 --- a/cardano-api/test/cardano-api-test/cardano-api-test.hs +++ b/cardano-api/test/cardano-api-test/cardano-api-test.hs @@ -28,6 +28,7 @@ import Test.Cardano.Api.Metadata qualified import Test.Cardano.Api.Ord qualified import Test.Cardano.Api.RawBytes qualified import Test.Cardano.Api.Transaction.Autobalance qualified +import Test.Cardano.Api.Transaction.Body.Plutus.RedeemerIndex qualified import Test.Cardano.Api.Transaction.Body.Plutus.Scripts qualified import Test.Cardano.Api.Transaction.Collateral qualified import Test.Cardano.Api.TxBody qualified @@ -69,6 +70,7 @@ tests = , Test.Cardano.Api.Metadata.tests , Test.Cardano.Api.Ord.tests , Test.Cardano.Api.RawBytes.tests + , Test.Cardano.Api.Transaction.Body.Plutus.RedeemerIndex.tests , Test.Cardano.Api.Transaction.Body.Plutus.Scripts.tests , Test.Cardano.Api.Transaction.Autobalance.tests , Test.Cardano.Api.Transaction.Collateral.tests