Skip to content

Commit 7be6c52

Browse files
tbagrel1agustinmistaamesgengeo2anbacquey
committed
Add definitions and codec for PerasCert diffusion through ObjectDiffusion
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> Co-authored-by: Nicolas "Niols" Jeannerod <nicolas.jeannerod@moduscreate.com>
1 parent 25f658d commit 7be6c52

File tree

4 files changed

+185
-3
lines changed

4 files changed

+185
-3
lines changed

‎ouroboros-consensus/ouroboros-consensus.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -193,7 +193,9 @@ library
193193
Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server
194194
Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound
195195
Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
196+
Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert
196197
Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound
198+
Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert
197199
Ouroboros.Consensus.Node.GsmState
198200
Ouroboros.Consensus.Node.InitStorage
199201
Ouroboros.Consensus.Node.NetworkProtocolVersion

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

Lines changed: 105 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,105 @@
1+
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE StandaloneDeriving #-}
3+
4+
-- | Instantiate 'ObjectPoolReader' and 'ObjectPoolWriter' using Peras
5+
-- certificates from the 'PerasCertDB' (or the 'ChainDB' which is wrapping the
6+
-- 'PerasCertDB').
7+
module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert
8+
( makePerasCertPoolReaderFromCertDB
9+
, makePerasCertPoolWriterFromCertDB
10+
, makePerasCertPoolReaderFromChainDB
11+
, makePerasCertPoolWriterFromChainDB
12+
) where
13+
14+
import GHC.Exception (throw)
15+
import Ouroboros.Consensus.Block
16+
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
17+
import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
18+
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
19+
import Ouroboros.Consensus.Storage.PerasCertDB.API
20+
( PerasCertDB
21+
, PerasCertSnapshot
22+
, PerasCertTicketNo
23+
)
24+
import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB
25+
import Ouroboros.Consensus.Util.IOLike
26+
27+
makePerasCertPoolReaderFromSnapshot ::
28+
(IOLike m, StandardHash blk) =>
29+
STM m (PerasCertSnapshot blk) ->
30+
ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
31+
makePerasCertPoolReaderFromSnapshot getCertSnapshot =
32+
ObjectPoolReader
33+
{ oprObjectId = getPerasCertRound
34+
, oprZeroTicketNo = PerasCertDB.zeroPerasCertTicketNo
35+
, oprObjectsAfter = \lastKnown limit -> do
36+
certSnapshot <- getCertSnapshot
37+
pure $
38+
take (fromIntegral limit) $
39+
[ (ticketNo, getPerasCertRound cert, pure (getPerasCert cert))
40+
| (cert, ticketNo) <- PerasCertDB.getCertsAfter certSnapshot lastKnown
41+
]
42+
}
43+
44+
makePerasCertPoolReaderFromCertDB ::
45+
(IOLike m, StandardHash blk) =>
46+
PerasCertDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
47+
makePerasCertPoolReaderFromCertDB perasCertDB =
48+
makePerasCertPoolReaderFromSnapshot (PerasCertDB.getCertSnapshot perasCertDB)
49+
50+
makePerasCertPoolWriterFromCertDB ::
51+
(StandardHash blk, IOLike m) =>
52+
PerasCertDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m
53+
makePerasCertPoolWriterFromCertDB perasCertDB =
54+
ObjectPoolWriter
55+
{ opwObjectId = getPerasCertRound
56+
, opwAddObjects = \certs -> do
57+
validatePerasCerts certs
58+
>>= mapM_ (PerasCertDB.addCert perasCertDB)
59+
, opwHasObject = do
60+
certSnapshot <- PerasCertDB.getCertSnapshot perasCertDB
61+
pure $ PerasCertDB.containsCert certSnapshot
62+
}
63+
64+
makePerasCertPoolReaderFromChainDB ::
65+
(IOLike m, StandardHash blk) =>
66+
ChainDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
67+
makePerasCertPoolReaderFromChainDB chainDB =
68+
makePerasCertPoolReaderFromSnapshot (ChainDB.getPerasCertSnapshot chainDB)
69+
70+
makePerasCertPoolWriterFromChainDB ::
71+
(StandardHash blk, IOLike m) =>
72+
ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m
73+
makePerasCertPoolWriterFromChainDB chainDB =
74+
ObjectPoolWriter
75+
{ opwObjectId = getPerasCertRound
76+
, opwAddObjects = \certs -> do
77+
validatePerasCerts certs
78+
>>= mapM_ (ChainDB.addPerasCertAsync chainDB)
79+
, opwHasObject = do
80+
certSnapshot <- ChainDB.getPerasCertSnapshot chainDB
81+
pure $ PerasCertDB.containsCert certSnapshot
82+
}
83+
84+
data PerasCertInboundException
85+
= forall blk. PerasCertValidationError (PerasValidationErr blk)
86+
87+
deriving instance Show PerasCertInboundException
88+
89+
instance Exception PerasCertInboundException
90+
91+
-- | Validate a list of 'PerasCert's, throwing a 'PerasCertInboundException' if
92+
-- any of them are invalid.
93+
validatePerasCerts ::
94+
(StandardHash blk, MonadThrow m) =>
95+
[PerasCert blk] ->
96+
m [ValidatedPerasCert blk]
97+
validatePerasCerts certs = do
98+
let perasCfg = makePerasCfg Nothing
99+
-- TODO replace the mocked-up Nothing with a real
100+
-- 'BlockConfig' when all the plumbing is in place
101+
-- see https://github.com/tweag/cardano-peras/issues/73
102+
-- see https://github.com/tweag/cardano-peras/issues/120
103+
case traverse (validatePerasCert perasCfg) certs of
104+
Left validationErr -> throw (PerasCertValidationError validationErr)
105+
Right validatedCerts -> return validatedCerts

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

