Merge pull request #3628 from input-output-hk/aniketd/deleg-pool-gsta…

…te-certs-spec-v0-8-conformance

DELEG, GOVCERT conformance with Spec v0.8

eras/conway/impl/CHANGELOG.md

@@ -2,6 +2,10 @@
 
 ## 1.7.0.0
 
+* Make `DELEG`, `POOL` and `GOVCERT` conform to spec-v0.8 #3628
+  * Add `CertEnv` and `CertsEnv` to pass `EpochNo` down from `LEDGER` to sub-rules
+  * Add `drepDeposit` to `DRepState` to track deposits paid by `DRep`s
+  * Update `DRep` expiry in `LEDGER` for all `DRep`s who are voting in current `Tx`
 * Add `ConwayGovCertEnv`
 * Change the environment of `GOVCERT` to `ConwayGovCertEnv`
 * Add `ConwayEraGov` with `constitutionGovStateL`

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Cert.hs

@@ -18,9 +18,10 @@ module Cardano.Ledger.Conway.Rules.Cert (
   ConwayCERT,
   ConwayCertPredFailure (..),
   ConwayCertEvent,
+  CertEnv (..),
 ) where
 
-import Cardano.Ledger.BaseTypes (ShelleyBase)
+import Cardano.Ledger.BaseTypes (EpochNo, ShelleyBase, SlotNo)
 import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
 import Cardano.Ledger.Binary.Coders
 import Cardano.Ledger.Conway.Core
