Minimal workaround for updating protocol params on Babbage→Conway

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs

@@ -29,19 +29,27 @@ import qualified Cardano.Chain.Genesis as CC.Genesis
 import qualified Cardano.Chain.Update as CC.Update
 import           Cardano.Crypto.DSIGN (Ed25519DSIGN)
 import           Cardano.Crypto.Hash.Blake2b (Blake2b_224, Blake2b_256)
+import qualified Cardano.Ledger.BaseTypes as SL
+import qualified Cardano.Ledger.Core as Core
 import           Cardano.Ledger.Crypto (ADDRHASH, Crypto, DSIGN, HASH)
 import qualified Cardano.Ledger.Era as SL
 import           Cardano.Ledger.Hashes (EraIndependentTxBody)
 import           Cardano.Ledger.Keys (DSignable, Hash)
 import qualified Cardano.Ledger.Shelley.API as SL
+import qualified Cardano.Ledger.Shelley.Governance as SL
+import qualified Cardano.Ledger.Shelley.LedgerState as SL
 import           Cardano.Ledger.Shelley.Translation
                      (toFromByronTranslationContext)
 import qualified Cardano.Protocol.TPraos.API as SL
 import qualified Cardano.Protocol.TPraos.Rules.Prtcl as SL
 import qualified Cardano.Protocol.TPraos.Rules.Tickn as SL
+import           Cardano.Slotting.EpochInfo (epochInfoFirst)
 import           Control.Monad
 import           Control.Monad.Except (runExcept, throwError)
+import qualified Control.State.Transition as STS
 import           Data.Coerce (coerce)
+import           Data.Function ((&))
+import           Data.Functor.Identity
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (listToMaybe, mapMaybe)
 import           Data.Proxy
@@ -50,8 +58,11 @@ import           Data.SOP.InPairs (RequiringBoth (..), ignoringBoth)
 import           Data.SOP.Strict (hpure)
 import           Data.SOP.Tails (Tails (..))
 import qualified Data.SOP.Tails as Tails
+import           Data.Void
 import           Data.Word
 import           GHC.Generics (Generic)
+import           Lens.Micro (Lens', (.~))
+import           Lens.Micro.Extras (view)
 import           NoThunks.Class (NoThunks)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Byron.Ledger
@@ -677,16 +688,72 @@ translateValidatedTxAlonzoToBabbageWrapper ctxt = InjectValidatedTx $
 -------------------------------------------------------------------------------}
 
 translateLedgerStateBabbageToConwayWrapper ::
-     (Praos.PraosCrypto c)
+     forall c. (Praos.PraosCrypto c)
   => RequiringBoth
        WrapLedgerConfig
        (Translate LedgerState)
        (ShelleyBlock (Praos c) (BabbageEra c))
        (ShelleyBlock (Praos c) (ConwayEra c))
 translateLedgerStateBabbageToConwayWrapper =
-    RequireBoth $ \_cfgBabbage cfgConway ->
-      Translate $ \_epochNo ->
-        unComp . SL.translateEra' (getConwayTranslationContext cfgConway) . Comp
+    RequireBoth $ \cfgBabbage cfgConway ->
+      Translate $ \epochNo ->
+        let -- It would be cleaner to just pass in the entire 'Bound' instead of
+            -- just the 'EpochNo'.
+            firstSlotNewEra = runIdentity $ epochInfoFirst ei epochNo
+              where
+                ei =
+                    SL.epochInfoPure
+                  $ shelleyLedgerGlobals
+                  $ unwrapLedgerConfig cfgConway
+
+            -- HACK to make sure protocol parameters get properly updated on the
+            -- era transition from Babbage to Conway. This will be replaced by a
+            -- more principled refactoring in the future.
+            --
+            -- Pre-Conway, protocol parameters (like the ledger protocol
+            -- version) were updated by the UPEC rule, which is executed while
+            -- ticking across an epoch boundary. If sufficiently many Genesis
+            -- keys submitted the same update proposal, it will update the
+            -- governance state accordingly.
+            --
+            -- Conway has a completely different governance scheme (CIP-1694),
+            -- and thus has no representation for pre-Conway update proposals,
+            -- which are hence discarded by 'SL.translateEra'' below. Therefore,
+            -- we monkey-patch the governance state by ticking across the
+            -- era/epoch boundary using Babbage logic, and set the governance
+            -- state to the updated one /before/ translating.
+            patchGovState ::
+                 LedgerState (ShelleyBlock proto (BabbageEra c))
+              -> LedgerState (ShelleyBlock proto (BabbageEra c))
+            patchGovState st =
+                st { shelleyLedgerState = shelleyLedgerState st
+                       & newEpochStateGovStateL .~ newGovState
+                   }
+              where
+                -- next ledger release already provides this
+                newEpochStateGovStateL ::
+                     Lens' (SL.NewEpochState era) (SL.GovState era)
+                newEpochStateGovStateL =
+                  SL.nesEsL . SL.esLStateL . SL.lsUTxOStateL . SL.utxosGovStateL
+
+                newGovState =
+                    view newEpochStateGovStateL
+                  . tickedShelleyLedgerState
+                  . applyChainTick
+                      (unwrapLedgerConfig cfgBabbage)
+                      firstSlotNewEra
+                  $ st
+
+            -- The UPEC rule emits no ledger events, hence this hack is not
+            -- swallowing anything.
+            _upecNoLedgerEvents ::
+                 STS.Event (Core.EraRule "UPEC" (BabbageEra c)) :~: Void
+            _upecNoLedgerEvents = Refl
+
+        in    unComp
+            . SL.translateEra' (getConwayTranslationContext cfgConway)
+            . Comp
+            . patchGovState
 
 getConwayTranslationContext ::
      WrapLedgerConfig (ShelleyBlock (Praos c) (ConwayEra c))