Add codec for PerasCert and PerasCertDiffusion

Author: tbagrel1

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs

@@ -85,10 +85,6 @@ import Ouroboros.Consensus.Util.IOLike
 import Ouroboros.Consensus.Util.Orphans ()
 import Ouroboros.Network.Block
   ( Serialised (..)
-  , decodePoint
-  , decodeTip
-  , encodePoint
-  , encodeTip
   )
 import Ouroboros.Network.BlockFetch
 import Ouroboros.Network.BlockFetch.Client
@@ -128,6 +124,10 @@ import Ouroboros.Network.Protocol.KeepAlive.Client
 import Ouroboros.Network.Protocol.KeepAlive.Codec
 import Ouroboros.Network.Protocol.KeepAlive.Server
 import Ouroboros.Network.Protocol.KeepAlive.Type
+import Ouroboros.Network.Protocol.ObjectDiffusion.Codec
+  ( codecObjectDiffusion
+  , codecObjectDiffusionId
+  )
 import Ouroboros.Network.Protocol.PeerSharing.Client
   ( PeerSharingClient
   , peerSharingClientPeer
@@ -337,14 +337,15 @@ mkHandlers
 -------------------------------------------------------------------------------}
 
 -- | Node-to-node protocol codecs needed to run 'Handlers'.
-data Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS = Codecs
+data Codecs blk addr e m bCS bSCS bBF bSBF bTX bPCD bKA bPS = Codecs
   { cChainSyncCodec :: Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS
   , cChainSyncCodecSerialised ::
       Codec (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bSCS
   , cBlockFetchCodec :: Codec (BlockFetch blk (Point blk)) e m bBF
   , cBlockFetchCodecSerialised ::
       Codec (BlockFetch (Serialised blk) (Point blk)) e m bSBF
   , cTxSubmission2Codec :: Codec (TxSubmission2 (GenTxId blk) (GenTx blk)) e m bTX
+  , cPerasCertDiffusionCodec :: Codec (PerasCertDiffusion blk) e m bPCD
   , cKeepAliveCodec :: Codec KeepAlive e m bKA
   , cPeerSharingCodec :: Codec (PeerSharing addr) e m bPS
   }
@@ -372,49 +373,53 @@ defaultCodecs ::
     ByteString
     ByteString
     ByteString
+    ByteString
 defaultCodecs ccfg version encAddr decAddr nodeToNodeVersion =
   Codecs
     { cChainSyncCodec =
         codecChainSync
           enc
           dec
-          (encodePoint (encodeRawHash p))
-          (decodePoint (decodeRawHash p))
-          (encodeTip (encodeRawHash p))
-          (decodeTip (decodeRawHash p))
+          enc
+          dec
+          enc
+          dec
     , cChainSyncCodecSerialised =
         codecChainSync
           enc
           dec
-          (encodePoint (encodeRawHash p))
-          (decodePoint (decodeRawHash p))
-          (encodeTip (encodeRawHash p))
-          (decodeTip (decodeRawHash p))
+          enc
+          dec
+          enc
+          dec
     , cBlockFetchCodec =
         codecBlockFetch
           enc
           dec
-          (encodePoint (encodeRawHash p))
-          (decodePoint (decodeRawHash p))
+          enc
+          dec
     , cBlockFetchCodecSerialised =
         codecBlockFetch
           enc
           dec
-          (encodePoint (encodeRawHash p))
-          (decodePoint (decodeRawHash p))
+          enc
+          dec
     , cTxSubmission2Codec =
         codecTxSubmission2
           enc
           dec
           enc
           dec
+    , cPerasCertDiffusionCodec =
+        codecObjectDiffusion
+          enc
+          dec
+          enc
+          dec
     , cKeepAliveCodec = codecKeepAlive_v2
     , cPeerSharingCodec = codecPeerSharing (encAddr nodeToNodeVersion) (decAddr nodeToNodeVersion)
     }
  where
-  p :: Proxy blk
-  p = Proxy
-
   enc :: SerialiseNodeToNode blk a => a -> Encoding
   enc = encodeNodeToNode ccfg version
 
@@ -434,6 +439,7 @@ identityCodecs ::
     (AnyMessage (BlockFetch blk (Point blk)))
     (AnyMessage (BlockFetch (Serialised blk) (Point blk)))
     (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))
