Introduce Peras votes and certificate forging API

This commit introduces a couple of new types to represent Peras votes
and their corresponding certificate forging API. Notably, this requires
an initial representation of notions like vote targets, vote stakes and stake
distributions over multiple stake pools.

Co-authored-by: Agustin Mista <agustin.mista@moduscreate.com>
Co-authored-by: Alexander Esgen <alexander.esgen@iohk.io>
Co-authored-by: Georgy Lukyanov <georgy.lukyanov@iohk.io>
Co-authored-by: Thomas BAGREL <thomas.bagrel@tweag.io>
Co-authored-by: Nicolas BACQUEY <nicolas.bacquey@tweag.io>

Author: 5 people

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
@@ -14,21 +15,40 @@
 module Ouroboros.Consensus.Block.SupportsPeras
   ( PerasRoundNo (..)
   , onPerasRoundNo
+  , PerasVoteId (..)
+  , PerasVoteTarget (..)
+  , PerasVoterId (..)
+  , PerasVoteStake (..)
+  , PerasVoteStakeDistr (..)
+  , lookupPerasVoteStake
   , BlockSupportsPeras (..)
   , PerasCert (..)
+  , PerasVote (..)
   , ValidatedPerasCert (..)
+  , ValidatedPerasVote (..)
   , HasPerasCertRound (..)
   , HasPerasCertBoostedBlock (..)
   , HasPerasCertBoost (..)
+  , HasPerasVoteRound (..)
+  , HasPerasVoteBlock (..)
+  , HasPerasVoteVoterId (..)
+  , HasPerasVoteStake (..)
+  , HasPerasVoteTarget (..)
+  , HasPerasVoteId (..)
 
     -- * Convenience re-exports
   , module Ouroboros.Consensus.Peras.Params
   ) where
 
+import qualified Cardano.Binary as KeyHash
+import Cardano.Ledger.Hashes (KeyHash, KeyRole (..))
 import Codec.Serialise (Serialise (..))
 import Codec.Serialise.Decoding (decodeListLenOf)
 import Codec.Serialise.Encoding (encodeListLen)
 import Data.Coerce (coerce)
+import qualified Data.Map as Map
+import Data.Map.Strict (Map)
+import Data.Monoid (Sum (..))
 import Data.Proxy (Proxy (..))
 import Data.Word (Word64)
 import GHC.Generics (Generic)
@@ -40,6 +60,12 @@ import Ouroboros.Consensus.Util
 import Ouroboros.Consensus.Util.Condense
 import Quiet (Quiet (..))
 
+{-------------------------------------------------------------------------------
+-- * Peras types
+-------------------------------------------------------------------------------}
+
+-- ** Round numbers
+
 newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64}
   deriving Show via Quiet PerasRoundNo
   deriving stock Generic
@@ -57,14 +83,70 @@ onPerasRoundNo ::
   (PerasRoundNo -> PerasRoundNo -> PerasRoundNo)
 onPerasRoundNo = coerce
 
