Utilize new PParams prediction functionality for HFC

cabal.project

@@ -29,8 +29,8 @@ packages:
 source-repository-package
   type: git
   location: https://github.com/IntersectMBO/cardano-ledger
-  tag: a6ee7925fa8070497658a2c8b3770dcd79017281
-  --sha256: sha256-rigDlJcsTYa56/qa+W9TGBu2IbHLndmrHqVzcHoPTBI=
+  tag: 2b5a62eb1025b22ff10f46727d1d7b521df865d9
+  --sha256: sha256-oVMvD1mO+le+ur+o5UPttfXt4Htqrb0hM1mAmvGrapk=
   subdir: eras/allegra/impl
     eras/alonzo/impl
     eras/alonzo/test-suite

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -141,7 +141,7 @@ library
     cardano-ledger-byron ^>=1.0,
     cardano-ledger-conway ^>=1.14,
     cardano-ledger-core ^>=1.12,
-    cardano-ledger-mary ^>=1.5,
+    cardano-ledger-mary ^>=1.6,
     cardano-ledger-shelley ^>=1.10,
     cardano-prelude,
     cardano-protocol-tpraos ^>=1.2,

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs

@@ -159,14 +159,6 @@ class ( Core.EraSegWits era
          , SL.Validated (Core.Tx era)
          )
 
