Skip to content

Commit 5cec5cd

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 053dc5a commit 5cec5cd

File tree

4 files changed

+194
-3
lines changed

4 files changed

+194
-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: 114 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,114 @@
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 Data.Map (Map)
15+
import qualified Data.Map as Map
16+
import GHC.Exception (throw)
17+
import Ouroboros.Consensus.Block
18+
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
19+
import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
20+
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
21+
import Ouroboros.Consensus.Storage.PerasCertDB.API
22+
( PerasCertDB
23+
, PerasCertSnapshot
24+
, PerasCertTicketNo
25+
)
26+
import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB
27+
import Ouroboros.Consensus.Util.IOLike
28+
29+
-- | TODO: replace by `Data.Map.take` as soon as we move to GHC 9.8
30+
takeAscMap :: Int -> Map k v -> Map k v
31+
takeAscMap n = Map.fromDistinctAscList . take n . Map.toAscList
32+
33+
makePerasCertPoolReaderFromSnapshot ::
34+
(IOLike m, StandardHash blk) =>
35+
STM m (PerasCertSnapshot blk) ->
36+
ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
37+
makePerasCertPoolReaderFromSnapshot getCertSnapshot =
38+
ObjectPoolReader
39+
{ oprObjectId = getPerasCertRound
40+
, oprZeroTicketNo = PerasCertDB.zeroPerasCertTicketNo
41+
, oprObjectsAfter = \lastKnown limit -> do
42+
certSnapshot <- getCertSnapshot
43+
let certsAfterLastKnown =
44+
PerasCertDB.getCertsAfter certSnapshot lastKnown
45+
let loadCertsAfterLastKnown =
46+
pure (getPerasCert <$> takeAscMap (fromIntegral limit) certsAfterLastKnown)
47+
pure $
48+
if Map.null certsAfterLastKnown
49+
then Nothing
50+
else Just loadCertsAfterLastKnown
51+
}
52+
53+
makePerasCertPoolReaderFromCertDB ::
54+
(IOLike m, StandardHash blk) =>
55+
PerasCertDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
56+
makePerasCertPoolReaderFromCertDB perasCertDB =
57+
makePerasCertPoolReaderFromSnapshot (PerasCertDB.getCertSnapshot perasCertDB)
58+
59+
makePerasCertPoolWriterFromCertDB ::
60+
(StandardHash blk, IOLike m) =>
61+
PerasCertDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m
62+
makePerasCertPoolWriterFromCertDB perasCertDB =
63+
ObjectPoolWriter
64+
{ opwObjectId = getPerasCertRound
65+
, opwAddObjects = \certs -> do
66+
validatePerasCerts certs
67+
>>= mapM_ (PerasCertDB.addCert perasCertDB)
68+
, opwHasObject = do
69+
certSnapshot <- PerasCertDB.getCertSnapshot perasCertDB
70+
pure $ PerasCertDB.containsCert certSnapshot
71+
}
72+
73+
makePerasCertPoolReaderFromChainDB ::
74+
(IOLike m, StandardHash blk) =>
75+
ChainDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
76+
makePerasCertPoolReaderFromChainDB chainDB =
77+
makePerasCertPoolReaderFromSnapshot (ChainDB.getPerasCertSnapshot chainDB)
78+
79+
makePerasCertPoolWriterFromChainDB ::
80+
(StandardHash blk, IOLike m) =>
81+
ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m
82+
makePerasCertPoolWriterFromChainDB chainDB =
83+
ObjectPoolWriter
84+
{ opwObjectId = getPerasCertRound
85+
, opwAddObjects = \certs -> do
86+
validatePerasCerts certs
87+
>>= mapM_ (ChainDB.addPerasCertAsync chainDB)
88+
, opwHasObject = do
89+
certSnapshot <- ChainDB.getPerasCertSnapshot chainDB
90+
pure $ PerasCertDB.containsCert certSnapshot
91+
}
92+
93+
data PerasCertInboundException
94+
= forall blk. PerasCertValidationError (PerasValidationErr blk)
95+
96+
deriving instance Show PerasCertInboundException
97+
98+
instance Exception PerasCertInboundException
99+
100+
-- | Validate a list of 'PerasCert's, throwing a 'PerasCertInboundException' if
101+
-- any of them are invalid.
102+
validatePerasCerts ::
103+
(StandardHash blk, MonadThrow m) =>
104+
[PerasCert blk] ->
105+
m [ValidatedPerasCert blk]
106+
validatePerasCerts certs = do
107+
let perasCfg = makePerasCfg Nothing
108+
-- TODO replace the mocked-up Nothing with a real
109+
-- 'BlockConfig' when all the plumbing is in place
110+
-- see https://github.com/tweag/cardano-peras/issues/73
111+
-- see https://github.com/tweag/cardano-peras/issues/120
112+
case traverse (validatePerasCert perasCfg) certs of
113+
Left validationErr -> throw (PerasCertValidationError validationErr)
114+
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)