--- TODO using 'Validated' for extra safety? Or some @.Unsafe@ module?
+-- ** Stake pool distributions
+
+newtype PerasVoterId = PerasVoterId
+  { unPerasVoterId :: KeyHash StakePool
+  }
+  deriving newtype NoThunks
+  deriving stock (Eq, Ord, Generic)
+  deriving Show via Quiet PerasVoterId
+
+newtype PerasVoteStake = PerasVoteStake
+  { unPerasVoteStake :: Rational
+  }
+  deriving newtype (Enum, Eq, Ord, Num, Fractional, NoThunks, Serialise)
+  deriving stock Generic
+  deriving Show via Quiet PerasVoteStake
+  deriving Semigroup via Sum Rational
+  deriving Monoid via Sum Rational
+
+newtype PerasVoteStakeDistr = PerasVoteStakeDistr
+  { unPerasVoteStakeDistr :: Map PerasVoterId PerasVoteStake
+  }
+  deriving newtype NoThunks
+  deriving stock (Show, Eq, Generic)
+
+data PerasVoteTarget blk = PerasVoteTarget
+  { pvtRoundNo :: !PerasRoundNo
+  , pvtBlock :: !(Point blk)
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass NoThunks
+
+data PerasVoteId blk = PerasVoteId
+  { pviRoundNo :: !PerasRoundNo
+  , pviVoterId :: !PerasVoterId
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass NoThunks
+
+-- | Lookup the stake of vote casted by a member of a given stake distribution.
+lookupPerasVoteStake ::
+  PerasVote blk ->
+  PerasVoteStakeDistr ->
+  Maybe PerasVoteStake
+lookupPerasVoteStake vote distr =
+  Map.lookup
+    (pvVoteVoterId vote)
+    (unPerasVoteStakeDistr distr)
+
+-- ** Validated types
+
 data ValidatedPerasCert blk = ValidatedPerasCert
   { vpcCert :: !(PerasCert blk)
   , vpcCertBoost :: !PerasWeight
   }
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass NoThunks
 
+data ValidatedPerasVote blk = ValidatedPerasVote
+  { vpvVote :: !(PerasVote blk)
+  , vpvVoteStake :: !PerasVoteStake
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass NoThunks
+
 {-------------------------------------------------------------------------------
 -- * BlockSupportsPeras class
 -------------------------------------------------------------------------------}
@@ -79,13 +161,29 @@ class
 
   data PerasCert blk
 
+  data PerasVote blk
+
   data PerasValidationErr blk
 
+  data PerasForgeErr blk
+
   validatePerasCert ::
     PerasCfg blk ->
     PerasCert blk ->
     Either (PerasValidationErr blk) (ValidatedPerasCert blk)
 
+  validatePerasVote ::
+    PerasCfg blk ->
+    PerasVoteStakeDistr ->
+    PerasVote blk ->
+    Either (PerasValidationErr blk) (ValidatedPerasVote blk)
+
+  forgePerasCert ::
+    PerasCfg blk ->
+    PerasVoteTarget blk ->
+    [ValidatedPerasVote blk] ->
+    Either (PerasForgeErr blk) (ValidatedPerasCert blk)
+
 -- TODO: degenerate instance for all blks to get things to compile
 -- see https://github.com/tweag/cardano-peras/issues/73
 instance StandardHash blk => BlockSupportsPeras blk where
@@ -98,12 +196,27 @@ instance StandardHash blk => BlockSupportsPeras blk where
     deriving stock (Generic, Eq, Ord, Show)
     deriving anyclass NoThunks
 
+  data PerasVote blk = PerasVote
+    { pvVoteRound :: PerasRoundNo
+    , pvVoteBlock :: Point blk
+    , pvVoteVoterId :: PerasVoterId
+    }
+    deriving stock (Generic, Eq, Ord, Show)
+    deriving anyclass NoThunks
+
   -- TODO: enrich with actual error types
   -- see https://github.com/tweag/cardano-peras/issues/120
   data PerasValidationErr blk
     = PerasValidationErr
     deriving stock (Show, Eq)
 
+  -- TODO: enrich with actual error types
+  -- see https://github.com/tweag/cardano-peras/issues/120
+  data PerasForgeErr blk
+    = PerasForgeErrInsufficientVotes
+    | PerasForgeErrTargetMismatch
+    deriving stock (Show, Eq)
+
   -- TODO: perform actual validation against all
   -- possible 'PerasValidationErr' variants
   -- see https://github.com/tweag/cardano-peras/issues/120
@@ -114,9 +227,54 @@ instance StandardHash blk => BlockSupportsPeras blk where
         , vpcCertBoost = perasWeight params
         }
 
+  -- TODO: perform actual validation against all
+  -- possible 'PerasValidationErr' variants
+  -- see https://github.com/tweag/cardano-peras/issues/120
+  validatePerasVote _params stakeDistr vote
+    | Just stake <- lookupPerasVoteStake vote stakeDistr =
+        Right
+          ValidatedPerasVote
+            { vpvVote = vote
+            , vpvVoteStake = stake
+            }
+    | otherwise =
+        Left PerasValidationErr
+
+  -- TODO: perform actual validation against all
+  -- possible 'PerasForgeErr' variants
+  -- see https://github.com/tweag/cardano-peras/issues/120
+  forgePerasCert params target votes
+    | not allVotersMatchTarget =
+        Left PerasForgeErrTargetMismatch
+    | not votesHaveEnoughStake =
+        Left PerasForgeErrInsufficientVotes
+    | otherwise =
+        return $
+          ValidatedPerasCert
+            { vpcCert =
+                PerasCert
+                  { pcCertRound = pvtRoundNo target
+                  , pcCertBoostedBlock = pvtBlock target
+                  }
+            , vpcCertBoost = perasWeight params
+            }
+   where
+    totalVotesStake =
+      mconcat (vpvVoteStake <$> votes)
+
+    votesHaveEnoughStake =
+      unPerasVoteStake totalVotesStake
+        >= unPerasQuorumStakeThreshold (perasQuorumStakeThreshold params)
+
+    allVotersMatchTarget =
+      all ((target ==) . getPerasVoteTarget) votes
+
 instance ShowProxy blk => ShowProxy (PerasCert blk) where
   showProxy _ = "PerasCert " <> showProxy (Proxy @blk)
 
+instance ShowProxy blk => ShowProxy (PerasVote blk) where
+  showProxy _ = "PerasVote " <> showProxy (Proxy @blk)
+
 instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where
   encode PerasCert{pcCertRound, pcCertBoostedBlock} =
     encodeListLen 2
@@ -128,6 +286,19 @@ instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where
     pcCertBoostedBlock <- decode
     pure $ PerasCert{pcCertRound, pcCertBoostedBlock}
 
+instance Serialise (HeaderHash blk) => Serialise (PerasVote blk) where
+  encode PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId} =
+    encodeListLen 3
+      <> encode pvVoteRound
+      <> encode pvVoteBlock
+      <> KeyHash.toCBOR (unPerasVoterId pvVoteVoterId)
+  decode = do
+    decodeListLenOf 3
+    pvVoteRound <- decode
+    pvVoteBlock <- decode
+    pvVoteVoterId <- PerasVoterId <$> KeyHash.fromCBOR
+    pure $ PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId}
+
 -- | Extract the certificate round from a Peras certificate container
 class HasPerasCertRound cert where
   getPerasCertRound :: cert -> PerasRoundNo
