Cardano: refactor creation of initial non-Byron ledger state

A subsequent commit will remove the `InPairs` of `Translate`ions from
`CanHardFork`. Apart from their use in the HFC, they are also used for Cardano
to create initial non-Byron extended ledger states at Genesis.

This commit refactors this logic to no longer rely on `CanHardFork`, while being
semantically equivalent. See the added Note [Creating the initial extended
ledger state for Cardano] for details.

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

@@ -26,6 +26,7 @@ module Ouroboros.Consensus.Cardano.CanHardFork (
   , ShelleyPartialLedgerConfig (..)
   , crossEraForecastAcrossShelley
   , translateChainDepStateAcrossShelley
+  , translateLedgerStateByronToShelley
   ) where
 
 import qualified Cardano.Chain.Common as CC
@@ -41,6 +42,7 @@ import           Cardano.Ledger.Keys (DSignable, Hash)
 import qualified Cardano.Ledger.Shelley.API as SL
 import           Cardano.Ledger.Shelley.Translation
                      (toFromByronTranslationContext)
+import qualified Cardano.Ledger.Shelley.Translation as SL
 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
@@ -424,21 +426,33 @@ translateLedgerStateByronToShelleyWrapper ::
        ByronBlock
        (ShelleyBlock (TPraos c) (ShelleyEra c))
 translateLedgerStateByronToShelleyWrapper =
-    RequireBoth $ \_ (WrapLedgerConfig cfgShelley) ->
-    Translate   $ \epochNo ledgerByron ->
-      ShelleyLedgerState {
-        shelleyLedgerTip =
-          translatePointByronToShelley
-            (ledgerTipPoint ledgerByron)
-            (byronLedgerTipBlockNo ledgerByron)
-      , shelleyLedgerState =
-          SL.translateToShelleyLedgerState
-            (toFromByronTranslationContext (shelleyLedgerGenesis cfgShelley))
-            epochNo
-            (byronLedgerState ledgerByron)
-      , shelleyLedgerTransition =
-          ShelleyTransitionInfo{shelleyAfterVoting = 0}
-      }
+    RequireBoth $ \_ (WrapLedgerConfig cfgShelley) -> Translate $
+      translateLedgerStateByronToShelley
+        (toFromByronTranslationContext (shelleyLedgerGenesis cfgShelley))
+
+translateLedgerStateByronToShelley ::
+     ( ShelleyCompatible (TPraos c) (ShelleyEra c)
+     , HASH     c ~ Blake2b_256
+     , ADDRHASH c ~ Blake2b_224
+     )
+  => SL.FromByronTranslationContext c
+  -> EpochNo -- ^ Start of the new era
+  -> LedgerState ByronBlock
+  -> LedgerState (ShelleyBlock (TPraos c) (ShelleyEra c))
+translateLedgerStateByronToShelley ctx epochNo ledgerByron =
+    ShelleyLedgerState {
+      shelleyLedgerTip =
+        translatePointByronToShelley
+          (ledgerTipPoint ledgerByron)
+          (byronLedgerTipBlockNo ledgerByron)
+    , shelleyLedgerState =
+        SL.translateToShelleyLedgerState
+          ctx
+          epochNo
+          (byronLedgerState ledgerByron)
+    , shelleyLedgerTransition =
+        ShelleyTransitionInfo{shelleyAfterVoting = 0}
+    }
 
 translateChainDepStateByronToShelleyWrapper ::
      RequiringBoth

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

@@ -66,6 +66,7 @@ import qualified Cardano.Ledger.Api.Era as L
 import qualified Cardano.Ledger.Api.Transition as L
 import qualified Cardano.Ledger.BaseTypes as SL
 import qualified Cardano.Ledger.Shelley.API as SL
+import qualified Cardano.Ledger.Shelley.Translation as SL
 import           Cardano.Prelude (cborError)
 import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..),
                      ocertKESPeriod)
@@ -96,17 +97,20 @@ import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.HardFork.Combinator
 import           Ouroboros.Consensus.HardFork.Combinator.Embed.Nary
 import           Ouroboros.Consensus.HardFork.Combinator.Serialisation
+import           Ouroboros.Consensus.HardFork.Combinator.State.Types
 import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Node.NetworkProtocolVersion
 import           Ouroboros.Consensus.Node.ProtocolInfo
 import           Ouroboros.Consensus.Node.Run
 import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
