extendToSlot: always first tick across the era boundary

IntersectMBO · Sep 8, 2023 · 5d8e37e · 5d8e37e
1 parent d9d82ca
commit 5d8e37e
Show file tree

Hide file tree

Showing 9 changed files with 187 additions and 110 deletions.
diff --git a/...sensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs b/...sensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs
@@ -384,22 +384,22 @@ translateLedgerStateByronToShelleyWrapper ::
      )
   => RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       (Translate' (Ticked :.: LedgerState) LedgerState)
        ByronBlock
        (ShelleyBlock (TPraos c) (ShelleyEra c))
 translateLedgerStateByronToShelleyWrapper =
     RequireBoth $ \_ (WrapLedgerConfig cfgShelley) ->
-    Translate   $ \epochNo ledgerByron ->
+    Translate   $ \epochNo (Comp ledgerByron) ->
       ShelleyLedgerState {
         shelleyLedgerTip =
           translatePointByronToShelley
-            (ledgerTipPoint ledgerByron)
-            (byronLedgerTipBlockNo ledgerByron)
+            (castPoint $ getTip ledgerByron)
+            (untickedByronLedgerTipBlockNo ledgerByron)
       , shelleyLedgerState =
           SL.translateToShelleyLedgerState
             (toFromByronTranslationContext (shelleyLedgerGenesis cfgShelley))
             epochNo
-            (byronLedgerState ledgerByron)
+            (tickedByronLedgerState ledgerByron)
       , shelleyLedgerTransition =
           ShelleyTransitionInfo{shelleyAfterVoting = 0}
       }
@@ -509,13 +509,14 @@ translateLedgerStateShelleyToAllegraWrapper ::
      (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       (Translate' (Ticked :.: LedgerState) LedgerState)
        (ShelleyBlock (TPraos c) (ShelleyEra c))
        (ShelleyBlock (TPraos c) (AllegraEra c))
 translateLedgerStateShelleyToAllegraWrapper =
     ignoringBoth $
       Translate $ \_epochNo ->
-        unComp . SL.translateEra' () . Comp
+          unComp . SL.translateEra' () . Comp
+        . untickShelleyLedgerState . unComp
 
 translateTxShelleyToAllegraWrapper ::
      (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
@@ -541,13 +542,14 @@ translateLedgerStateAllegraToMaryWrapper ::
      (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       (Translate' (Ticked :.: LedgerState) LedgerState)
        (ShelleyBlock (TPraos c) (AllegraEra c))
        (ShelleyBlock (TPraos c) (MaryEra c))
 translateLedgerStateAllegraToMaryWrapper =
     ignoringBoth $
       Translate $ \_epochNo ->
-        unComp . SL.translateEra' () . Comp
+          unComp . SL.translateEra' () . Comp
+        . untickShelleyLedgerState . unComp
 
 {-------------------------------------------------------------------------------
   Translation from Allegra to Mary
@@ -577,13 +579,14 @@ translateLedgerStateMaryToAlonzoWrapper ::
      (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       (Translate' (Ticked :.: LedgerState) LedgerState)
        (ShelleyBlock (TPraos c) (MaryEra c))
        (ShelleyBlock (TPraos c) (AlonzoEra c))
 translateLedgerStateMaryToAlonzoWrapper =
     RequireBoth $ \_cfgMary cfgAlonzo ->
       Translate $ \_epochNo ->
-        unComp . SL.translateEra' (getAlonzoTranslationContext cfgAlonzo) . Comp
+          unComp . SL.translateEra' (getAlonzoTranslationContext cfgAlonzo) . Comp
+        . untickShelleyLedgerState . unComp
 
 getAlonzoTranslationContext ::
      WrapLedgerConfig (ShelleyBlock (TPraos c) (AlonzoEra c))
@@ -618,13 +621,15 @@ translateLedgerStateAlonzoToBabbageWrapper ::
      (Praos.PraosCrypto c, TPraos.PraosCrypto c)
   => RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       (Translate' (Ticked :.: LedgerState) LedgerState)
        (ShelleyBlock (TPraos c) (AlonzoEra c))
        (ShelleyBlock (Praos c) (BabbageEra c))
 translateLedgerStateAlonzoToBabbageWrapper =
     RequireBoth $ \_cfgAlonzo _cfgBabbage ->
       Translate $ \_epochNo ->
-        unComp . SL.translateEra' () . Comp . transPraosLS
+          unComp . SL.translateEra' () . Comp
+        . transPraosLS . untickShelleyLedgerState . unComp
+
   where
     transPraosLS ::
       LedgerState (ShelleyBlock (TPraos c) (AlonzoEra c)) ->
@@ -680,13 +685,14 @@ translateLedgerStateBabbageToConwayWrapper ::
      (Praos.PraosCrypto c)
   => RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       (Translate' (Ticked :.: LedgerState) LedgerState)
        (ShelleyBlock (Praos c) (BabbageEra c))
        (ShelleyBlock (Praos c) (ConwayEra c))
 translateLedgerStateBabbageToConwayWrapper =
     RequireBoth $ \_cfgBabbage cfgConway ->
       Translate $ \_epochNo ->
-        unComp . SL.translateEra' (getConwayTranslationContext cfgConway) . Comp
+          unComp . SL.translateEra' (getConwayTranslationContext cfgConway) . Comp
+        . untickShelleyLedgerState . unComp
 
 getConwayTranslationContext ::
      WrapLedgerConfig (ShelleyBlock (Praos c) (ConwayEra c))
@@ -712,3 +718,17 @@ translateValidatedTxBabbageToConwayWrapper ::
        (ShelleyBlock (Praos c) (ConwayEra c))
 translateValidatedTxBabbageToConwayWrapper ctxt = InjectValidatedTx $
     fmap unComp . eitherToMaybe . runExcept . SL.translateEra ctxt . Comp
+
+{-------------------------------------------------------------------------------
+  Auxiliary
+-------------------------------------------------------------------------------}
+
+-- TODO abstract this out more
+untickShelleyLedgerState ::
+     TickedLedgerState (ShelleyBlock proto era)
+  -> LedgerState       (ShelleyBlock proto era)
+untickShelleyLedgerState st = ShelleyLedgerState {
+     shelleyLedgerTip        = untickedShelleyLedgerTip      st
+   , shelleyLedgerState      = tickedShelleyLedgerState      st
+   , shelleyLedgerTransition = tickedShelleyLedgerTransition st
+   }
diff --git a/...nsensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs b/...nsensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs
@@ -45,7 +45,7 @@ import           Ouroboros.Consensus.HardFork.Combinator.Embed.Binary
 import           Ouroboros.Consensus.HardFork.Combinator.Serialisation
 import qualified Ouroboros.Consensus.HardFork.Combinator.State.Types as HFC
 import qualified Ouroboros.Consensus.HardFork.History as History
-import           Ouroboros.Consensus.Ledger.Basics (LedgerConfig)
+import           Ouroboros.Consensus.Ledger.Basics
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
                      (LedgerSupportsProtocol)
 import           Ouroboros.Consensus.Mempool (TxLimits)
@@ -154,7 +154,7 @@ instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2
       translateLedgerState ::
            InPairs.RequiringBoth
              WrapLedgerConfig
-             (HFC.Translate LedgerState)
+             (HFC.Translate' (Ticked :.: LedgerState) LedgerState)
              (ShelleyBlock proto1 era1)
              (ShelleyBlock proto2 era2)
       translateLedgerState =
@@ -165,6 +165,18 @@ instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2
             . SL.translateEra'
                 (shelleyLedgerTranslationContext (unwrapLedgerConfig cfg2))
             . Comp
+            . untickShelleyLedgerState
+            . unComp
+
+      -- TODO duplicated from Cardano CanHardFork
+      untickShelleyLedgerState ::
+           TickedLedgerState (ShelleyBlock proto era)
+        -> LedgerState       (ShelleyBlock proto era)
+      untickShelleyLedgerState st = ShelleyLedgerState {
+           shelleyLedgerTip        = untickedShelleyLedgerTip      st
+         , shelleyLedgerState      = tickedShelleyLedgerState      st
+         , shelleyLedgerTransition = tickedShelleyLedgerTransition st
+         }
 
       forecastAcrossShelleyWrapper ::
            InPairs.RequiringBoth

diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal
@@ -227,6 +227,7 @@ test-suite consensus-test
     , quiet
     , serialise
     , si-timers
+    , sop-core
     , sop-extras
     , strict-sop-core
     , tasty

diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs
@@ -18,10 +18,12 @@
 {-# LANGUAGE TypeFamilies               #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE TypeOperators              #-}
 
 module Test.Consensus.HardFork.Combinator (tests) where
 
 import qualified Data.Map.Strict as Map
+import           Data.SOP.BasicFunctors
 import           Data.SOP.Counting
 import           Data.SOP.InPairs (RequiringBoth (..))
 import qualified Data.SOP.InPairs as InPairs
@@ -406,11 +408,11 @@ instance SerialiseHFC '[BlockA, BlockB]
 ledgerState_AtoB ::
      RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       (Translate' (Ticked :.: LedgerState) LedgerState)
        BlockA
        BlockB
-ledgerState_AtoB = InPairs.ignoringBoth $ Translate $ \_ LgrA{..} -> LgrB {
-      lgrB_tip = castPoint lgrA_tip
+ledgerState_AtoB = InPairs.ignoringBoth $ Translate $ \_ (Comp st) -> LgrB {
+      lgrB_tip = castPoint . lgrA_tip . getTickedLedgerStateA $ st
     }
 
 chainDepState_AtoB ::

diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs
@@ -35,6 +35,7 @@ module Test.Consensus.HardFork.Combinator.A (
   , LedgerState (..)
   , NestedCtxt_ (..)
   , StorageConfig (..)
+  , Ticked (..)
   , TxId (..)
   ) where
 

diff --git a/...s-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs b/...s-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs
@@ -34,6 +34,7 @@ import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
 import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.HeaderValidation (AnnTip, HeaderState (..),
                      genesisHeaderState)
+import           Ouroboros.Consensus.Ledger.Abstract (LedgerResult (..))
 import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..))
 import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Consensus.TypeFamilyWrappers
@@ -205,10 +206,11 @@ injectInitialExtLedgerState cfg extLedgerState0 =
 
     targetEraLedgerState :: LedgerState (HardForkBlock (x ': xs))
     targetEraLedgerState =
-        HardForkLedgerState $
+        -- TODO discarding ledger events, probably fine?
+        HardForkLedgerState . lrResult $
           -- We can immediately extend it to the right slot, executing any
           -- scheduled hard forks in the first slot
-          State.extendToSlot
+          extendToSlot
             (configLedger cfg)
             (SlotNo 0)
             (initHardForkState (ledgerState extLedgerState0))