From 090aa57aff7052da73f1c89dbb7e2627a8ee06b1 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Wed, 22 Jan 2025 22:23:21 +0100 Subject: [PATCH] Change a representation of witnesses in transaction's certificates to an ordered map where a certificate is the key. --- cardano-api/cardano-api.cabal | 1 + cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 2 +- .../internal/Cardano/Api/Certificate.hs | 2 + .../Cardano/Api/Eon/ConwayEraOnwards.hs | 2 + .../Cardano/Api/Eon/ShelleyToBabbageEra.hs | 2 + cardano-api/internal/Cardano/Api/Fees.hs | 37 +++++++----- cardano-api/internal/Cardano/Api/Script.hs | 4 +- cardano-api/internal/Cardano/Api/Tx/Body.hs | 58 +++++++++++++------ .../internal/Cardano/Api/Tx/Compatible.hs | 3 +- cardano-api/src/Cardano/Api.hs | 1 + 10 files changed, 76 insertions(+), 36 deletions(-) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 2d189f6e6a..ea4440c017 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -207,6 +207,7 @@ library internal mtl, network, network-mux, + ordered-containers, ouroboros-consensus ^>=0.22, ouroboros-consensus-cardano ^>=0.21, ouroboros-consensus-diffusion ^>=0.19, diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 4081e38724..2e75577322 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -621,7 +621,7 @@ genTxCertificates = certs <- Gen.list (Range.constant 0 3) $ genCertificate w Gen.choice [ pure TxCertificatesNone - , pure (TxCertificates w certs $ BuildTxWith mempty) + , pure (TxCertificates w $ fromList ((,BuildTxWith Nothing) <$> certs)) -- TODO: Generate certificates ] ) diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index 571d6ab402..6a58308f4f 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -142,6 +142,8 @@ data Certificate era where deriving instance Eq (Certificate era) +deriving instance Ord (Certificate era) + deriving instance Show (Certificate era) instance Typeable era => HasTypeProxy (Certificate era) where diff --git a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs index 44b6f9f08e..dd8a56b73f 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs @@ -55,6 +55,8 @@ deriving instance Show (ConwayEraOnwards era) deriving instance Eq (ConwayEraOnwards era) +deriving instance Ord (ConwayEraOnwards era) + instance Eon ConwayEraOnwards where inEonForEra no yes = \case ByronEra -> no diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs index 5aead9b370..2535bc79d0 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs @@ -50,6 +50,8 @@ deriving instance Show (ShelleyToBabbageEra era) deriving instance Eq (ShelleyToBabbageEra era) +deriving instance Ord (ShelleyToBabbageEra era) + instance Eon ShelleyToBabbageEra where inEonForEra no yes = \case ByronEra -> no diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 6c52171f8c..81a1eedf12 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -245,10 +245,7 @@ estimateBalancedTxBody -- 1. Subtract certificate and proposal deposits -- from the total available Ada value! -- Page 24 Shelley ledger spec - let certificates = - case txCertificates txbodycontent1 of - TxCertificatesNone -> [] - TxCertificates _ certs _ -> map toShelleyCertificate certs + let certificates = convCertificates sbe $ txCertificates txbodycontent1 proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era)) proposalProcedures = @@ -478,8 +475,9 @@ estimateTransactionKeyWitnessCount length [() | (_, _, BuildTxWith KeyWitness{}) <- withdrawals] _ -> 0 + case txCertificates of - TxCertificates _ _ (BuildTxWith witnesses) -> - length [() | (_, KeyWitness{}) <- witnesses] + TxCertificates _ credWits -> + length + [() | (_, BuildTxWith (Just (_, KeyWitness{}))) <- toList credWits] _ -> 0 + case txUpdateProposal of TxUpdateProposal _ (UpdateProposal updatePerGenesisKey _) -> @@ -1500,18 +1498,27 @@ substituteExecutionUnits :: TxCertificates BuildTx era -> Either (TxBodyErrorAutoBalance era) (TxCertificates BuildTx era) mapScriptWitnessesCertificates TxCertificatesNone = Right TxCertificatesNone - mapScriptWitnessesCertificates txCertificates'@(TxCertificates supported certs _) = + mapScriptWitnessesCertificates txCertificates'@(TxCertificates supported _) = do let mappedScriptWitnesses - :: [(StakeCredential, Either (TxBodyErrorAutoBalance era) (Witness WitCtxStake era))] + :: [ ( Certificate era + , Either + (TxBodyErrorAutoBalance era) + ( BuildTxWith + BuildTx + ( Maybe + ( StakeCredential + , Witness WitCtxStake era + ) + ) + ) + ) + ] mappedScriptWitnesses = - [ (stakeCred, witness') - | (ix, _, stakeCred, witness) <- indexTxCertificates txCertificates' - , let witness' = adjustScriptWitness (substituteExecUnits ix) witness + [ (cert, BuildTxWith . Just . (stakeCred,) <$> eWitness') + | (ix, cert, stakeCred, witness) <- indexTxCertificates txCertificates' + , let eWitness' = adjustScriptWitness (substituteExecUnits ix) witness ] - in TxCertificates supported certs . BuildTxWith - <$> traverse - (\(sCred, eScriptWitness) -> (sCred,) <$> eScriptWitness) - mappedScriptWitnesses + TxCertificates supported . fromList <$> traverseScriptWitnesses mappedScriptWitnesses mapScriptWitnessesVotes :: Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era)) diff --git a/cardano-api/internal/Cardano/Api/Script.hs b/cardano-api/internal/Cardano/Api/Script.hs index 0ba0c92068..5e05384229 100644 --- a/cardano-api/internal/Cardano/Api/Script.hs +++ b/cardano-api/internal/Cardano/Api/Script.hs @@ -565,6 +565,8 @@ data ScriptLanguageInEra lang era where deriving instance Eq (ScriptLanguageInEra lang era) +deriving instance Ord (ScriptLanguageInEra lang era) + deriving instance Show (ScriptLanguageInEra lang era) instance ToJSON (ScriptLanguageInEra lang era) where @@ -742,7 +744,7 @@ data ScriptWitness witctx era where deriving instance Show (ScriptWitness witctx era) --- The GADT in the SimpleScriptWitness constructor requires a custom instance +-- The existential in the SimpleScriptWitness constructor requires a custom instance instance Eq (ScriptWitness witctx era) where (==) (SimpleScriptWitness langInEra script) diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 93dd37f9b9..a639599ed5 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -11,6 +11,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -135,6 +136,7 @@ module Cardano.Api.Tx.Body , TxWithdrawals (..) , indexTxWithdrawals , TxCertificates (..) + , mkTxCertificates , indexTxCertificates , TxUpdateProposal (..) , TxMintValue (..) @@ -302,6 +304,7 @@ import Data.Functor (($>)) import Data.List (sortBy) import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Ordered.Strict (OMap) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe @@ -1280,38 +1283,56 @@ indexTxWithdrawals (TxWithdrawals _ withdrawals) = -- data TxCertificates build era where + -- | No certificates TxCertificatesNone :: TxCertificates build era + -- | Represents certificates present in transaction. Prefer using 'mkTxCertificates' to constructing + -- this type with a constructor TxCertificates :: ShelleyBasedEra era - -> [Certificate era] - -> BuildTxWith build [(StakeCredential, Witness WitCtxStake era)] - -- ^ There can be more than one script witness per stake credential + -> OMap + (Certificate era) + ( BuildTxWith + build + (Maybe (StakeCredential, Witness WitCtxStake era)) + ) -> TxCertificates build era 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 same stake credential, they will be present multiple times with the same index. --- are multiple witnesses for the credential, there will be multiple entries for +-- | Create 'TxCertificates'. Note that 'Certificate era' will be deduplicated. Only Certificates with a +-- stake credential will be in the result. +mkTxCertificates + :: Applicative (BuildTxWith build) + => ShelleyBasedEra era + -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] + -> TxCertificates build era +mkTxCertificates _ [] = TxCertificatesNone +mkTxCertificates sbe certs = TxCertificates sbe . fromList $ map getStakeCred certs + where + getStakeCred (cert, mWit) = do + let wit = + maybe + (KeyWitness KeyWitnessForStakeAddr) + (ScriptWitness ScriptWitnessForStakeAddr) + mWit + ( cert + , pure $ + (,wit) <$> selectStakeCredentialWitness cert + ) + +-- | Index certificates with witnesses by the order they appear in the list (in the transaction). -- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf indexTxCertificates :: TxCertificates BuildTx era -> [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)] indexTxCertificates TxCertificatesNone = [] -indexTxCertificates (TxCertificates _ certs (BuildTxWith witnesses)) = - [ (ScriptWitnessIndexCertificate ix, cert, stakeCred, wit) - | (ix, cert) <- zip [0 ..] certs - , stakeCred <- maybeToList (selectStakeCredentialWitness cert) - , wit <- findAll stakeCred witnesses +indexTxCertificates (TxCertificates _ certsWits) = + [ (ScriptWitnessIndexCertificate ix, cert, stakeCred, witness) + | (ix, (cert, BuildTxWith (Just (stakeCred, witness)))) <- zip [0 ..] $ toList certsWits ] - where - findAll needle = map snd . filter ((==) needle . fst) - --- ---------------------------------------------------------------------------- --- Transaction update proposal (era-dependent) --- data TxUpdateProposal era where TxUpdateProposalNone :: TxUpdateProposal era @@ -2537,7 +2558,8 @@ fromLedgerTxCertificates sbe body = let certificates = body ^. L.certsTxBodyL in if null certificates then TxCertificatesNone - else TxCertificates sbe (map (fromShelleyCertificate sbe) $ toList certificates) ViewTx + else + TxCertificates sbe . fromList $ map ((,ViewTx) . fromShelleyCertificate sbe) $ toList certificates maybeFromLedgerTxUpdateProposal :: () @@ -2645,7 +2667,7 @@ convCertificates -> Seq.StrictSeq (Shelley.TxCert (ShelleyLedgerEra era)) convCertificates _ = \case TxCertificatesNone -> Seq.empty - TxCertificates _ cs _ -> fromList (map toShelleyCertificate cs) + TxCertificates _ cs -> fromList . map (toShelleyCertificate . fst) $ toList cs convWithdrawals :: TxWithdrawals build era -> L.Withdrawals StandardCrypto convWithdrawals txWithdrawals = diff --git a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs index 84c58d597f..4928309b99 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs @@ -159,7 +159,8 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote conwayEraOnwardsConstraints conwayOnwards $ (L.bodyTxL . L.votingProceduresTxBodyL) .~ votingProcedures - indexedTxCerts :: [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)] + indexedTxCerts + :: [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)] indexedTxCerts = indexTxCertificates txCertificates' allWitnesses diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 64c29775e8..3847e2893a 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -391,6 +391,7 @@ module Cardano.Api , TxExtraKeyWitnesses (..) , TxWithdrawals (..) , TxCertificates (..) + , mkTxCertificates , TxUpdateProposal (..) , TxMintValue (..) , txMintValueToValue