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 <[email protected]>

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) #-}
 

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) #-}
 

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) #-}
 

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

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
 

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) #-}
 

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`

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 =>

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

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
           )
         ,

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
 

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,
  )

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

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`

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