From 22c41240952428b4f364ef5ec9b629ff59ad6cdc Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Wed, 22 Nov 2023 20:43:23 +0100 Subject: [PATCH] Use only stake credentials required in witnessing --- .../internal/Cardano/Api/Certificate.hs | 24 +++++++++++-------- cardano-api/internal/Cardano/Api/Fees.hs | 2 +- cardano-api/internal/Cardano/Api/TxBody.hs | 8 ++++--- cardano-api/internal/Cardano/Api/Utils.hs | 1 + cardano-api/src/Cardano/Api.hs | 1 + 5 files changed, 22 insertions(+), 14 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index 3dc15ee526..65880cd429 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -55,6 +55,7 @@ module Cardano.Api.Certificate ( makeGenesisKeyDelegationCertificate, Ledger.MIRTarget (..), Ledger.MIRPot(..), + selectStakeCredentialWitness, -- * Internal conversion functions toShelleyCertificate, @@ -62,13 +63,13 @@ module Cardano.Api.Certificate ( toShelleyPoolParams, fromShelleyPoolParams, + -- * Data family instances AsType(..), -- * Internal functions filterUnRegCreds, filterUnRegDRepCreds, - selectStakeCredential, ) where import Cardano.Api.Address @@ -467,19 +468,21 @@ makeStakeAddressAndDRepDelegationCertificate w cred delegatee deposit = -- Helper functions -- -selectStakeCredential - :: Certificate era -> Maybe StakeCredential -selectStakeCredential = fmap fromShelleyStakeCredential . \case +-- | Get the stake credential witness for a certificate that requires it. +-- Only stake address deregistration and delegation requires witnessing (witness can be script or key). +selectStakeCredentialWitness + :: Certificate era + -> Maybe StakeCredential +selectStakeCredentialWitness = fmap fromShelleyStakeCredential . \case ShelleyRelatedCertificate stbEra shelleyCert -> shelleyToBabbageEraConstraints stbEra $ case shelleyCert of - Ledger.RegTxCert sCred -> Just sCred + Ledger.RegTxCert _ -> Nothing -- contains stake cred Ledger.UnRegTxCert sCred -> Just sCred Ledger.DelegStakeTxCert sCred _ -> Just sCred -- StakePool is always controlled by key, i.e. it is never a script. In other words, -- @Credential StakePool@ cannot exist, because @ScriptHashObj@ constructor can't be used for that type. Ledger.RegPoolTxCert _ -> Nothing -- contains StakePool key which cannot be a credential Ledger.RetirePoolTxCert _ _ -> Nothing -- contains StakePool key which cannot be a credential - Ledger.MirTxCert _ -> Nothing Ledger.GenesisDelegTxCert{} -> Nothing @@ -487,9 +490,9 @@ selectStakeCredential = fmap fromShelleyStakeCredential . \case case conwayCert of Ledger.RegPoolTxCert _ -> Nothing -- contains StakePool key which cannot be a credential Ledger.RetirePoolTxCert _ _ -> Nothing -- contains StakePool key which cannot be a credential - Ledger.RegTxCert sCred -> Just sCred + Ledger.RegTxCert{} -> Nothing -- contains stake cred Ledger.UnRegTxCert sCred -> Just sCred - Ledger.RegDepositTxCert sCred _ -> Just sCred + Ledger.RegDepositTxCert{} -> Nothing -- contains stake cred Ledger.UnRegDepositTxCert sCred _ -> Just sCred Ledger.DelegTxCert sCred _ -> Just sCred Ledger.RegDepositDelegTxCert sCred _ _ -> Just sCred @@ -499,6 +502,7 @@ selectStakeCredential = fmap fromShelleyStakeCredential . \case Ledger.UnRegDRepTxCert{} -> Nothing Ledger.UpdateDRepTxCert{} -> Nothing + filterUnRegCreds :: Certificate era -> Maybe StakeCredential filterUnRegCreds = fmap fromShelleyStakeCredential . \case @@ -523,7 +527,7 @@ filterUnRegCreds = fmap fromShelleyStakeCredential . \case Ledger.DelegTxCert _ _ -> Nothing Ledger.RegDepositDelegTxCert{} -> Nothing Ledger.AuthCommitteeHotKeyTxCert{} -> Nothing - Ledger.ResignCommitteeColdTxCert _ _ -> Nothing + Ledger.ResignCommitteeColdTxCert{} -> Nothing Ledger.RegDRepTxCert{} -> Nothing Ledger.UnRegDRepTxCert{} -> Nothing Ledger.UpdateDRepTxCert{} -> Nothing @@ -544,7 +548,7 @@ filterUnRegDRepCreds = \case Ledger.DelegTxCert _ _ -> Nothing Ledger.RegDepositDelegTxCert{} -> Nothing Ledger.AuthCommitteeHotKeyTxCert{} -> Nothing - Ledger.ResignCommitteeColdTxCert _ _ -> Nothing + Ledger.ResignCommitteeColdTxCert{} -> Nothing Ledger.RegDRepTxCert{} -> Nothing Ledger.UnRegDRepTxCert cred _ -> Just cred Ledger.UpdateDRepTxCert{} -> Nothing diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 362f00c04f..408e3ea642 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -1150,7 +1150,7 @@ mapTxScriptWitnesses f txbodycontent@TxBodyContent { [ (stakecred, ScriptWitness ctx <$> witness') -- The certs are indexed in list order | (ix, cert) <- zip [0..] certs - , stakecred <- maybeToList (selectStakeCredential cert) + , stakecred <- maybeToList (selectStakeCredentialWitness cert) , ScriptWitness ctx witness <- maybeToList (Map.lookup stakecred witnesses) , let witness' = f (ScriptWitnessIndexCertificate ix) witness diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 78fa5205e4..3db1dc1f0e 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -257,6 +257,7 @@ import qualified Text.Parsec as Parsec import Text.Parsec (()) import qualified Text.Parsec.String as Parsec + -- | Indicates whether a script is expected to fail or pass validation. data ScriptValidity = ScriptInvalid -- ^ Script is expected to fail validation. @@ -1843,7 +1844,8 @@ createTransactionBody sbe bc = mkCommonTxBody sbe (txIns bc) (txOuts bc) (txFee bc) (txWithdrawals bc) txAuxData & A.certsTxBodyL sbe .~ certs & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound bc) - & ( appEndo $ mconcat + & appEndo + ( mconcat [ setUpdateProposal , setInvalidBefore , setMint @@ -1854,7 +1856,7 @@ createTransactionBody sbe bc = , setCollateralReturn , setTotalCollateral ] - ) + ) -- TODO: NetworkId for hardware wallets. We don't always want this -- & L.networkIdTxBodyL .~ ... @@ -3264,7 +3266,7 @@ collectTxBodyScriptWitnesses _ TxBodyContent { -- The certs are indexed in list order | (ix, cert) <- zip [0..] certs , ScriptWitness _ witness <- maybeToList $ do - stakecred <- selectStakeCredential cert + stakecred <- selectStakeCredentialWitness cert Map.lookup stakecred witnesses ] diff --git a/cardano-api/internal/Cardano/Api/Utils.hs b/cardano-api/internal/Cardano/Api/Utils.hs index 67147d1d4f..6e6ce008e7 100644 --- a/cardano-api/internal/Cardano/Api/Utils.hs +++ b/cardano-api/internal/Cardano/Api/Utils.hs @@ -140,3 +140,4 @@ modifyWith :: () => (a -> a) -> (a -> a) modifyWith = id + diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 1f7600e2d6..2c8c8e9413 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -862,6 +862,7 @@ module Cardano.Api ( makeGenesisKeyDelegationCertificate, MIRTarget (..), MIRPot(..), + selectStakeCredentialWitness, -- * Protocol parameter updates UpdateProposal(..),