Skip to content

Commit

Permalink
Merge #4430
Browse files Browse the repository at this point in the history 
4430: Add CBORCodec Tuple and refactor code to use it r=bolt12 a=bolt12

Closes #4340 

Co-authored-by: Armando Santos <armando@well-typed.com>
  • Loading branch information
@iohk-bors @bolt12
iohk-bors[bot] and bolt12 authored Apr 21, 2023
2 parents fd4e201 + 19ada83 commit 8d6cec5
Show file tree
Hide file tree
Showing 37 changed files with 302 additions and 300 deletions.
103 changes: 37 additions & 66 deletions ouroboros-consensus-diffusion/src/Ouroboros/Consensus/Network/NodeToClient.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,8 +33,6 @@ module Ouroboros.Consensus.Network.NodeToClient (
, responder
) where

import Codec.CBOR.Decoding (Decoder)
import Codec.CBOR.Encoding (Encoding)
import Codec.CBOR.Read (DeserialiseFailure)
import Codec.Serialise (Serialise)
import Control.Tracer
Expand Down Expand Up @@ -70,6 +68,7 @@ import Ouroboros.Network.Mux
import Ouroboros.Network.NodeToClient hiding
(NodeToClientVersion (..))
import qualified Ouroboros.Network.NodeToClient as N (NodeToClientVersion (..))
import Ouroboros.Network.Protocol.CBOR (CBORCodec, CBORCodec' (..))
import Ouroboros.Network.Protocol.ChainSync.Codec
import Ouroboros.Network.Protocol.ChainSync.Server
import Ouroboros.Network.Protocol.ChainSync.Type
Expand Down Expand Up @@ -183,36 +182,16 @@ defaultCodecs :: forall m blk.
-> N.NodeToClientVersion
-> DefaultCodecs blk m
defaultCodecs ccfg version networkVersion = Codecs {
cChainSyncCodec =
codecChainSync
enc
dec
(encodePoint (encodeRawHash p))
(decodePoint (decodeRawHash p))
(encodeTip (encodeRawHash p))
(decodeTip (decodeRawHash p))

, cTxSubmissionCodec =
codecLocalTxSubmission
enc
dec
enc
dec

cChainSyncCodec = codecChainSync codec pointCodec tipCodec
, cTxSubmissionCodec = codecLocalTxSubmission codec codec
, cStateQueryCodec =
codecLocalStateQuery
(encodePoint (encodeRawHash p))
(decodePoint (decodeRawHash p))
(queryEncodeNodeToClient ccfg queryVersion version . SomeSecond)
((\(SomeSecond qry) -> Some qry) <$> queryDecodeNodeToClient ccfg queryVersion version)
(encodeResult ccfg version)
(decodeResult ccfg version)

, cTxMonitorCodec =
codecLocalTxMonitor
enc dec
enc dec
enc dec
pointCodec
(CBORCodec (queryEncodeNodeToClient ccfg queryVersion version . SomeSecond)
((\(SomeSecond qry) -> Some qry) <$> queryDecodeNodeToClient ccfg queryVersion version))
(\qr -> CBORCodec (encodeResult ccfg version qr)
(decodeResult ccfg version qr))
, cTxMonitorCodec = codecLocalTxMonitor codec codec codec
}
where
queryVersion :: QueryVersion
Expand All @@ -221,11 +200,17 @@ defaultCodecs ccfg version networkVersion = Codecs {
p :: Proxy blk
p = Proxy

enc :: SerialiseNodeToClient blk a => a -> Encoding
enc = encodeNodeToClient ccfg version
codec :: SerialiseNodeToClient blk a => CBORCodec a
codec = CBORCodec (encodeNodeToClient ccfg version)
(decodeNodeToClient ccfg version)

pointCodec :: CBORCodec (Point blk)
pointCodec = CBORCodec (encodePoint (encodeRawHash p))
(decodePoint (decodeRawHash p))

dec :: SerialiseNodeToClient blk a => forall s. Decoder s a
dec = decodeNodeToClient ccfg version
tipCodec :: CBORCodec (Tip blk)
tipCodec = CBORCodec (encodeTip (encodeRawHash p))
(decodeTip (decodeRawHash p))

-- | Protocol codecs for the node-to-client protocols which serialise
-- / deserialise blocks in /chain-sync/ protocol.
Expand All @@ -242,36 +227,16 @@ clientCodecs :: forall m blk.
-> N.NodeToClientVersion
-> ClientCodecs blk m
clientCodecs ccfg version networkVersion = Codecs {
cChainSyncCodec =
codecChainSync
enc
dec
(encodePoint (encodeRawHash p))
(decodePoint (decodeRawHash p))
(encodeTip (encodeRawHash p))
(decodeTip (decodeRawHash p))

, cTxSubmissionCodec =
codecLocalTxSubmission
enc
dec
enc
dec

cChainSyncCodec = codecChainSync codec pointCodec tipCodec
, cTxSubmissionCodec = codecLocalTxSubmission codec codec
, cStateQueryCodec =
codecLocalStateQuery
(encodePoint (encodeRawHash p))
(decodePoint (decodeRawHash p))
(queryEncodeNodeToClient ccfg queryVersion version . SomeSecond)
((\(SomeSecond qry) -> Some qry) <$> queryDecodeNodeToClient ccfg queryVersion version)
(encodeResult ccfg version)
(decodeResult ccfg version)

, cTxMonitorCodec =
codecLocalTxMonitor
enc dec
enc dec
enc dec
pointCodec
(CBORCodec (queryEncodeNodeToClient ccfg queryVersion version . SomeSecond)
((\(SomeSecond qry) -> Some qry) <$> queryDecodeNodeToClient ccfg queryVersion version))
(\qr -> CBORCodec (encodeResult ccfg version qr)
(decodeResult ccfg version qr))
, cTxMonitorCodec = codecLocalTxMonitor codec codec codec
}
where
queryVersion :: QueryVersion
Expand All @@ -280,11 +245,17 @@ clientCodecs ccfg version networkVersion = Codecs {
p :: Proxy blk
p = Proxy

enc :: SerialiseNodeToClient blk a => a -> Encoding
enc = encodeNodeToClient ccfg version
codec :: SerialiseNodeToClient blk a => CBORCodec a
codec = CBORCodec (encodeNodeToClient ccfg version)
(decodeNodeToClient ccfg version)

pointCodec :: CBORCodec (Point blk)
pointCodec = CBORCodec (encodePoint (encodeRawHash p))
(decodePoint (decodeRawHash p))

dec :: SerialiseNodeToClient blk a => forall s. Decoder s a
dec = decodeNodeToClient ccfg version
tipCodec :: CBORCodec (Tip blk)
tipCodec = CBORCodec (encodeTip (encodeRawHash p))
(decodeTip (decodeRawHash p))

-- | Identity codecs used in tests.
identityCodecs :: (Monad m, QueryLedger blk)
Expand Down
71 changes: 19 additions & 52 deletions ouroboros-consensus-diffusion/src/Ouroboros/Consensus/Network/NodeToNode.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -37,10 +37,6 @@ module Ouroboros.Consensus.Network.NodeToNode (
, ChainSyncTimeout (..)
) where

import Codec.CBOR.Decoding (Decoder)
import qualified Codec.CBOR.Decoding as CBOR
import Codec.CBOR.Encoding (Encoding)
import qualified Codec.CBOR.Encoding as CBOR
import Codec.CBOR.Read (DeserialiseFailure)
import Control.Monad.Class.MonadMVar (MonadMVar)
import Control.Monad.Class.MonadTime (MonadTime)
Expand Down Expand Up @@ -95,6 +91,7 @@ import Ouroboros.Network.Protocol.BlockFetch.Codec
import Ouroboros.Network.Protocol.BlockFetch.Server (BlockFetchServer,
blockFetchServerPeer)
import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch (..))
import Ouroboros.Network.Protocol.CBOR (CBORCodec, CBORCodec' (..))
import Ouroboros.Network.Protocol.ChainSync.ClientPipelined
import Ouroboros.Network.Protocol.ChainSync.Codec
import Ouroboros.Network.Protocol.ChainSync.PipelineDecision
Expand Down Expand Up @@ -276,64 +273,34 @@ defaultCodecs :: forall m blk addr.
)
=> CodecConfig blk
-> BlockNodeToNodeVersion blk
-> (addr -> CBOR.Encoding)
-> (forall s . CBOR.Decoder s addr)
-> CBORCodec addr
-> NodeToNodeVersion
-> Codecs blk addr DeserialiseFailure m
ByteString ByteString ByteString 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))

