diff --git a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs index 811d23d0e..795b84852 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 9298b47b1..44b6f9f08 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 262737593..93dd37f9b 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 fceb8c1e5..adca8c30e 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,13 @@ 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.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 +30,13 @@ 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 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,62 +68,109 @@ 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 +createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote txCertificates' = + shelleyBasedEraConstraints sbe $ do + let txbody = + createCommonTxBody sbe ins outs txFee' + & setCerts + & setRefInputs + + fTx <- case anyProtocolUpdate of ProtocolUpdate shelleyToBabbageEra updateProposal -> do - let sbe = convert shelleyToBabbageEra - ledgerPParamsUpdate <- toLedgerUpdate sbe updateProposal - let txbody = createCommonTxBody sbe ins outs txFee' - bodyWithProtocolUpdate = + let apiScriptWitnesses = + [ (ix, AnyScriptWitness witness) + | (ix, _, _, ScriptWitness _ witness) <- indexedTxCerts + ] + ledgerScripts = convScripts apiScriptWitnesses + sData = convScriptData sbe outs apiScriptWitnesses + let 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 + pure $ + L.mkBasicTx bodyWithProtocolUpdate + & L.witsTxL .~ allWitnesses sData ledgerScripts allShelleyToBabbageWitnesses + NoPParamsUpdate _ -> do + let apiScriptWitnesses = + [ (ix, AnyScriptWitness witness) + | (ix, _, _, ScriptWitness _ witness) <- indexedTxCerts + ] + ledgerScripts = convScripts apiScriptWitnesses + referenceInputs = + [ toShelleyTxIn txIn + | (_, AnyScriptWitness sWit) <- apiScriptWitnesses + , txIn <- maybeToList $ getScriptWitnessReferenceInput sWit + ] + sData = convScriptData sbe outs apiScriptWitnesses + updatedBody = + txbody + & caseShelleyToAlonzoOrBabbageEraOnwards + (const id) + (const $ L.referenceInputsTxBodyL %~ (<> fromList referenceInputs)) + sbe + pure $ + L.mkBasicTx updatedBody + & L.witsTxL .~ allWitnesses sData ledgerScripts allShelleyToBabbageWitnesses ProposalProcedures conwayOnwards proposalProcedures -> do - let sbe = convert conwayOnwards - proposals = convProposalProcedures proposalProcedures - apiScriptWitnesses = scriptWitnessesProposing proposalProcedures + let proposals = convProposalProcedures proposalProcedures + apiScriptWitnesses = + [ (ix, AnyScriptWitness witness) + | (ix, _, witness) <- indexTxProposalProcedures proposalProcedures + ] + <> [ (ix, AnyScriptWitness witness) + | (ix, _, _, ScriptWitness _ witness) <- indexedTxCerts + ] ledgerScripts = convScripts apiScriptWitnesses referenceInputs = - map toShelleyTxIn $ - catMaybes [getScriptWitnessReferenceInput sWit | (_, AnyScriptWitness sWit) <- apiScriptWitnesses] + [ toShelleyTxIn txIn + | (_, AnyScriptWitness sWit) <- apiScriptWitnesses + , txIn <- maybeToList $ getScriptWitnessReferenceInput sWit + ] sData = convScriptData sbe outs apiScriptWitnesses - txbody = + updatedTxBody = conwayEraOnwardsConstraints conwayOnwards $ - createCommonTxBody sbe ins outs txFee' - & L.referenceInputsTxBodyL .~ fromList referenceInputs - & L.proposalProceduresTxBodyL - .~ proposals + txbody + & L.referenceInputsTxBodyL %~ (<> fromList referenceInputs) + & L.proposalProceduresTxBodyL .~ proposals - finalTx = - L.mkBasicTx txbody - & L.witsTxL - .~ conwayEraOnwardsConstraints conwayOnwards (allConwayEraOnwardsWitnesses sData ledgerScripts) - - return $ ShelleyTx sbe finalTx + pure $ + L.mkBasicTx updatedTxBody + & L.witsTxL + .~ allWitnesses sData ledgerScripts allShelleyToBabbageWitnesses case anyVote of - NoVotes -> return tx + NoVotes -> return $ ShelleyTx sbe fTx VotingProcedures conwayOnwards procedures -> do let ledgerVotingProcedures = convVotingProcedures procedures - ShelleyTx sbe' fTx = tx updatedTx = conwayEraOnwardsConstraints conwayOnwards $ overwriteVotingProcedures fTx ledgerVotingProcedures - return $ ShelleyTx sbe' updatedTx + return $ ShelleyTx sbe updatedTx where + setCerts :: L.TxBody (ShelleyLedgerEra era) -> L.TxBody (ShelleyLedgerEra era) + setCerts = + shelleyBasedEraConstraints sbe $ + caseShelleyToMaryOrAlonzoEraOnwards + (const id) + (const $ L.certsTxBodyL .~ convCertificates sbe txCertificates') + sbe + + setRefInputs :: L.TxBody (ShelleyLedgerEra era) -> L.TxBody (ShelleyLedgerEra era) + setRefInputs = do + let refInputs = + [ toShelleyTxIn refInput + | (_, _, _, ScriptWitness _ wit) <- indexedTxCerts + , refInput <- maybeToList $ getScriptWitnessReferenceInput wit + ] + + caseShelleyToAlonzoOrBabbageEraOnwards + (const id) + (const $ L.referenceInputsTxBodyL .~ fromList refInputs) + sbe + overwriteVotingProcedures :: L.ConwayEraTxBody ledgerera => L.EraTx ledgerera @@ -125,32 +178,46 @@ createCompatibleSignedTx sbeF ins outs witnesses txFee' anyProtocolUpdate anyVot overwriteVotingProcedures lTx vProcedures = lTx & (L.bodyTxL . L.votingProceduresTxBodyL) .~ vProcedures + indexedTxCerts :: [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)] + indexedTxCerts = indexTxCertificates txCertificates' + shelleyKeywitnesses = - fromList [w | ShelleyKeyWitness _ w <- witnesses] + fromList @(Set _) [w | ShelleyKeyWitness _ w <- witnesses] shelleyBootstrapWitnesses = - fromList [w | ShelleyBootstrapWitness _ w <- witnesses] - - 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 - ] + fromList @(Set _) [w | ShelleyBootstrapWitness _ w <- witnesses] + + allWitnesses + :: TxBodyScriptData era + -> [L.Script (ShelleyLedgerEra era)] + -> L.TxWits (ShelleyLedgerEra era) + -> L.TxWits (ShelleyLedgerEra era) + allWitnesses sData ledgerScripts txw = shelleyBasedEraConstraints sbe $ do + let txw1 = + caseShelleyToMaryOrAlonzoEraOnwards + (const txw) + ( const $ do + let (datums, redeemers) = case sData of + TxBodyScriptData _ ds rs -> (ds, rs) + TxBodyNoScriptData -> (mempty, L.Redeemers mempty) + txw + & L.datsTxWitsL .~ datums + & L.rdmrsTxWitsL %~ (<> redeemers) + ) + sbe + txw2 = + caseShelleyEraOnlyOrAllegraEraOnwards + (const txw1) + ( const $ + txw1 + & L.scriptTxWitsL + .~ Map.fromList + [ (L.hashScript sw, sw) + | sw <- ledgerScripts + ] + ) + sbe + txw2 allShelleyToBabbageWitnesses :: L.EraTxWits (ShelleyLedgerEra era)