Added RATIFY thresholds

IntersectMBO · Aug 25, 2023 · 96b4497 · 96b4497
1 parent 63d98c3
commit 96b4497
Show file tree

Hide file tree

Showing 7 changed files with 301 additions and 40 deletions.
diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -16,6 +17,11 @@ module Cardano.Ledger.Conway.Core (
   module X,
   ConwayEraTxBody (..),
   ConwayEraPParams (..),
+  PParamGroup (..),
+  ParamGrouper,
+  pGroup,
+  pUngrouped,
+  modifiedGroups,
   ppPoolVotingThresholdsL,
   ppDRepVotingThresholdsL,
   ppMinCommitteeSizeL,
@@ -34,11 +40,16 @@ module Cardano.Ledger.Conway.Core (
   ppuDRepActivityL,
   PoolVotingThresholds (..),
   DRepVotingThresholds (..),
+  dvtPPNetworkGroupL,
+  dvtPPGovGroupL,
+  dvtPPTechnicalGroupL,
+  dvtPPEconomicGroupL,
 )
 where
 
+import Cardano.Ledger.Ap (Ap, runAp_)
 import Cardano.Ledger.Babbage.Core as X
-import Cardano.Ledger.BaseTypes (EpochNo, StrictMaybe, UnitInterval)
+import Cardano.Ledger.BaseTypes (EpochNo, StrictMaybe (..), UnitInterval)
 import Cardano.Ledger.Binary (DecCBOR, EncCBOR, decodeRecordNamed, encodeListLen)
 import Cardano.Ledger.Binary.Decoding (DecCBOR (decCBOR))
 import Cardano.Ledger.Binary.Encoding (EncCBOR (encCBOR))
@@ -50,8 +61,10 @@ import Data.Aeson (ToJSON)
 import Data.Default.Class (Default)
 import Data.Functor.Identity (Identity)
 import Data.Sequence.Strict (StrictSeq (..))
+import Data.Set (Set)
+import qualified Data.Set as Set
 import GHC.Generics (Generic)
-import Lens.Micro (Lens')
+import Lens.Micro (Lens', lens)
 import NoThunks.Class (NoThunks)
 import Numeric.Natural (Natural)
 
@@ -68,7 +81,33 @@ class BabbageEraTxBody era => ConwayEraTxBody era where
 
   treasuryDonationTxBodyL :: Lens' (TxBody era) Coin
 
+data PParamGroup
+  = EconomicGroup
+  | NetworkGroup
+  | TechnicalGroup
+  | GovernanceGroup
+  deriving (Eq, Ord)
+
+newtype ParamGrouper a = ParamGrouper {unParamGrouper :: Set PParamGroup}
+  deriving (Functor)
+
+pGroup :: PParamGroup -> StrictMaybe a -> Ap f (ParamGrouper a)
+pGroup pg (SJust _) = pure . ParamGrouper $ Set.singleton pg
+pGroup _ SNothing = pure $ ParamGrouper mempty
+
+pUngrouped :: Ap f (ParamGrouper a)
+pUngrouped = pure $ ParamGrouper mempty
+
+modifiedGroups ::
+  forall era.
+  ConwayEraPParams era =>
+  PParamsUpdate era ->
+  Set PParamGroup
+modifiedGroups = runAp_ unParamGrouper . (pparamsGroups @era)
+
 class BabbageEraPParams era => ConwayEraPParams era where
+  pparamsGroups ::
+    Functor f => PParamsUpdate era -> Ap f (PParamsHKD ParamGrouper era)
   ppuWellFormed :: PParamsUpdate era -> Bool
 
   hkdPoolVotingThresholdsL :: HKDFunctor f => Lens' (PParamsHKD f era) (HKD f PoolVotingThresholds)
@@ -167,6 +206,18 @@ data DRepVotingThresholds = DRepVotingThresholds
   }
   deriving (Eq, Ord, Show, Generic, Default, ToJSON, NFData, NoThunks)
 
+dvtPPNetworkGroupL :: Lens' DRepVotingThresholds UnitInterval
+dvtPPNetworkGroupL = lens dvtPPNetworkGroup (\x y -> x {dvtPPNetworkGroup = y})
+
+dvtPPEconomicGroupL :: Lens' DRepVotingThresholds UnitInterval
+dvtPPEconomicGroupL = lens dvtPPEconomicGroup (\x y -> x {dvtPPEconomicGroup = y})
+
+dvtPPTechnicalGroupL :: Lens' DRepVotingThresholds UnitInterval
+dvtPPTechnicalGroupL = lens dvtPPTechnicalGroup (\x y -> x {dvtPPTechnicalGroup = y})
+
+dvtPPGovGroupL :: Lens' DRepVotingThresholds UnitInterval
+dvtPPGovGroupL = lens dvtPPGovGroup (\x y -> x {dvtPPGovGroup = y})
+
 instance EncCBOR DRepVotingThresholds where
   encCBOR DRepVotingThresholds {..} =
     encodeListLen 10

diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -27,6 +28,7 @@ module Cardano.Ledger.Conway.Governance (
   GovActionIx (..),
   GovActionId (..),
   GovActionPurpose (..),
+  GovRole (..),
   PrevGovActionId (..),
   govActionIdToText,
   Voter (..),
@@ -40,9 +42,11 @@ module Cardano.Ledger.Conway.Governance (
   indexedGovProps,
   Constitution (..),
   ConwayEraGov (..),
+  threshold,
   -- Lenses
   cgGovActionsStateL,
   cgRatifyStateL,
+  ensCommitteeL,
   ensConstitutionL,
   rsEnactStateL,
   curPParamsConwayGovStateL,
@@ -52,7 +56,7 @@ module Cardano.Ledger.Conway.Governance (
 ) where
 
 import Cardano.Ledger.Address (RewardAcnt)
-import Cardano.Ledger.BaseTypes (EpochNo (..), ProtVer (..), StrictMaybe)
+import Cardano.Ledger.BaseTypes (EpochNo (..), ProtVer (..), StrictMaybe (..), UnitInterval)
 import Cardano.Ledger.Binary (
   DecCBOR (..),
   EncCBOR (..),
@@ -68,6 +72,7 @@ import Cardano.Ledger.Binary.Coders (
   (<!),
  )
 import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Conway.Core (ConwayEraPParams, PParamGroup (..), dvtPPEconomicGroupL, dvtPPGovGroupL, dvtPPNetworkGroupL, dvtPPTechnicalGroupL, modifiedGroups, ppDRepVotingThresholdsL, ppPoolVotingThresholdsL)
 import Cardano.Ledger.Conway.Era (ConwayEra)
 import Cardano.Ledger.Conway.Governance.Procedures (
   Anchor (..),
@@ -87,7 +92,10 @@ import Cardano.Ledger.Conway.Governance.Procedures (
   govActionIdToText,
   indexedGovProps,
  )
-import Cardano.Ledger.Conway.PParams ()
+import Cardano.Ledger.Conway.PParams (
+  DRepVotingThresholds (..),
+  PoolVotingThresholds (..),
+ )
 import Cardano.Ledger.Core
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.Crypto (Crypto)
@@ -99,6 +107,7 @@ import Data.Default.Class (Default (..))
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Sequence.Strict (StrictSeq)
+import qualified Data.Set as Set
 import GHC.Generics (Generic)
 import Lens.Micro
 import NoThunks.Class (NoThunks)
@@ -216,6 +225,9 @@ data EnactState era = EnactState
   }
   deriving (Generic)
 
+ensCommitteeL :: Lens' (EnactState era) (StrictMaybe (Committee era))
+ensCommitteeL = lens ensCommittee (\x y -> x {ensCommittee = y})
+
 ensConstitutionL :: Lens' (EnactState era) (Constitution era)
 ensConstitutionL = lens ensConstitution (\x y -> x {ensConstitution = y})
 
@@ -413,3 +425,65 @@ class EraGov era => ConwayEraGov era where
 
 instance Crypto c => ConwayEraGov (ConwayEra c) where
   constitutionGovStateL = cgRatifyStateL . rsEnactStateL . ensConstitutionL
+
+data GovRole
+  = SPO
+  | DRep
+  | CC
+
+pparamsUpdateThreshold ::
+  forall era.
+  ConwayEraPParams era =>
+  PParams era ->
+  PParamsUpdate era ->
+  UnitInterval
+pparamsUpdateThreshold pp ppu =
+  let thresholdLens = \case
+        NetworkGroup -> dvtPPNetworkGroupL
+        GovernanceGroup -> dvtPPGovGroupL
+        TechnicalGroup -> dvtPPTechnicalGroupL
+        EconomicGroup -> dvtPPEconomicGroupL
+      lookupGroupThreshold grp =
+        pp ^. ppDRepVotingThresholdsL . thresholdLens grp
+   in maximum $
+        Set.map lookupGroupThreshold $
+          modifiedGroups @era ppu
+
+threshold ::
+  ConwayEraPParams era =>
+  RatifyState era ->
+  GovAction era ->
+  GovRole ->
+  StrictMaybe UnitInterval
+threshold rSt action role =
+  let pp = rSt ^. rsEnactStateL . ensCurPParamsL
+      DRepVotingThresholds {..} = pp ^. ppDRepVotingThresholdsL
+      PoolVotingThresholds {..} = pp ^. ppPoolVotingThresholdsL
+      committee = rSt ^. rsEnactStateL . ensCommitteeL
+      ccThreshold = committeeQuorum <$> committee
+   in case (action, role) of
+        (NoConfidence {}, CC) -> SJust minBound
+        (NoConfidence {}, DRep) -> SJust dvtCommitteeNoConfidence
+        (NoConfidence {}, SPO) -> SJust pvtCommitteeNoConfidence
+        (NewCommittee {}, CC) -> SJust minBound
+        (NewCommittee {}, DRep) -> SJust $
+          case committee of
+            SJust _ -> dvtCommitteeNormal
+            SNothing -> dvtCommitteeNoConfidence
+        (NewCommittee {}, SPO) -> SJust $
+          case committee of
+            SJust _ -> pvtCommitteeNormal
+            SNothing -> pvtCommitteeNoConfidence
+        (NewConstitution {}, CC) -> ccThreshold
+        (NewConstitution {}, DRep) -> SJust dvtUpdateToConstitution
+        (NewConstitution {}, SPO) -> SJust minBound
+        (HardForkInitiation {}, CC) -> ccThreshold
+        (HardForkInitiation {}, DRep) -> SJust dvtHardForkInitiation
+        (HardForkInitiation {}, SPO) -> SJust pvtHardForkInitiation
+        (ParameterChange {}, CC) -> ccThreshold
+        (ParameterChange _ ppu, DRep) -> SJust $ pparamsUpdateThreshold pp ppu
+        (ParameterChange {}, SPO) -> SJust minBound
+        (TreasuryWithdrawals {}, CC) -> ccThreshold
+        (TreasuryWithdrawals {}, DRep) -> SJust dvtTreasuryWithdrawal
+        (TreasuryWithdrawals {}, SPO) -> SJust minBound
+        (InfoAction {}, _) -> SNothing
diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs
@@ -36,7 +36,6 @@ where
 import Cardano.Ledger.Alonzo.PParams (OrdExUnits (..))
 import Cardano.Ledger.Alonzo.Scripts (CostModels, ExUnits (..), Prices (Prices), emptyCostModels)
 import Cardano.Ledger.Babbage (BabbageEra)
-import Cardano.Ledger.Babbage.Core hiding (Value)
 import Cardano.Ledger.Babbage.PParams
 import Cardano.Ledger.BaseTypes (EpochNo (EpochNo), NonNegativeInterval, ProtVer (ProtVer), UnitInterval)
 import Cardano.Ledger.Binary
@@ -294,6 +293,39 @@ instance Crypto c => BabbageEraPParams (ConwayEra c) where
   hkdCoinsPerUTxOByteL = lens cppCoinsPerUTxOByte (\pp x -> pp {cppCoinsPerUTxOByte = x})
 
 instance Crypto c => ConwayEraPParams (ConwayEra c) where
+  pparamsGroups (PParamsUpdate ConwayPParams {..}) =
+    ConwayPParams
+      <$> pGroup EconomicGroup cppMinFeeA
+      <*> pGroup EconomicGroup cppMinFeeB
+      <*> pGroup NetworkGroup cppMaxBBSize
+      <*> pGroup NetworkGroup cppMaxTxSize
+      <*> pGroup NetworkGroup cppMaxBHSize
+      <*> pGroup EconomicGroup cppKeyDeposit
+      <*> pGroup EconomicGroup cppPoolDeposit
+      <*> pGroup TechnicalGroup cppEMax
+      <*> pGroup TechnicalGroup cppNOpt
+      <*> pGroup TechnicalGroup cppA0
+      <*> pGroup EconomicGroup cppRho
+      <*> pGroup EconomicGroup cppTau
+      <*> pUngrouped
+      <*> pGroup EconomicGroup cppMinPoolCost
+      <*> pGroup EconomicGroup cppCoinsPerUTxOByte
+      <*> pGroup TechnicalGroup cppCostModels
+      <*> pGroup EconomicGroup cppPrices
+      <*> pGroup NetworkGroup cppMaxTxExUnits
+      <*> pGroup NetworkGroup cppMaxBlockExUnits
+      <*> pGroup NetworkGroup cppMaxValSize
+      <*> pGroup TechnicalGroup cppCollateralPercentage
+      <*> pGroup NetworkGroup cppMaxCollateralInputs
+      <*> pGroup GovernanceGroup cppPoolVotingThresholds
+      <*> pGroup GovernanceGroup cppDRepVotingThresholds
+      <*> pGroup GovernanceGroup cppMinCommitteeSize
+      <*> pGroup GovernanceGroup cppCommitteeTermLimit
+      <*> pGroup GovernanceGroup cppGovActionExpiration
+      <*> pGroup GovernanceGroup cppGovActionDeposit
+      <*> pGroup GovernanceGroup cppDRepDeposit
+      <*> pGroup GovernanceGroup cppDRepActivity
+
   ppuWellFormed ppu =
     and
       [ -- Numbers