Lines changed: 41 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,41 @@
1+
-- | This module defines type aliases for the ObjectDiffusion protocol applied
2+
-- to PerasCert diffusion.
3+
module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert
4+
( TracePerasCertDiffusionInbound
5+
, TracePerasCertDiffusionOutbound
6+
, PerasCertPoolReader
7+
, PerasCertPoolWriter
8+
, PerasCertDiffusionInboundPipelined
9+
, PerasCertDiffusionOutbound
10+
, PerasCertDiffusion
11+
) where
12+
13+
import Ouroboros.Consensus.Block
14+
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound
15+
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
16+
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound
17+
import Ouroboros.Consensus.Storage.PerasCertDB.API
18+
import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound (ObjectDiffusionInboundPipelined)
19+
import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (ObjectDiffusionOutbound)
20+
import Ouroboros.Network.Protocol.ObjectDiffusion.Type (ObjectDiffusion)
21+
22+
type TracePerasCertDiffusionInbound blk =
23+
TraceObjectDiffusionInbound PerasRoundNo (PerasCert blk)
24+
25+
type TracePerasCertDiffusionOutbound blk =
26+
TraceObjectDiffusionOutbound PerasRoundNo (PerasCert blk)
27+
28+
type PerasCertPoolReader blk m =
29+
ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
30+
31+
type PerasCertPoolWriter blk m =
32+
ObjectPoolWriter PerasRoundNo (PerasCert blk) m
33+
34+
type PerasCertDiffusionInboundPipelined blk m a =
35+
ObjectDiffusionInboundPipelined PerasRoundNo (PerasCert blk) m a
36+
37+
type PerasCertDiffusionOutbound blk m a =
38+
ObjectDiffusionOutbound PerasRoundNo (PerasCert blk) m a
39+
40+
type PerasCertDiffusion blk =
41+
ObjectDiffusion PerasRoundNo (PerasCert blk)

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

