Make the HFC aware of Peras rounds

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs

@@ -333,6 +333,7 @@ byronEraParams genesis =
     , eraSlotLength = fromByronSlotLength $ genesisSlotLength genesis
     , eraSafeZone = HardFork.StandardSafeZone (2 * k)
     , eraGenesisWin = GenesisWindow (2 * k)
+    , eraPerasRoundLength = HardFork.NoPerasEnabled
     }
  where
   k = unNonZero $ maxRollbacks $ genesisSecurityParam genesis
@@ -345,6 +346,7 @@ byronEraParamsNeverHardForks genesis =
     , eraSlotLength = fromByronSlotLength $ genesisSlotLength genesis
     , eraSafeZone = HardFork.UnsafeIndefiniteSafeZone
     , eraGenesisWin = GenesisWindow (2 * Gen.unBlockCount (Gen.configK genesis))
+    , eraPerasRoundLength = HardFork.NoPerasEnabled
     }
 
 instance HasHardForkHistory ByronBlock where

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

@@ -113,6 +113,7 @@ import Ouroboros.Consensus.Config
 import Ouroboros.Consensus.HardFork.Abstract
 import Ouroboros.Consensus.HardFork.Combinator.PartialConfig
 import qualified Ouroboros.Consensus.HardFork.History as HardFork
+import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (..))
 import Ouroboros.Consensus.HardFork.History.Util
 import Ouroboros.Consensus.HardFork.Simple
 import Ouroboros.Consensus.HeaderValidation
@@ -168,6 +169,7 @@ shelleyEraParams genesis =
     , eraSlotLength = mkSlotLength $ SL.fromNominalDiffTimeMicro $ SL.sgSlotLength genesis
     , eraSafeZone = HardFork.StandardSafeZone stabilityWindow
     , eraGenesisWin = GenesisWindow stabilityWindow
+    , eraPerasRoundLength = HardFork.NoPerasEnabled
     }
  where
   stabilityWindow =
@@ -183,6 +185,7 @@ shelleyEraParamsNeverHardForks genesis =
     , eraSlotLength = mkSlotLength $ SL.fromNominalDiffTimeMicro $ SL.sgSlotLength genesis
     , eraSafeZone = HardFork.UnsafeIndefiniteSafeZone
     , eraGenesisWin = GenesisWindow stabilityWindow
+    , eraPerasRoundLength = HardFork.NoPerasEnabled
     }
  where
   stabilityWindow =

ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Generators.hs

@@ -137,7 +137,8 @@ instance
     aux ::
       forall blk.
       SingleEraBlock blk =>
-      WrapHeaderHash blk -> K (OneEraHash (CardanoEras c)) blk
+      WrapHeaderHash blk ->
+      K (OneEraHash (CardanoEras c)) blk
     aux = K . OneEraHash . toShortRawHash (Proxy @blk) . unwrapHeaderHash
 
 instance
@@ -993,11 +994,11 @@ instance Arbitrary History.EraEnd where
       ]
 
 instance Arbitrary History.EraSummary where
-  arbitrary =
-    History.EraSummary
-      <$> arbitrary
-      <*> arbitrary
-      <*> arbitrary
+  -- Note: this generator may produce EraSummary with nonsensical bounds,
+  -- i.e. with existing PerasRoundNo at era start and Nothing for it at the end.
+  -- However, this does not create problems, and we thus choose to keep the generator
+  -- unconstrained.
+  arbitrary = History.EraSummary <$> arbitrary <*> arbitrary <*> arbitrary
 
 instance (Arbitrary a, SListI xs) => Arbitrary (NonEmpty xs a) where
   arbitrary = do

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs

@@ -79,6 +79,7 @@ import Test.Util.HardFork.Future
 import Test.Util.SanityCheck (prop_sanityChecks)
 import Test.Util.Slots (NumSlots (..))
 import Test.Util.Time (dawnOfTime)
+import Ouroboros.Consensus.HardFork.History.EraParams (PerasEnabled(PerasEnabled))
 
 tests :: TestTree
 tests =
@@ -164,6 +165,7 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} =
         (History.StandardSafeZone (safeFromTipA k))
         (safeZoneB k)
       <*> pure (GenesisWindow ((unNonZero $ maxRollbacks k) * 2))
+      <*> pure (PerasEnabled defaultPerasRoundLength)
 
   shape :: History.Shape '[BlockA, BlockB]
   shape = History.Shape $ exactlyTwo eraParamsA eraParamsB

ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs

@@ -103,6 +103,7 @@ prop_simple_bft_convergence
         , version = newestVersion (Proxy @MockBftBlock)
         }
 
+    testOutput :: TestOutput MockBftBlock
     testOutput =
       runTestNetwork
         testConfig

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Abstract.hs

