From bc68c47c93db7b0f6a01f901a8cca41bd2bc55fd Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Thu, 28 Nov 2024 13:00:55 +0100 Subject: [PATCH] Refactor witnesses indexing functions to have the indexing logic in one place --- cardano-api/internal/Cardano/Api/Fees.hs | 98 +++++--------- cardano-api/internal/Cardano/Api/Script.hs | 34 ++--- cardano-api/internal/Cardano/Api/Tx/Body.hs | 140 ++++++++++++++------ 3 files changed, 147 insertions(+), 125 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 3e44dc189..b33d5e44d 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -87,6 +87,7 @@ 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 @@ -1449,6 +1450,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 +1468,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 +1488,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 +1521,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 +1542,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..3f48ecfe1 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 @@ -172,8 +177,6 @@ module Cardano.Api.Tx.Body -- * Misc helpers , calculateExecutionUnitsLovelace - , orderStakeAddrs - , orderTxIns -- * Data family instances , AsType (AsTxId, AsTxBody, AsByronTxBody, AsShelleyTxBody, AsMaryTxBody) @@ -909,6 +912,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 +1230,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 +1265,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 +1391,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 +1448,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 +3386,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,37 +3422,19 @@ 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) - ] - --- 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)) +scriptWitnessesProposing txp = + [ (ix, AnyScriptWitness witness) + | (ix, _, witness) <- txProposalProceduresToIndexed txp + ] -- TODO: Investigate if we need toShelleyWithdrawal :: [(StakeAddress, L.Coin, a)] -> L.Withdrawals StandardCrypto