Lines changed: 37 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -6,8 +6,11 @@
66
{-# LANGUAGE MultiParamTypeClasses #-}
77
{-# LANGUAGE PolyKinds #-}
88
{-# LANGUAGE RankNTypes #-}
9+
{-# LANGUAGE RecordWildCards #-}
10+
{-# LANGUAGE ScopedTypeVariables #-}
911
{-# LANGUAGE StandaloneDeriving #-}
1012
{-# LANGUAGE StandaloneKindSignatures #-}
13+
{-# LANGUAGE TypeApplications #-}
1114
{-# LANGUAGE UndecidableInstances #-}
1215

1316
-- | Serialisation for sending things across the network.
@@ -33,8 +36,8 @@ module Ouroboros.Consensus.Node.Serialisation
3336
, Some (..)
3437
) where
3538

36-
import Codec.CBOR.Decoding (Decoder)
37-
import Codec.CBOR.Encoding (Encoding)
39+
import Codec.CBOR.Decoding (Decoder, decodeListLenOf)
40+
import Codec.CBOR.Encoding (Encoding, encodeListLen)
3841
import Codec.Serialise (Serialise (decode, encode))
3942
import Data.Kind
4043
import Data.SOP.BasicFunctors
@@ -47,7 +50,15 @@ import Ouroboros.Consensus.Ledger.SupportsMempool
4750
import Ouroboros.Consensus.Node.NetworkProtocolVersion
4851
import Ouroboros.Consensus.TypeFamilyWrappers
4952
import Ouroboros.Consensus.Util (Some (..))
50-
import Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR)
53+
import Ouroboros.Network.Block
54+
( Tip
55+
, decodePoint
56+
, decodeTip
57+
, encodePoint
58+
, encodeTip
59+
, unwrapCBORinCBOR
60+
, wrapCBORinCBOR
61+
)
5162

5263
{-------------------------------------------------------------------------------
5364
NodeToNode
@@ -173,6 +184,29 @@ deriving newtype instance
173184
SerialiseNodeToNode blk (GenTxId blk) =>
174185
SerialiseNodeToNode blk (WrapGenTxId blk)
175186

187+
instance ConvertRawHash blk => SerialiseNodeToNode blk (Point blk) where
188+
encodeNodeToNode _ccfg _version = encodePoint $ encodeRawHash (Proxy @blk)
189+
decodeNodeToNode _ccfg _version = decodePoint $ decodeRawHash (Proxy @blk)
190+
191+
instance ConvertRawHash blk => SerialiseNodeToNode blk (Tip blk) where
192+
encodeNodeToNode _ccfg _version = encodeTip $ encodeRawHash (Proxy @blk)
193+
decodeNodeToNode _ccfg _version = decodeTip $ decodeRawHash (Proxy @blk)
194+
195+
instance SerialiseNodeToNode blk PerasRoundNo where
196+
encodeNodeToNode _ccfg _version = encode
197+
decodeNodeToNode _ccfg _version = decode
198+
instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasCert blk) where
199+
-- Consistent with the 'Serialise' instance for 'PerasCert' defined in Ouroboros.Consensus.Block.SupportsPeras
200+
encodeNodeToNode ccfg version PerasCert{..} =
201+
encodeListLen 2
202+
<> encodeNodeToNode ccfg version pcCertRound
203+
<> encodeNodeToNode ccfg version pcCertBoostedBlock
204+
decodeNodeToNode ccfg version = do
205+
decodeListLenOf 2
206+
pcCertRound <- decodeNodeToNode ccfg version
207+
pcCertBoostedBlock <- decodeNodeToNode ccfg version
208+
pure $ PerasCert pcCertRound pcCertBoostedBlock
209+
176210
deriving newtype instance
177211
SerialiseNodeToClient blk (GenTxId blk) =>
178212
SerialiseNodeToClient blk (WrapGenTxId blk)

0 commit comments

Comments
 (0)