@@ -172,3 +343,104 @@ instance
   HasPerasCertBoost (WithArrivalTime cert)
   where
   getPerasCertBoost = getPerasCertBoost . forgetArrivalTime
+
+-- | Extract the vote round from a Peras vote container
+class HasPerasVoteRound vote where
+  getPerasVoteRound :: vote -> PerasRoundNo
+
+instance HasPerasVoteRound (PerasVote blk) where
+  getPerasVoteRound = pvVoteRound
+
+instance HasPerasVoteRound (ValidatedPerasVote blk) where
+  getPerasVoteRound = getPerasVoteRound . vpvVote
+
+instance
+  HasPerasVoteRound vote =>
+  HasPerasVoteRound (WithArrivalTime vote)
+  where
+  getPerasVoteRound = getPerasVoteRound . forgetArrivalTime
+
+-- | Extract the vote block point from a Peras vote container
+class HasPerasVoteBlock vote blk | vote -> blk where
+  getPerasVoteBlock :: vote -> Point blk
+
+instance HasPerasVoteBlock (PerasVote blk) blk where
+  getPerasVoteBlock = pvVoteBlock
+
+instance HasPerasVoteBlock (ValidatedPerasVote blk) blk where
+  getPerasVoteBlock = getPerasVoteBlock . vpvVote
+
+instance
+  HasPerasVoteBlock vote blk =>
+  HasPerasVoteBlock (WithArrivalTime vote) blk
+  where
+  getPerasVoteBlock = getPerasVoteBlock . forgetArrivalTime
+
+-- | Extract the stake pool ID from a Peras vote container
+class HasPerasVoteVoterId vote where
+  getPerasVoteVoterId :: vote -> PerasVoterId
+
+instance HasPerasVoteVoterId (PerasVote blk) where
+  getPerasVoteVoterId = pvVoteVoterId
+
+instance HasPerasVoteVoterId (ValidatedPerasVote blk) where
+  getPerasVoteVoterId = getPerasVoteVoterId . vpvVote
+
+instance
+  HasPerasVoteVoterId vote =>
+  HasPerasVoteVoterId (WithArrivalTime vote)
+  where
+  getPerasVoteVoterId = getPerasVoteVoterId . forgetArrivalTime
+
+-- | Extract the vote stake from a validated Peras vote container
+class HasPerasVoteStake vote where
+  getPerasVoteStake :: vote -> PerasVoteStake
+
+instance HasPerasVoteStake (ValidatedPerasVote blk) where
+  getPerasVoteStake = vpvVoteStake
+
+instance
+  HasPerasVoteStake vote =>
+  HasPerasVoteStake (WithArrivalTime vote)
+  where
+  getPerasVoteStake = getPerasVoteStake . forgetArrivalTime
+
+-- | Extract the vote target from a Peras vote container
+class HasPerasVoteTarget vote blk | vote -> blk where
+  getPerasVoteTarget :: vote -> PerasVoteTarget blk
+
+instance HasPerasVoteTarget (PerasVote blk) blk where
+  getPerasVoteTarget vote =
+    PerasVoteTarget
+      { pvtRoundNo = pvVoteRound vote
+      , pvtBlock = pvVoteBlock vote
+      }
+
+instance HasPerasVoteTarget (ValidatedPerasVote blk) blk where
+  getPerasVoteTarget = getPerasVoteTarget . vpvVote
+
+instance
+  HasPerasVoteTarget vote blk =>
+  HasPerasVoteTarget (WithArrivalTime vote) blk
+  where
+  getPerasVoteTarget = getPerasVoteTarget . forgetArrivalTime
+
+-- | Extract the vote ID from a Peras vote container
+class HasPerasVoteId vote blk | vote -> blk where
+  getPerasVoteId :: vote -> PerasVoteId blk
+
+instance HasPerasVoteId (PerasVote blk) blk where
+  getPerasVoteId vote =
+    PerasVoteId
+      { pviRoundNo = pvVoteRound vote
+      , pviVoterId = pvVoteVoterId vote
+      }
+
+instance HasPerasVoteId (ValidatedPerasVote blk) blk where
+  getPerasVoteId = getPerasVoteId . vpvVote
+
+instance
+  HasPerasVoteId vote blk =>
+  HasPerasVoteId (WithArrivalTime vote) blk
+  where
+  getPerasVoteId = getPerasVoteId . forgetArrivalTime