+    (AnyMessage (PerasCertDiffusion blk))
     (AnyMessage KeepAlive)
     (AnyMessage (PeerSharing addr))
 identityCodecs =
@@ -443,6 +449,7 @@ identityCodecs =
     , cBlockFetchCodec = codecBlockFetchId
     , cBlockFetchCodecSerialised = codecBlockFetchId
     , cTxSubmission2Codec = codecTxSubmission2Id
+    , cPerasCertDiffusionCodec = codecObjectDiffusionId
     , cKeepAliveCodec = codecKeepAliveId
     , cPeerSharingCodec = codecPeerSharingId
     }
@@ -620,7 +627,7 @@ byteLimits =
 
 -- | Construct the 'NetworkApplication' for the node-to-node protocols
 mkApps ::
-  forall m addrNTN addrNTC blk e bCS bBF bTX bKA bPS.
+  forall m addrNTN addrNTC blk e bCS bBF bTX bPCD bKA bPS.
   ( IOLike m
   , MonadTimer m
   , Ord addrNTN
@@ -635,7 +642,7 @@ mkApps ::
   NodeKernel m addrNTN addrNTC blk ->
   StdGen ->
   Tracers m addrNTN blk e ->
-  (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bKA bPS) ->
+  (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bPCD bKA bPS) ->
   ByteLimits bCS bBF bTX bKA ->
   -- Chain-Sync timeouts for chain-sync client (using `Header blk`) as well as
   -- the server (`SerialisedHeader blk`).

ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs

@@ -83,6 +83,7 @@ import Ouroboros.Consensus.Mempool
 import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient
 import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck
 import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert (PerasCertDiffusion)
 import qualified Ouroboros.Consensus.Network.NodeToNode as NTN
 import Ouroboros.Consensus.Node.ExitPolicy
 import qualified Ouroboros.Consensus.Node.GSM as GSM
@@ -1180,6 +1181,7 @@ runThreadNetwork
         Lazy.ByteString
         Lazy.ByteString
         (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))
+        (AnyMessage (PerasCertDiffusion blk))
         (AnyMessage KeepAlive)
         (AnyMessage (PeerSharing NodeId))
     customNodeToNodeCodecs cfg ntnVersion =
@@ -1199,6 +1201,9 @@ runThreadNetwork
         , cTxSubmission2Codec =
             mapFailureCodec CodecIdFailure $
               NTN.cTxSubmission2Codec NTN.identityCodecs
+        , cPerasCertDiffusionCodec =
+            mapFailureCodec CodecIdFailure $
+              NTN.cPerasCertDiffusionCodec NTN.identityCodecs
         , cKeepAliveCodec =
             mapFailureCodec CodecIdFailure $
               NTN.cKeepAliveCodec NTN.identityCodecs

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -16,6 +17,9 @@ module Ouroboros.Consensus.Block.SupportsPeras
   , PerasCert (..)
   ) where
 
+import Codec.Serialise (Serialise (..))
+import Codec.Serialise.Decoding (decodeListLenOf)
+import Codec.Serialise.Encoding (encodeListLen)
 import Data.Monoid (Sum (..))
 import Data.Word (Word64)
 import GHC.Generics (Generic)
@@ -27,7 +31,7 @@ import Quiet (Quiet (..))
 newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64}
   deriving Show via Quiet PerasRoundNo
   deriving stock Generic
-  deriving newtype (Eq, Ord, NoThunks)
+  deriving newtype (Eq, Ord, NoThunks, Serialise)
 
 instance Condense PerasRoundNo where
   condense = show . unPerasRoundNo
@@ -66,3 +70,14 @@ instance StandardHash blk => BlockSupportsPeras blk where
 
   perasCertRound = pcCertRound
   perasCertBoostedBlock = pcCertBoostedBlock
+
+instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where
+  encode PerasCert{..} =
+    encodeListLen 2
+      <> encode pcCertRound
+      <> encode pcCertBoostedBlock
+  decode = do
+    decodeListLenOf 2
+    pcCertRound <- decode
+    pcCertBoostedBlock <- decode
+    pure $ PerasCert pcCertRound pcCertBoostedBlock

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