, cChainSyncCodecSerialised =
codecChainSync
enc
dec
(encodePoint (encodeRawHash p))
(decodePoint (decodeRawHash p))
(encodeTip (encodeRawHash p))
(decodeTip (decodeRawHash p))

, cBlockFetchCodec =
codecBlockFetch
enc
dec
(encodePoint (encodeRawHash p))
(decodePoint (decodeRawHash p))

, cBlockFetchCodecSerialised =
codecBlockFetch
enc
dec
(encodePoint (encodeRawHash p))
(decodePoint (decodeRawHash p))

, cTxSubmission2Codec =
codecTxSubmission2
enc
dec
enc
dec

defaultCodecs ccfg version addrCodec _nodeToNodeVersion = Codecs {
cChainSyncCodec = codecChainSync codec pointCodec tipCodec
, cChainSyncCodecSerialised = codecChainSync codec pointCodec tipCodec
, cBlockFetchCodec = codecBlockFetch codec pointCodec
, cBlockFetchCodecSerialised = codecBlockFetch codec pointCodec
, cTxSubmission2Codec = codecTxSubmission2 codec codec
, cKeepAliveCodec = codecKeepAlive_v2

, cPeerSharingCodec = codecPeerSharing encAddr decAddr
, cPeerSharingCodec = codecPeerSharing addrCodec
}
where
p :: Proxy blk
p = Proxy

