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 3e44dc189..8c040c390 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -1449,6 +1449,13 @@ substituteExecutionUnits redeemer exunits + adjustWitness + :: (ScriptWitness witctx era -> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era)) + -> Witness witctx era + -> Either (TxBodyErrorAutoBalance era) (Witness witctx era) + adjustWitness _ (KeyWitness ctx) = Right $ KeyWitness ctx + adjustWitness g (ScriptWitness ctx witness') = ScriptWitness ctx <$> g witness' + mapScriptWitnessesTxIns :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] -> Either (TxBodyErrorAutoBalance era) [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] @@ -1460,27 +1467,18 @@ substituteExecutionUnits ] mappedScriptWitnesses = [ (txin, BuildTxWith <$> wit') - | -- The tx ins are indexed in the map order by txid - (ix, (txin, BuildTxWith wit)) <- zip [0 ..] (orderTxIns txins) - , let wit' = case wit of - KeyWitness{} -> Right wit - ScriptWitness ctx witness -> ScriptWitness ctx <$> witness' - where - witness' = substituteExecUnits (ScriptWitnessIndexTxIn ix) witness + | (ix, txin, wit) <- txInsToIndexed txins + , let wit' = adjustWitness (substituteExecUnits ix) wit ] in traverse - ( \(txIn, eWitness) -> - case eWitness of - Left e -> Left e - Right wit -> Right (txIn, wit) - ) + (\(txIn, eWitness) -> (txIn,) <$> eWitness) mappedScriptWitnesses mapScriptWitnessesWithdrawals :: TxWithdrawals BuildTx era -> Either (TxBodyErrorAutoBalance era) (TxWithdrawals BuildTx era) mapScriptWitnessesWithdrawals TxWithdrawalsNone = Right TxWithdrawalsNone - mapScriptWitnessesWithdrawals (TxWithdrawals supported withdrawals) = + mapScriptWitnessesWithdrawals txWithdrawals'@(TxWithdrawals supported _) = let mappedWithdrawals :: [ ( StakeAddress , L.Coin @@ -1489,55 +1487,30 @@ substituteExecutionUnits ] mappedWithdrawals = [ (addr, withdrawal, BuildTxWith <$> mappedWitness) - | -- The withdrawals are indexed in the map order by stake credential - (ix, (addr, withdrawal, BuildTxWith wit)) <- zip [0 ..] (orderStakeAddrs withdrawals) - , let mappedWitness = adjustWitness (substituteExecUnits (ScriptWitnessIndexWithdrawal ix)) wit + | (ix, addr, withdrawal, wit) <- txWithdrawalsToIndexed txWithdrawals' + , let mappedWitness = adjustWitness (substituteExecUnits ix) wit ] in TxWithdrawals supported <$> traverse - ( \(sAddr, ll, eWitness) -> - case eWitness of - Left e -> Left e - Right wit -> Right (sAddr, ll, wit) - ) + (\(sAddr, ll, eWitness) -> (sAddr,ll,) <$> eWitness) mappedWithdrawals - where - adjustWitness - :: (ScriptWitness witctx era -> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era)) - -> Witness witctx era - -> Either (TxBodyErrorAutoBalance era) (Witness witctx era) - adjustWitness _ (KeyWitness ctx) = Right $ KeyWitness ctx - adjustWitness g (ScriptWitness ctx witness') = ScriptWitness ctx <$> g witness' mapScriptWitnessesCertificates :: TxCertificates BuildTx era -> Either (TxBodyErrorAutoBalance era) (TxCertificates BuildTx era) mapScriptWitnessesCertificates TxCertificatesNone = Right TxCertificatesNone - mapScriptWitnessesCertificates - ( TxCertificates - supported - certs - (BuildTxWith witnesses) - ) = - let mappedScriptWitnesses - :: [(StakeCredential, Either (TxBodyErrorAutoBalance era) (Witness WitCtxStake era))] - mappedScriptWitnesses = - [ (stakecred, ScriptWitness ctx <$> witness') - | -- The certs are indexed in list order - (ix, cert) <- zip [0 ..] certs - , stakecred <- maybeToList (selectStakeCredentialWitness cert) - , ScriptWitness ctx witness <- - maybeToList (List.lookup stakecred witnesses) - , let witness' = substituteExecUnits (ScriptWitnessIndexCertificate ix) witness - ] - in TxCertificates supported certs . BuildTxWith - <$> traverse - ( \(sCred, eScriptWitness) -> - case eScriptWitness of - Left e -> Left e - Right wit -> Right (sCred, wit) - ) - mappedScriptWitnesses + mapScriptWitnessesCertificates txCertificates'@(TxCertificates supported certs _) = + let mappedScriptWitnesses + :: [(StakeCredential, Either (TxBodyErrorAutoBalance era) (Witness WitCtxStake era))] + mappedScriptWitnesses = + [ (stakeCred, witness') + | (ix, _, stakeCred, witness) <- txCertificatesToIndexed txCertificates' + , let witness' = adjustWitness (substituteExecUnits ix) witness + ] + in TxCertificates supported certs . BuildTxWith + <$> traverse + (\(sCred, eScriptWitness) -> (sCred,) <$> eScriptWitness) + mappedScriptWitnesses mapScriptWitnessesVotes :: Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era)) @@ -1547,13 +1520,11 @@ substituteExecutionUnits mapScriptWitnessesVotes Nothing = return Nothing mapScriptWitnessesVotes (Just (Featured _ TxVotingProceduresNone)) = return Nothing mapScriptWitnessesVotes (Just (Featured _ (TxVotingProcedures _ ViewTx))) = return Nothing - mapScriptWitnessesVotes (Just (Featured era (TxVotingProcedures vProcedures (BuildTxWith sWitMap)))) = do + mapScriptWitnessesVotes (Just (Featured era txVotingProcedures'@(TxVotingProcedures vProcedures (BuildTxWith _)))) = do let eSubstitutedExecutionUnits = [ (vote, updatedWitness) - | let allVoteMap = L.unVotingProcedures vProcedures - , (vote, scriptWitness) <- toList sWitMap - , index <- maybeToList $ Map.lookupIndex vote allVoteMap - , let updatedWitness = substituteExecUnits (ScriptWitnessIndexVoting $ fromIntegral index) scriptWitness + | (ix, vote, witness) <- txVotingProceduresToIndexed txVotingProcedures' + , let updatedWitness = substituteExecUnits ix witness ] substitutedExecutionUnits <- traverseScriptWitnesses eSubstitutedExecutionUnits @@ -1570,13 +1541,11 @@ substituteExecutionUnits mapScriptWitnessesProposals Nothing = return Nothing mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = return Nothing mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures _ ViewTx))) = return Nothing - mapScriptWitnessesProposals (Just (Featured era txpp@(TxProposalProcedures osetProposalProcedures (BuildTxWith sWitMap)))) = do - let allProposalsList = toList $ convProposalProcedures txpp - eSubstitutedExecutionUnits = + mapScriptWitnessesProposals (Just (Featured era txpp@(TxProposalProcedures osetProposalProcedures (BuildTxWith _)))) = do + let eSubstitutedExecutionUnits = [ (proposal, updatedWitness) - | (proposal, scriptWitness) <- toList sWitMap - , index <- maybeToList $ List.elemIndex proposal allProposalsList - , let updatedWitness = substituteExecUnits (ScriptWitnessIndexProposing $ fromIntegral index) scriptWitness + | (ix, proposal, scriptWitness) <- txProposalProceduresToIndexed txpp + , let updatedWitness = substituteExecUnits ix scriptWitness ] substitutedExecutionUnits <- traverseScriptWitnesses eSubstitutedExecutionUnits diff --git a/cardano-api/internal/Cardano/Api/Script.hs b/cardano-api/internal/Cardano/Api/Script.hs index ce59e80da..0ba0c9206 100644 --- a/cardano-api/internal/Cardano/Api/Script.hs +++ b/cardano-api/internal/Cardano/Api/Script.hs @@ -696,6 +696,23 @@ data SimpleScriptOrReferenceInput lang | SReferenceScript TxIn deriving (Eq, Show) +-- ---------------------------------------------------------------------------- +-- The kind of witness to use, key (signature) or script +-- + +data Witness witctx era where + KeyWitness + :: KeyWitnessInCtx witctx + -> Witness witctx era + ScriptWitness + :: ScriptWitnessInCtx witctx + -> ScriptWitness witctx era + -> Witness witctx era + +deriving instance Eq (Witness witctx era) + +deriving instance Show (Witness witctx era) + -- | A /use/ of a script within a transaction body to witness that something is -- being used in an authorised manner. That can be -- @@ -797,23 +814,6 @@ getScriptWitnessReferenceInputOrScript = \case PlutusScriptWitness _ _ (PReferenceScript txIn) _ _ _ -> Right txIn --- ---------------------------------------------------------------------------- --- The kind of witness to use, key (signature) or script --- - -data Witness witctx era where - KeyWitness - :: KeyWitnessInCtx witctx - -> Witness witctx era - ScriptWitness - :: ScriptWitnessInCtx witctx - -> ScriptWitness witctx era - -> Witness witctx era - -deriving instance Eq (Witness witctx era) - -deriving instance Show (Witness witctx era) - data KeyWitnessInCtx witctx where KeyWitnessForSpending :: KeyWitnessInCtx WitCtxTxIn KeyWitnessForStakeAddr :: KeyWitnessInCtx WitCtxStake diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 38d12be3e..d34f6ca1d 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -77,6 +77,7 @@ module Cardano.Api.Tx.Body -- * Transaction inputs , TxIn (..) , TxIns + , txInsToIndexed , TxIx (..) , genesisUTxOPseudoTxIn , getReferenceInputsSizeForTxIds @@ -108,15 +109,19 @@ module Cardano.Api.Tx.Body , TxAuxScripts (..) , TxExtraKeyWitnesses (..) , TxWithdrawals (..) + , txWithdrawalsToIndexed , TxCertificates (..) + , txCertificatesToIndexed , TxUpdateProposal (..) , TxMintValue (..) , txMintValueToValue , txMintValueToIndexed , TxVotingProcedures (..) , mkTxVotingProcedures + , txVotingProceduresToIndexed , TxProposalProcedures (..) , mkTxProposalProcedures + , txProposalProceduresToIndexed , convProposalProcedures -- ** Building vs viewing transactions @@ -156,7 +161,6 @@ module Cardano.Api.Tx.Body , convWithdrawals , getScriptIntegrityHash , mkCommonTxBody - , scriptWitnessesProposing , toAuxiliaryData , toByronTxId , toShelleyTxId @@ -172,8 +176,6 @@ module Cardano.Api.Tx.Body -- * Misc helpers , calculateExecutionUnitsLovelace - , orderStakeAddrs - , orderTxIns -- * Data family instances , AsType (AsTxId, AsTxBody, AsByronTxBody, AsShelleyTxBody, AsMaryTxBody) @@ -909,6 +911,22 @@ deriving instance Show a => Show (BuildTxWith build a) type TxIns build era = [(TxIn, BuildTxWith build (Witness WitCtxTxIn era))] +-- | Index transaction inputs ordered by TxIn +-- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf +txInsToIndexed + :: TxIns BuildTx era + -> [(ScriptWitnessIndex, TxIn, Witness WitCtxTxIn era)] +txInsToIndexed txins = + [ (ScriptWitnessIndexTxIn ix, txIn, witness) + | (ix, (txIn, BuildTxWith witness)) <- zip [0 ..] $ orderTxIns txins + ] + where + -- This relies on the TxId Ord instance being consistent with the + -- Ledger.TxId Ord instance via the toShelleyTxId conversion + -- This is checked by prop_ord_distributive_TxId + orderTxIns :: [(TxIn, v)] -> [(TxIn, v)] + orderTxIns = sortBy (compare `on` fst) + data TxInsCollateral era where TxInsCollateralNone :: TxInsCollateral era @@ -1211,6 +1229,23 @@ deriving instance Eq (TxWithdrawals build era) deriving instance Show (TxWithdrawals build era) +-- | Index the withdrawals with witnesses in the order of stake addresses. +-- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf +txWithdrawalsToIndexed + :: TxWithdrawals BuildTx era + -> [(ScriptWitnessIndex, StakeAddress, L.Coin, Witness WitCtxStake era)] +txWithdrawalsToIndexed TxWithdrawalsNone = [] +txWithdrawalsToIndexed (TxWithdrawals _ withdrawals) = + [ (ScriptWitnessIndexWithdrawal ix, addr, coin, witness) + | (ix, (addr, coin, BuildTxWith witness)) <- zip [0 ..] (orderStakeAddrs withdrawals) + ] + where + -- This relies on the StakeAddress Ord instance being consistent with the + -- Shelley.RewardAcnt Ord instance via the toShelleyStakeAddr conversion + -- This is checked by prop_ord_distributive_StakeAddress + orderStakeAddrs :: [(StakeAddress, x, v)] -> [(StakeAddress, x, v)] + orderStakeAddrs = sortBy (compare `on` (\(k, _, _) -> k)) + -- ---------------------------------------------------------------------------- -- Certificates within transactions (era-dependent) -- @@ -1229,6 +1264,20 @@ deriving instance Eq (TxCertificates build era) deriving instance Show (TxCertificates build era) +-- | Index certificates with witnesses by the order they appear in the list (in the transaction). If there +-- are multiple witnesses for the credential, the last one is returned. +-- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf +txCertificatesToIndexed + :: TxCertificates BuildTx era + -> [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)] +txCertificatesToIndexed TxCertificatesNone = [] +txCertificatesToIndexed (TxCertificates _ certs (BuildTxWith witnesses)) = + [ (ScriptWitnessIndexCertificate ix, cert, stakeCred, wit) + | (ix, cert) <- zip [0 ..] certs + , stakeCred <- maybeToList (selectStakeCredentialWitness cert) + , wit <- maybeToList $ List.lookup stakeCred witnesses + ] + -- ---------------------------------------------------------------------------- -- Transaction update proposal (era-dependent) -- @@ -1341,6 +1390,22 @@ mkTxVotingProcedures votingProcedures = do getVotingScriptCredentials (VotingProcedures (L.VotingProcedures m)) = listToMaybe $ Map.keys m +-- | Index voting procedures by the order of the votes ('Ord'). +txVotingProceduresToIndexed + :: TxVotingProcedures BuildTx era + -> [ ( ScriptWitnessIndex + , L.Voter (Ledger.EraCrypto (ShelleyLedgerEra era)) + , ScriptWitness WitCtxStake era + ) + ] +txVotingProceduresToIndexed TxVotingProceduresNone = [] +txVotingProceduresToIndexed (TxVotingProcedures vProcedures (BuildTxWith sWitMap)) = + [ (ScriptWitnessIndexVoting $ fromIntegral index, vote, scriptWitness) + | let allVoteMap = L.unVotingProcedures vProcedures + , (vote, scriptWitness) <- toList sWitMap + , index <- maybeToList $ Map.lookupIndex vote allVoteMap + ] + -- ---------------------------------------------------------------------------- -- Proposals within transactions (era-dependent) -- @@ -1382,6 +1447,18 @@ mkTxProposalProcedures proposalsWithWitnessesList = do partitionProposals (ps, pws) (p, Just w) = (DList.snoc ps p, DList.snoc pws (p, w)) -- add a proposal both to the list and to the witnessed list +-- | Index proposal procedures by their order ('Ord'). +txProposalProceduresToIndexed + :: TxProposalProcedures BuildTx era + -> [(ScriptWitnessIndex, L.ProposalProcedure (ShelleyLedgerEra era), ScriptWitness WitCtxStake era)] +txProposalProceduresToIndexed TxProposalProceduresNone = [] +txProposalProceduresToIndexed txpp@(TxProposalProcedures _ (BuildTxWith witnesses)) = do + let allProposalsList = toList $ convProposalProcedures txpp + [ (ScriptWitnessIndexProposing $ fromIntegral ix, proposal, scriptWitness) + | (proposal, scriptWitness) <- toList witnesses + , ix <- maybeToList $ List.elemIndex proposal allProposalsList + ] + -- ---------------------------------------------------------------------------- -- Transaction body content -- @@ -3308,35 +3385,27 @@ collectTxBodyScriptWitnesses scriptWitnessesTxIns :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] -> [(ScriptWitnessIndex, AnyScriptWitness era)] - scriptWitnessesTxIns txins = - [ (ScriptWitnessIndexTxIn ix, AnyScriptWitness witness) - | -- The tx ins are indexed in the map order by txid - (ix, (_, BuildTxWith (ScriptWitness _ witness))) <- - zip [0 ..] (orderTxIns txins) + scriptWitnessesTxIns txIns' = + [ (ix, AnyScriptWitness witness) + | (ix, _, ScriptWitness _ witness) <- txInsToIndexed txIns' ] scriptWitnessesWithdrawals :: TxWithdrawals BuildTx era -> [(ScriptWitnessIndex, AnyScriptWitness era)] scriptWitnessesWithdrawals TxWithdrawalsNone = [] - scriptWitnessesWithdrawals (TxWithdrawals _ withdrawals) = - [ (ScriptWitnessIndexWithdrawal ix, AnyScriptWitness witness) - | -- The withdrawals are indexed in the map order by stake credential - (ix, (_, _, BuildTxWith (ScriptWitness _ witness))) <- - zip [0 ..] (orderStakeAddrs withdrawals) + scriptWitnessesWithdrawals txw = + [ (ix, AnyScriptWitness witness) + | (ix, _, _, ScriptWitness _ witness) <- txWithdrawalsToIndexed txw ] scriptWitnessesCertificates :: TxCertificates BuildTx era -> [(ScriptWitnessIndex, AnyScriptWitness era)] scriptWitnessesCertificates TxCertificatesNone = [] - scriptWitnessesCertificates (TxCertificates _ certs (BuildTxWith witnesses)) = - [ (ScriptWitnessIndexCertificate ix, AnyScriptWitness witness) - | -- The certs are indexed in list order - (ix, cert) <- zip [0 ..] certs - , ScriptWitness _ witness <- maybeToList $ do - stakecred <- selectStakeCredentialWitness cert - List.lookup stakecred witnesses + scriptWitnessesCertificates txc = + [ (ix, AnyScriptWitness witness) + | (ix, _, _, ScriptWitness _ witness) <- txCertificatesToIndexed txc ] scriptWitnessesMinting @@ -3352,38 +3421,20 @@ collectTxBodyScriptWitnesses :: TxVotingProcedures BuildTx era -> [(ScriptWitnessIndex, AnyScriptWitness era)] scriptWitnessesVoting TxVotingProceduresNone = [] - scriptWitnessesVoting (TxVotingProcedures (L.VotingProcedures votes) (BuildTxWith witnesses)) = - [ (ScriptWitnessIndexVoting ix, AnyScriptWitness witness) - | let voterList = toList votes - , (ix, (voter, _)) <- zip [0 ..] voterList - , witness <- maybeToList (Map.lookup voter witnesses) + scriptWitnessesVoting txv = + [ (ix, AnyScriptWitness witness) + | (ix, _, witness) <- txVotingProceduresToIndexed txv ] -scriptWitnessesProposing - :: TxProposalProcedures BuildTx era - -> [(ScriptWitnessIndex, AnyScriptWitness era)] -scriptWitnessesProposing TxProposalProceduresNone = [] -scriptWitnessesProposing (TxProposalProcedures proposalProcedures (BuildTxWith mScriptWitnesses)) - | Map.null mScriptWitnesses = [] - | otherwise = - [ (ScriptWitnessIndexProposing ix, AnyScriptWitness witness) - | let proposalsList = toList proposalProcedures - , (ix, proposal) <- zip [0 ..] proposalsList - , witness <- maybeToList (Map.lookup proposal mScriptWitnesses) + scriptWitnessesProposing + :: TxProposalProcedures BuildTx era + -> [(ScriptWitnessIndex, AnyScriptWitness era)] + scriptWitnessesProposing TxProposalProceduresNone = [] + scriptWitnessesProposing txp = + [ (ix, AnyScriptWitness witness) + | (ix, _, witness) <- txProposalProceduresToIndexed txp ] --- This relies on the TxId Ord instance being consistent with the --- Ledger.TxId Ord instance via the toShelleyTxId conversion --- This is checked by prop_ord_distributive_TxId -orderTxIns :: [(TxIn, v)] -> [(TxIn, v)] -orderTxIns = sortBy (compare `on` fst) - --- This relies on the StakeAddress Ord instance being consistent with the --- Shelley.RewardAcnt Ord instance via the toShelleyStakeAddr conversion --- This is checked by prop_ord_distributive_StakeAddress -orderStakeAddrs :: [(StakeAddress, x, v)] -> [(StakeAddress, x, v)] -orderStakeAddrs = sortBy (compare `on` (\(k, _, _) -> k)) - -- TODO: Investigate if we need toShelleyWithdrawal :: [(StakeAddress, L.Coin, a)] -> L.Withdrawals StandardCrypto toShelleyWithdrawal withdrawals = 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]