-import           Ouroboros.Consensus.Protocol.Praos (Praos, PraosParams (..))
+import           Ouroboros.Consensus.Protocol.Praos (Praos, PraosParams (..),
+                     genesisPraosState)
 import           Ouroboros.Consensus.Protocol.Praos.Common
                      (praosCanBeLeaderOpCert)
-import           Ouroboros.Consensus.Protocol.TPraos (TPraos, TPraosParams (..))
+import           Ouroboros.Consensus.Protocol.TPraos (TPraos, TPraosParams (..),
+                     genesisTPraosState)
 import qualified Ouroboros.Consensus.Protocol.TPraos as Shelley
 import           Ouroboros.Consensus.Shelley.HFEras ()
 import           Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock)
@@ -119,6 +123,8 @@ import           Ouroboros.Consensus.Shelley.Node.Common (ShelleyEraWithCrypto,
                      shelleyBlockIssuerVKey)
 import qualified Ouroboros.Consensus.Shelley.Node.Praos as Praos
 import qualified Ouroboros.Consensus.Shelley.Node.TPraos as TPraos
+import           Ouroboros.Consensus.Shelley.ShelleyHFC
+                     (translateShelleyLedgerState)
 import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Consensus.TypeFamilyWrappers
 import           Ouroboros.Consensus.Util.Assert
@@ -575,6 +581,21 @@ pattern CardanoHardForkTriggers' {
       )
 {-# COMPLETE CardanoHardForkTriggers' #-}
 
+-- | Get the index of the first era which is not scheduled to end immediately
+-- via @'CardanoTriggerHardForkAtEpoch' 0@.
+--
+-- For mainnet, which starts in Byron, this returns
+--
+-- @'Z' 'Proxy' :: 'NS' 'Proxy' ('CardanoEras' c)@
+getInitialCardanoEra :: CardanoHardForkTriggers c -> NS Proxy (CardanoEras c)
+getInitialCardanoEra (CardanoHardForkTriggers triggers) =
+    go triggers
+  where
+    go :: NP CardanoHardForkTrigger xs -> NS Proxy (x : xs)
+    go = \case
+        CardanoTriggerHardForkAtEpoch (EpochNo 0) :* ts -> S $ go ts
+        _                                               -> Z Proxy
+
 -- | Parameters needed to run Cardano.
 --
 -- __On the relation between 'cardanoHardForkTriggers' and 'cardanoProtocolVersion'__:
@@ -656,7 +677,7 @@ protocolInfoCardano paramsCardano
     CardanoProtocolParams {
         byronProtocolParams
       , shelleyBasedProtocolParams
-      , cardanoHardForkTriggers = CardanoHardForkTriggers' {
+      , cardanoHardForkTriggers = cardanoHardForkTriggers@CardanoHardForkTriggers' {
           triggerHardForkShelley
         , triggerHardForkAllegra
         , triggerHardForkMary
@@ -687,6 +708,16 @@ protocolInfoCardano paramsCardano
     transitionConfigBabbage = transitionConfigConway  ^. L.tcPreviousEraConfigL
     transitionConfigConway  = cardanoLedgerTransitionConfig
 
+    transitionCfgs :: NP WrapTransitionConfig (CardanoShelleyEras c)
+    transitionCfgs =
+         WrapTransitionConfig transitionConfigShelley
+      :* WrapTransitionConfig transitionConfigAllegra
+      :* WrapTransitionConfig transitionConfigMary
+      :* WrapTransitionConfig transitionConfigAlonzo
+      :* WrapTransitionConfig transitionConfigBabbage
+      :* WrapTransitionConfig transitionConfigConway
+      :* Nil
+
     -- The major protocol version of the last era is the maximum major protocol
     -- version we support.
     --
@@ -701,7 +732,7 @@ protocolInfoCardano paramsCardano
           , topLevelConfigLedger   = ledgerConfigByron
           , topLevelConfigBlock    = blockConfigByron
           }
-      , pInfoInitLedger = initExtLedgerStateByron
+      , pInfoInitLedger = ExtLedgerState initLedgerStateByron initHeaderStateByron
       } = protocolInfoByron byronProtocolParams
 
     partialConsensusConfigByron :: PartialConsensusConfig (BlockProtocol ByronBlock)
@@ -944,42 +975,70 @@ protocolInfoCardano paramsCardano
       , topLevelConfigCheckpoints = cardanoCheckpoints
       }
 
-    -- When the initial ledger state is not in the Byron era, register various
-    -- data from the genesis config (if provided) in the ledger state. For
-    -- example, this includes initial staking and initial funds (useful for
-    -- testing/benchmarking).
+    -- See Note [Creating the initial extended ledger state for Cardano]
     initExtLedgerStateCardano :: ExtLedgerState (CardanoBlock c)
