Skip to content

Commit 4063507

Browse files
agustinmistaagustinmista
committed
Introduce Peras votes and helpers type classes
1 parent d51b1a1 commit 4063507

File tree

3 files changed

+268
-1
lines changed

3 files changed

+268
-1
lines changed

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

Lines changed: 237 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE DataKinds #-}
12
{-# LANGUAGE DeriveAnyClass #-}
23
{-# LANGUAGE DeriveGeneric #-}
34
{-# LANGUAGE DerivingVia #-}
@@ -14,21 +15,35 @@
1415
module Ouroboros.Consensus.Block.SupportsPeras
1516
( PerasRoundNo (..)
1617
, onPerasRoundNo
18+
, PerasVoterId (..)
19+
, PerasVoteStake (..)
20+
, PerasVoteStakeDistr (..)
21+
, lookupPerasVoteStake
1722
, BlockSupportsPeras (..)
1823
, PerasCert (..)
24+
, PerasVote (..)
1925
, ValidatedPerasCert (..)
26+
, ValidatedPerasVote (..)
2027
, HasPerasCertRound (..)
2128
, HasPerasCertBoostedBlock (..)
2229
, HasPerasCertBoost (..)
30+
, HasPerasVoteRound (..)
31+
, HasPerasVoteBlock (..)
32+
, HasPerasVoteVoterId (..)
2333

2434
-- * Convenience re-exports
2535
, module Ouroboros.Consensus.Peras.Params
2636
) where
2737

38+
import qualified Cardano.Binary as KeyHash
39+
import Cardano.Ledger.Hashes (KeyHash, KeyRole (..))
2840
import Codec.Serialise (Serialise (..))
2941
import Codec.Serialise.Decoding (decodeListLenOf)
3042
import Codec.Serialise.Encoding (encodeListLen)
3143
import Data.Coerce (coerce)
44+
import qualified Data.Map as Map
45+
import Data.Map.Strict (Map)
46+
import Data.Monoid (Sum (..))
3247
import Data.Proxy (Proxy (..))
3348
import Data.Word (Word64)
3449
import GHC.Generics (Generic)
@@ -40,6 +55,12 @@ import Ouroboros.Consensus.Util
4055
import Ouroboros.Consensus.Util.Condense
4156
import Quiet (Quiet (..))
4257

58+
{-------------------------------------------------------------------------------
59+
-- * Peras types
60+
-------------------------------------------------------------------------------}
61+
62+
-- ** Round numbers
63+
4364
newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64}
4465
deriving Show via Quiet PerasRoundNo
4566
deriving stock Generic
@@ -57,14 +78,63 @@ onPerasRoundNo ::
5778
(PerasRoundNo -> PerasRoundNo -> PerasRoundNo)
5879
onPerasRoundNo = coerce
5980

60-
-- TODO using 'Validated' for extra safety? Or some @.Unsafe@ module?
81+
-- ** Stake pool distributions
82+
83+
newtype PerasVoterId = PerasVoterId
84+
{ unPerasVoterId :: KeyHash StakePool
85+
}
86+
deriving newtype NoThunks
87+
deriving stock (Eq, Ord, Generic)
88+
deriving Show via Quiet PerasVoterId
89+
90+
newtype PerasVoteStake = PerasVoteStake
91+
{ unPerasVoteStake :: Rational
92+
}
93+
deriving newtype (Enum, Eq, Ord, Num, Fractional, NoThunks, Serialise)
94+
deriving stock Generic
95+
deriving Show via Quiet PerasVoteStake
96+
deriving Semigroup via Sum Rational
97+
deriving Monoid via Sum Rational
98+
99+
newtype PerasVoteStakeDistr = PerasVoteStakeDistr
100+
{ unPerasVoteStakeDistr :: Map PerasVoterId PerasVoteStake
101+
}
102+
deriving newtype NoThunks
103+
deriving stock (Show, Eq, Generic)
104+
105+
data PerasVoteTarget blk = PerasVoteTarget
106+
{ pvtRoundNo :: !PerasRoundNo
107+
, pvtBlock :: !(Point blk)
108+
}
109+
deriving stock (Show, Eq, Ord, Generic)
110+
deriving anyclass NoThunks
111+
112+
-- | Lookup the stake of vote casted by a member of a given stake distribution.
113+
lookupPerasVoteStake ::
114+
PerasVote blk ->
115+
PerasVoteStakeDistr ->
116+
Maybe PerasVoteStake
117+
lookupPerasVoteStake vote distr =
118+
Map.lookup
119+
(pvVoteVoterId vote)
120+
(unPerasVoteStakeDistr distr)
121+
122+
-- ** Validated types
123+
61124
data ValidatedPerasCert blk = ValidatedPerasCert
62125
{ vpcCert :: !(PerasCert blk)
63126
, vpcCertBoost :: !PerasWeight
64127
}
65128
deriving stock (Show, Eq, Ord, Generic)
66129
deriving anyclass NoThunks
67130

131+
data ValidatedPerasVote blk = ValidatedPerasVote
132+
{ vpvVote :: !(PerasVote blk)
133+
, vpvVoteStake :: !PerasVoteStake
134+
}
135+
deriving stock (Show, Eq, Ord, Generic)
136+
deriving anyclass NoThunks
137+
68138
{-------------------------------------------------------------------------------
69139
-- * BlockSupportsPeras class
70140
-------------------------------------------------------------------------------}
@@ -79,13 +149,29 @@ class
79149

80150
data PerasCert blk
81151

152+
data PerasVote blk
153+
82154
data PerasValidationErr blk
83155

156+
data PerasForgeErr blk
157+
84158
validatePerasCert ::
85159
PerasCfg blk ->
86160
PerasCert blk ->
87161
Either (PerasValidationErr blk) (ValidatedPerasCert blk)
88162

163+
validatePerasVote ::
164+
PerasCfg blk ->
165+
PerasVote blk ->
166+
PerasVoteStakeDistr ->
167+
Either (PerasValidationErr blk) (ValidatedPerasVote blk)
168+
169+
forgePerasCert ::
170+
PerasCfg blk ->
171+
PerasVoteTarget blk ->
172+
[ValidatedPerasVote blk] ->
173+
Either (PerasForgeErr blk) (PerasCert blk)
174+
89175
-- TODO: degenerate instance for all blks to get things to compile
90176
-- see https://github.com/tweag/cardano-peras/issues/73
91177
instance StandardHash blk => BlockSupportsPeras blk where
@@ -98,12 +184,27 @@ instance StandardHash blk => BlockSupportsPeras blk where
98184
deriving stock (Generic, Eq, Ord, Show)
99185
deriving anyclass NoThunks
100186

187+
data PerasVote blk = PerasVote
188+
{ pvVoteRound :: PerasRoundNo
189+
, pvVoteBlock :: Point blk
190+
, pvVoteVoterId :: PerasVoterId
191+
}
192+
deriving stock (Generic, Eq, Ord, Show)
193+
deriving anyclass NoThunks
194+
101195
-- TODO: enrich with actual error types
102196
-- see https://github.com/tweag/cardano-peras/issues/120
103197
data PerasValidationErr blk
104198
= PerasValidationErr
105199
deriving stock (Show, Eq)
106200

201+
-- TODO: enrich with actual error types
202+
-- see https://github.com/tweag/cardano-peras/issues/120
203+
data PerasForgeErr blk
204+
= PerasForgeErrInsufficientVotes
205+
| PerasForgeErrTargetMismatch
206+
deriving stock (Show, Eq)
207+
107208
-- TODO: perform actual validation against all
108209
-- possible 'PerasValidationErr' variants
109210
-- see https://github.com/tweag/cardano-peras/issues/120
@@ -114,9 +215,50 @@ instance StandardHash blk => BlockSupportsPeras blk where
114215
, vpcCertBoost = perasWeight params
115216
}
116217

218+
-- TODO: perform actual validation against all
219+
-- possible 'PerasValidationErr' variants
220+
-- see https://github.com/tweag/cardano-peras/issues/120
221+
validatePerasVote _params vote stakeDistr
222+
| Just stake <- lookupPerasVoteStake vote stakeDistr =
223+
Right
224+
ValidatedPerasVote
225+
{ vpvVote = vote
226+
, vpvVoteStake = stake
227+
}
228+
| otherwise =
229+
Left PerasValidationErr
230+
231+
-- TODO: perform actual validation against all
232+
-- possible 'PerasForgeErr' variants
233+
-- see https://github.com/tweag/cardano-peras/issues/120
234+
forgePerasCert params target votes
235+
| not allVotersMatchTarget =
236+
Left PerasForgeErrTargetMismatch
237+
| not votesHaveEnoughStake =
238+
Left PerasForgeErrInsufficientVotes
239+
| otherwise =
240+
return $
241+
PerasCert
242+
{ pcCertRound = pvtRoundNo target
243+
, pcCertBoostedBlock = pvtBlock target
244+
}
245+
where
246+
totalVotesStake =
247+
mconcat (vpvVoteStake <$> votes)
248+
249+
votesHaveEnoughStake =
250+
unPerasVoteStake totalVotesStake
251+
>= unPerasQuorumStakeThreshold (perasQuorumStakeThreshold params)
252+
253+
allVotersMatchTarget =
254+
all ((target ==) . getPerasVoteTarget) votes
255+
117256
instance ShowProxy blk => ShowProxy (PerasCert blk) where
118257
showProxy _ = "PerasCert " <> showProxy (Proxy @blk)
119258

259+
instance ShowProxy blk => ShowProxy (PerasVote blk) where
260+
showProxy _ = "PerasVote " <> showProxy (Proxy @blk)
261+
120262
instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where
121263
encode PerasCert{pcCertRound, pcCertBoostedBlock} =
122264
encodeListLen 2
@@ -128,6 +270,19 @@ instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where
128270
pcCertBoostedBlock <- decode
129271
pure $ PerasCert{pcCertRound, pcCertBoostedBlock}
130272

273+
instance Serialise (HeaderHash blk) => Serialise (PerasVote blk) where
274+
encode PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId} =
275+
encodeListLen 3
276+
<> encode pvVoteRound
277+
<> encode pvVoteBlock
278+
<> KeyHash.toCBOR (unPerasVoterId pvVoteVoterId)
279+
decode = do
280+
decodeListLenOf 3
281+
pvVoteRound <- decode
282+
pvVoteBlock <- decode
283+
pvVoteVoterId <- PerasVoterId <$> KeyHash.fromCBOR
284+
pure $ PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId}
285+
131286
-- | Extract the certificate round from a Peras certificate container
132287
class HasPerasCertRound cert where
133288
getPerasCertRound :: cert -> PerasRoundNo
@@ -172,3 +327,84 @@ instance
172327
HasPerasCertBoost (WithArrivalTime cert)
173328
where
174329
getPerasCertBoost = getPerasCertBoost . forgetArrivalTime
330+
331+
-- | Extract the vote round from a Peras vote container
332+
class HasPerasVoteRound vote where
333+
getPerasVoteRound :: vote -> PerasRoundNo
334+
335+
instance HasPerasVoteRound (PerasVote blk) where
336+
getPerasVoteRound = pvVoteRound
337+
338+
instance HasPerasVoteRound (ValidatedPerasVote blk) where
339+
getPerasVoteRound = getPerasVoteRound . vpvVote
340+
341+
instance
342+
HasPerasVoteRound vote =>
343+
HasPerasVoteRound (WithArrivalTime vote)
344+
where
345+
getPerasVoteRound = getPerasVoteRound . forgetArrivalTime
346+
347+
-- | Extract the vote block point from a Peras vote container
348+
class HasPerasVoteBlock vote blk | vote -> blk where
349+
getPerasVoteBlock :: vote -> Point blk
350+
351+
instance HasPerasVoteBlock (PerasVote blk) blk where
352+
getPerasVoteBlock = pvVoteBlock
353+
354+
instance HasPerasVoteBlock (ValidatedPerasVote blk) blk where
355+
getPerasVoteBlock = getPerasVoteBlock . vpvVote
356+
357+
instance
358+
HasPerasVoteBlock vote blk =>
359+
HasPerasVoteBlock (WithArrivalTime vote) blk
360+
where
361+
getPerasVoteBlock = getPerasVoteBlock . forgetArrivalTime
362+
363+
-- | Extract the stake pool ID from a Peras vote container
364+
class HasPerasVoteVoterId vote where
365+
getPerasVoteVoterId :: vote -> PerasVoterId
366+
367+
instance HasPerasVoteVoterId (PerasVote blk) where
368+
getPerasVoteVoterId = pvVoteVoterId
369+
370+
instance HasPerasVoteVoterId (ValidatedPerasVote blk) where
371+
getPerasVoteVoterId = getPerasVoteVoterId . vpvVote
372+
373+
instance
374+
HasPerasVoteVoterId vote =>
375+
HasPerasVoteVoterId (WithArrivalTime vote)
376+
where
377+
getPerasVoteVoterId = getPerasVoteVoterId . forgetArrivalTime
378+
379+
-- | Extract the vote stake from a validated Peras vote container
380+
class HasPerasVoteStake vote where
381+
getPerasVoteStake :: vote -> PerasVoteStake
382+
383+
instance HasPerasVoteStake (ValidatedPerasVote blk) where
384+
getPerasVoteStake = vpvVoteStake
385+
386+
instance
387+
HasPerasVoteStake vote =>
388+
HasPerasVoteStake (WithArrivalTime vote)
389+
where
390+
getPerasVoteStake = getPerasVoteStake . forgetArrivalTime
391+
392+
-- | Extract the vote target from a Peras vote container
393+
class HasPerasVoteTarget vote blk | vote -> blk where
394+
getPerasVoteTarget :: vote -> PerasVoteTarget blk
395+
396+
instance HasPerasVoteTarget (PerasVote blk) blk where
397+
getPerasVoteTarget vote =
398+
PerasVoteTarget
399+
{ pvtRoundNo = pvVoteRound vote
400+
, pvtBlock = pvVoteBlock vote
401+
}
402+
403+
instance HasPerasVoteTarget (ValidatedPerasVote blk) blk where
404+
getPerasVoteTarget = getPerasVoteTarget . vpvVote
405+
406+
instance
407+
HasPerasVoteTarget vote blk =>
408+
HasPerasVoteTarget (WithArrivalTime vote) blk
409+
where
410+
getPerasVoteTarget = getPerasVoteTarget . forgetArrivalTime

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@ module Ouroboros.Consensus.Node.Serialisation
3636
, Some (..)
3737
) where
3838