@@ -7,6 +7,7 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert
   , PerasCertPoolWriter
   , PerasCertDiffusionInboundPipelined
   , PerasCertDiffusionOutbound
+  , PerasCertDiffusion
   ) where
 
 import Ouroboros.Consensus.Block
@@ -16,6 +17,7 @@ import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound
 import Ouroboros.Consensus.Storage.PerasCertDB.API
 import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound (ObjectDiffusionInboundPipelined)
 import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (ObjectDiffusionOutbound)
+import Ouroboros.Network.Protocol.ObjectDiffusion.Type (ObjectDiffusion, OutboundAgency)
 
 type TracePerasCertDiffusionInbound blk =
   TraceObjectDiffusionInbound PerasRoundNo (PerasCert blk)
@@ -34,3 +36,6 @@ type PerasCertDiffusionInboundPipelined blk m a =
 
 type PerasCertDiffusionOutbound blk m a =
   ObjectDiffusionOutbound PerasRoundNo (PerasCert blk) m a
+
+type PerasCertDiffusion blk =
+  ObjectDiffusion OutboundAgency PerasRoundNo (PerasCert blk)

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

@@ -6,6 +6,8 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -33,8 +35,8 @@ module Ouroboros.Consensus.Node.Serialisation
   , Some (..)
   ) where
 
-import Codec.CBOR.Decoding (Decoder)
-import Codec.CBOR.Encoding (Encoding)
+import Codec.CBOR.Decoding (Decoder, decodeListLenOf)
+import Codec.CBOR.Encoding (Encoding, encodeListLen)
 import Codec.Serialise (Serialise (decode, encode))
 import Data.Kind
 import Data.SOP.BasicFunctors
@@ -47,7 +49,15 @@ import Ouroboros.Consensus.Ledger.SupportsMempool
 import Ouroboros.Consensus.Node.NetworkProtocolVersion
 import Ouroboros.Consensus.TypeFamilyWrappers
 import Ouroboros.Consensus.Util (Some (..))
-import Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR)
+import Ouroboros.Network.Block
+  ( Tip
+  , decodePoint
+  , decodeTip
+  , encodePoint
+  , encodeTip
+  , unwrapCBORinCBOR
+  , wrapCBORinCBOR
+  )
 
 {-------------------------------------------------------------------------------
   NodeToNode
@@ -173,6 +183,30 @@ deriving newtype instance
   SerialiseNodeToNode blk (GenTxId blk) =>
   SerialiseNodeToNode blk (WrapGenTxId blk)
 
+-- TODO: move these orphan instances elsewhere
+instance ConvertRawHash blk => SerialiseNodeToNode blk (Point blk) where
+  encodeNodeToNode _ccfg _version = encodePoint $ encodeRawHash (Proxy :: Proxy blk)
+  decodeNodeToNode _ccfg _version = decodePoint $ decodeRawHash (Proxy :: Proxy blk)
+
+instance ConvertRawHash blk => SerialiseNodeToNode blk (Tip blk) where
+  encodeNodeToNode _ccfg _version = encodeTip $ encodeRawHash (Proxy :: Proxy blk)
+  decodeNodeToNode _ccfg _version = decodeTip $ decodeRawHash (Proxy :: Proxy blk)
+
+instance SerialiseNodeToNode blk PerasRoundNo where
+  encodeNodeToNode _ccfg _version = encode
+  decodeNodeToNode _ccfg _version = decode
+instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasCert blk) where
+  -- Consistent with the 'Serialise' instance for 'PerasCert' defined in Ouroboros.Consensus.Block.SupportsPeras
+  encodeNodeToNode ccfg version PerasCert{..} =
+    encodeListLen 2
+      <> encodeNodeToNode ccfg version pcCertRound
+      <> encodeNodeToNode ccfg version pcCertBoostedBlock
+  decodeNodeToNode ccfg version = do
+    decodeListLenOf 2
+    pcCertRound <- decodeNodeToNode ccfg version
+    pcCertBoostedBlock <- decodeNodeToNode ccfg version
+    pure $ PerasCert pcCertRound pcCertBoostedBlock
+
 deriving newtype instance
   SerialiseNodeToClient blk (GenTxId blk) =>
   SerialiseNodeToClient blk (WrapGenTxId blk)