Adapt the HFC time translation layer for Peras

- Add `PerasRoundLength`
- introduce the `PerasEnabled` datatype to track values
  are only used when Peras is enabled
- HFC: translate between Peras rounds and slots

Author: geo2a

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,8 @@ shelleyEraParams genesis =
     , eraSlotLength = mkSlotLength $ SL.fromNominalDiffTimeMicro $ SL.sgSlotLength genesis
     , eraSafeZone = HardFork.StandardSafeZone stabilityWindow
     , eraGenesisWin = GenesisWindow stabilityWindow
+    , -- TODO(geo2a): enabled Peras conditionally in the Dijkstra era
+      eraPerasRoundLength = HardFork.NoPerasEnabled
     }
  where
   stabilityWindow =
@@ -183,6 +186,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

@@ -993,11 +993,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, we only use this generator to check that the serialisation roundtrips,
+  -- and the internal structure of EraSummary is irrelevant for that.
+  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

@@ -164,6 +164,7 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} =
         (History.StandardSafeZone (safeFromTipA k))
         (safeZoneB k)
       <*> pure (GenesisWindow ((unNonZero $ maxRollbacks k) * 2))
+      <*> pure (History.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/SupportsPeras.hs

@@ -23,6 +23,10 @@ module Ouroboros.Consensus.Block.SupportsPeras
   , getPerasCertRound
   , getPerasCertBoostedBlock
   , getPerasCertBoost
+
+    -- * Ouroboros Peras round length
+  , PerasRoundLength (..)
+  , defaultPerasRoundLength
   ) where
 
 import Codec.Serialise (Serialise (..))
@@ -41,7 +45,7 @@ import Quiet (Quiet (..))
 newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64}
   deriving Show via Quiet PerasRoundNo
   deriving stock Generic
-  deriving newtype (Eq, Ord, NoThunks, Serialise)
+  deriving newtype (Enum, Eq, Ord, NoThunks, Serialise)
 
 instance Condense PerasRoundNo where
   condense = show . unPerasRoundNo
@@ -70,6 +74,20 @@ data ValidatedPerasCert blk = ValidatedPerasCert
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass NoThunks
 
+{-------------------------------------------------------------------------------
+  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
+-- TODO this will become a Ledger protocol parameter
+defaultPerasRoundLength :: PerasRoundLength
+defaultPerasRoundLength = 90
+
 class
   ( Show (PerasCfg blk)
   , NoThunks (PerasCert blk)

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/History/EraParams.hs

@@ -1,9 +1,13 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -12,17 +16,23 @@ module Ouroboros.Consensus.HardFork.History.EraParams
   ( -- * API
     EraParams (..)
   , SafeZone (..)
+  , PerasEnabled
+  , pattern PerasEnabled
+  , pattern NoPerasEnabled
+  , 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 (ap, liftM, void)
+import Control.Monad.Trans.Class
 import Data.Word
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks)
@@ -136,17 +146,65 @@ 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
+newtype PerasEnabled a = MkPerasEnabled (Maybe a)
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass NoThunks
+  deriving newtype (Functor, Applicative, Monad)
+
+pattern PerasEnabled :: a -> PerasEnabled a
+pattern PerasEnabled x <- MkPerasEnabled (Just !x)
+  where
+    PerasEnabled !x = MkPerasEnabled (Just x)
+
+pattern NoPerasEnabled :: PerasEnabled a
+pattern NoPerasEnabled = MkPerasEnabled Nothing
+
+{-# COMPLETE PerasEnabled, 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 +214,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 +295,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{..}