39+
import qualified Cardano.Binary as KeyHash
3940
import Codec.CBOR.Decoding (Decoder, decodeListLenOf)
4041
import Codec.CBOR.Encoding (Encoding, encodeListLen)
4142
import Codec.Serialise (Serialise (decode, encode))
@@ -195,6 +196,7 @@ instance ConvertRawHash blk => SerialiseNodeToNode blk (Tip blk) where
195196
instance SerialiseNodeToNode blk PerasRoundNo where
196197
encodeNodeToNode _ccfg _version = encode
197198
decodeNodeToNode _ccfg _version = decode
199+
198200
instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasCert blk) where
199201
-- Consistent with the 'Serialise' instance for 'PerasCert' defined in Ouroboros.Consensus.Block.SupportsPeras
200202
encodeNodeToNode ccfg version PerasCert{..} =
@@ -207,6 +209,24 @@ instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasCert blk) where
207209
pcCertBoostedBlock <- decodeNodeToNode ccfg version
208210
pure $ PerasCert pcCertRound pcCertBoostedBlock
209211

212+
instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasVote blk) where
213+
-- Consistent with the 'Serialise' instance for 'PerasVote' defined in Ouroboros.Consensus.Block.SupportsPeras
214+
encodeNodeToNode ccfg version PerasVote{..} =
215+
encodeListLen 3
216+
<> encodeNodeToNode ccfg version pvVoteRound
217+
<> encodeNodeToNode ccfg version pvVoteBlock
218+
<> encodeNodeToNode ccfg version pvVoteVoterId
219+
decodeNodeToNode ccfg version = do
220+
decodeListLenOf 3
221+
pvVoteRound <- decodeNodeToNode ccfg version
222+
pvVoteBlock <- decodeNodeToNode ccfg version
223+
pvVoteVoterId <- decodeNodeToNode ccfg version
224+
pure $ PerasVote pvVoteRound pvVoteBlock pvVoteVoterId
225+
226+
instance SerialiseNodeToNode blk PerasVoterId where
227+
encodeNodeToNode _ccfg _version = KeyHash.toCBOR . unPerasVoterId
228+
decodeNodeToNode _ccfg _version = PerasVoterId <$> KeyHash.fromCBOR
229+
210230
deriving newtype instance
211231
SerialiseNodeToClient blk (GenTxId blk) =>
212232
SerialiseNodeToClient blk (WrapGenTxId blk)

0 commit comments

Comments
 (0)