@@ -41,6 +41,10 @@ module Ouroboros.Consensus.Block.Abstract
     -- * Ouroboros Genesis window
   , GenesisWindow (..)
 
+    -- * Ouroboros Peras round length
+  , PerasRoundLength (..)
+  , defaultPerasRoundLength
+
     -- * Re-export basic definitions from @ouroboros-network@
   , ChainHash (..)
   , HasHeader (..)
@@ -300,3 +304,16 @@ succWithOrigin = withOrigin minBound succ
 newtype GenesisWindow = GenesisWindow {unGenesisWindow :: Word64}
   deriving stock (Show, Eq, Ord)
   deriving newtype (NoThunks, Num)
+
+{-------------------------------------------------------------------------------
+  Ouroboros Peras round length
+-------------------------------------------------------------------------------}
+
+newtype PerasRoundLength = PerasRoundLength {unPerasRoundLength :: Word64}
+  deriving stock (Show, Eq, Ord)
+  deriving newtype (NoThunks, Num)
+
+-- | See the Protocol parameters section of the Peras design report:
+--   https://tweag.github.io/cardano-peras/peras-design.pdf#section.2.1
+defaultPerasRoundLength :: PerasRoundLength
+defaultPerasRoundLength = 90

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs

@@ -10,12 +10,14 @@
 
 module Ouroboros.Consensus.Block.SupportsPeras
   ( PerasRoundNo (..)
+  , defaultPerasRoundNo
   , PerasWeight (..)
   , boostPerCert
   , BlockSupportsPeras (..)
   , PerasCert (..)
   ) where
 
+import Codec.Serialise.Class
 import Data.Monoid (Sum (..))
 import Data.Word (Word64)
 import GHC.Generics (Generic)
@@ -27,7 +29,10 @@ import Quiet (Quiet (..))
 newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64}
   deriving Show via Quiet PerasRoundNo
   deriving stock Generic
-  deriving newtype (Eq, Ord, NoThunks)
+  deriving newtype (Enum, Eq, Ord, NoThunks, Serialise)
+
+defaultPerasRoundNo :: PerasRoundNo
+defaultPerasRoundNo = PerasRoundNo 0
 
 instance Condense PerasRoundNo where
   condense = show . unPerasRoundNo

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Abstract.hs

@@ -67,6 +67,6 @@ neverForksHardForkSummary ::
   LedgerState blk mk ->
   HardFork.Summary '[blk]
 neverForksHardForkSummary getParams cfg _st =
-  HardFork.neverForksSummary eraEpochSize eraSlotLength eraGenesisWin
+  HardFork.neverForksSummary eraEpochSize eraSlotLength eraGenesisWin eraPerasRoundLength
  where
   HardFork.EraParams{..} = getParams cfg

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseNodeToClient.hs

@@ -539,7 +539,9 @@ encodeQueryIfCurrentResult (_ :* _) (EraNodeToClientDisabled :* _) (QZ qry) =
   qryDisabledEra ::
     forall blk fp result.
     SingleEraBlock blk =>
-    BlockQuery blk fp result -> result -> Encoding
+    BlockQuery blk fp result ->
+    result ->
+    Encoding
   qryDisabledEra _ _ = throw $ disabledEraException (Proxy @blk)
 encodeQueryIfCurrentResult (_ :* cs) (_ :* vs) (QS qry) =
   encodeQueryIfCurrentResult cs vs qry
@@ -560,7 +562,9 @@ decodeQueryIfCurrentResult (_ :* _) (EraNodeToClientDisabled :* _) (QZ qry) =
   qryDisabledEra ::
     forall blk fp result.
     SingleEraBlock blk =>
-    BlockQuery blk fp result -> forall s. Decoder s result
+    BlockQuery blk fp result ->
+    forall s.
+    Decoder s result
   qryDisabledEra _ = fail . show $ disabledEraException (Proxy @blk)
 decodeQueryIfCurrentResult (_ :* cs) (_ :* vs) (QS qry) =
   decodeQueryIfCurrentResult cs vs qry

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/EraParams.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -12,17 +13,21 @@ module Ouroboros.Consensus.HardFork.History.EraParams
   ( -- * API
     EraParams (..)
   , SafeZone (..)
+  , PerasEnabled (..)
+  , PerasEnabledT (..)
+  , fromPerasEnabled
 
     -- * Defaults
   , defaultEraParams
   ) where
 
-import Cardano.Binary (enforceSize)
+import Cardano.Binary (DecoderError (DecoderErrorCustom), cborError)
 import Cardano.Ledger.BaseTypes (unNonZero)
 import Codec.CBOR.Decoding (Decoder, decodeListLen, decodeWord8)
 import Codec.CBOR.Encoding (Encoding, encodeListLen, encodeWord8)
 import Codec.Serialise (Serialise (..))