-    initExtLedgerStateCardano = ExtLedgerState {
-          headerState = initHeaderState
-        , ledgerState =
-              HardForkLedgerState
-            . hap (fn id :* registerAny)
-            $ hardForkLedgerStatePerEra initLedgerState
-        }
+    initExtLedgerStateCardano =
+          injectInitialExtLedgerState
+        $ hliftA3
+            (\(Fn injIntoTestState) (WrapChainDepState cds) lst ->
+              ExtLedgerState {
+                  ledgerState = injIntoTestState lst
+                , headerState = genesisHeaderState cds
+                })
+            injectIntoTestState
+            initChainDepStates
+            initLedgerState
       where
-        initHeaderState :: HeaderState (CardanoBlock c)
-        initLedgerState :: LedgerState (CardanoBlock c)
-        ExtLedgerState initLedgerState initHeaderState =
-          injectInitialExtLedgerState cfg initExtLedgerStateByron
-
-        registerAny :: NP (LedgerState -.-> LedgerState) (CardanoShelleyEras c)
-        registerAny =
-            hcmap (Proxy @IsShelleyBlock) injectIntoTestState $
-                WrapTransitionConfig transitionConfigShelley
-             :* WrapTransitionConfig transitionConfigAllegra
-             :* WrapTransitionConfig transitionConfigMary
-             :* WrapTransitionConfig transitionConfigAlonzo
-             :* WrapTransitionConfig transitionConfigBabbage
-             :* WrapTransitionConfig transitionConfigConway
-             :* Nil
-
-        injectIntoTestState ::
-             L.EraTransition era
-          => WrapTransitionConfig (ShelleyBlock proto era)
-          -> (LedgerState -.-> LedgerState) (ShelleyBlock proto era)
-        injectIntoTestState (WrapTransitionConfig cfg) = fn $ \st -> st {
-            Shelley.shelleyLedgerState = L.injectIntoTestState cfg (Shelley.shelleyLedgerState st)
-          }
+        initLedgerState :: NS LedgerState (CardanoEras c)
+        initLedgerState =
+            mkInitialStateViaTranslation
+              ledgerStateTranslations
+              initLedgerStateByron
+              (getInitialCardanoEra cardanoHardForkTriggers)
+
+        initChainDepStates :: NP WrapChainDepState (CardanoEras c)
+        initChainDepStates =
+             WrapChainDepState (headerStateChainDep initHeaderStateByron)
+          :* WrapChainDepState tpraos
+          :* WrapChainDepState tpraos
+          :* WrapChainDepState tpraos
+          :* WrapChainDepState tpraos
+          :* WrapChainDepState praos
+          :* WrapChainDepState praos
+          :* Nil
+          where
+            tpraos = genesisTPraosState initialNonceShelley
+            praos  = genesisPraosState  initialNonceShelley
+
+        ledgerStateTranslations :: InPairs (Translate LedgerState) (CardanoEras c)
+        ledgerStateTranslations =
+             PCons byronToShelleyTranslation
+           $ PCons (interShelleyTranslation transitionConfigAllegra)
+           $ PCons (interShelleyTranslation transitionConfigMary)
+           $ PCons (interShelleyTranslation transitionConfigAlonzo)
+           $ PCons (interShelleyTranslation transitionConfigBabbage)
+           $ PCons (interShelleyTranslation transitionConfigConway)
+             PNil
+           where
+             byronToShelleyTranslation =
+                 Translate $ translateLedgerStateByronToShelley ctx
+               where
+                 ctx = SL.toFromByronTranslationContext genesisShelley
+
+             interShelleyTranslation transitionConfig =
+                 Translate $ \_ -> translateShelleyLedgerState ctx
+               where
+                 ctx = transitionConfig ^. L.tcTranslationContextL
+
+        injectIntoTestState :: NP (LedgerState -.-> LedgerState) (CardanoEras c)
+        injectIntoTestState =
+             fn id -- do nothing in Byron
+          :* hcmap (Proxy @IsShelleyBlock)
+               (\(WrapTransitionConfig cfg) -> fn $ \st -> st {
+                   Shelley.shelleyLedgerState =
+                     L.injectIntoTestState cfg (Shelley.shelleyLedgerState st)
+                 })
+               transitionCfgs
 
     -- | For each element in the list, a block forging thread will be started.
     --
