[WIP] Add pure Peras voting rules

ouroboros-consensus/ouroboros-consensus.cabal

@@ -208,6 +208,8 @@ library
     Ouroboros.Consensus.NodeId
     Ouroboros.Consensus.Peras.SelectView
     Ouroboros.Consensus.Peras.Weight
+    Ouroboros.Consensus.Peras.Voting
+    Ouroboros.Consensus.Peras.Params
     Ouroboros.Consensus.Protocol.Abstract
     Ouroboros.Consensus.Protocol.BFT
     Ouroboros.Consensus.Protocol.LeaderSchedule
@@ -310,6 +312,7 @@ library
     Ouroboros.Consensus.Util.NormalForm.StrictMVar
     Ouroboros.Consensus.Util.NormalForm.StrictTVar
     Ouroboros.Consensus.Util.Orphans
+    Ouroboros.Consensus.Util.Pred
     Ouroboros.Consensus.Util.RedundantConstraints
     Ouroboros.Consensus.Util.STM
     Ouroboros.Consensus.Util.Time
@@ -613,8 +616,10 @@ test-suite consensus-test
     Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke
     Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke
     Test.Consensus.Peras.WeightSnapshot
+    Test.Consensus.Peras.Voting
     Test.Consensus.Util.MonadSTM.NormalForm
     Test.Consensus.Util.Versioned
+    Test.Consensus.Util.Pred
 
   build-depends:
     QuickCheck,

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

@@ -13,16 +13,16 @@
 
 module Ouroboros.Consensus.Block.SupportsPeras
   ( PerasRoundNo (..)
+  , onPerasRoundNo
   , PerasWeight (..)
   , BlockSupportsPeras (..)
   , PerasCert (..)
   , PerasCfg (..)
   , ValidatedPerasCert (..)
   , makePerasCfg
-  , HasPerasCert (..)
-  , getPerasCertRound
-  , getPerasCertBoostedBlock
-  , getPerasCertBoost
+  , HasPerasCertRound (..)
+  , HasPerasCertBoostedBlock (..)
+  , HasPerasCertBoost (..)
 
     -- * Ouroboros Peras round length
   , PerasRoundLength (..)
@@ -45,6 +45,7 @@ import Quiet (Quiet (..))
 
 newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64}
   deriving Show via Quiet PerasRoundNo
+  deriving Semigroup via Sum Word64
   deriving stock Generic
   deriving newtype (Enum, Eq, Ord, NoThunks, Serialise)
 
@@ -54,6 +55,10 @@ instance Condense PerasRoundNo where
 instance ShowProxy PerasRoundNo where
   showProxy _ = "PerasRoundNo"
 
+-- | Lift a binary operation on 'Word64' to 'PerasRoundNo'
+onPerasRoundNo :: (Word64 -> Word64 -> Word64) -> PerasRoundNo -> PerasRoundNo -> PerasRoundNo
+onPerasRoundNo f a b = PerasRoundNo $ (unPerasRoundNo a `f` unPerasRoundNo b)
+
 newtype PerasWeight = PerasWeight {unPerasWeight :: Word64}
   deriving Show via Quiet PerasWeight
   deriving stock Generic
@@ -158,29 +163,51 @@ makePerasCfg _ =
     { perasCfgWeightBoost = boostPerCert
     }
 
-class StandardHash blk => HasPerasCert cert blk | cert -> blk where
-  getPerasCert :: cert -> PerasCert blk
+-- | Extract the certificate round from a Peras certificate container
+class HasPerasCertRound cert where
+  getPerasCertRound :: cert -> PerasRoundNo
+
+instance HasPerasCertRound (PerasCert blk) where
+  getPerasCertRound = pcCertRound
+
+instance HasPerasCertRound (ValidatedPerasCert blk) where
+  getPerasCertRound = getPerasCertRound . vpcCert
 
-getPerasCertRound :: HasPerasCert cert blk => cert -> PerasRoundNo
-getPerasCertRound = pcCertRound . getPerasCert
+instance
+  HasPerasCertRound cert =>
+  HasPerasCertRound (WithArrivalTime cert)
+  where
+  getPerasCertRound = getPerasCertRound . forgetArrivalTime
 
-getPerasCertBoostedBlock :: HasPerasCert cert blk => cert -> Point blk
-getPerasCertBoostedBlock = pcCertBoostedBlock . getPerasCert
+-- | Extract the boosted block point from a Peras certificate container
+class HasPerasCertBoostedBlock cert where
+  type BoostedBlock cert
+  getPerasCertBoostedBlock :: cert -> BoostedBlock cert
 
-instance StandardHash blk => HasPerasCert (PerasCert blk) blk where
-  getPerasCert = id
+instance HasPerasCertBoostedBlock (PerasCert blk) where
+  type BoostedBlock (PerasCert blk) = Point blk
+  getPerasCertBoostedBlock = pcCertBoostedBlock
 
-instance StandardHash blk => HasPerasCert (ValidatedPerasCert blk) blk where
-  getPerasCert = vpcCert
+instance HasPerasCertBoostedBlock (ValidatedPerasCert blk) where
+  type BoostedBlock (ValidatedPerasCert blk) = Point blk
+  getPerasCertBoostedBlock = getPerasCertBoostedBlock . vpcCert
 
-instance HasPerasCert cert blk => HasPerasCert (WithArrivalTime cert) blk where
-  getPerasCert = getPerasCert . forgetArrivalTime
+instance
+  HasPerasCertBoostedBlock cert =>
+  HasPerasCertBoostedBlock (WithArrivalTime cert)
+  where
+  type BoostedBlock (WithArrivalTime cert) = BoostedBlock cert
+  getPerasCertBoostedBlock = getPerasCertBoostedBlock . forgetArrivalTime
 
