From 60194a81a37ced7ecee821687d1e8721b6c5232f Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Mon, 25 Nov 2024 20:34:18 +0100 Subject: [PATCH] Add certs support in compatible Tx building --- .../Cardano/Api/Eon/BabbageEraOnwards.hs | 5 + .../Cardano/Api/Eon/ConwayEraOnwards.hs | 5 + cardano-api/internal/Cardano/Api/Tx/Body.hs | 19 +- .../internal/Cardano/Api/Tx/Compatible.hs | 238 +++++++++++------- 4 files changed, 166 insertions(+), 101 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs index 811d23d0ef..795b848529 100644 --- a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs @@ -83,6 +83,11 @@ instance Convert BabbageEraOnwards MaryEraOnwards where BabbageEraOnwardsBabbage -> MaryEraOnwardsBabbage BabbageEraOnwardsConway -> MaryEraOnwardsConway +instance Convert BabbageEraOnwards AlonzoEraOnwards where + convert = \case + BabbageEraOnwardsBabbage -> AlonzoEraOnwardsBabbage + BabbageEraOnwardsConway -> AlonzoEraOnwardsConway + type BabbageEraOnwardsConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed diff --git a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs index 9298b47b1a..44b6f9f08e 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs @@ -19,6 +19,7 @@ module Cardano.Api.Eon.ConwayEraOnwards ) where +import Cardano.Api.Eon.AllegraEraOnwards (AllegraEraOnwards (..)) import Cardano.Api.Eon.BabbageEraOnwards import Cardano.Api.Eon.Convert import Cardano.Api.Eon.ShelleyBasedEra @@ -75,6 +76,10 @@ instance Convert ConwayEraOnwards ShelleyBasedEra where convert = \case ConwayEraOnwardsConway -> ShelleyBasedEraConway +instance Convert ConwayEraOnwards AllegraEraOnwards where + convert = \case + ConwayEraOnwardsConway -> AllegraEraOnwardsConway + instance Convert ConwayEraOnwards BabbageEraOnwards where convert = \case ConwayEraOnwardsConway -> BabbageEraOnwardsConway diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 2627375931..93dd37f9b9 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -185,7 +185,6 @@ module Cardano.Api.Tx.Body , convWithdrawals , getScriptIntegrityHash , mkCommonTxBody - , scriptWitnessesProposing , toAuxiliaryData , toByronTxId , toShelleyTxId @@ -3626,15 +3625,15 @@ collectTxBodyScriptWitnesses | (ix, _, witness) <- indexTxVotingProcedures txv ] -scriptWitnessesProposing - :: TxProposalProcedures BuildTx era - -> [(ScriptWitnessIndex, AnyScriptWitness era)] -scriptWitnessesProposing TxProposalProceduresNone = [] -scriptWitnessesProposing txp = - List.nub - [ (ix, AnyScriptWitness witness) - | (ix, _, witness) <- indexTxProposalProcedures txp - ] + scriptWitnessesProposing + :: TxProposalProcedures BuildTx era + -> [(ScriptWitnessIndex, AnyScriptWitness era)] + scriptWitnessesProposing TxProposalProceduresNone = [] + scriptWitnessesProposing txp = + List.nub + [ (ix, AnyScriptWitness witness) + | (ix, _, witness) <- indexTxProposalProcedures txp + ] -- TODO: Investigate if we need toShelleyWithdrawal :: [(StakeAddress, L.Coin, a)] -> L.Withdrawals StandardCrypto diff --git a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs index fceb8c1e5d..e80bb825f8 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs @@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -- | This module provides a way to construct a simple transaction over all eras. @@ -13,10 +15,15 @@ module Cardano.Api.Tx.Compatible ) where -import Cardano.Api.Eon.Convert +import Cardano.Api.Address (StakeCredential) +import Cardano.Api.Certificate (Certificate) +import Cardano.Api.Eon.AlonzoEraOnwards +import Cardano.Api.Eon.BabbageEraOnwards import Cardano.Api.Eon.ConwayEraOnwards import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eon.ShelleyToBabbageEra +import Cardano.Api.Eras +import Cardano.Api.Eras.Case import Cardano.Api.ProtocolParameters import Cardano.Api.Script import Cardano.Api.Tx.Body @@ -25,12 +32,14 @@ import Cardano.Api.Value import qualified Cardano.Ledger.Api as L -import Control.Error (catMaybes) import qualified Data.Map.Strict as Map +import Data.Maybe import Data.Maybe.Strict +import Data.Monoid import qualified Data.Sequence.Strict as Seq -import Data.Set (fromList) -import Lens.Micro +import Data.Set (Set) +import GHC.Exts (IsList (..)) +import Lens.Micro hiding (ix) data AnyProtocolUpdate era where ProtocolUpdate @@ -62,101 +71,148 @@ createCompatibleSignedTx -- ^ Fee -> AnyProtocolUpdate era -> AnyVote era + -> TxCertificates BuildTx era -> Either ProtocolParametersConversionError (Tx era) -createCompatibleSignedTx sbeF ins outs witnesses txFee' anyProtocolUpdate anyVote = - shelleyBasedEraConstraints sbeF $ do - tx <- case anyProtocolUpdate of - ProtocolUpdate shelleyToBabbageEra updateProposal -> do - let sbe = convert shelleyToBabbageEra - - ledgerPParamsUpdate <- toLedgerUpdate sbe updateProposal - - let txbody = createCommonTxBody sbe ins outs txFee' - bodyWithProtocolUpdate = - shelleyToBabbageEraConstraints shelleyToBabbageEra $ - txbody & L.updateTxBodyL .~ SJust ledgerPParamsUpdate - finalTx = - L.mkBasicTx bodyWithProtocolUpdate - & L.witsTxL .~ shelleyToBabbageEraConstraints shelleyToBabbageEra allShelleyToBabbageWitnesses - - return $ ShelleyTx sbe finalTx - NoPParamsUpdate sbe -> do - let txbody = createCommonTxBody sbe ins outs txFee' - finalTx = L.mkBasicTx txbody & L.witsTxL .~ shelleyBasedEraConstraints sbe allShelleyToBabbageWitnesses - - return $ ShelleyTx sbe finalTx - ProposalProcedures conwayOnwards proposalProcedures -> do - let sbe = convert conwayOnwards - proposals = convProposalProcedures proposalProcedures - apiScriptWitnesses = scriptWitnessesProposing proposalProcedures - ledgerScripts = convScripts apiScriptWitnesses - referenceInputs = - map toShelleyTxIn $ - catMaybes [getScriptWitnessReferenceInput sWit | (_, AnyScriptWitness sWit) <- apiScriptWitnesses] - sData = convScriptData sbe outs apiScriptWitnesses - txbody = - conwayEraOnwardsConstraints conwayOnwards $ - createCommonTxBody sbe ins outs txFee' - & L.referenceInputsTxBodyL .~ fromList referenceInputs - & L.proposalProceduresTxBodyL - .~ proposals - - finalTx = - L.mkBasicTx txbody - & L.witsTxL - .~ conwayEraOnwardsConstraints conwayOnwards (allConwayEraOnwardsWitnesses sData ledgerScripts) - - return $ ShelleyTx sbe finalTx - - case anyVote of - NoVotes -> return tx - VotingProcedures conwayOnwards procedures -> do - let ledgerVotingProcedures = convVotingProcedures procedures - ShelleyTx sbe' fTx = tx - updatedTx = - conwayEraOnwardsConstraints conwayOnwards $ - overwriteVotingProcedures fTx ledgerVotingProcedures - return $ ShelleyTx sbe' updatedTx +createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote txCertificates' = + shelleyBasedEraConstraints sbe $ do + let apiScriptWitnesses = + [ (ix, AnyScriptWitness witness) + | (ix, _, _, ScriptWitness _ witness) <- indexedTxCerts + ] + + (updateTxBody, extraScriptWitnesses) <- + case anyProtocolUpdate of + ProtocolUpdate shelleyToBabbageEra updateProposal -> do + ledgerPParamsUpdate <- toLedgerUpdate sbe updateProposal + let updateTxBody :: Endo (L.TxBody (ShelleyLedgerEra era)) = + Endo $ \txb -> + shelleyToBabbageEraConstraints shelleyToBabbageEra $ + txb & L.updateTxBodyL .~ SJust ledgerPParamsUpdate + + pure (updateTxBody, []) + NoPParamsUpdate _ -> do + let referenceInputs = + fromList @(Set _) + [ toShelleyTxIn txIn + | (_, AnyScriptWitness sWit) <- apiScriptWitnesses + , txIn <- maybeToList $ getScriptWitnessReferenceInput sWit + ] + + updateTxBody :: Endo (L.TxBody (ShelleyLedgerEra era)) = + monoidForEraInEon era $ \eon -> + babbageEraOnwardsConstraints eon $ + Endo $ + L.referenceInputsTxBodyL %~ (<> referenceInputs) + pure (updateTxBody, []) + ProposalProcedures conwayOnwards proposalProcedures -> do + let proposals = convProposalProcedures proposalProcedures + proposalWitnesses = + [ (ix, AnyScriptWitness witness) + | (ix, _, witness) <- indexTxProposalProcedures proposalProcedures + ] + referenceInputs = + [ toShelleyTxIn txIn + | (_, AnyScriptWitness sWit) <- proposalWitnesses <> apiScriptWitnesses + , txIn <- maybeToList $ getScriptWitnessReferenceInput sWit + ] + updateTxBody :: Endo (L.TxBody (ShelleyLedgerEra era)) = + conwayEraOnwardsConstraints conwayOnwards $ + Endo $ + (L.referenceInputsTxBodyL %~ (<> fromList referenceInputs)) + . (L.proposalProceduresTxBodyL .~ proposals) + + pure (updateTxBody, proposalWitnesses) + + let txbody = + createCommonTxBody sbe ins outs txFee' + & appEndos [setCerts, setRefInputs, updateTxBody] + + updateVotingProcedures = + case anyVote of + NoVotes -> id + VotingProcedures conwayOnwards procedures -> + overwriteVotingProcedures conwayOnwards (convVotingProcedures procedures) + + pure + . ShelleyTx sbe + $ L.mkBasicTx txbody + & L.witsTxL + .~ allWitnesses (apiScriptWitnesses <> extraScriptWitnesses) allShelleyToBabbageWitnesses + & updateVotingProcedures where - overwriteVotingProcedures - :: L.ConwayEraTxBody ledgerera - => L.EraTx ledgerera - => L.Tx ledgerera -> L.VotingProcedures ledgerera -> L.Tx ledgerera - overwriteVotingProcedures lTx vProcedures = - lTx & (L.bodyTxL . L.votingProceduresTxBodyL) .~ vProcedures - - shelleyKeywitnesses = - fromList [w | ShelleyKeyWitness _ w <- witnesses] - - shelleyBootstrapWitnesses = - fromList [w | ShelleyBootstrapWitness _ w <- witnesses] + era = toCardanoEra sbe + appEndos = appEndo . mconcat + + setCerts :: Endo (L.TxBody (ShelleyLedgerEra era)) + setCerts = + monoidForEraInEon era $ \aeo -> + alonzoEraOnwardsConstraints aeo $ + Endo $ + L.certsTxBodyL .~ convCertificates sbe txCertificates' + + setRefInputs :: Endo (L.TxBody (ShelleyLedgerEra era)) + setRefInputs = do + let refInputs = + [ toShelleyTxIn refInput + | (_, _, _, ScriptWitness _ wit) <- indexedTxCerts + , refInput <- maybeToList $ getScriptWitnessReferenceInput wit + ] + + monoidForEraInEon era $ \beo -> + babbageEraOnwardsConstraints beo $ + Endo $ + L.referenceInputsTxBodyL .~ fromList refInputs - allConwayEraOnwardsWitnesses - :: L.AlonzoEraTxWits (ShelleyLedgerEra era) - => L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto - => TxBodyScriptData era -> [L.Script (ShelleyLedgerEra era)] -> L.TxWits (ShelleyLedgerEra era) - allConwayEraOnwardsWitnesses sData ledgerScripts = - let (datums, redeemers) = case sData of - TxBodyScriptData _ ds rs -> (ds, rs) - TxBodyNoScriptData -> (mempty, L.Redeemers mempty) - in L.mkBasicTxWits - & L.addrTxWitsL - .~ shelleyKeywitnesses - & L.bootAddrTxWitsL - .~ shelleyBootstrapWitnesses - & L.datsTxWitsL .~ datums - & L.rdmrsTxWitsL .~ redeemers - & L.scriptTxWitsL - .~ Map.fromList - [ (L.hashScript sw, sw) - | sw <- ledgerScripts - ] + overwriteVotingProcedures + :: ConwayEraOnwards era + -> L.VotingProcedures (ShelleyLedgerEra era) + -> L.Tx (ShelleyLedgerEra era) + -> L.Tx (ShelleyLedgerEra era) + overwriteVotingProcedures conwayOnwards votingProcedures = + conwayEraOnwardsConstraints conwayOnwards $ + (L.bodyTxL . L.votingProceduresTxBodyL) .~ votingProcedures + + indexedTxCerts :: [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)] + indexedTxCerts = indexTxCertificates txCertificates' + + allWitnesses + :: [(ScriptWitnessIndex, AnyScriptWitness era)] + -> L.TxWits (ShelleyLedgerEra era) + -> L.TxWits (ShelleyLedgerEra era) + allWitnesses scriptWitnesses = + shelleyBasedEraConstraints sbe $ + do + caseShelleyToMaryOrAlonzoEraOnwards + (const id) + ( const $ do + let sData = convScriptData sbe outs scriptWitnesses + let (datums, redeemers) = case sData of + TxBodyScriptData _ ds rs -> (ds, rs) + TxBodyNoScriptData -> (mempty, L.Redeemers mempty) + (L.datsTxWitsL .~ datums) . (L.rdmrsTxWitsL %~ (<> redeemers)) + ) + sbe + . caseShelleyEraOnlyOrAllegraEraOnwards + (const id) + ( const $ do + let ledgerScripts = convScripts scriptWitnesses + L.scriptTxWitsL + .~ Map.fromList + [ (L.hashScript sw, sw) + | sw <- ledgerScripts + ] + ) + sbe allShelleyToBabbageWitnesses :: L.EraTxWits (ShelleyLedgerEra era) => L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto => L.TxWits (ShelleyLedgerEra era) - allShelleyToBabbageWitnesses = + allShelleyToBabbageWitnesses = do + let shelleyKeywitnesses = + fromList [w | ShelleyKeyWitness _ w <- witnesses] + let shelleyBootstrapWitnesses = + fromList [w | ShelleyBootstrapWitness _ w <- witnesses] L.mkBasicTxWits & L.addrTxWitsL .~ shelleyKeywitnesses