diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs index 04608a0e72..c2f9fe3b0f 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -23,6 +23,7 @@ module Ouroboros.Consensus.Cardano.CanHardFork -- * Re-exports of Shelley code , ShelleyPartialLedgerConfig (..) , crossEraForecastAcrossShelley + , viaTranslateProto , translateChainDepStateAcrossShelley -- * Exposed for testing @@ -47,6 +48,8 @@ import Control.Monad.Except (throwError) import Data.Coerce (coerce) import qualified Data.Map.Strict as Map import Data.Proxy +import Cardano.Ledger.Dijkstra.Genesis (DijkstraGenesis (..)) +import Cardano.Ledger.Dijkstra.PParams (UpgradeDijkstraPParams (..)) import Data.SOP.BasicFunctors import Data.SOP.Functors (Flip (..)) import Data.SOP.InPairs (RequiringBoth (..), ignoringBoth) @@ -95,7 +98,8 @@ import qualified Ouroboros.Consensus.Protocol.PBFT.State as PBftState import Ouroboros.Consensus.Protocol.Praos (Praos) import qualified Ouroboros.Consensus.Protocol.Praos as Praos import Ouroboros.Consensus.Protocol.Praos.Common (PraosTiebreakerView) -import Ouroboros.Consensus.Protocol.Praos2 (LeiosCrypto, Praos2) +import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views +import Ouroboros.Consensus.Protocol.Praos2 (LeiosCrypto, LeiosOnly (Praos2HasLeios), Praos2) import Ouroboros.Consensus.Protocol.TPraos import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos import Ouroboros.Consensus.Shelley.HFEras () @@ -169,12 +173,12 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where PNil , crossEraForecast = PCons crossEraForecastByronToShelleyWrapper $ - PCons crossEraForecastAcrossShelley $ - PCons crossEraForecastAcrossShelley $ - PCons crossEraForecastAcrossShelley $ - PCons crossEraForecastAcrossShelley $ - PCons crossEraForecastAcrossShelley $ - PCons crossEraForecastAcrossShelley $ + PCons (crossEraForecastAcrossShelley viaTranslateProto) $ + PCons (crossEraForecastAcrossShelley viaTranslateProto) $ + PCons (crossEraForecastAcrossShelley viaTranslateProto) $ + PCons (crossEraForecastAcrossShelley viaTranslateProto) $ + PCons (crossEraForecastAcrossShelley viaTranslateProto) $ + PCons (crossEraForecastAcrossShelley translateLedgerViewConwayToDijkstra) $ PNil } hardForkChainSel = @@ -728,15 +732,15 @@ translateLedgerStateConwayToDijkstraWrapper = . SL.translateEra' (getDijkstraTranslationContext cfgDijkstra) . Comp . Flip - . transLeiosLS + . transPraos2LS } where -- Only the protocol index changes, so nothing in here is converted; the -- rebuild is what retypes it. - transLeiosLS :: + transPraos2LS :: LedgerState (ShelleyBlock (Praos c) ConwayEra) mk -> LedgerState (ShelleyBlock (Praos2 c) ConwayEra) mk - transLeiosLS (ShelleyLedgerState wo nes st tb) = + transPraos2LS (ShelleyLedgerState wo nes st tb) = ShelleyLedgerState { shelleyLedgerTip = fmap castShelleyTip wo , shelleyLedgerState = nes @@ -754,6 +758,38 @@ translateLedgerTablesConwayToDijkstraWrapper = , translateTxOutWith = SL.upgradeTxOut } +-- | How Dijkstra sees a Conway ledger view, for forecasting across the +-- boundary. +-- +-- The Leios parameters are those the Dijkstra genesis sets when the ledger +-- translates its state at the boundary; Conway's governance cannot change +-- them. The committee is empty, which is the truth in every slot a forecast +-- from Conway can reach: Conway's stake snapshots carry no committee, a +-- Dijkstra committee is first seated by a snapshot rotation at an epoch +-- boundary after the first Dijkstra epoch, and a forecast reaches at most a +-- stability window, less than an epoch, past the boundary. +translateLedgerViewConwayToDijkstra :: + forall c. + TranslateLedgerViewAcrossShelley (Praos c) (Praos2 c) DijkstraEra +translateLedgerViewConwayToDijkstra = + TranslateLedgerViewAcrossShelley $ \cfgDijkstra lv -> + let DijkstraGenesis{dgUpgradePParams = upgrade} = + shelleyLedgerTranslationContext cfgDijkstra + in (translateLedgerView (Proxy @(Praos c, Praos2 c)) lv) + { Views.plvQuorumStakeThreshold = + Praos2HasLeios $ udppLeiosQuorumStakeThreshold upgrade + , Views.plvAnnouncementPeriodLength = + Praos2HasLeios $ udppLeiosAnnouncementPeriodLength upgrade + , Views.plvVotePeriodLength = + Praos2HasLeios $ udppLeiosVotePeriodLength upgrade + , Views.plvDiffusionPeriodLength = + Praos2HasLeios $ udppLeiosDiffusionPeriodLength upgrade + , Views.plvMaxEbBodySize = + Praos2HasLeios $ udppMaxEndorserBlockReferencesSize upgrade + , Views.plvMaxEbTxsSize = + Praos2HasLeios $ udppMaxEndorserBlockTxsSize upgrade + } + getDijkstraTranslationContext :: WrapLedgerConfig (ShelleyBlock (Praos2 c) DijkstraEra) -> SL.TranslationContext DijkstraEra diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs index dcd5c86b7b..2fc92fe0b6 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -22,6 +22,8 @@ module Ouroboros.Consensus.Shelley.ShelleyHFC , ShelleyPartialLedgerConfig (..) , crossEraForecastAcrossShelley , forecastAcrossShelley + , TranslateLedgerViewAcrossShelley (..) + , viaTranslateProto , translateChainDepStateAcrossShelley ) where @@ -298,24 +300,41 @@ translateChainDepStateAcrossShelley = -- ticking the state. WrapChainDepState $ translateChainDepState (Proxy @(protoFrom, protoTo)) chainDepState +-- | How the next Shelley-based era sees the ledger view of the era before it, +-- for forecasting across the boundary; see 'crossEraForecastAcrossShelley'. +-- +-- The new era's ledger config is at hand, since its translation context +-- determines whatever the new view has that the old one lacks. +newtype TranslateLedgerViewAcrossShelley protoFrom protoTo eraTo + = TranslateLedgerViewAcrossShelley + (ShelleyLedgerConfig eraTo -> LedgerView protoFrom -> LedgerView protoTo) + +-- | The protocol's own translation, which suffices whenever the new view has +-- nothing the old one lacks. +viaTranslateProto :: + forall protoFrom protoTo eraTo. + TranslateProto protoFrom protoTo => + TranslateLedgerViewAcrossShelley protoFrom protoTo eraTo +viaTranslateProto = + TranslateLedgerViewAcrossShelley $ \_cfgTo -> + translateLedgerView (Proxy @(protoFrom, protoTo)) + crossEraForecastAcrossShelley :: forall eraFrom eraTo protoFrom protoTo. - ( TranslateProto protoFrom protoTo - , LedgerSupportsProtocol (ShelleyBlock protoFrom eraFrom) - ) => + LedgerSupportsProtocol (ShelleyBlock protoFrom eraFrom) => + TranslateLedgerViewAcrossShelley protoFrom protoTo eraTo -> RequiringBoth WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView) (ShelleyBlock protoFrom eraFrom) (ShelleyBlock protoTo eraTo) -crossEraForecastAcrossShelley = coerce forecastAcrossShelley +crossEraForecastAcrossShelley translate = coerce (forecastAcrossShelley translate) -- | Forecast from a Shelley-based era to the next Shelley-based era. forecastAcrossShelley :: forall protoFrom protoTo eraFrom eraTo mk. - ( TranslateProto protoFrom protoTo - , LedgerSupportsProtocol (ShelleyBlock protoFrom eraFrom) - ) => + LedgerSupportsProtocol (ShelleyBlock protoFrom eraFrom) => + TranslateLedgerViewAcrossShelley protoFrom protoTo eraTo -> ShelleyLedgerConfig eraFrom -> ShelleyLedgerConfig eraTo -> -- | Transition between the two eras @@ -324,7 +343,7 @@ forecastAcrossShelley :: SlotNo -> LedgerState (ShelleyBlock protoFrom eraFrom) mk -> Except OutsideForecastRange (WrapLedgerView (ShelleyBlock protoTo eraTo)) -forecastAcrossShelley cfgFrom cfgTo transition forecastFor ledgerStateFrom +forecastAcrossShelley (TranslateLedgerViewAcrossShelley translate) cfgFrom cfgTo transition forecastFor ledgerStateFrom | forecastFor < maxFor = return $ futureLedgerView forecastFor | otherwise = @@ -342,7 +361,7 @@ forecastAcrossShelley cfgFrom cfgTo transition forecastFor ledgerStateFrom WrapLedgerView . either (\e -> error ("futureLedgerView failed: " <> show e)) - (translateLedgerView (Proxy @(protoFrom, protoTo))) + (translate cfgTo) . runExcept . Forecast.forecastFor (ledgerViewForecastAt cfgFrom ledgerStateFrom) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs index f09589f07a..923c179026 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs @@ -72,6 +72,7 @@ import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Forging (MkBlockForging) import Ouroboros.Consensus.Cardano.CanHardFork ( crossEraForecastAcrossShelley + , viaTranslateProto , translateChainDepStateAcrossShelley ) import Ouroboros.Consensus.Cardano.Node (TriggerHardFork (..)) @@ -268,7 +269,7 @@ instance { translateLedgerState = PCons translateLedgerState PNil , translateLedgerTables = PCons translateLedgerTables PNil , translateChainDepState = PCons translateChainDepStateAcrossShelley PNil - , crossEraForecast = PCons crossEraForecastAcrossShelley PNil + , crossEraForecast = PCons (crossEraForecastAcrossShelley viaTranslateProto) PNil } where translateLedgerState :: diff --git a/ouroboros-consensus-cardano/test/cardano-test/Main.hs b/ouroboros-consensus-cardano/test/cardano-test/Main.hs index 88fbe76863..4321b111e3 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Main.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Main.hs @@ -10,7 +10,7 @@ import qualified Test.Consensus.Cardano.Serialisation (tests) import qualified Test.Consensus.Cardano.Show () import qualified Test.Consensus.Cardano.SupportedNetworkProtocolVersion import qualified Test.Consensus.Cardano.SupportsSanityCheck -import qualified Test.Consensus.Cardano.Translation (tests) +import qualified Test.Consensus.Cardano.Translation (forecastTests, tests) import qualified Test.Consensus.Cardano.TxId (tests) import Test.Tasty import qualified Test.ThreadNet.AllegraMary @@ -47,5 +47,6 @@ tests = , Test.ThreadNet.ShelleyAllegra.tests , Test.Consensus.Cardano.MiniProtocol.LocalTxSubmission.Server.tests , Test.Consensus.Cardano.Translation.tests + , Test.Consensus.Cardano.Translation.forecastTests , Test.Consensus.Cardano.TxId.tests ] diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs index e0b0371eed..f5626a49d7 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs @@ -11,7 +11,7 @@ {-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-} #endif -module Test.Consensus.Cardano.Translation (tests) where +module Test.Consensus.Cardano.Translation (forecastTests, tests) where import qualified Cardano.Chain.Block as Byron import qualified Cardano.Chain.UTxO as Byron @@ -39,18 +39,26 @@ import Cardano.Slotting.Slot (EpochNo (..)) import qualified Data.Map.Strict as Map import Data.SOP.InPairs (RequiringBoth (..), provideBoth) import Ouroboros.Consensus.BlockchainTime.WallClock.Types - ( slotLengthFromSec + ( RelativeTime (..) + , slotLengthFromSec ) +import Ouroboros.Consensus.Ledger.Abstract (ledgerTipSlot) import Ouroboros.Consensus.Byron.Ledger (ByronBlock, byronLedgerState) import Ouroboros.Consensus.Cardano.Block (CardanoEras) import Ouroboros.Consensus.Cardano.CanHardFork () +import Cardano.Ledger.Dijkstra.Genesis (DijkstraGenesis (..)) +import Cardano.Ledger.Dijkstra.PParams (UpgradeDijkstraPParams (..)) +import Control.Monad.Except (runExcept) +import Ouroboros.Consensus.HardFork.History (Bound (..)) +import Ouroboros.Consensus.Block (PerasRoundNo (..), succWithOrigin) import Ouroboros.Consensus.HardFork.Combinator - ( InPairs (..) + ( EraTranslation (..) + , InPairs (..) , hardForkEraTranslation - , translateLedgerState ) import Ouroboros.Consensus.HardFork.Combinator.State.Types - ( TranslateLedgerState (..) + ( CrossEraForecaster (..) + , TranslateLedgerState (..) ) import Ouroboros.Consensus.Ledger.Basics ( LedgerCfg @@ -61,7 +69,8 @@ import Ouroboros.Consensus.Ledger.Tables hiding (TxIn) import Ouroboros.Consensus.Ledger.Tables.Diff (Diff) import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff import Ouroboros.Consensus.Protocol.Praos -import Ouroboros.Consensus.Protocol.Praos2 (Praos2) +import Ouroboros.Consensus.Protocol.Praos2 (LeiosOnly (Praos2HasLeios), Praos2) +import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.HFEras () @@ -69,6 +78,7 @@ import Ouroboros.Consensus.Shelley.Ledger ( BigEndianTxIn (..) , ShelleyBlock , ShelleyLedgerConfig + , ShelleyLedgerConfig (..) , mkShelleyLedgerConfig , shelleyLedgerState , shelleyLedgerTables @@ -260,6 +270,89 @@ testTablesTranslation propLabel translateWithConfig translationShouldSatisfy led (WrapLedgerConfig tsSrcLedgerConfig) (WrapLedgerConfig tsDestLedgerConfig) + +{------------------------------------------------------------------------------- + Forecasting across an era boundary +-------------------------------------------------------------------------------} + +forecastTests :: TestTree +forecastTests = + testGroup + "CrossEraForecast" + [ testProperty + "Conway to Dijkstra takes the Leios parameters from the Dijkstra genesis" + prop_conwayToDijkstraForecast + ] + + +-- | The combinator's own Conway-to-Dijkstra forecaster, as 'CanHardFork' wires it. +conwayToDijkstraForecast :: + RequiringBoth + WrapLedgerConfig + (CrossEraForecaster LedgerState WrapLedgerView) + (ShelleyBlock (Praos Crypto) ConwayEra) + (ShelleyBlock (Praos2 Crypto) DijkstraEra) +PCons _ (PCons _ (PCons _ (PCons _ (PCons _ (PCons _ (PCons conwayToDijkstraForecast PNil)))))) = + crossEraForecast (hardForkEraTranslation :: EraTranslation (CardanoEras Crypto)) + +-- | Forecasting a Dijkstra ledger view from a Conway ledger state, for the +-- first slot past a boundary just after its tip, gives the Leios parameters +-- the Dijkstra genesis sets. +prop_conwayToDijkstraForecast :: + TestSetup + (ShelleyBlock (Praos Crypto) ConwayEra) + (ShelleyBlock (Praos2 Crypto) DijkstraEra) -> + Property +prop_conwayToDijkstraForecast ts = + case runExcept forecast of + Left err -> counterexample (show err) False + Right (WrapLedgerView lv) -> leiosParameters lv === expected + where + TestSetup{tsSrcLedgerConfig, tsDestLedgerConfig, tsSrcLedgerState, tsEpochNo} = ts + slot = succWithOrigin (ledgerTipSlot tsSrcLedgerState) + transition = + Bound + { boundTime = RelativeTime 0 + , boundSlot = slot + , boundEpoch = tsEpochNo + , boundNextPerasRound = PerasRoundNo 0 + } + forecast = + crossEraForecastWith + ( provideBoth + conwayToDijkstraForecast + (WrapLedgerConfig tsSrcLedgerConfig) + (WrapLedgerConfig tsDestLedgerConfig) + ) + transition + slot + tsSrcLedgerState + DijkstraGenesis{dgUpgradePParams = upgrade} = shelleyLedgerTranslationContext tsDestLedgerConfig + expected = + ( udppMaxEndorserBlockReferencesSize upgrade + , udppMaxEndorserBlockTxsSize upgrade + , udppLeiosAnnouncementPeriodLength upgrade + , udppLeiosVotePeriodLength upgrade + , udppLeiosDiffusionPeriodLength upgrade + , udppLeiosQuorumStakeThreshold upgrade + ) + leiosParameters + Views.PraosLedgerView + { Views.plvMaxEbBodySize = Praos2HasLeios maxEbBodySize + , Views.plvMaxEbTxsSize = Praos2HasLeios maxEbTxsSize + , Views.plvAnnouncementPeriodLength = Praos2HasLeios announcementPeriodLength + , Views.plvVotePeriodLength = Praos2HasLeios votePeriodLength + , Views.plvDiffusionPeriodLength = Praos2HasLeios diffusionPeriodLength + , Views.plvQuorumStakeThreshold = Praos2HasLeios quorumStakeThreshold + } = + ( maxEbBodySize + , maxEbTxsSize + , announcementPeriodLength + , votePeriodLength + , diffusionPeriodLength + , quorumStakeThreshold + ) + {------------------------------------------------------------------------------- Specific predicates -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 9b89ff5c2e..edb17c5968 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -1947,6 +1947,7 @@ test-suite cardano-test fs-sim, measures, microlens, + mtl, ouroboros-consensus:{cardano, ouroboros-consensus, protocol, unstable-cardano-testlib, unstable-consensus-testlib, unstable-diffusion-testlib, unstable-mempool-test-utils}, ouroboros-network:{api, protocols, protocols-tests-lib}, pretty-simple,