@@ -43,8 +44,6 @@ import Cardano.Ledger.Conway.TxCert (
 import Cardano.Ledger.Shelley.API (
   CertState (..),
   DState,
-  DelegEnv (DelegEnv),
-  DelplEnv (DelplEnv),
   PState,
   PoolEnv (PoolEnv),
   VState,
@@ -65,6 +64,12 @@ import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks)
 
+data CertEnv era = CertEnv
+  { ceSlotNo :: !SlotNo
+  , cePParams :: !(PParams era)
+  , ceCurrentEpoch :: !EpochNo
+  }
+
 data ConwayCertPredFailure era
   = DelegFailure (PredicateFailure (EraRule "DELEG" era))
   | PoolFailure (PredicateFailure (EraRule "POOL" era))
@@ -110,7 +115,7 @@ instance
   , State (EraRule "DELEG" era) ~ DState era
   , State (EraRule "POOL" era) ~ PState era
   , State (EraRule "GOVCERT" era) ~ VState era
-  , Environment (EraRule "DELEG" era) ~ DelegEnv era
+  , Environment (EraRule "DELEG" era) ~ PParams era
   , Environment (EraRule "POOL" era) ~ PoolEnv era
   , Environment (EraRule "GOVCERT" era) ~ ConwayGovCertEnv era
   , Signal (EraRule "DELEG" era) ~ ConwayDelegCert (EraCrypto era)
@@ -125,7 +130,7 @@ instance
   where
   type State (ConwayCERT era) = CertState era
   type Signal (ConwayCERT era) = TxCert era
-  type Environment (ConwayCERT era) = DelplEnv era
+  type Environment (ConwayCERT era) = CertEnv era
   type BaseM (ConwayCERT era) = ShelleyBase
   type PredicateFailure (ConwayCERT era) = ConwayCertPredFailure era
   type Event (ConwayCERT era) = ConwayCertEvent era
@@ -137,7 +142,7 @@ certTransition ::
   ( State (EraRule "DELEG" era) ~ DState era
   , State (EraRule "POOL" era) ~ PState era
   , State (EraRule "GOVCERT" era) ~ VState era
-  , Environment (EraRule "DELEG" era) ~ DelegEnv era
+  , Environment (EraRule "DELEG" era) ~ PParams era
   , Environment (EraRule "POOL" era) ~ PoolEnv era
   , Environment (EraRule "GOVCERT" era) ~ ConwayGovCertEnv era
   , Signal (EraRule "DELEG" era) ~ ConwayDelegCert (EraCrypto era)
@@ -150,17 +155,17 @@ certTransition ::
   ) =>
   TransitionRule (ConwayCERT era)
 certTransition = do
-  TRC (DelplEnv slot ptr pp acnt, cState, c) <- judgmentContext
+  TRC (CertEnv slot pp currentEpoch, cState, c) <- judgmentContext
   let CertState {certDState, certPState, certVState} = cState
   case c of
     ConwayTxCertDeleg delegCert -> do
-      newDState <- trans @(EraRule "DELEG" era) $ TRC (DelegEnv slot ptr acnt pp, certDState, delegCert)
+      newDState <- trans @(EraRule "DELEG" era) $ TRC (pp, certDState, delegCert)
       pure $ cState {certDState = newDState}
     ConwayTxCertPool poolCert -> do
       newPState <- trans @(EraRule "POOL" era) $ TRC (PoolEnv slot pp, certPState, poolCert)
       pure $ cState {certPState = newPState}
     ConwayTxCertGov govCert -> do
-      newVState <- trans @(EraRule "GOVCERT" era) $ TRC (ConwayGovCertEnv pp slot, certVState, govCert)
+      newVState <- trans @(EraRule "GOVCERT" era) $ TRC (ConwayGovCertEnv pp currentEpoch, certVState, govCert)
       pure $ cState {certVState = newVState}
 
 instance

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs

@@ -19,9 +19,10 @@ module Cardano.Ledger.Conway.Rules.Certs (
   ConwayCERTS,
   ConwayCertsPredFailure (..),
   ConwayCertsEvent (..),
+  CertsEnv (..),
 ) where
 
-import Cardano.Ledger.BaseTypes (Globals (..), ShelleyBase, mkCertIxPartial)
+import Cardano.Ledger.BaseTypes (EpochNo, Globals (..), ShelleyBase, SlotNo)
 import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
 import Cardano.Ledger.Binary.Coders (
   Decode (..),
@@ -31,20 +32,29 @@ import Cardano.Ledger.Binary.Coders (
   (!>),
   (<!),
  )
+import Cardano.Ledger.CertState (certDStateL, certVStateL, vsDRepsL)
+import Cardano.Ledger.Conway.Core (
+  ConwayEraPParams,
+  ConwayEraTxBody (votingProceduresTxBodyL),
+  Era (EraCrypto),
+  EraRule,
+  EraTx (Tx, bodyTxL),
+  EraTxBody (withdrawalsTxBodyL),
+  EraTxCert (TxCert),
+  PParams,
+  ppDRepActivityL,
+ )
 import Cardano.Ledger.Conway.Era (ConwayCERT, ConwayCERTS)
-import Cardano.Ledger.Conway.Rules.Cert (ConwayCertEvent, ConwayCertPredFailure)
-import Cardano.Ledger.Core
+import Cardano.Ledger.Conway.Governance (Voter (DRepVoter), VotingProcedures (unVotingProcedures))
+import Cardano.Ledger.Conway.Rules.Cert (CertEnv (CertEnv), ConwayCertEvent, ConwayCertPredFailure)
+import Cardano.Ledger.DRepDistr (drepExpiryL)
 import Cardano.Ledger.Shelley.API (
   CertState (..),
   Coin,
-  DelegsEnv (DelegsEnv),
-  DelplEnv (DelplEnv),
   KeyHash,
   KeyRole (..),
-  Ptr (Ptr),
   RewardAcnt,
  )
-import Cardano.Ledger.Shelley.Core (ShelleyEraTxBody)
 import Cardano.Ledger.Shelley.Rules (
   drainWithdrawals,
   validateDelegationRegistered,
@@ -61,19 +71,26 @@ import Control.State.Transition.Extended (
   trans,
   validateTrans,
  )
-import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
 import Data.Sequence (Seq (..))
 import GHC.Generics (Generic)
-import Lens.Micro ((^.))
+import Lens.Micro
 import NoThunks.Class (NoThunks (..))
 
+data CertsEnv era = CertsEnv
+  { certsTx :: !(Tx era)
+  , certsPParams :: !(PParams era)
+  , certsSlotNo :: !SlotNo
+  , certsCurrentEpoch :: !EpochNo
+  }
+
 data ConwayCertsPredFailure era
   = -- | Target pool which is not registered
     DelegateeNotRegisteredDELEG
       !(KeyHash 'StakePool (EraCrypto era))
   | -- | Withdrawals that are missing or do not withdrawal the entire amount
     WithdrawalsNotInRewardsCERTS
-      !(Map (RewardAcnt (EraCrypto era)) Coin)
+      !(Map.Map (RewardAcnt (EraCrypto era)) Coin)
   | -- | CERT rule subtransition Failures
     CertFailure !(PredicateFailure (EraRule "CERT" era))
   deriving (Generic)
@@ -118,17 +135,18 @@ instance
 
 instance
   ( EraTx era
-  , ShelleyEraTxBody era
+  , ConwayEraTxBody era
+  , ConwayEraPParams era
   , State (EraRule "CERT" era) ~ CertState era
   , Signal (EraRule "CERT" era) ~ TxCert era
-  , Environment (EraRule "CERT" era) ~ DelplEnv era
+  , Environment (EraRule "CERT" era) ~ CertEnv era
   , Embed (EraRule "CERT" era) (ConwayCERTS era)
   ) =>
   STS (ConwayCERTS era)
   where
   type State (ConwayCERTS era) = CertState era
   type Signal (ConwayCERTS era) = Seq (TxCert era)
-  type Environment (ConwayCERTS era) = DelegsEnv era
+  type Environment (ConwayCERTS era) = CertsEnv era
   type BaseM (ConwayCERTS era) = ShelleyBase
   type
     PredicateFailure (ConwayCERTS era) =
@@ -140,34 +158,49 @@ instance
 conwayCertsTransition ::
   forall era.
   ( EraTx era
-  , ShelleyEraTxBody era
+  , ConwayEraTxBody era
+  , ConwayEraPParams era
   , State (EraRule "CERT" era) ~ CertState era
   , Embed (EraRule "CERT" era) (ConwayCERTS era)
-  , Environment (EraRule "CERT" era) ~ DelplEnv era
+  , Environment (EraRule "CERT" era) ~ CertEnv era
   , Signal (EraRule "CERT" era) ~ TxCert era
   ) =>
   TransitionRule (ConwayCERTS era)
 conwayCertsTransition = do
-  TRC (env@(DelegsEnv slot txIx pp tx acnt), certState, certificates) <- judgmentContext
+  TRC
+    ( env@(CertsEnv tx pp slot currentEpoch)
+      , certState
+      , certificates
+      ) <-
+    judgmentContext
   network <- liftSTS $ asks networkId
 
   case certificates of
     Empty -> do
-      let dState = certDState certState
+      -- Update DRep expiry for all DReps that are voting in this transaction
+      let drepActivity = pp ^. ppDRepActivityL
+          updatedVSDReps =
+            Map.foldlWithKey'
+              ( \dreps voter _ -> case voter of
+                  DRepVoter cred -> Map.adjust (drepExpiryL .~ currentEpoch + drepActivity) cred dreps
+                  _ -> dreps
+              )
+              (certState ^. certVStateL . vsDRepsL)
+              (unVotingProcedures $ tx ^. bodyTxL . votingProceduresTxBodyL)
+          certStateWithDRepExpiryUpdated = certState & certVStateL . vsDRepsL .~ updatedVSDReps
+          dState = certStateWithDRepExpiryUpdated ^. certDStateL
           withdrawals = tx ^. bodyTxL . withdrawalsTxBodyL
+      -- Validate withdrawals and rewards and drain withdrawals
       validateTrans WithdrawalsNotInRewardsCERTS $
         validateZeroRewards dState withdrawals network
-      pure $ certState {certDState = drainWithdrawals dState withdrawals}
+      pure $ certStateWithDRepExpiryUpdated & certDStateL .~ drainWithdrawals dState withdrawals
     gamma :|> c -> do
       certState' <-
         trans @(ConwayCERTS era) $ TRC (env, certState, gamma)
       validateTrans DelegateeNotRegisteredDELEG $
         validateDelegationRegistered certState' c
-      -- It is impossible to have 65535 number of certificates in a
-      -- transaction, therefore partial function is justified.
-      let ptr = Ptr slot txIx (mkCertIxPartial $ toInteger $ length gamma)
       trans @(EraRule "CERT" era) $
-        TRC (DelplEnv slot ptr pp acnt, certState', c)
+        TRC (CertEnv slot pp currentEpoch, certState', c)
 
 instance
   ( Era era