-  -- | Get the protocol version out of a 'Core.PParamsUpdate', used to detect
-  -- whether we should perform a HF. This will likely be removed/changed once we
-  -- implement HF enactment in Conway (see
-  -- <https://github.com/IntersectMBO/ouroboros-consensus/issues/61>).
-  --
-  -- For now, this always returns 'Nothing' for Conway (see the instance below).
-  getProposedProtocolVersion :: Core.PParamsUpdate era -> Maybe ProtVer
-
   -- | Whether the era has an instance of 'CG.ConwayEraGov'
   getConwayEraGovDict :: proxy era -> Maybe (ConwayEraGovDict era)
 
@@ -194,58 +186,41 @@ defaultApplyShelleyBasedTx globals ledgerEnv mempoolState _wti tx =
       mempoolState
       tx
 
-defaultGetProposedProtocolVersion ::
-     (EraPParams era, ProtVerAtMost era 8)
-  => Core.PParamsUpdate era
-  -> Maybe ProtVer
-defaultGetProposedProtocolVersion proposal =
-    strictMaybeToMaybe $ proposal ^. ppuProtocolVersionL
-
 defaultGetConwayEraGovDict :: proxy era -> Maybe (ConwayEraGovDict era)
 defaultGetConwayEraGovDict _ = Nothing
 
 instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => ShelleyBasedEra (ShelleyEra c) where
   applyShelleyBasedTx = defaultApplyShelleyBasedTx
 
-  getProposedProtocolVersion = defaultGetProposedProtocolVersion
-
   getConwayEraGovDict = defaultGetConwayEraGovDict
 
 instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => ShelleyBasedEra (AllegraEra c) where
   applyShelleyBasedTx = defaultApplyShelleyBasedTx
 
-  getProposedProtocolVersion = defaultGetProposedProtocolVersion
-
   getConwayEraGovDict = defaultGetConwayEraGovDict
 
 instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => ShelleyBasedEra (MaryEra c) where
   applyShelleyBasedTx = defaultApplyShelleyBasedTx
 
-  getProposedProtocolVersion = defaultGetProposedProtocolVersion
-
   getConwayEraGovDict = defaultGetConwayEraGovDict
 
 instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => ShelleyBasedEra (AlonzoEra c) where
   applyShelleyBasedTx = applyAlonzoBasedTx
 
-  getProposedProtocolVersion = defaultGetProposedProtocolVersion
-
   getConwayEraGovDict = defaultGetConwayEraGovDict
 
 instance (Praos.PraosCrypto c) => ShelleyBasedEra (BabbageEra c) where
   applyShelleyBasedTx = applyAlonzoBasedTx
 
-  getProposedProtocolVersion = defaultGetProposedProtocolVersion
-
   getConwayEraGovDict = defaultGetConwayEraGovDict
 
 instance (Praos.PraosCrypto c) => ShelleyBasedEra (ConwayEra c) where
   applyShelleyBasedTx = applyAlonzoBasedTx
-  getProposedProtocolVersion _ = Nothing
+
   getConwayEraGovDict _ = Just ConwayEraGovDict
 
 applyAlonzoBasedTx :: forall era.

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Inspect.hs

@@ -8,166 +8,52 @@
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 module Ouroboros.Consensus.Shelley.Ledger.Inspect (
-    ProtocolUpdate (..)
-  , ShelleyLedgerUpdate (..)
-  , UpdateProposal (..)
-  , UpdateState (..)
-  , protocolUpdates
+    ShelleyLedgerUpdate (..)
+  , pparamsUpdate
   ) where
 
 import qualified Cardano.Ledger.Shelley.API as SL
 import qualified Cardano.Ledger.Shelley.Core as Core
+import qualified Cardano.Ledger.Shelley.Governance as SL
 import qualified Cardano.Ledger.Shelley.LedgerState as SL
-import qualified Cardano.Ledger.Shelley.PParams as SL
 import           Control.Monad
-import           Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import           Data.Maybe (fromMaybe)
 import           Data.Void
-import           Data.Word (Word64)
-import           Lens.Micro.Extras (view)
+import           Lens.Micro ((^.))
 import           Ouroboros.Consensus.Block
-import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.Inspect
-import           Ouroboros.Consensus.Shelley.Eras (EraCrypto,
-                     ShelleyBasedEra (..))
 import           Ouroboros.Consensus.Shelley.Ledger.Block
 import           Ouroboros.Consensus.Shelley.Ledger.Ledger
 import           Ouroboros.Consensus.Util.Condense
 
-data ProtocolUpdate era = ProtocolUpdate {
-      protocolUpdateProposal :: UpdateProposal era
-    , protocolUpdateState    :: UpdateState (EraCrypto era)
-    }
-deriving instance Eq (Core.PParamsUpdate era) => Eq (ProtocolUpdate era)
-deriving instance Show (Core.PParamsUpdate era) => Show (ProtocolUpdate era)
-
--- | Update proposal
---
--- As in Byron, a proposal is a partial map from parameters to their values.
-data UpdateProposal era = UpdateProposal {
-      -- | The protocol parameters changed by this update proposal
-      --
-      -- An update is /identified/ by how it updates the protocol parameters.
-      proposalParams  :: Core.PParamsUpdate era
-
-      -- | New version (if changed by this proposal)
-      --
-      -- The protocol version itself is also considered to be just another
-      -- parameter, and parameters can change /without/ changing the protocol
-      -- version, although a convention /could/ be established that the protocol
-      -- version must change if any of the parameters do; but the specification
-      -- itself does not mandate this.
-      --
-      -- We record the version separately for the convenience of the HFC.
-    , proposalVersion :: Maybe SL.ProtVer
-
-      -- | The 'EpochNo' the proposal becomes active in, if it is adopted
-    , proposalEpoch   :: EpochNo
-    }
-
-deriving instance Eq (Core.PParamsUpdate era) => Eq (UpdateProposal era)
-deriving instance Show (Core.PParamsUpdate era) => Show (UpdateProposal era)
-
--- | Proposal state
---
--- The update mechanism in Shelley is simpler than it is in Byron. There is no
--- distinction between votes and proposals: to \"vote\" for a proposal one
--- merely submits the exact same proposal. There is also no separate
--- endorsement step. The procedure is as follows:
---
--- 1. During each epoch, a genesis key can submit (via its delegates) zero,
---    one, or many proposals; each submission overrides the previous one.
--- 2. \"Voting\" (submitting of proposals) ends @2 * stabilityWindow@ slots
---    (i.e. @6k/f@) before the end of the epoch. In other words, proposals
---    for the upcoming epoch must be submitted within the first @4k/f@ slots
---    of this one.
--- 3. At the end of an epoch, if the majority of nodes (as determined by the
---    @Quorum@ specification constant, which must be greater than half the
---    nodes) have most recently submitted the same exact proposal, then it is
---    adopted.
--- 4. The next epoch is always started with a clean slate, proposals from the
---    previous epoch that didn't make it are discarded (except for "future
---    proposals" that are explicitly marked for future epochs).
-data UpdateState c = UpdateState {
-      -- | The genesis delegates that voted for this proposal
-      proposalVotes         :: [SL.KeyHash 'SL.Genesis c]
-
-      -- | Has this proposal reached sufficient votes to be adopted?
-    , proposalReachedQuorum :: Bool
-    }
-  deriving (Show, Eq)
-
-protocolUpdates ::
-       forall era proto. ShelleyBasedEra era
-    => SL.ShelleyGenesis (EraCrypto era)
-    -> LedgerState (ShelleyBlock proto era)
-    -> [ProtocolUpdate era]
-protocolUpdates genesis st = [
-      ProtocolUpdate {
-          protocolUpdateProposal = UpdateProposal {
-              proposalParams  = proposal
-            , proposalEpoch   = succ currentEpoch
-            , proposalVersion = getProposedProtocolVersion proposal
-            }
-        , protocolUpdateState = UpdateState {
-              proposalVotes         = votes
-            , proposalReachedQuorum = length votes >= fromIntegral quorum
-            }
-        }
-    | (proposal, votes) <- Map.toList $ invertMap proposals
-    ]
-  where
-    invertMap :: Ord b => Map a b -> Map b [a]
-    invertMap = Map.fromListWith (<>) . fmap swizzle . Map.toList
-      where
-        swizzle (a, b) = (b, [a])
-
-    -- Updated proposed within the proposal window
-    proposals :: Map (SL.KeyHash 'SL.Genesis (EraCrypto era)) (Core.PParamsUpdate era)
-    SL.ProposedPPUpdates proposals =
-          fromMaybe SL.emptyPPPUpdates
-        . Core.getProposedPPUpdates
-        . view SL.newEpochStateGovStateL
-        . shelleyLedgerState
-        $ st
-
-    -- A proposal is accepted if the number of votes is equal to or greater
-    -- than the quorum. The quorum itself must be strictly greater than half
-    -- the number of genesis keys, but we do not rely on that property here.
-    quorum :: Word64
-    quorum = SL.sgUpdateQuorum genesis
-
-    -- The proposals in 'SL.proposals' are for the upcoming epoch
-    -- (we ignore 'futureProposals')
-    currentEpoch :: EpochNo
-    currentEpoch = SL.nesEL . shelleyLedgerState $ st
-
-{-------------------------------------------------------------------------------
-  Inspection
--------------------------------------------------------------------------------}
-
 data ShelleyLedgerUpdate era =
-    ShelleyUpdatedProtocolUpdates [ProtocolUpdate era]
+  ShelleyUpdatedPParams (Maybe (Core.PParams era)) EpochNo
 
-deriving instance Eq (Core.PParamsUpdate era) => Eq (ShelleyLedgerUpdate era)
-deriving instance Show (Core.PParamsUpdate era) => Show (ShelleyLedgerUpdate era)
+deriving instance Eq (Core.PParams era) => Eq (ShelleyLedgerUpdate era)
+deriving instance Show (Core.PParams era) => Show (ShelleyLedgerUpdate era)
 
-instance Show (Core.PParamsUpdate era) => Condense (ShelleyLedgerUpdate era) where
+instance Show (Core.PParams era) => Condense (ShelleyLedgerUpdate era) where
   condense = show
 
 instance ShelleyBasedEra era => InspectLedger (ShelleyBlock proto era) where
   type LedgerWarning (ShelleyBlock proto era) = Void
   type LedgerUpdate  (ShelleyBlock proto era) = ShelleyLedgerUpdate era
 
-  inspectLedger tlc before after = do
+  inspectLedger _tlc before after = do
       guard $ updatesBefore /= updatesAfter
-      return $ LedgerUpdate $ ShelleyUpdatedProtocolUpdates updatesAfter
+      return $ LedgerUpdate updatesAfter
     where
-      genesis :: SL.ShelleyGenesis (EraCrypto era)
-      genesis = shelleyLedgerGenesis (configLedger tlc)
 
-      updatesBefore, updatesAfter :: [ProtocolUpdate era]
-      updatesBefore = protocolUpdates genesis before
-      updatesAfter  = protocolUpdates genesis after
+      updatesBefore, updatesAfter :: ShelleyLedgerUpdate era
+      updatesBefore = pparamsUpdate before
+      updatesAfter  = pparamsUpdate after
+
+pparamsUpdate ::
+       forall era proto. ShelleyBasedEra era
+    => LedgerState (ShelleyBlock proto era)
+    -> ShelleyLedgerUpdate era
+pparamsUpdate st =
+    let nes = shelleyLedgerState st
+     in ShelleyUpdatedPParams
+          (nes ^. SL.newEpochStateGovStateL . SL.futurePParamsGovStateG)
+          (succ (SL.nesEL nes))

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs

@@ -32,13 +32,13 @@ import           Cardano.Slotting.EpochInfo (hoistEpochInfo)
 import           Control.Monad (guard)
 import           Control.Monad.Except (runExcept, throwError, withExceptT)
 import qualified Data.Map.Strict as Map
-import           Data.Maybe
 import           Data.SOP.BasicFunctors
 import           Data.SOP.InPairs (RequiringBoth (..), ignoringBoth)
 import qualified Data.Text as T (pack)
 import           Data.Void (Void)
 import           Data.Word
 import           GHC.Generics (Generic)
+import           Lens.Micro ((^.))
 import           NoThunks.Class (NoThunks)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
@@ -137,9 +137,8 @@ shelleyTransition ::
 shelleyTransition ShelleyPartialLedgerConfig{..}
                   transitionMajorVersionRaw
                   state =
-      takeAny
-    . mapMaybe isTransition
-    . Shelley.Inspect.protocolUpdates genesis
+      isTransition
+    . Shelley.Inspect.pparamsUpdate
     $ state
   where
     ShelleyTransitionInfo{..} = shelleyLedgerTransition state
@@ -152,24 +151,14 @@ shelleyTransition ShelleyPartialLedgerConfig{..}
     k :: Word64
     k = SL.sgSecurityParam genesis
 
-    isTransition :: Shelley.Inspect.ProtocolUpdate era -> Maybe EpochNo
-    isTransition Shelley.Inspect.ProtocolUpdate{..} = do
-         SL.ProtVer major _minor <- proposalVersion
+    isTransition :: ShelleyLedgerUpdate era -> Maybe EpochNo
+    isTransition (ShelleyUpdatedPParams maybePParams newPParamsEpochNo) = do
+         pp <- maybePParams
+         let protVer = pp ^. SL.ppProtocolVersionL
          transitionMajorVersion <- SL.mkVersion transitionMajorVersionRaw
-         guard $ major == transitionMajorVersion
-         guard $ proposalReachedQuorum
+         guard $ SL.pvMajor protVer == transitionMajorVersion
          guard $ shelleyAfterVoting >= fromIntegral k
-         return proposalEpoch
-       where
-         Shelley.Inspect.UpdateProposal{..} = protocolUpdateProposal
-         Shelley.Inspect.UpdateState{..}    = protocolUpdateState
-
-    -- In principle there could be multiple proposals that all change the
-    -- major protocol version. In practice this can't happen because each
-    -- delegate can only vote for one proposal, but the types don't guarantee
-    -- this. We don't need to worry about this, and just pick any of them.
-    takeAny :: [a] -> Maybe a
-    takeAny = listToMaybe
+         return newPParamsEpochNo
 
 instance
   ( ShelleyCompatible proto era,