Fix Conway->Dijkstra LedgerView translation

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

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)
 

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

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
     ]

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,14 +69,16 @@ 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 ()
 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
 -------------------------------------------------------------------------------}

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,