-class HasPerasCertBoost cert blk | cert -> blk where
+-- | Extract the certificate boost from a Peras certificate container
+class HasPerasCertBoost cert where
   getPerasCertBoost :: cert -> PerasWeight
 
-instance HasPerasCertBoost (ValidatedPerasCert blk) blk where
+instance HasPerasCertBoost (ValidatedPerasCert blk) where
   getPerasCertBoost = vpcCertBoost
 
-instance HasPerasCertBoost cert blk => HasPerasCertBoost (WithArrivalTime cert) blk where
+instance
+  HasPerasCertBoost cert =>
+  HasPerasCertBoost (WithArrivalTime cert)
+  where
   getPerasCertBoost = getPerasCertBoost . forgetArrivalTime

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs

@@ -15,7 +15,7 @@ import Control.Monad ((>=>))
 import GHC.Exception (throw)
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.BlockchainTime (WithArrivalTime)
-import Ouroboros.Consensus.BlockchainTime.WallClock.Types (SystemTime (..), addArrivalTime)
+import Ouroboros.Consensus.BlockchainTime.WallClock.Types (SystemTime (..), addArrivalTime, WithArrivalTime (..))
 import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
 import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
 import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
@@ -28,7 +28,7 @@ import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB
 import Ouroboros.Consensus.Util.IOLike
 
 makePerasCertPoolReaderFromSnapshot ::
-  (IOLike m, StandardHash blk) =>
+  IOLike m =>
   STM m (PerasCertSnapshot blk) ->
   ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
 makePerasCertPoolReaderFromSnapshot getCertSnapshot =
@@ -39,13 +39,13 @@ makePerasCertPoolReaderFromSnapshot getCertSnapshot =
         certSnapshot <- getCertSnapshot
         pure $
           take (fromIntegral limit) $
-            [ (ticketNo, getPerasCertRound cert, pure (getPerasCert cert))
+            [ (ticketNo, getPerasCertRound cert, pure (vpcCert (forgetArrivalTime cert)))
             | (cert, ticketNo) <- PerasCertDB.getCertsAfter certSnapshot lastKnown
             ]
     }
 
 makePerasCertPoolReaderFromCertDB ::
-  (IOLike m, StandardHash blk) =>
+  IOLike m =>
   PerasCertDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
 makePerasCertPoolReaderFromCertDB perasCertDB =
   makePerasCertPoolReaderFromSnapshot (PerasCertDB.getCertSnapshot perasCertDB)
@@ -65,7 +65,7 @@ makePerasCertPoolWriterFromCertDB systemTime perasCertDB =
     }
 
 makePerasCertPoolReaderFromChainDB ::
-  (IOLike m, StandardHash blk) =>
+  IOLike m =>
   ChainDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
 makePerasCertPoolReaderFromChainDB chainDB =
   makePerasCertPoolReaderFromSnapshot (ChainDB.getPerasCertSnapshot chainDB)

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- | Peras protocol parameters
+module Ouroboros.Consensus.Peras.Params
+  ( PerasIgnoranceRounds (..)
+  , PerasCooldownRounds (..)
+  , PerasBlockMinSlots (..)
+  , PerasCertArrivalThreshold (..)
+  , PerasParams (..)
+  )
+where
+
+import Data.Word (Word64)
+import GHC.Generics (Generic)
+import Ouroboros.Consensus.Util.IOLike (NoThunks)
+import Quiet (Quiet (..))
+
+{-------------------------------------------------------------------------------
+  Protocol parameters
+-------------------------------------------------------------------------------}
+
+-- | Number of rounds for which to ignore certificates after entering a cool-down period.
+newtype PerasIgnoranceRounds = PerasIgnoranceRounds {unPerasIgnoranceRounds :: Word64}
+  deriving Show via Quiet PerasIgnoranceRounds
+  deriving stock Generic
+  deriving newtype (Enum, Eq, Ord, NoThunks)
+
+-- | Minimum number of rounds to wait before voting again after a cool-down period starts.
+newtype PerasCooldownRounds = PerasCooldownRounds {unPerasCooldownRounds :: Word64}
+  deriving Show via Quiet PerasCooldownRounds
+  deriving stock Generic
+  deriving newtype (Enum, Eq, Ord, NoThunks)
+
+-- | Minimum age (in slots) of a block to be voted on at the beginning of a Peras round.
+newtype PerasBlockMinSlots = PerasBlockMinSlots {unPerasBlockMinSlots :: Word64}
+  deriving Show via Quiet PerasBlockMinSlots
+  deriving stock Generic
+  deriving newtype (Enum, Eq, Ord, NoThunks)
+
+-- | Maximum number of slots to after the start of a round to consider a certificate for voting.
+newtype PerasCertArrivalThreshold = PerasCertArrivalThreshold {unPerasCertArrivalThreshold :: Word64}
+  deriving Show via Quiet PerasCertArrivalThreshold
+  deriving stock Generic
+  deriving newtype (Enum, Eq, Ord, NoThunks)
+
+{-------------------------------------------------------------------------------
+  Protocol parameters bundle
+-------------------------------------------------------------------------------}
+
+data PerasParams = PerasParams
+  { perasIgnoranceRounds :: PerasIgnoranceRounds
+  , perasCooldownRounds :: PerasCooldownRounds
+  , perasBlockMinSlots :: PerasBlockMinSlots
+  , perasCertArrivalThreshold :: PerasCertArrivalThreshold
+  }
+  deriving (Show, Generic, NoThunks)