From 16a9090d62bacaf441a4da9726cf2483d006e0ee Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Wed, 6 Sep 2023 15:37:46 +0530 Subject: [PATCH] Add conway-specific certs to deposit/refunds (#3700) * Add conway-specific certs to deposit/refunds * A cleaner way to deal with deposits/refunds cross eras * Deprecate is(De)RegKey in favour of is(Un)RegStakeTxCert * Update changelogs * Revert is(De)RegKey --------- Co-authored-by: Alexey Kuleshevich --- .../impl/src/Cardano/Ledger/Allegra/TxCert.hs | 8 ++++ .../impl/src/Cardano/Ledger/Alonzo/TxCert.hs | 9 +++++ .../impl/src/Cardano/Ledger/Babbage/TxCert.hs | 8 ++++ eras/conway/impl/CHANGELOG.md | 1 + .../impl/src/Cardano/Ledger/Conway/TxCert.hs | 10 +++++ .../impl/src/Cardano/Ledger/Mary/TxCert.hs | 11 +++++ eras/shelley/impl/CHANGELOG.md | 1 + .../Shelley/LedgerState/RefundsAndDeposits.hs | 40 +++++++++---------- .../impl/src/Cardano/Ledger/Shelley/TxCert.hs | 11 +++++ .../Ledger/Shelley/Rules/ClassifyTraces.hs | 6 +-- libs/cardano-ledger-api/CHANGELOG.md | 2 + .../src/Cardano/Ledger/Api/Tx/Cert.hs | 8 ++++ .../test/Test/Cardano/Ledger/Api/Tx/Body.hs | 3 +- libs/cardano-ledger-core/CHANGELOG.md | 1 + .../src/Cardano/Ledger/Core/TxCert.hs | 17 ++++++++ 15 files changed, 109 insertions(+), 27 deletions(-) diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxCert.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxCert.hs index 31f2110c6cb..688fd801e04 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxCert.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxCert.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -28,6 +29,13 @@ instance Crypto c => EraTxCert (AllegraEra c) where getRetirePoolTxCert (ShelleyTxCertPool (RetirePool poolId epochNo)) = Just (poolId, epochNo) getRetirePoolTxCert _ = Nothing + lookupRegStakeTxCert = \case + RegTxCert c -> Just c + _ -> Nothing + lookupUnRegStakeTxCert = \case + UnRegTxCert c -> Just c + _ -> Nothing + instance Crypto c => ShelleyEraTxCert (AllegraEra c) where {-# SPECIALIZE instance ShelleyEraTxCert (AllegraEra StandardCrypto) #-} diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxCert.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxCert.hs index ca29afb8e99..18b00fdc6ab 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxCert.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxCert.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -28,6 +30,13 @@ instance Crypto c => EraTxCert (AlonzoEra c) where getRetirePoolTxCert (ShelleyTxCertPool (RetirePool poolId epochNo)) = Just (poolId, epochNo) getRetirePoolTxCert _ = Nothing + lookupRegStakeTxCert = \case + RegTxCert c -> Just c + _ -> Nothing + lookupUnRegStakeTxCert = \case + UnRegTxCert c -> Just c + _ -> Nothing + instance Crypto c => ShelleyEraTxCert (AlonzoEra c) where {-# SPECIALIZE instance ShelleyEraTxCert (AlonzoEra StandardCrypto) #-} diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxCert.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxCert.hs index b1b24cd3128..94b8105658e 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxCert.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxCert.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -28,6 +29,13 @@ instance Crypto c => EraTxCert (BabbageEra c) where getRetirePoolTxCert (ShelleyTxCertPool (RetirePool poolId epochNo)) = Just (poolId, epochNo) getRetirePoolTxCert _ = Nothing + lookupRegStakeTxCert = \case + RegTxCert c -> Just c + _ -> Nothing + lookupUnRegStakeTxCert = \case + UnRegTxCert c -> Just c + _ -> Nothing + instance Crypto c => ShelleyEraTxCert (BabbageEra c) where {-# SPECIALIZE instance ShelleyEraTxCert (BabbageEra StandardCrypto) #-} diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index 2d56cb838a7..d5b095da809 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -27,6 +27,7 @@ ## 1.8.0.0 +* Add all Conway `TxCert` to consumed/produced calculations in the `UTXO` rule. #3700 * Change `ToJSONKey` implementation of `Voter` to flat text * Add DRep refund calculation #3688 * Add `conwayConsumedValue` as `getConsumedValue` for Conway diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs index 693f8f3a762..318b4b9315f 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs @@ -122,6 +122,16 @@ instance Crypto c => EraTxCert (ConwayEra c) where getRetirePoolTxCert (ConwayTxCertPool (RetirePool poolId epochNo)) = Just (poolId, epochNo) getRetirePoolTxCert _ = Nothing + lookupRegStakeTxCert = \case + RegTxCert c -> Just c + RegDepositTxCert c _ -> Just c + RegDepositDelegTxCert c _ _ -> Just c + _ -> Nothing + lookupUnRegStakeTxCert = \case + UnRegTxCert c -> Just c + UnRegDepositTxCert c _ -> Just c + _ -> Nothing + instance Crypto c => ShelleyEraTxCert (ConwayEra c) where mkRegTxCert c = ConwayTxCertDeleg $ ConwayRegCert c SNothing diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/TxCert.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/TxCert.hs index 6631fceecf2..348830353df 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/TxCert.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/TxCert.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -14,6 +16,8 @@ import Cardano.Ledger.Shelley.TxCert ( getScriptWitnessShelleyTxCert, getVKeyWitnessShelleyTxCert, upgradeShelleyTxCert, + pattern RegTxCert, + pattern UnRegTxCert, ) instance Crypto c => EraTxCert (MaryEra c) where @@ -37,6 +41,13 @@ instance Crypto c => EraTxCert (MaryEra c) where getRetirePoolTxCert (ShelleyTxCertPool (RetirePool poolId epochNo)) = Just (poolId, epochNo) getRetirePoolTxCert _ = Nothing + lookupRegStakeTxCert = \case + RegTxCert c -> Just c + _ -> Nothing + lookupUnRegStakeTxCert = \case + UnRegTxCert c -> Just c + _ -> Nothing + instance Crypto c => ShelleyEraTxCert (MaryEra c) where {-# SPECIALIZE instance ShelleyEraTxCert (MaryEra StandardCrypto) #-} diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 14829497f2f..b36aca50338 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -6,6 +6,7 @@ ## 1.6.0.0 +* Deprecate `isRegKey` and `isDeRegKey` in favor of `isRegStakeTxCert` and `isUnRegStakeTxCert` #3700 * Add lenses for `UTxOEnv` #3688 * Add `getTotalTxDepositsBody` to `ShelleyEraTxBody` * Add `obligationGovState` to `EraGov` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/RefundsAndDeposits.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/RefundsAndDeposits.hs index bab610bf24d..7e93c0a8f90 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/RefundsAndDeposits.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/RefundsAndDeposits.hs @@ -25,11 +25,6 @@ import Cardano.Ledger.Credential (StakeCredential) import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) import Cardano.Ledger.PoolParams (PoolParams (..)) import Cardano.Ledger.Shelley.Core (ShelleyEraTxBody (..), ShelleyEraTxCert) -import Cardano.Ledger.Shelley.TxCert ( - isRegKey, - pattern RegTxCert, - pattern UnRegTxCert, - ) import Cardano.Ledger.Val ((<+>), (<×>)) import Data.Foldable (Foldable (..), foldMap', foldl') import qualified Data.Map.Strict as Map @@ -61,7 +56,7 @@ totalCertsDeposits pp isRegPool certs = <+> numNewRegPoolCerts <×> (pp ^. ppPoolDepositL) where - numKeys = getSum @Int $ foldMap' (\x -> if isRegKey x then 1 else 0) certs + numKeys = getSum @Int $ foldMap' (\x -> if isRegStakeTxCert x then 1 else 0) certs numNewRegPoolCerts = Set.size (foldl' addNewPoolIds Set.empty certs) addNewPoolIds regPoolIds = \case RegPoolTxCert (PoolParams {ppId}) @@ -118,21 +113,24 @@ keyCertsRefunds :: keyCertsRefunds pp lookupDeposit certs = snd (foldl' accum (mempty, Coin 0) certs) where keyDeposit = pp ^. ppKeyDepositL - accum (!regKeys, !totalRefunds) = \case - RegTxCert k -> - -- Need to track new delegations in case that the same key is later deregistered in - -- the same transaction. - (Set.insert k regKeys, totalRefunds) - UnRegTxCert k - -- We first check if there was already a registration certificate in this - -- transaction. - | Set.member k regKeys -> (Set.delete k regKeys, totalRefunds <+> keyDeposit) - -- Check for the deposit left during registration in some previous - -- transaction. This de-registration check will be matched first, despite being - -- the last case to match, because registration is not possible without - -- de-registration. - | Just deposit <- lookupDeposit k -> (regKeys, totalRefunds <+> deposit) - _ -> (regKeys, totalRefunds) + accum (!regKeys, !totalRefunds) cert = + case lookupRegStakeTxCert cert of + Just k -> + -- Need to track new delegations in case that the same key is later deregistered in + -- the same transaction. + (Set.insert k regKeys, totalRefunds) + Nothing -> + case lookupUnRegStakeTxCert cert of + Just k + -- We first check if there was already a registration certificate in this + -- transaction. + | Set.member k regKeys -> (Set.delete k regKeys, totalRefunds <+> keyDeposit) + -- Check for the deposit left during registration in some previous + -- transaction. This de-registration check will be matched first, despite being + -- the last case to match, because registration is not possible without + -- de-registration. + | Just deposit <- lookupDeposit k -> (regKeys, totalRefunds <+> deposit) + _ -> (regKeys, totalRefunds) keyTxRefunds :: ShelleyEraTxBody era => diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxCert.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxCert.hs index e8ea3dccc22..e1dba80b480 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxCert.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxCert.hs @@ -72,6 +72,8 @@ module Cardano.Ledger.Shelley.TxCert ( Delegation (..), PoolCert (..), poolCWitness, + isRegStakeTxCert, + isUnRegStakeTxCert, ) where @@ -130,6 +132,13 @@ instance Crypto c => EraTxCert (ShelleyEra c) where getRetirePoolTxCert (ShelleyTxCertPool (RetirePool poolId epochNo)) = Just (poolId, epochNo) getRetirePoolTxCert _ = Nothing + lookupRegStakeTxCert = \case + RegTxCert c -> Just c + _ -> Nothing + lookupUnRegStakeTxCert = \case + UnRegTxCert c -> Just c + _ -> Nothing + class EraTxCert era => ShelleyEraTxCert era where mkRegTxCert :: StakeCredential (EraCrypto era) -> TxCert era getRegTxCert :: TxCert era -> Maybe (StakeCredential (EraCrypto era)) @@ -478,11 +487,13 @@ delegCWitness (ShelleyDelegCert cred _) = cred isRegKey :: ShelleyEraTxCert era => TxCert era -> Bool isRegKey (RegTxCert _) = True isRegKey _ = False +{-# DEPRECATED isRegKey "Use `isRegStakeTxCert` instead" #-} -- | Check for 'ShelleyUnRegCert' constructor isDeRegKey :: ShelleyEraTxCert era => TxCert era -> Bool isDeRegKey (UnRegTxCert _) = True isDeRegKey _ = False +{-# DEPRECATED isDeRegKey "Use `isUnRegStakeTxCert` instead" #-} -- | Check for 'ShelleyDelegCert' constructor isDelegation :: ShelleyEraTxCert era => TxCert era -> Bool diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs index 23592a1cc52..3c013c276de 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs @@ -34,10 +34,8 @@ import Cardano.Ledger.Shelley.PParams ( pattern Update, ) import Cardano.Ledger.Shelley.TxCert ( - isDeRegKey, isDelegation, isGenesisDelegation, - isRegKey, isRegPool, isReservesMIRCert, isRetirePool, @@ -146,12 +144,12 @@ relevantCasesAreCoveredForTrace tr = do ) , ( "there is at least 1 RegKey certificate for every 10 transactions" - , length txs < 10 * length (filter isRegKey certs_) + , length txs < 10 * length (filter isRegStakeTxCert certs_) , 60 ) , ( "there is at least 1 DeRegKey certificate for every 20 transactions" - , length txs < 20 * length (filter isDeRegKey certs_) + , length txs < 20 * length (filter isUnRegStakeTxCert certs_) , 60 ) , diff --git a/libs/cardano-ledger-api/CHANGELOG.md b/libs/cardano-ledger-api/CHANGELOG.md index 42a947269af..0ae60f26341 100644 --- a/libs/cardano-ledger-api/CHANGELOG.md +++ b/libs/cardano-ledger-api/CHANGELOG.md @@ -5,6 +5,8 @@ * Rename: * `GovActionsState` to `GovSnapshots` * `cgGovActionsStateL` to `cgGovSnapshotsL` +* Add `lookupRegStakeTxCert` and `lookupUnRegStakeTxCert` +* Add `isRegStakeTxCert` and `isUnRegStakeTxCert` ## 1.5.0.0 diff --git a/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx/Cert.hs b/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx/Cert.hs index 5cd2d889161..612ca9f62bd 100644 --- a/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx/Cert.hs +++ b/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx/Cert.hs @@ -7,6 +7,10 @@ module Cardano.Ledger.Api.Tx.Cert ( getScriptWitnessTxCert, pattern RegPoolTxCert, pattern RetirePoolTxCert, + lookupRegStakeTxCert, + lookupUnRegStakeTxCert, + isRegStakeTxCert, + isUnRegStakeTxCert, -- * Shelley Era @@ -79,8 +83,12 @@ import Cardano.Ledger.Core ( TxCertUpgradeError, getScriptWitnessTxCert, getVKeyWitnessTxCert, + lookupRegStakeTxCert, + lookupUnRegStakeTxCert, upgradeTxCert ), + isRegStakeTxCert, + isUnRegStakeTxCert, pattern RegPoolTxCert, pattern RetirePoolTxCert, ) diff --git a/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/Tx/Body.hs b/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/Tx/Body.hs index 4dc2e4537db..5526cad1c2b 100644 --- a/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/Tx/Body.hs +++ b/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/Tx/Body.hs @@ -17,7 +17,6 @@ import Cardano.Ledger.Compactible import Cardano.Ledger.PoolParams import Cardano.Ledger.Shelley.Core import Cardano.Ledger.Shelley.TxCert ( - isRegKey, pattern RegTxCert, pattern UnRegTxCert, ) @@ -42,7 +41,7 @@ totalTxDeposits pp dpstate txb = numKeys <×> pp ^. ppKeyDepositL <+> snd (foldl' accum (regpools, Coin 0) certs) where certs = toList (txb ^. certsTxBodyL) - numKeys = length $ filter isRegKey certs + numKeys = length $ filter isRegStakeTxCert certs regpools = psStakePoolParams (certPState dpstate) accum (!pools, !ans) (RegPoolTxCert poolparam) = -- We don't pay a deposit on a pool that is already registered diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 14a679ec59c..44f8fc3519b 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -6,6 +6,7 @@ ## 1.6.0.0 +* Add `lookupRegStakeTxCert` and `lookupUnRegStakeTxCert` to `EraTxCert` typeclass #3700 * Change `ToJSONKey`/`FromJSONKey` implementation of `Credential` to flat text * Add one more parameter to `getConsumedValue` to lookup DRep deposits #3688 * `Credential 'DRepRole (EraCrypto era) -> Maybe Coin` diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core/TxCert.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/TxCert.hs index 127d935ec9a..c1408052e1a 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core/TxCert.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/TxCert.hs @@ -24,6 +24,8 @@ module Cardano.Ledger.Core.TxCert ( DRepAlwaysAbstain, DRepAlwaysNoConfidence ), + isRegStakeTxCert, + isUnRegStakeTxCert, ) where @@ -48,6 +50,7 @@ import Cardano.Ledger.TreeDiff (ToExpr) import Control.DeepSeq (NFData (..), rwhnf) import Data.Aeson (ToJSON) import Data.Kind (Type) +import Data.Maybe (isJust) import Data.Void (Void) import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) @@ -92,6 +95,12 @@ class mkRetirePoolTxCert :: KeyHash 'StakePool (EraCrypto era) -> EpochNo -> TxCert era getRetirePoolTxCert :: TxCert era -> Maybe (KeyHash 'StakePool (EraCrypto era), EpochNo) + -- | Extract staking credential from any certificate that can register such credential + lookupRegStakeTxCert :: TxCert era -> Maybe (Credential 'Staking (EraCrypto era)) + + -- | Extract staking credential from any certificate that can unregister such credential + lookupUnRegStakeTxCert :: TxCert era -> Maybe (Credential 'Staking (EraCrypto era)) + pattern RegPoolTxCert :: EraTxCert era => PoolParams (EraCrypto era) -> TxCert era pattern RegPoolTxCert d <- (getRegPoolTxCert -> Just d) where @@ -193,3 +202,11 @@ pattern DRepCredential c <- (dRepToCred -> Just c) KeyHashObj kh -> DRepKeyHash kh {-# COMPLETE DRepCredential, DRepAlwaysAbstain, DRepAlwaysNoConfidence :: DRep #-} + +-- | Check if supplied TxCert is a stake registering certificate +isRegStakeTxCert :: EraTxCert era => TxCert era -> Bool +isRegStakeTxCert = isJust . lookupRegStakeTxCert + +-- | Check if supplied TxCert is a stake un-registering certificate +isUnRegStakeTxCert :: EraTxCert era => TxCert era -> Bool +isUnRegStakeTxCert = isJust . lookupUnRegStakeTxCert