diff --git a/ouroboros-consensus-diffusion/src/Ouroboros/Consensus/Network/NodeToClient.hs b/ouroboros-consensus-diffusion/src/Ouroboros/Consensus/Network/NodeToClient.hs index 121de45a367..3a03cb3cda2 100644 --- a/ouroboros-consensus-diffusion/src/Ouroboros/Consensus/Network/NodeToClient.hs +++ b/ouroboros-consensus-diffusion/src/Ouroboros/Consensus/Network/NodeToClient.hs @@ -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 @@ -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 @@ -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 @@ -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. @@ -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 @@ -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) diff --git a/ouroboros-consensus-diffusion/src/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/Ouroboros/Consensus/Network/NodeToNode.hs index d7803f4b8cb..b3b5d7a157d 100644 --- a/ouroboros-consensus-diffusion/src/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/Ouroboros/Consensus/Network/NodeToNode.hs @@ -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) @@ -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 @@ -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 diff --git a/ouroboros-consensus-diffusion/src/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/Ouroboros/Consensus/Node.hs index 2ab59aa7ed1..4b804f1b4d9 100644 --- a/ouroboros-consensus-diffusion/src/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/src/Ouroboros/Consensus/Node.hs @@ -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) @@ -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 @@ -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. -- @@ -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 -> @@ -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 @@ -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 @@ -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) diff --git a/ouroboros-consensus-mock/ouroboros-consensus-mock.cabal b/ouroboros-consensus-mock/ouroboros-consensus-mock.cabal index e917ea60d2c..16a167bc9ae 100644 --- a/ouroboros-consensus-mock/ouroboros-consensus-mock.cabal +++ b/ouroboros-consensus-mock/ouroboros-consensus-mock.cabal @@ -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 diff --git a/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs index 9972dd9c913..c9c5c0fcf1c 100644 --- a/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -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 @@ -589,10 +591,9 @@ 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 @@ -600,7 +601,7 @@ decodeSimpleHeader encodeExt decodeExt = do 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') diff --git a/ouroboros-consensus-test/src/Test/ThreadNet/Network.hs b/ouroboros-consensus-test/src/Test/ThreadNet/Network.hs index 56003f21edb..4dd128a9b90 100644 --- a/ouroboros-consensus-test/src/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-test/src/Test/ThreadNet/Network.hs @@ -1090,7 +1090,7 @@ runThreadNetwork systemTime ThreadNetworkArgs NTN.cPeerSharingCodec NTN.identityCodecs } where - binaryProtocolCodecs = NTN.defaultCodecs (configCodec cfg) blockVersion encodeNodeId decodeNodeId ntnVersion + binaryProtocolCodecs = NTN.defaultCodecs (configCodec cfg) blockVersion nodeIdCodec ntnVersion -- | Sum of 'CodecFailure' (from @identityCodecs@) and 'DeserialiseFailure' -- (from @defaultCodecs@). @@ -1332,7 +1332,7 @@ directedEdgeInner registry clock (version, blockVersion) (cfg, calcMessageDelay) _ -> pure () where codec = - NTN.cChainSyncCodec $ NTN.defaultCodecs cfg blockVersion encodeNodeId decodeNodeId version + NTN.cChainSyncCodec $ NTN.defaultCodecs cfg blockVersion nodeIdCodec version -- | Variant of 'createConnectChannels' with intermediate queues for -- delayed-but-in-order messages diff --git a/ouroboros-consensus/changelog.d/20230421_123326_armando_4340.md b/ouroboros-consensus/changelog.d/20230421_123326_armando_4340.md new file mode 100644 index 00000000000..cc615cfb4e1 --- /dev/null +++ b/ouroboros-consensus/changelog.d/20230421_123326_armando_4340.md @@ -0,0 +1,25 @@ + + + + +### Breaking + +- `ouroboros-consensus-diffusion`: Add CBORCodec tuple and refactor code +- `ouroboros-consensus-mock`: Add CBORCodec tuple and refactor code +- `ouroboros-consensus-test`: Add CBORCodec tuple and refactor code +- `ouroboros-consensus`: Add CBORCodec tuple and refactor code + diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/NodeId.hs b/ouroboros-consensus/src/Ouroboros/Consensus/NodeId.hs index 1e076ca4587..afaf2dfb750 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/NodeId.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/NodeId.hs @@ -12,6 +12,7 @@ module Ouroboros.Consensus.NodeId ( , decodeNodeId , encodeNodeId , fromCoreNodeId + , nodeIdCodec ) where import qualified Codec.CBOR.Decoding as CBOR @@ -22,6 +23,7 @@ import Data.Word import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Util.Condense (Condense (..)) +import Ouroboros.Network.Protocol.CBOR (CBORCodec, CBORCodec' (..)) import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) import Quiet @@ -71,5 +73,8 @@ decodeNodeId = do 1 -> RelayId <$> CBOR.decodeWord64 _ -> fail ("decodeNodeId: unknown tok:" ++ show tok) +nodeIdCodec :: CBORCodec NodeId +nodeIdCodec = CBORCodec encodeNodeId decodeNodeId + fromCoreNodeId :: CoreNodeId -> NodeId fromCoreNodeId = CoreId diff --git a/ouroboros-network-protocols/CHANGELOG.md b/ouroboros-network-protocols/CHANGELOG.md index 045dd6d1990..2ca0318280f 100644 --- a/ouroboros-network-protocols/CHANGELOG.md +++ b/ouroboros-network-protocols/CHANGELOG.md @@ -1,5 +1,13 @@ # Revision history for ouroboros-network-protocols +## Next version + +### Breaking + +- Add CBORCodec type and refactor code + +### Non-Breaking + ## 0.3.0.0 -- 2023-02-24 ### Breaking diff --git a/ouroboros-network-protocols/ouroboros-network-protocols.cabal b/ouroboros-network-protocols/ouroboros-network-protocols.cabal index 25e8553c6fd..dd8f82db9be 100644 --- a/ouroboros-network-protocols/ouroboros-network-protocols.cabal +++ b/ouroboros-network-protocols/ouroboros-network-protocols.cabal @@ -41,6 +41,7 @@ library Ouroboros.Network.Protocol.ChainSync.Server Ouroboros.Network.Protocol.ChainSync.Type Ouroboros.Network.Protocol.ChainSync.PipelineDecision + Ouroboros.Network.Protocol.CBOR Ouroboros.Network.Protocol.BlockFetch.Type Ouroboros.Network.Protocol.BlockFetch.Client Ouroboros.Network.Protocol.BlockFetch.Server diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/BlockFetch/Codec.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/BlockFetch/Codec.hs index 7e5821d24ae..bc8521aaf90 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/BlockFetch/Codec.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/BlockFetch/Codec.hs @@ -27,6 +27,7 @@ import Text.Printf import Network.TypedProtocol.Codec.CBOR import Ouroboros.Network.Protocol.BlockFetch.Type +import Ouroboros.Network.Protocol.CBOR (CBORCodec, CBORCodec' (..)) import Ouroboros.Network.Protocol.Limits -- | Byte Limit. @@ -63,13 +64,11 @@ timeLimitsBlockFetch = ProtocolTimeLimits stateToLimit codecBlockFetch :: forall block point m. MonadST m - => (block -> CBOR.Encoding) - -> (forall s. CBOR.Decoder s block) - -> (point -> CBOR.Encoding) - -> (forall s. CBOR.Decoder s point) + => CBORCodec block + -> CBORCodec point -> Codec (BlockFetch block point) CBOR.DeserialiseFailure m LBS.ByteString -codecBlockFetch encodeBlock decodeBlock - encodePoint decodePoint = +codecBlockFetch (CBORCodec encodeBlock decodeBlock) + (CBORCodec encodePoint decodePoint) = mkCodecCborLazyBS encode decode where encode :: forall (pr :: PeerRole) st st'. diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/CBOR.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/CBOR.hs new file mode 100644 index 00000000000..70e5c77eb96 --- /dev/null +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/CBOR.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE RankNTypes #-} + +module Ouroboros.Network.Protocol.CBOR where + +import qualified Codec.CBOR.Decoding as CBOR +import qualified Codec.CBOR.Encoding as CBOR +import qualified Codec.Serialise as CBOR + +data CBORCodec' a b = CBORCodec { + encodeCBOR :: a -> CBOR.Encoding, + decodeCBOR :: forall s. CBOR.Decoder s b + } + +type CBORCodec a = CBORCodec' a a + +serialiseCodec :: ( CBOR.Serialise a + , CBOR.Serialise b + ) + => CBORCodec' a b +serialiseCodec = CBORCodec CBOR.encode CBOR.decode diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/ChainSync/Codec.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/ChainSync/Codec.hs index 2fc2a66b3d2..cba45e8dd04 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/ChainSync/Codec.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/ChainSync/Codec.hs @@ -28,6 +28,7 @@ import qualified Codec.CBOR.Decoding as CBOR import Codec.CBOR.Encoding (encodeListLen, encodeWord) import qualified Codec.CBOR.Encoding as CBOR import qualified Codec.CBOR.Read as CBOR +import Ouroboros.Network.Protocol.CBOR (CBORCodec, CBORCodec' (..)) import Text.Printf @@ -89,17 +90,14 @@ timeLimitsChainSync csTimeouts = ProtocolTimeLimits stateToLimit codecChainSync :: forall header point tip m. (MonadST m) - => (header -> CBOR.Encoding) - -> (forall s . CBOR.Decoder s header) - -> (point -> CBOR.Encoding) - -> (forall s . CBOR.Decoder s point) - -> (tip -> CBOR.Encoding) - -> (forall s. CBOR.Decoder s tip) + => CBORCodec header + -> CBORCodec point + -> CBORCodec tip -> Codec (ChainSync header point tip) CBOR.DeserialiseFailure m LBS.ByteString -codecChainSync encodeHeader decodeHeader - encodePoint decodePoint - encodeTip decodeTip = +codecChainSync (CBORCodec encodeHeader decodeHeader) + (CBORCodec encodePoint decodePoint) + (CBORCodec encodeTip decodeTip) = mkCodecCborLazyBS encode decode where encode :: forall (pr :: PeerRole) diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalStateQuery/Codec.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalStateQuery/Codec.hs index ebc371efe91..16644d1c98b 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalStateQuery/Codec.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalStateQuery/Codec.hs @@ -24,6 +24,7 @@ import Text.Printf import Network.TypedProtocol.Codec.CBOR +import Ouroboros.Network.Protocol.CBOR (CBORCodec, CBORCodec' (..)) import Ouroboros.Network.Protocol.LocalStateQuery.Type @@ -35,16 +36,14 @@ codecLocalStateQuery ( MonadST m , ShowQuery query ) - => (point -> CBOR.Encoding) - -> (forall s . CBOR.Decoder s point) - -> (forall result . query result -> CBOR.Encoding) - -> (forall s . CBOR.Decoder s (Some query)) - -> (forall result . query result -> result -> CBOR.Encoding) - -> (forall result . query result -> forall s . CBOR.Decoder s result) + => CBORCodec point + -> (forall result . CBORCodec' (query result) (Some query)) + -> (forall result . query result -> CBORCodec result) -> Codec (LocalStateQuery block point query) CBOR.DeserialiseFailure m ByteString -codecLocalStateQuery encodePoint decodePoint - encodeQuery decodeQuery - encodeResult decodeResult = +codecLocalStateQuery (CBORCodec encodePoint decodePoint) + codecQueryResult + codecResult + = mkCodecCborLazyBS encode decode where encodeFailure :: AcquireFailure -> CBOR.Encoding @@ -86,12 +85,12 @@ codecLocalStateQuery encodePoint decodePoint encode (ClientAgency TokAcquired) (MsgQuery query) = CBOR.encodeListLen 2 <> CBOR.encodeWord 3 - <> encodeQuery query + <> (encodeCBOR codecQueryResult) query encode (ServerAgency (TokQuerying _query)) (MsgResult query result) = CBOR.encodeListLen 2 <> CBOR.encodeWord 4 - <> encodeResult query result + <> encodeCBOR (codecResult query) result encode (ClientAgency TokAcquired) MsgRelease = CBOR.encodeListLen 1 @@ -132,11 +131,11 @@ codecLocalStateQuery encodePoint decodePoint return (SomeMessage (MsgFailure failure)) (ClientAgency TokAcquired, 2, 3) -> do - Some query <- decodeQuery + Some query <- decodeCBOR codecQueryResult return (SomeMessage (MsgQuery query)) (ServerAgency (TokQuerying query), 2, 4) -> do - result <- decodeResult query + result <- decodeCBOR (codecResult query) return (SomeMessage (MsgResult query result)) (ClientAgency TokAcquired, 1, 5) -> diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalTxMonitor/Codec.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalTxMonitor/Codec.hs index 4fadc71a170..cf19f57d1a1 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalTxMonitor/Codec.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalTxMonitor/Codec.hs @@ -23,6 +23,7 @@ import qualified Codec.CBOR.Encoding as CBOR import qualified Codec.CBOR.Read as CBOR import Text.Printf +import Ouroboros.Network.Protocol.CBOR (CBORCodec, CBORCodec' (..)) import Ouroboros.Network.Protocol.LocalTxMonitor.Type codecLocalTxMonitor :: @@ -30,16 +31,13 @@ codecLocalTxMonitor :: ( MonadST m , ptcl ~ LocalTxMonitor txid tx slot ) - => (txid -> CBOR.Encoding) - -> (forall s. CBOR.Decoder s txid) - -> (tx -> CBOR.Encoding) - -> (forall s. CBOR.Decoder s tx) - -> (slot -> CBOR.Encoding) - -> (forall s. CBOR.Decoder s slot) + => CBORCodec txid + -> CBORCodec tx + -> CBORCodec slot -> Codec (LocalTxMonitor txid tx slot) CBOR.DeserialiseFailure m ByteString -codecLocalTxMonitor encodeTxId decodeTxId - encodeTx decodeTx - encodeSlot decodeSlot = +codecLocalTxMonitor (CBORCodec encodeTxId decodeTxId) + (CBORCodec encodeTx decodeTx) + (CBORCodec encodeSlot decodeSlot) = mkCodecCborLazyBS encode decode where encode :: diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalTxSubmission/Codec.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalTxSubmission/Codec.hs index 606543366c2..3d2504af951 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalTxSubmission/Codec.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalTxSubmission/Codec.hs @@ -21,19 +21,19 @@ import Text.Printf import Network.TypedProtocol.Codec.CBOR +import Ouroboros.Network.Protocol.CBOR (CBORCodec, CBORCodec' (..)) import Ouroboros.Network.Protocol.LocalTxSubmission.Type codecLocalTxSubmission :: forall tx reject m. MonadST m - => (tx -> CBOR.Encoding) - -> (forall s . CBOR.Decoder s tx) - -> (reject -> CBOR.Encoding) - -> (forall s . CBOR.Decoder s reject) + => CBORCodec tx + -> CBORCodec reject -> Codec (LocalTxSubmission tx reject) CBOR.DeserialiseFailure m ByteString -codecLocalTxSubmission encodeTx decodeTx encodeReject decodeReject = - mkCodecCborLazyBS encode decode +codecLocalTxSubmission (CBORCodec encodeTx decodeTx) + (CBORCodec encodeReject decodeReject) = + mkCodecCborLazyBS encode decode where encode :: forall (pr :: PeerRole) st st'. PeerHasAgency pr st diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Codec.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Codec.hs index 9a30e02d1b0..11e25cd47c0 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Codec.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Codec.hs @@ -23,17 +23,18 @@ import Ouroboros.Network.Protocol.PeerSharing.Type ServerHasAgency (..)) import Control.Monad.Class.MonadTime (DiffTime) +import Ouroboros.Network.Protocol.CBOR (CBORCodec, CBORCodec' (..)) import Ouroboros.Network.Protocol.Limits codecPeerSharing :: forall m peerAddress. MonadST m - => (peerAddress -> CBOR.Encoding) - -> (forall s . CBOR.Decoder s peerAddress) + => CBORCodec peerAddress -> Codec (PeerSharing peerAddress) CBOR.DeserialiseFailure m ByteString -codecPeerSharing encodeAddress decodeAddress = mkCodecCborLazyBS encodeMsg decodeMsg +codecPeerSharing (CBORCodec encodeAddress decodeAddress) = + mkCodecCborLazyBS encodeMsg decodeMsg where encodeMsg :: PeerHasAgency pr st -> Message (PeerSharing peerAddress) st st' diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission/Hello/Codec.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission/Hello/Codec.hs index 8d2d4d1dd5e..c7a22bf6028 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission/Hello/Codec.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission/Hello/Codec.hs @@ -53,13 +53,11 @@ codecTxSubmission2 , ShowProxy txid , ShowProxy tx ) - => (txid -> CBOR.Encoding) - -> (forall s . CBOR.Decoder s txid) - -> (tx -> CBOR.Encoding) - -> (forall s . CBOR.Decoder s tx) + => CBORCodec txid + -> CBORCodec tx -> Codec (TxSubmission2 txid tx) CBOR.DeserialiseFailure m ByteString -codecTxSubmission2 encodeTxId decodeTxId - encodeTx decodeTx = +codecTxSubmission2 (CBORCodec encodeTxId) + (CBORCodec encodeTx decodeTx) = codecHello 6 (encodeTxSubmission encodeTxId encodeTx) diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Codec.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Codec.hs index 89792ce2b52..2aa75b7357c 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Codec.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Codec.hs @@ -27,6 +27,7 @@ import Text.Printf import Network.TypedProtocol.Codec.CBOR +import Ouroboros.Network.Protocol.CBOR (CBORCodec, CBORCodec' (..)) import Ouroboros.Network.Protocol.Limits import Ouroboros.Network.Protocol.TxSubmission2.Type @@ -66,13 +67,11 @@ timeLimitsTxSubmission2 = ProtocolTimeLimits stateToLimit codecTxSubmission2 :: forall txid tx m. MonadST m - => (txid -> CBOR.Encoding) - -> (forall s . CBOR.Decoder s txid) - -> (tx -> CBOR.Encoding) - -> (forall s . CBOR.Decoder s tx) + => CBORCodec txid + -> CBORCodec tx -> Codec (TxSubmission2 txid tx) CBOR.DeserialiseFailure m ByteString -codecTxSubmission2 encodeTxId decodeTxId - encodeTx decodeTx = +codecTxSubmission2 (CBORCodec encodeTxId decodeTxId) + (CBORCodec encodeTx decodeTx) = mkCodecCborLazyBS (encodeTxSubmission2 encodeTxId encodeTx) decode diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Hello/Codec.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Hello/Codec.hs index 8d2d4d1dd5e..c7a22bf6028 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Hello/Codec.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Hello/Codec.hs @@ -53,13 +53,11 @@ codecTxSubmission2 , ShowProxy txid , ShowProxy tx ) - => (txid -> CBOR.Encoding) - -> (forall s . CBOR.Decoder s txid) - -> (tx -> CBOR.Encoding) - -> (forall s . CBOR.Decoder s tx) + => CBORCodec txid + -> CBORCodec tx -> Codec (TxSubmission2 txid tx) CBOR.DeserialiseFailure m ByteString -codecTxSubmission2 encodeTxId decodeTxId - encodeTx decodeTx = +codecTxSubmission2 (CBORCodec encodeTxId) + (CBORCodec encodeTx decodeTx) = codecHello 6 (encodeTxSubmission encodeTxId encodeTx) diff --git a/ouroboros-network-protocols/test-cddl/Main.hs b/ouroboros-network-protocols/test-cddl/Main.hs index 5aaea6b7dd4..b711aac5bb2 100644 --- a/ouroboros-network-protocols/test-cddl/Main.hs +++ b/ouroboros-network-protocols/test-cddl/Main.hs @@ -106,6 +106,8 @@ import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as TxSubmission2 import Network.Socket (SockAddr (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..), decodeRemoteAddress, encodeRemoteAddress) +import Ouroboros.Network.Protocol.CBOR (CBORCodec' (..), + serialiseCodec) import Ouroboros.Network.Protocol.PeerSharing.Codec (codecPeerSharing) import Ouroboros.Network.Protocol.PeerSharing.Test () import Ouroboros.Network.Protocol.PeerSharing.Type @@ -282,51 +284,41 @@ chainSyncCodec :: Codec (ChainSync BlockHeader (Point BlockHeader) (Tip BlockHea CBOR.DeserialiseFailure IO BL.ByteString chainSyncCodec = codecChainSync - (wrapCBORinCBOR Serialise.encode) - (unwrapCBORinCBOR (const <$> Serialise.decode)) - Serialise.encode - Serialise.decode - (encodeTip Serialise.encode) - (decodeTip Serialise.decode) + (CBORCodec (wrapCBORinCBOR Serialise.encode) + (unwrapCBORinCBOR (const <$> Serialise.decode))) + serialiseCodec + (CBORCodec (encodeTip Serialise.encode) + (decodeTip Serialise.decode)) blockFetchCodec :: Codec (BlockFetch Block (Point Block)) CBOR.DeserialiseFailure IO BL.ByteString blockFetchCodec = codecBlockFetch - (wrapCBORinCBOR Serialise.encode) - (unwrapCBORinCBOR (const <$> Serialise.decode)) - Serialise.encode - Serialise.decode + (CBORCodec (wrapCBORinCBOR Serialise.encode) + (unwrapCBORinCBOR (const <$> Serialise.decode))) + serialiseCodec txSubmissionCodec2 :: Codec (TxSubmission2 TxId Tx) CBOR.DeserialiseFailure IO BL.ByteString txSubmissionCodec2 = codecTxSubmission2 - Serialise.encode - Serialise.decode - Serialise.encode - Serialise.decode + serialiseCodec + serialiseCodec localTxSubmissionCodec :: Codec (LocalTxSubmission LocalTxSubmission.Tx LocalTxSubmission.Reject) CBOR.DeserialiseFailure IO BL.ByteString localTxSubmissionCodec = codecLocalTxSubmission - Serialise.encode - Serialise.decode - Serialise.encode - Serialise.decode + serialiseCodec + serialiseCodec localTxMonitorCodec :: Codec (LocalTxMonitor TxId Tx SlotNo) CBOR.DeserialiseFailure IO BL.ByteString -localTxMonitorCodec = - codecLocalTxMonitor - Serialise.encode Serialise.decode - Serialise.encode Serialise.decode - Serialise.encode Serialise.decode +localTxMonitorCodec = codecLocalTxMonitor serialiseCodec serialiseCodec serialiseCodec localStateQueryCodec :: Codec (LocalStateQuery Block (Point Block) LocalStateQuery.Query) @@ -588,7 +580,7 @@ prop_encodePeerSharing -> AnyMessageAndAgency (PeerSharing.PeerSharing SockAddr) -> Property prop_encodePeerSharing spec = - validateEncoder spec (codecPeerSharing encodeRemoteAddress decodeRemoteAddress) + validateEncoder spec (codecPeerSharing (CBORCodec encodeRemoteAddress decodeRemoteAddress)) -- @@ -811,7 +803,7 @@ unit_decodePeerSharing -> Assertion unit_decodePeerSharing spec = validateDecoder Nothing - spec (codecPeerSharing encodeRemoteAddress decodeRemoteAddress) + spec (codecPeerSharing (CBORCodec encodeRemoteAddress decodeRemoteAddress)) [ SomeAgency $ ClientAgency TokIdle , SomeAgency $ ServerAgency TokBusy ] diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/BlockFetch/Test.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/BlockFetch/Test.hs index 937121bbc39..57f8d1eea5a 100644 --- a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/BlockFetch/Test.hs +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/BlockFetch/Test.hs @@ -44,6 +44,8 @@ import Test.ChainGenerators (TestChainAndPoints (..)) import Test.Ouroboros.Network.Testing.Utils (prop_codec_cborM, prop_codec_valid_cbor_encoding, splits2, splits3) +import Ouroboros.Network.Protocol.CBOR (CBORCodec' (..), + serialiseCodec) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -320,8 +322,7 @@ codec :: MonadST m => Codec (BlockFetch Block (Point Block)) S.DeserialiseFailure m ByteString -codec = codecBlockFetch S.encode S.decode - S.encode S.decode +codec = codecBlockFetch serialiseCodec serialiseCodec codecWrapped :: MonadST m => Codec (BlockFetch Block (Point Block)) @@ -329,14 +330,14 @@ codecWrapped :: MonadST m m ByteString codecWrapped = codecBlockFetch - (wrapCBORinCBOR S.encode) (unwrapCBORinCBOR (const <$> S.decode)) - S.encode S.decode + (CBORCodec (wrapCBORinCBOR S.encode) (unwrapCBORinCBOR (const <$> S.decode))) + serialiseCodec codecSerialised :: MonadST m => Codec (BlockFetch (Serialised Block) (Point Block)) S.DeserialiseFailure m ByteString -codecSerialised = codecBlockFetch S.encode S.decode S.encode S.decode +codecSerialised = codecBlockFetch serialiseCodec serialiseCodec genBlockFetch :: Gen block -> Gen (ChainRange point) diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/ChainSync/Test.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/ChainSync/Test.hs index ce35580e383..73b571a6c59 100644 --- a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/ChainSync/Test.hs +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/ChainSync/Test.hs @@ -57,6 +57,8 @@ import Test.ChainProducerState (ChainProducerStateForkTest (..)) import Test.Ouroboros.Network.Testing.Utils (prop_codec_cborM, prop_codec_valid_cbor_encoding, splits2, splits3) +import Ouroboros.Network.Protocol.CBOR (CBORCodec, CBORCodec' (..), + serialiseCodec) import Test.QuickCheck hiding (Result) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -421,9 +423,13 @@ codec :: ( MonadST m => Codec (ChainSync block (Point block) (Tip block)) S.DeserialiseFailure m ByteString -codec = codecChainSync S.encode S.decode - S.encode S.decode - (encodeTip S.encode) (decodeTip S.decode) +codec = codecChainSync serialiseCodec + serialiseCodec + tipCodec + +tipCodec :: (S.Serialise (Chain.HeaderHash block)) + => CBORCodec (Tip block) +tipCodec = CBORCodec (encodeTip S.encode) (decodeTip S.decode) codecWrapped :: ( MonadST m , S.Serialise block @@ -433,9 +439,9 @@ codecWrapped :: ( MonadST m S.DeserialiseFailure m ByteString codecWrapped = - codecChainSync (wrapCBORinCBOR S.encode) (unwrapCBORinCBOR (const <$> S.decode)) - S.encode S.decode - (encodeTip S.encode) (decodeTip S.decode) + codecChainSync (CBORCodec (wrapCBORinCBOR S.encode) (unwrapCBORinCBOR (const <$> S.decode))) + serialiseCodec + tipCodec prop_codec_ChainSync :: AnyMessageAndAgency ChainSync_BlockHeader @@ -480,9 +486,9 @@ codecSerialised S.DeserialiseFailure m ByteString codecSerialised = codecChainSync - S.encode S.decode - S.encode S.decode - (encodeTip S.encode) (decodeTip S.decode) + serialiseCodec + serialiseCodec + tipCodec prop_codec_ChainSyncSerialised :: AnyMessageAndAgency ChainSync_Serialised_BlockHeader diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs index 3a366f13ade..5676ed2f6ed 100644 --- a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs @@ -51,6 +51,8 @@ import Test.ChainGenerators () import Test.Ouroboros.Network.Testing.Utils (prop_codec_cborM, prop_codec_valid_cbor_encoding, splits2, splits3) +import Ouroboros.Network.Protocol.CBOR (CBORCodec' (..), + serialiseCodec) import Test.QuickCheck as QC hiding (Result) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -327,9 +329,9 @@ codec :: MonadST m m ByteString codec = codecLocalStateQuery - Serialise.encode Serialise.decode - encodeQuery decodeQuery - encodeResult decodeResult + serialiseCodec + (CBORCodec (\qr -> encodeQuery qr) decodeQuery) + (\qr -> CBORCodec (encodeResult qr) (decodeResult qr)) where encodeQuery :: Query result -> CBOR.Encoding encodeQuery QueryPoint = Serialise.encode () diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalTxMonitor/Test.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalTxMonitor/Test.hs index 5b8f4d498be..00f2badce91 100644 --- a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalTxMonitor/Test.hs +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalTxMonitor/Test.hs @@ -35,6 +35,7 @@ import Ouroboros.Network.Protocol.LocalTxMonitor.Examples import Ouroboros.Network.Protocol.LocalTxMonitor.Server import Ouroboros.Network.Protocol.LocalTxMonitor.Type +import Ouroboros.Network.Protocol.CBOR (serialiseCodec) import Test.ChainGenerators () import Test.Ouroboros.Network.Testing.Utils (prop_codec_cborM, prop_codec_valid_cbor_encoding, splits2, splits3) @@ -68,10 +69,7 @@ codec :: ( MonadST m ) => Codec (LocalTxMonitor TxId Tx SlotNo) S.DeserialiseFailure m ByteString -codec = codecLocalTxMonitor - S.encode S.decode - S.encode S.decode - S.encode S.decode +codec = codecLocalTxMonitor serialiseCodec serialiseCodec serialiseCodec -- -- Properties diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalTxSubmission/Test.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalTxSubmission/Test.hs index 14d276ebe7c..d75ad749e77 100644 --- a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalTxSubmission/Test.hs +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalTxSubmission/Test.hs @@ -25,7 +25,6 @@ import Control.Monad.ST (runST) import Control.Tracer (nullTracer) import Codec.Serialise (DeserialiseFailure, Serialise) -import qualified Codec.Serialise as Serialise (decode, encode) import Network.TypedProtocol.Codec hiding (prop_codec) import Network.TypedProtocol.Proofs @@ -44,6 +43,7 @@ import Ouroboros.Network.Protocol.LocalTxSubmission.Type import Test.Ouroboros.Network.Testing.Utils (prop_codec_cborM, prop_codec_valid_cbor_encoding, splits2, splits3) +import Ouroboros.Network.Protocol.CBOR (serialiseCodec) import Test.QuickCheck as QC import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -230,8 +230,8 @@ codec :: MonadST m DeserialiseFailure m ByteString codec = codecLocalTxSubmission - Serialise.encode Serialise.decode - Serialise.encode Serialise.decode + serialiseCodec + serialiseCodec -- | Check the codec round trip property. diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Test.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Test.hs index a633d247492..dd39a6eab16 100644 --- a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Test.hs +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Test.hs @@ -26,6 +26,7 @@ import Network.TypedProtocol.Proofs (TerminalStates (..), connect) import Ouroboros.Network.Channel (createConnectedChannels) import Ouroboros.Network.Driver.Limits (ProtocolSizeLimits (..)) import Ouroboros.Network.Driver.Simple (runConnectedPeers) +import Ouroboros.Network.Protocol.CBOR (CBORCodec' (..)) import Ouroboros.Network.Protocol.PeerSharing.Client (peerSharingClientPeer) import Ouroboros.Network.Protocol.PeerSharing.Codec @@ -112,7 +113,7 @@ prop_channel :: ( MonadST m prop_channel f l = do (s, _) <- runConnectedPeers createConnectedChannels nullTracer - (codecPeerSharing CBOR.encodeInt CBOR.decodeInt) + (codecPeerSharing (CBORCodec CBOR.encodeInt CBOR.decodeInt)) client server let compute = foldl' (\(x, r) (PeerSharingAmount amount) -> (x + 1, replicate (applyFun f amount) x ++ r)) @@ -158,28 +159,28 @@ instance Eq peer => Eq (AnyMessage (PeerSharing peer)) where prop_codec :: AnyMessageAndAgency (PeerSharing Int) -> Bool prop_codec msg = - runST (prop_codecM (codecPeerSharing CBOR.encodeInt CBOR.decodeInt) msg) + runST (prop_codecM (codecPeerSharing (CBORCodec CBOR.encodeInt CBOR.decodeInt)) msg) prop_codec_cbor :: AnyMessageAndAgency (PeerSharing Int) -> Bool prop_codec_cbor msg = - runST (prop_codec_cborM (codecPeerSharing CBOR.encodeInt CBOR.decodeInt) msg) + runST (prop_codec_cborM (codecPeerSharing (CBORCodec CBOR.encodeInt CBOR.decodeInt)) msg) prop_codec_valid_cbor :: AnyMessageAndAgency (PeerSharing Int) -> Property -prop_codec_valid_cbor = prop_codec_valid_cbor_encoding (codecPeerSharing CBOR.encodeInt CBOR.decodeInt) +prop_codec_valid_cbor = prop_codec_valid_cbor_encoding (codecPeerSharing (CBORCodec CBOR.encodeInt CBOR.decodeInt)) -- | Check for data chunk boundary problems in the codec using 2 chunks. -- prop_codec_splits2 :: AnyMessageAndAgency (PeerSharing Int) -> Bool prop_codec_splits2 msg = - runST (prop_codec_splitsM splits2 (codecPeerSharing CBOR.encodeInt CBOR.decodeInt) msg) + runST (prop_codec_splitsM splits2 (codecPeerSharing (CBORCodec CBOR.encodeInt CBOR.decodeInt)) msg) -- | Check for data chunk boundary problems in the codec using 3 chunks. -- prop_codec_splits3 :: AnyMessageAndAgency (PeerSharing Int) -> Bool prop_codec_splits3 msg = - runST (prop_codec_splitsM splits3 (codecPeerSharing CBOR.encodeInt CBOR.decodeInt) msg) + runST (prop_codec_splitsM splits3 (codecPeerSharing (CBORCodec CBOR.encodeInt CBOR.decodeInt)) msg) prop_byteLimits :: AnyMessageAndAgency (PeerSharing Int) -> Bool @@ -187,6 +188,6 @@ prop_byteLimits (AnyMessageAndAgency agency msg) = dataSize (encode agency msg) <= sizeLimitForState agency where - Codec { encode } = codecPeerSharing @IO CBOR.encodeInt CBOR.decodeInt + Codec { encode } = codecPeerSharing @IO (CBORCodec CBOR.encodeInt CBOR.decodeInt) ProtocolSizeLimits { sizeLimitForState, dataSize } = byteLimitsPeerSharing (fromIntegral . BL.length) diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Test.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Test.hs index e52f910babf..7e8e2113ef6 100644 --- a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Test.hs +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Test.hs @@ -32,7 +32,6 @@ import Control.Monad.ST (runST) import Control.Tracer (Tracer (..), nullTracer) import Codec.Serialise (DeserialiseFailure, Serialise) -import qualified Codec.Serialise as Serialise (decode, encode) import Network.TypedProtocol.Codec hiding (prop_codec) import Network.TypedProtocol.Proofs @@ -51,6 +50,7 @@ import Ouroboros.Network.Protocol.TxSubmission2.Type import Test.Ouroboros.Network.Testing.Utils (prop_codec_cborM, prop_codec_valid_cbor_encoding, splits2, splits3) +import Ouroboros.Network.Protocol.CBOR (serialiseCodec) import Test.QuickCheck as QC import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -304,9 +304,7 @@ codec_v2 :: MonadST m => Codec (TxSubmission2 TxId Tx) DeserialiseFailure m ByteString -codec_v2 = codecTxSubmission2 - Serialise.encode Serialise.decode - Serialise.encode Serialise.decode +codec_v2 = codecTxSubmission2 serialiseCodec serialiseCodec -- | Check the codec round trip property. diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index 39c37f27cec..713f38069d8 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -6,6 +6,10 @@ - Fix interop problems between NonP2P and P2P nodes (PR #4465) +### Breaking + +- Add CBORCodec Tuple and refactor code to use it + ## 0.4.0.1 -- 2023-02-24 ### Non-Breaking diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index 4012770dc9b..de6966ef3b8 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -70,6 +70,7 @@ import qualified Ouroboros.Network.Protocol.BlockFetch.Type as BlockFetch import Ouroboros.Network.BlockFetch import Ouroboros.Network.BlockFetch.Client +import Ouroboros.Network.Protocol.CBOR (serialiseCodec) main :: IO () @@ -229,9 +230,9 @@ codecChainSync :: ( CBOR.Serialise block IO LBS.ByteString codecChainSync = ChainSync.codecChainSync - CBOR.encode CBOR.decode - CBOR.encode CBOR.decode - CBOR.encode CBOR.decode + serialiseCodec + serialiseCodec + serialiseCodec -- @@ -476,8 +477,8 @@ codecBlockFetch :: Codec (BlockFetch.BlockFetch Block (Point Block)) IO LBS.ByteString codecBlockFetch = BlockFetch.codecBlockFetch - CBOR.encode CBOR.decode - CBOR.encode CBOR.decode + serialiseCodec + serialiseCodec -- diff --git a/ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs index 001f6f02d3b..f3266d57ba4 100644 --- a/ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs +++ b/ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs @@ -56,6 +56,7 @@ import Ouroboros.Network.Protocol.BlockFetch.Type import Ouroboros.Network.Util.ShowProxy import Ouroboros.Network.Mock.ConcreteBlock +import Ouroboros.Network.Protocol.CBOR (serialiseCodec) -- | Run a single block fetch protocol until the chain is downloaded. @@ -336,7 +337,7 @@ runFetchClient tracer version isPipeliningEnabled registry peerid channel client runPipelinedPeerWithLimits tracer codec (byteLimitsBlockFetch (fromIntegral . LBS.length)) timeLimitsBlockFetch channel (client clientCtx) where - codec = codecBlockFetch encode decode encode decode + codec = codecBlockFetch serialiseCodec serialiseCodec runFetchServer :: (MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m), MonadST m, MonadTime m, MonadTimer m, @@ -352,7 +353,7 @@ runFetchServer tracer channel server = runPeerWithLimits tracer codec (byteLimitsBlockFetch (fromIntegral . LBS.length)) timeLimitsBlockFetch channel (blockFetchServerPeer server) where - codec = codecBlockFetch encode decode encode decode + codec = codecBlockFetch serialiseCodec serialiseCodec runFetchClientAndServerAsync :: forall peerid block header version m a b. diff --git a/ouroboros-network/test/Test/Mux.hs b/ouroboros-network/test/Test/Mux.hs index 2c6d4577adf..2934838b3c8 100644 --- a/ouroboros-network/test/Test/Mux.hs +++ b/ouroboros-network/test/Test/Mux.hs @@ -47,6 +47,8 @@ import qualified Network.Mux.Bearer as Mx import qualified Network.Mux.Bearer.Queues as Mx import qualified Network.Mux.Compat as Mx (muxStart) import Ouroboros.Network.Mux as Mx +import Ouroboros.Network.Protocol.CBOR (CBORCodec' (..), + serialiseCodec) tests :: TestTree @@ -117,9 +119,9 @@ demo chain0 updates delay = do MuxPeer nullTracer (ChainSync.codecChainSync - encode decode - encode decode - (encodeTip encode) (decodeTip decode)) + serialiseCodec + serialiseCodec + (CBORCodec (encodeTip encode) (decodeTip decode))) consumerPeer consumerPeer :: Peer (ChainSync.ChainSync block (Point block) (Tip block)) @@ -135,9 +137,9 @@ demo chain0 updates delay = do MuxPeer nullTracer (ChainSync.codecChainSync - encode decode - encode decode - (encodeTip encode) (decodeTip decode)) + serialiseCodec + serialiseCodec + (CBORCodec (encodeTip encode) (decodeTip decode))) producerPeer producerPeer :: Peer (ChainSync.ChainSync block (Point block) (Tip block)) diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs index 6cc9582504c..ff8345be39b 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -92,6 +92,8 @@ import Ouroboros.Network.NodeToNode (blockFetchMiniProtocolNum, import qualified Ouroboros.Network.PeerSelection.PeerSharing as PSTypes import Ouroboros.Network.PeerSharing (bracketPeerSharingClient, peerSharingClient, peerSharingServer) +import Ouroboros.Network.Protocol.CBOR (CBORCodec' (..), + serialiseCodec) import Ouroboros.Network.Protocol.PeerSharing.Client (peerSharingClientPeer) import Ouroboros.Network.Protocol.PeerSharing.Codec (codecPeerSharing) @@ -119,15 +121,14 @@ data Codecs addr block m = Codecs cborCodecs :: MonadST m => Codecs NtNAddr Block m cborCodecs = Codecs - { chainSyncCodec = codecChainSync Serialise.encode Serialise.decode - Serialise.encode Serialise.decode - (Block.encodeTip Serialise.encode) - (Block.decodeTip Serialise.decode) - , blockFetchCodec = codecBlockFetch Serialise.encode Serialise.decode - Serialise.encode Serialise.decode + { chainSyncCodec = codecChainSync serialiseCodec + serialiseCodec + (CBORCodec (Block.encodeTip Serialise.encode) + (Block.decodeTip Serialise.decode)) + , blockFetchCodec = codecBlockFetch serialiseCodec serialiseCodec , keepAliveCodec = codecKeepAlive_v2 , pingPongCodec = codecPingPong - , peerSharingCodec = codecPeerSharing encodeNtNAddr decodeNtNAddr + , peerSharingCodec = codecPeerSharing ntnAddrCodec } diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs index 63d0e209837..b64fa08549c 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs @@ -9,8 +9,7 @@ module Test.Ouroboros.Network.Diffusion.Node.NodeKernel ( -- * Common types NtNAddr , NtNAddr_ (..) - , encodeNtNAddr - , decodeNtNAddr + , ntnAddrCodec , NtNVersion , NtNVersionData (..) , NtCAddr @@ -79,6 +78,7 @@ import Ouroboros.Network.NodeToNode () import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) import Ouroboros.Network.PeerSharing (PeerSharingRegistry (..), newPeerSharingRegistry) +import Ouroboros.Network.Protocol.CBOR (CBORCodec, CBORCodec' (..)) import Test.QuickCheck (Arbitrary (..), choose, chooseInt, frequency, oneof) @@ -153,6 +153,9 @@ decodeNtNAddr = do 2 -> TestAddress <$> (IPAddr <$> decodeIP <*> decodePortNumber) _ -> fail ("decodeNtNAddr: unknown tok:" ++ show tok) +ntnAddrCodec :: CBORCodec NtNAddr +ntnAddrCodec = CBORCodec encodeNtNAddr decodeNtNAddr + encodeIP :: IP -> CBOR.Encoding encodeIP (IPv4 ip) = CBOR.encodeListLen 2 <> CBOR.encodeWord 0 diff --git a/ouroboros-network/test/Test/Ouroboros/Network/TxSubmission.hs b/ouroboros-network/test/Test/Ouroboros/Network/TxSubmission.hs index de56d11be24..1c85629b044 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/TxSubmission.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/TxSubmission.hs @@ -59,6 +59,7 @@ import Ouroboros.Network.Util.ShowProxy import Ouroboros.Network.Testing.Utils +import Ouroboros.Network.Protocol.CBOR (CBORCodec' (..)) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -171,8 +172,8 @@ txSubmissionCodec2 :: MonadST m => Codec (TxSubmission2 Int (Tx Int)) CBOR.DeserialiseFailure m ByteString txSubmissionCodec2 = - codecTxSubmission2 CBOR.encodeInt CBOR.decodeInt - encodeTx decodeTx + codecTxSubmission2 (CBORCodec CBOR.encodeInt CBOR.decodeInt) + (CBORCodec encodeTx decodeTx) where encodeTx Tx {getTxId, getTxSize, getTxValid} = CBOR.encodeListLen 3 diff --git a/ouroboros-network/test/Test/Pipe.hs b/ouroboros-network/test/Test/Pipe.hs index b08aafb1b76..73e680b4e72 100644 --- a/ouroboros-network/test/Test/Pipe.hs +++ b/ouroboros-network/test/Test/Pipe.hs @@ -48,6 +48,8 @@ import Ouroboros.Network.ControlMessage (continueForever) import Ouroboros.Network.Mock.Chain (Chain, ChainUpdate, Point) import qualified Ouroboros.Network.Mock.Chain as Chain import qualified Ouroboros.Network.Mock.ProducerState as CPS +import Ouroboros.Network.Protocol.CBOR (CBORCodec' (..), + serialiseCodec) import Ouroboros.Network.Protocol.ChainSync.Client as ChainSync import Ouroboros.Network.Protocol.ChainSync.Codec as ChainSync import Ouroboros.Network.Protocol.ChainSync.Examples as ChainSync @@ -166,9 +168,9 @@ demo chain0 updates = do chainSyncInitator = InitiatorProtocolOnly $ MuxPeer nullTracer - (ChainSync.codecChainSync encode decode - encode decode - (encodeTip encode) (decodeTip decode)) + (ChainSync.codecChainSync serialiseCodec + serialiseCodec + (CBORCodec (encodeTip encode) (decodeTip decode))) (ChainSync.chainSyncClientPeer (ChainSync.chainSyncClientExample consumerVar (consumerClient done target consumerVar))) @@ -182,9 +184,9 @@ demo chain0 updates = do chainSyncResponder = ResponderProtocolOnly $ MuxPeer nullTracer - (ChainSync.codecChainSync encode decode - encode decode - (encodeTip encode) (decodeTip decode)) + (ChainSync.codecChainSync serialiseCodec + serialiseCodec + (CBORCodec (encodeTip encode) (decodeTip decode))) (ChainSync.chainSyncServerPeer server) clientBearer <- Mx.getBearer Mx.makePipeChannelBearer (-1) activeTracer chan1 diff --git a/ouroboros-network/test/Test/Socket.hs b/ouroboros-network/test/Test/Socket.hs index 3943330af6a..0379ce341d3 100644 --- a/ouroboros-network/test/Test/Socket.hs +++ b/ouroboros-network/test/Test/Socket.hs @@ -50,6 +50,8 @@ import Ouroboros.Network.Util.ShowProxy import Test.ChainGenerators (TestBlockChainAndUpdates (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.Protocol.CBOR (CBORCodec' (..), + serialiseCodec) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -148,9 +150,9 @@ demo chain0 updates = withIOManager $ \iocp -> do codecChainSync (ChainSync.chainSyncServerPeer server) - codecChainSync = ChainSync.codecChainSync encode decode - encode decode - (encodeTip encode) (decodeTip decode) + codecChainSync = ChainSync.codecChainSync serialiseCodec + serialiseCodec + (CBORCodec (encodeTip encode) (decodeTip decode)) withServerNode (socketSnocket iocp)