-import Control.Monad (void)
+import Control.Monad (void, ap, liftM)
+import Control.Monad.Trans.Class
 import Data.Word
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks)
@@ -136,17 +141,67 @@ data EraParams = EraParams
   , eraSlotLength :: !SlotLength
   , eraSafeZone :: !SafeZone
   , eraGenesisWin :: !GenesisWindow
+  , eraPerasRoundLength :: !(PerasEnabled PerasRoundLength)
+  -- ^ Optional, as not every era will be Peras-enabled
   }
   deriving stock (Show, Eq, Generic)
   deriving anyclass NoThunks
 
+-- | A marker for era parameters that are Peras-specific
+--   and are not present in pre-Peras eras
+--
+-- NOTE: the 'Applicative' behaves like the one for 'Maybe'.
+data PerasEnabled a
+  = PerasEnabled !a
+  | NoPerasEnabled
+  deriving stock (Show, Eq, Ord, Generic, Functor)
+  deriving anyclass NoThunks
+
+instance Applicative PerasEnabled where
+  pure = PerasEnabled
+
+  PerasEnabled f <*> m = fmap f m
+  NoPerasEnabled <*> _m = NoPerasEnabled
+
+  PerasEnabled _m1 *> m2 = m2
+  NoPerasEnabled *> _m2 = NoPerasEnabled
+
+-- | A 'fromMaybe'-like eliminator for 'PerasEnabled'
+fromPerasEnabled :: a -> PerasEnabled a -> a
+fromPerasEnabled defaultValue =
+  \case
+    NoPerasEnabled -> defaultValue
+    PerasEnabled value -> value
+
+-- | A 'MaybeT'-line monad transformer.
+--
+--   Used solely for the Peras-related hard fork combinator queries,
+--   see 'Ouroboros.Consensus.HardFork.History.Qry'.
+newtype PerasEnabledT m a = PerasEnabledT {runPerasEnabledT :: m (PerasEnabled a) }
+  deriving stock Functor
+
+instance (Functor m, Monad m) => Applicative (PerasEnabledT m) where
+    pure = PerasEnabledT . pure . PerasEnabled
+    (<*>) = ap
+
+instance Monad m => Monad (PerasEnabledT m) where
+    x >>= f = PerasEnabledT $ do
+        v <- runPerasEnabledT x
+        case v of
+            NoPerasEnabled -> pure NoPerasEnabled
+            PerasEnabled y  -> runPerasEnabledT (f y)
+
+instance MonadTrans PerasEnabledT where
+    lift = PerasEnabledT . liftM PerasEnabled
+
 -- | Default 'EraParams'
 --
 -- We set
 --
 -- * epoch size to @10k@ slots
 -- * the safe zone to @2k@ slots
 -- * the upper bound to 'NoLowerBound'
+-- * the Peras Round Length is unset
 --
 -- This is primarily useful for tests.
 defaultEraParams :: SecurityParam -> SlotLength -> EraParams
@@ -156,6 +211,8 @@ defaultEraParams (SecurityParam k) slotLength =
     , eraSlotLength = slotLength
     , eraSafeZone = StandardSafeZone (unNonZero k * 2)
     , eraGenesisWin = GenesisWindow (unNonZero k * 2)
+    , -- Peras is disabled by default
+      eraPerasRoundLength = NoPerasEnabled
     }
 
 -- | Zone in which it is guaranteed that no hard fork can take place
@@ -235,17 +292,27 @@ decodeSafeBeforeEpoch = do
 instance Serialise EraParams where
   encode EraParams{..} =
     mconcat $
-      [ encodeListLen 4
+      [ encodeListLen $ case eraPerasRoundLength of
+          NoPerasEnabled -> 4
+          PerasEnabled{} -> 5
       , encode (unEpochSize eraEpochSize)
       , encode eraSlotLength
       , encode eraSafeZone
       , encode (unGenesisWindow eraGenesisWin)
       ]
+        <> case eraPerasRoundLength of
+          NoPerasEnabled -> []
+          PerasEnabled rl -> [encode (unPerasRoundLength rl)]
 
   decode = do
-    enforceSize "EraParams" 4
+    len <- decodeListLen
     eraEpochSize <- EpochSize <$> decode
     eraSlotLength <- decode
     eraSafeZone <- decode
     eraGenesisWin <- GenesisWindow <$> decode
+    eraPerasRoundLength <-
+      case len of
+        4 -> pure NoPerasEnabled
+        5 -> PerasEnabled . PerasRoundLength <$> decode
+        _ -> cborError (DecoderErrorCustom "EraParams" "unexpected list length")
     return EraParams{..}