diff --git a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs index baab37a13..ba3173baa 100644 --- a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs @@ -81,6 +81,11 @@ instance Inject (BabbageEraOnwards era) (MaryEraOnwards era) where BabbageEraOnwardsBabbage -> MaryEraOnwardsBabbage BabbageEraOnwardsConway -> MaryEraOnwardsConway +instance Inject (BabbageEraOnwards era) (AlonzoEraOnwards era) where + inject = \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 17923ce82..d3e3d4c05 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.ShelleyBasedEra import Cardano.Api.Eras.Core @@ -74,6 +75,10 @@ instance Inject (ConwayEraOnwards era) (ShelleyBasedEra era) where inject = \case ConwayEraOnwardsConway -> ShelleyBasedEraConway +instance Inject (ConwayEraOnwards era) (AllegraEraOnwards era) where + inject = \case + ConwayEraOnwardsConway -> AllegraEraOnwardsConway + instance Inject (ConwayEraOnwards era) (BabbageEraOnwards era) where inject = \case ConwayEraOnwardsConway -> BabbageEraOnwardsConway diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index b33d5e44d..8c040c390 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -87,7 +87,6 @@ import Control.Monad import Data.Bifunctor (bimap, first, second) import Data.ByteString.Short (ShortByteString) import Data.Function ((&)) -import Data.Functor import qualified Data.List as List import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 3f48ecfe1..d34f6ca1d 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -161,7 +161,6 @@ module Cardano.Api.Tx.Body , convWithdrawals , getScriptIntegrityHash , mkCommonTxBody - , scriptWitnessesProposing , toAuxiliaryData , toByronTxId , toShelleyTxId @@ -3427,14 +3426,14 @@ collectTxBodyScriptWitnesses | (ix, _, witness) <- txVotingProceduresToIndexed txv ] -scriptWitnessesProposing - :: TxProposalProcedures BuildTx era - -> [(ScriptWitnessIndex, AnyScriptWitness era)] -scriptWitnessesProposing TxProposalProceduresNone = [] -scriptWitnessesProposing txp = - [ (ix, AnyScriptWitness witness) - | (ix, _, witness) <- txProposalProceduresToIndexed txp - ] + scriptWitnessesProposing + :: TxProposalProcedures BuildTx era + -> [(ScriptWitnessIndex, AnyScriptWitness era)] + scriptWitnessesProposing TxProposalProceduresNone = [] + scriptWitnessesProposing txp = + [ (ix, AnyScriptWitness witness) + | (ix, _, witness) <- txProposalProceduresToIndexed 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 da05768d0..edc5dee3d 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. @@ -17,6 +19,7 @@ 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 +28,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 +66,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 = inject shelleyToBabbageEra - ledgerPParamsUpdate <- toLedgerUpdate sbe updateProposal - let txbody = createCommonTxBody sbe ins outs txFee' - bodyWithProtocolUpdate = + let apiScriptWitnesses = + [ (ix, AnyScriptWitness witness) + | (ix, _, _, ScriptWitness _ witness) <- txCertificatesToIndexed txCertificates' + ] + 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) <- txCertificatesToIndexed txCertificates' + ] + 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 = inject conwayOnwards - proposals = convProposalProcedures proposalProcedures - apiScriptWitnesses = scriptWitnessesProposing proposalProcedures + let proposals = convProposalProcedures proposalProcedures + apiScriptWitnesses = + [ (ix, AnyScriptWitness witness) + | (ix, _, witness) <- txProposalProceduresToIndexed proposalProcedures + ] + <> [ (ix, AnyScriptWitness witness) + | (ix, _, _, ScriptWitness _ witness) <- txCertificatesToIndexed txCertificates' + ] 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) <- txCertificatesToIndexed txCertificates' + , refInput <- maybeToList $ getScriptWitnessReferenceInput wit + ] + + caseShelleyToAlonzoOrBabbageEraOnwards + (const id) + (const $ L.referenceInputsTxBodyL .~ fromList refInputs) + sbe + overwriteVotingProcedures :: L.ConwayEraTxBody ledgerera => L.EraTx ledgerera @@ -126,31 +177,42 @@ createCompatibleSignedTx sbeF ins outs witnesses txFee' anyProtocolUpdate anyVot lTx & (L.bodyTxL . L.votingProceduresTxBodyL) .~ vProcedures 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) @@ -163,6 +225,8 @@ createCompatibleSignedTx sbeF ins outs witnesses txFee' anyProtocolUpdate anyVot & L.bootAddrTxWitsL .~ shelleyBootstrapWitnesses +-- allWitnessesToIndexed :: + createCommonTxBody :: ShelleyBasedEra era -> [TxIn]