enc :: SerialiseNodeToNode blk a => a -> Encoding
enc = encodeNodeToNode ccfg version
codec :: SerialiseNodeToNode blk a => CBORCodec a
codec = CBORCodec (encodeNodeToNode ccfg version)
(decodeNodeToNode ccfg version)

pointCodec :: CBORCodec (Point blk)
pointCodec = CBORCodec (encodePoint (encodeRawHash p))
(decodePoint (decodeRawHash p))

dec :: SerialiseNodeToNode blk a => forall s. Decoder s a
dec = decodeNodeToNode ccfg version
tipCodec :: CBORCodec (Tip blk)
tipCodec = CBORCodec (encodeTip (encodeRawHash p))
(decodeTip (decodeRawHash p))

-- | Identity codecs used in tests.
identityCodecs :: Monad m
Expand Down
20 changes: 9 additions & 11 deletions ouroboros-consensus-diffusion/src/Ouroboros/Consensus/Node.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -51,8 +51,6 @@ module Ouroboros.Consensus.Node (
, openChainDB
) where

import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Encoding as CBOR
import Codec.Serialise (DeserialiseFailure)
import Control.Monad.Class.MonadMVar (MonadMVar)
import Control.Monad.Class.MonadTime (MonadTime)
Expand Down Expand Up @@ -117,6 +115,7 @@ import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics,
newPeerMetric, reportMetric)
import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing,
decodeRemoteAddress, encodeRemoteAddress)
import Ouroboros.Network.Protocol.CBOR (CBORCodec, CBORCodec' (..))
import Ouroboros.Network.Protocol.Limits (shortWait)
import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount)
import Ouroboros.Network.RethrowPolicy
Expand Down Expand Up @@ -272,7 +271,9 @@ run :: forall blk p2p.
=> RunNodeArgs IO RemoteAddress LocalAddress blk p2p
-> StdRunNodeArgs IO blk p2p
-> IO ()
run args stdArgs = stdLowLevelRunNodeArgsIO args stdArgs >>= runWith args encodeRemoteAddress decodeRemoteAddress
run args stdArgs =
stdLowLevelRunNodeArgsIO args stdArgs
>>= runWith args (CBORCodec encodeRemoteAddress decodeRemoteAddress)

-- | Start a node.
--
Expand All @@ -286,11 +287,10 @@ runWith :: forall m addrNTN addrNTC versionDataNTN versionDataNTC blk p2p.
, Hashable addrNTN, Ord addrNTN, Show addrNTN, Typeable addrNTN
)
=> RunNodeArgs m addrNTN addrNTC blk p2p
-> (addrNTN -> CBOR.Encoding)
-> (forall s . CBOR.Decoder s addrNTN)
-> CBORCodec addrNTN
-> LowLevelRunNodeArgs m addrNTN addrNTC versionDataNTN versionDataNTC blk p2p
-> m ()
runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
runWith RunNodeArgs{..} addrNTNCodec LowLevelRunNodeArgs{..} =

llrnWithCheckedDB $ \(LastShutDownWasClean lastShutDownWasClean) continueWithCleanChainDB ->
withRegistry $ \registry ->
Expand Down Expand Up @@ -370,7 +370,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
rnNodeKernelHook registry nodeKernel