@@ -1065,6 +1124,32 @@ protocolInfoCardano paramsCardano
             praos  :*
             Nil
 
+{- Note [Creating the initial extended ledger state for Cardano]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+   For mainnet, this is a very simple operation: Create the initial Byron
+   extended ledger state, and wrap it in the HFC envelope.
+
+   However, for testing/benchmarks, we also want to support starting at genesis
+   from some /later/, non-Byron era, which is configured by triggering a hard
+   fork at epoch 0 for a prefix of all eras.
+
+   In this case, we construct the initial header state/chain-dependent state for
+   that era directly, due to their simple structure. In contrast, we construct
+   the initial ledger state by (potentially repeatedly) invoking the
+   Ledger-provided translation functions, in order to retain backwards
+   compatibility.
+
+   (If we want/can break backwards compatibility, it would be cleaner to
+   directly use Ledger's 'createInitialState' instead of the iterated
+   translation. However, this means that usages of eg @nonAvvmBalances@ in the
+   Byron genesis config would need to be replaced, which seems easy, but tedious
+   in particular for existing long-lived testnets like preview.)
+
+   Finally, if we start from a post-Byron era, we also register certain initial
+   data from the genesis config, for example initial staking/funds.
+-}
+
 protocolClientInfoCardano ::
      forall c.
      -- Byron

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

@@ -36,7 +36,6 @@ import qualified Cardano.Crypto.VRF as VRF
 import qualified Cardano.Ledger.Api.Era as L
 import qualified Cardano.Ledger.Api.Transition as L
 import qualified Cardano.Ledger.Shelley.API as SL
-import qualified Cardano.Protocol.TPraos.API as SL
 import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..))
 import qualified Cardano.Protocol.TPraos.OCert as SL
 import           Cardano.Slotting.EpochInfo
@@ -281,12 +280,8 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased {
       , shelleyLedgerTransition = ShelleyTransitionInfo {shelleyAfterVoting = 0}
       }
 
-    initChainDepState :: TPraosState c
-    initChainDepState = TPraosState Origin $
-      SL.initialChainDepState initialNonce (SL.sgGenDelegs genesis)
-
     initExtLedgerState :: ExtLedgerState (ShelleyBlock (TPraos c) era)
     initExtLedgerState = ExtLedgerState {
         ledgerState = initLedgerState
-      , headerState = genesisHeaderState initChainDepState
+      , headerState = genesisHeaderState $ genesisTPraosState initialNonce
       }

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

@@ -11,6 +11,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -22,6 +23,7 @@ module Ouroboros.Consensus.Shelley.ShelleyHFC (
   , crossEraForecastAcrossShelley
   , forecastAcrossShelley
   , translateChainDepStateAcrossShelley
+  , translateShelleyLedgerState
   ) where
 
 import qualified Cardano.Ledger.Api.Era as L
@@ -64,6 +66,7 @@ import           Ouroboros.Consensus.Shelley.Eras
 import           Ouroboros.Consensus.Shelley.Ledger
 import           Ouroboros.Consensus.Shelley.Ledger.Inspect as Shelley.Inspect
 import           Ouroboros.Consensus.Shelley.Node ()
+import           Ouroboros.Consensus.Shelley.Protocol.Abstract
 import           Ouroboros.Consensus.TypeFamilyWrappers
 
 {-------------------------------------------------------------------------------
@@ -334,6 +337,22 @@ instance ( ShelleyBasedEra era
         , shelleyLedgerTransition = ShelleyTransitionInfo 0
         }
 
+translateShelleyLedgerState ::
+     ( eraFrom ~ SL.PreviousEra eraTo
+     , SL.TranslateEra eraTo SL.NewEpochState
+     , SL.TranslationError eraTo SL.NewEpochState ~ Void
+     , ProtoCrypto protoFrom ~ ProtoCrypto protoTo
+     )
+  => SL.TranslationContext eraTo
+  -> LedgerState (ShelleyBlock protoFrom eraFrom)
+  -> LedgerState (ShelleyBlock protoTo   eraTo  )
+translateShelleyLedgerState ctx (ShelleyLedgerState wo nes st) =
+    ShelleyLedgerState {
+        shelleyLedgerTip        = fmap castShelleyTip wo
+      , shelleyLedgerState      = SL.translateEra' ctx nes
+      , shelleyLedgerTransition = st
+      }
+
 instance ( ShelleyBasedEra era
          , SL.TranslateEra era WrapTx
          ) => SL.TranslateEra era (GenTx :.: ShelleyBlock proto) where