Introduce Peras votes and helpers type classes

Author: agustinmista

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
@@ -16,19 +17,30 @@ module Ouroboros.Consensus.Block.SupportsPeras
   , onPerasRoundNo
   , BlockSupportsPeras (..)
   , PerasCert (..)
+  , PerasVote (..)
   , ValidatedPerasCert (..)
+  , ValidatedPerasVote (..)
   , HasPerasCertRound (..)
   , HasPerasCertBoostedBlock (..)
   , HasPerasCertBoost (..)
+  , HasPerasVoteRound (..)
+  , HasPerasVoteBlock (..)
+  , HasPerasVoteVoterId (..)
 
     -- * Convenience re-exports
   , module Ouroboros.Consensus.Peras.Params
   ) where
 
+import qualified Cardano.Binary as KeyHash
+import Cardano.Ledger.Hashes (KeyHash, KeyRole (..))
+import Cardano.Ledger.State (IndividualPoolStake)
+import qualified Cardano.Ledger.State as SL
 import Codec.Serialise (Serialise (..))
 import Codec.Serialise.Decoding (decodeListLenOf)
 import Codec.Serialise.Encoding (encodeListLen)
 import Data.Coerce (coerce)
+import Data.Function (on)
+import qualified Data.Map as Map
 import Data.Proxy (Proxy (..))
 import Data.Word (Word64)
 import GHC.Generics (Generic)
@@ -40,6 +52,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 +75,56 @@ 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 stock (Show, Eq, Ord, Generic)
+  deriving newtype NoThunks
+
+newtype PerasIndividualVoterStake = PerasIndividualVoterStake
+  { perasIndividualVoterStake :: IndividualPoolStake
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving newtype NoThunks
+
+instance Ord PerasIndividualVoterStake where
+  compare = compare `on` (SL.individualPoolStakeVrf . perasIndividualVoterStake)
+
+newtype PerasVoterStakeDistr = PerasVotingStakeDistr
+  { unPerasVotingStakeDistr :: SL.PoolDistr
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving newtype NoThunks
+
+-- | Lookup the stake of a vote's stake pool in a given stake distribution.
+lookupPerasVoterStake ::
+  PerasVote blk ->
+  PerasVoterStakeDistr ->
+  Maybe PerasIndividualVoterStake
+lookupPerasVoterStake vote (PerasVotingStakeDistr distr) =
+  PerasIndividualVoterStake
+    <$> Map.lookup
+      (unPerasVoterId (pvVoteVoterId vote))
+      (SL.unPoolDistr 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 :: !PerasIndividualVoterStake
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass NoThunks
+
 {-------------------------------------------------------------------------------
 -- * BlockSupportsPeras class
 -------------------------------------------------------------------------------}
@@ -79,13 +139,21 @@ class
 
   data PerasCert blk
 
+  data PerasVote blk
+
   data PerasValidationErr blk
 
   validatePerasCert ::
     PerasCfg blk ->
     PerasCert blk ->
     Either (PerasValidationErr blk) (ValidatedPerasCert blk)
 
+  validatePerasVote ::
+    PerasCfg blk ->
+    PerasVote blk ->
+    PerasVoterStakeDistr ->
+    Either (PerasValidationErr blk) (ValidatedPerasVote 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,6 +166,14 @@ 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
@@ -114,9 +190,25 @@ 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 vote stakeDistr
+    | Just stake <- lookupPerasVoterStake vote stakeDistr =
+        Right
+          ValidatedPerasVote
+            { vpvVote = vote
+            , vpvVoteStake = stake
+            }
+    | otherwise =
+        Left PerasValidationErr
+
 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 +220,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 +277,51 @@ 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