peerMetrics <- newPeerMetric Diffusion.peerMetricsConfiguration
let ntnApps = mkNodeToNodeApps nodeKernelArgs nodeKernel peerMetrics encAddrNtN decAddrNtN
let ntnApps = mkNodeToNodeApps nodeKernelArgs nodeKernel peerMetrics
ntcApps = mkNodeToClientApps nodeKernelArgs nodeKernel
(apps, appsExtra) = mkDiffusionApplications
rnEnableP2P
Expand All @@ -395,8 +395,6 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
:: NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> PeerMetrics m addrNTN
-> (addrNTN -> CBOR.Encoding)
-> (forall s . CBOR.Decoder s addrNTN)
-> BlockNodeToNodeVersion blk
-> (PeerSharingAmount -> m [addrNTN])
-- ^ Peer Sharing result computation callback
Expand All @@ -409,11 +407,11 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
ByteString
NodeToNodeInitiatorResult
()
mkNodeToNodeApps nodeKernelArgs nodeKernel peerMetrics encAddrNTN decAddrNTN version computePeers =
mkNodeToNodeApps nodeKernelArgs nodeKernel peerMetrics version computePeers =
NTN.mkApps
nodeKernel
rnTraceNTN
(NTN.defaultCodecs codecConfig version encAddrNTN decAddrNTN)
(NTN.defaultCodecs codecConfig version addrNTNCodec)
NTN.byteLimits
llrnChainSyncTimeout
(reportMetric Diffusion.peerMetricsConfiguration peerMetrics)
Expand Down
17 changes: 9 additions & 8 deletions ouroboros-consensus-mock/ouroboros-consensus-mock.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -49,22 +49,23 @@ library
Ouroboros.Consensus.Mock.Protocol.Praos

build-depends:
, base >=4.14 && <4.17
, bimap >=0.4 && <0.5
, bytestring >=0.10 && <0.12
, base >=4.14 && <4.17
, bimap >=0.4 && <0.5
, bytestring >=0.10 && <0.12
, cardano-binary
, cardano-crypto-class
, cardano-slotting
, cborg >=0.2.2 && <0.3
, containers >=0.5 && <0.7
, cborg >=0.2.2 && <0.3
, containers >=0.5 && <0.7
, deepseq
, hashable
, mtl >=2.2 && <2.3
, mtl >=2.2 && <2.3
, nothunks
, ouroboros-consensus ^>=0.3.1
, ouroboros-consensus ^>=0.3.1
, ouroboros-network-api
, ouroboros-network-mock
, serialise >=0.2 && <0.3
, ouroboros-network-protocols
, serialise >=0.2 && <0.3
, time

default-language: Haskell2010
Expand Down
9 changes: 5 additions & 4 deletions ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -98,6 +98,8 @@ import Ouroboros.Consensus.Util (ShowProxy (..), hashFromBytesShortE,
(..:), (.:))
import Ouroboros.Consensus.Util.Condense
import Ouroboros.Consensus.Util.Orphans ()
import Ouroboros.Network.Protocol.CBOR (CBORCodec, CBORCodec' (..),
serialiseCodec)

{-------------------------------------------------------------------------------
Definition of a block
Expand Down Expand Up @@ -589,18 +591,17 @@ encodeSimpleHeader encodeExt SimpleHeader{..} = mconcat [
]

decodeSimpleHeader :: SimpleCrypto c
=> (ext' -> CBOR.Encoding)
-> (forall s. CBOR.Decoder s ext')
=> CBORCodec ext'
-> forall s. CBOR.Decoder s (Header (SimpleBlock' c ext ext'))
decodeSimpleHeader encodeExt decodeExt = do
decodeSimpleHeader (CBORCodec encodeExt decodeExt) = do
CBOR.decodeListLenOf 2
mkSimpleHeader encodeExt <$> decode <*> decodeExt

-- | Custom 'Serialise' instance that doesn't serialise the hash
instance (SimpleCrypto c, Serialise ext')
=> Serialise (Header (SimpleBlock' c ext ext')) where
encode = encodeSimpleHeader encode
decode = decodeSimpleHeader encode decode
decode = decodeSimpleHeader serialiseCodec

simpleBlockBinaryBlockInfo ::
(SimpleCrypto c, Serialise ext', Typeable ext, Typeable ext')
Expand Down
Loading

0 comments on commit 8d6cec5

Please sign in to comment.