diff --git a/ouroboros-consensus-test/src/Test/ThreadNet/Network.hs b/ouroboros-consensus-test/src/Test/ThreadNet/Network.hs index 319d45aac1a..b0e10df1be6 100644 --- a/ouroboros-consensus-test/src/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-test/src/Test/ThreadNet/Network.hs @@ -69,6 +69,7 @@ import Ouroboros.Network.NodeToNode (MiniProtocolParameters (..)) import Ouroboros.Network.Protocol.KeepAlive.Type import Ouroboros.Network.Protocol.Limits (waitForever) import Ouroboros.Network.Protocol.TxSubmission.Type +import Ouroboros.Network.Protocol.TxSubmission2.Type import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime @@ -1057,6 +1058,7 @@ runThreadNetwork systemTime ThreadNetworkArgs Lazy.ByteString Lazy.ByteString (AnyMessage (TxSubmission (GenTxId blk) (GenTx blk))) + (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))) (AnyMessage KeepAlive) customNodeToNodeCodecs cfg = NTN.Codecs { cChainSyncCodec = @@ -1074,6 +1076,9 @@ runThreadNetwork systemTime ThreadNetworkArgs , cTxSubmissionCodec = mapFailureCodec CodecIdFailure $ NTN.cTxSubmissionCodec NTN.identityCodecs + , cTxSubmission2Codec = + mapFailureCodec CodecIdFailure $ + NTN.cTxSubmission2Codec NTN.identityCodecs , cKeepAliveCodec = mapFailureCodec CodecIdFailure $ NTN.cKeepAliveCodec NTN.identityCodecs @@ -1605,7 +1610,8 @@ type LimitedApp' m peer blk = -- channel with the same type on both ends, i.e., 'Lazy.ByteString'. Lazy.ByteString Lazy.ByteString - (AnyMessage (TxSubmission (GenTxId blk) (GenTx blk))) + (AnyMessage (TxSubmission (GenTxId blk) (GenTx blk))) + (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))) (AnyMessage KeepAlive) () diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Network/NodeToNode.hs index bbe3e007ac2..3e465eeb5bb 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Network/NodeToNode.hs @@ -67,10 +67,13 @@ 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 qualified Ouroboros.Network.Protocol.Trans.Hello.Util as Hello import Ouroboros.Network.Protocol.TxSubmission.Client import Ouroboros.Network.Protocol.TxSubmission.Codec import Ouroboros.Network.Protocol.TxSubmission.Server import Ouroboros.Network.Protocol.TxSubmission.Type +import Ouroboros.Network.Protocol.TxSubmission2.Codec +import Ouroboros.Network.Protocol.TxSubmission2.Type import Ouroboros.Network.TxSubmission.Inbound import Ouroboros.Network.TxSubmission.Outbound @@ -207,21 +210,23 @@ mkHandlers -------------------------------------------------------------------------------} -- | Node-to-node protocol codecs needed to run 'Handlers'. -data Codecs blk e m bCS bSCS bBF bSBF bTX bKA = Codecs { +data Codecs blk e m bCS bSCS bBF bSBF bTX bTX2 bKA = 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 , cTxSubmissionCodec :: Codec (TxSubmission (GenTxId blk) (GenTx blk)) e m bTX + , cTxSubmission2Codec :: Codec (TxSubmission2 (GenTxId blk) (GenTx blk)) e m bTX2 , cKeepAliveCodec :: Codec KeepAlive e m bKA } -- | Protocol codecs for the node-to-node protocols -defaultCodecs :: forall m blk. (IOLike m, SerialiseNodeToNodeConstraints blk) +defaultCodecs :: forall m blk. (IOLike m, SerialiseNodeToNodeConstraints blk, + ShowProxy (GenTxId blk), ShowProxy (GenTx blk)) => CodecConfig blk -> BlockNodeToNodeVersion blk -> Codecs blk DeserialiseFailure m - ByteString ByteString ByteString ByteString ByteString ByteString + ByteString ByteString ByteString ByteString ByteString ByteString ByteString defaultCodecs ccfg version = Codecs { cChainSyncCodec = codecChainSync @@ -262,6 +267,13 @@ defaultCodecs ccfg version = Codecs { enc dec + , cTxSubmission2Codec = + codecTxSubmission2 + enc + dec + enc + dec + , cKeepAliveCodec = codecKeepAlive } @@ -283,6 +295,7 @@ identityCodecs :: Monad m (AnyMessage (BlockFetch blk (Point blk))) (AnyMessage (BlockFetch (Serialised blk) (Point blk))) (AnyMessage (TxSubmission (GenTxId blk) (GenTx blk))) + (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))) (AnyMessage KeepAlive) identityCodecs = Codecs { cChainSyncCodec = codecChainSyncId @@ -290,6 +303,7 @@ identityCodecs = Codecs { , cBlockFetchCodec = codecBlockFetchId , cBlockFetchCodecSerialised = codecBlockFetchId , cTxSubmissionCodec = codecTxSubmissionId + , cTxSubmission2Codec = codecTxSubmission2Id , cKeepAliveCodec = codecKeepAliveId } @@ -307,6 +321,7 @@ data Tracers' peer blk e f = Tracers { , tBlockFetchTracer :: f (TraceLabelPeer peer (TraceSendRecv (BlockFetch blk (Point blk)))) , tBlockFetchSerialisedTracer :: f (TraceLabelPeer peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk)))) , tTxSubmissionTracer :: f (TraceLabelPeer peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk)))) + , tTxSubmission2Tracer :: f (TraceLabelPeer peer (TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk)))) } instance (forall a. Semigroup (f a)) => Semigroup (Tracers' peer blk e f) where @@ -316,6 +331,7 @@ instance (forall a. Semigroup (f a)) => Semigroup (Tracers' peer blk e f) where , tBlockFetchTracer = f tBlockFetchTracer , tBlockFetchSerialisedTracer = f tBlockFetchSerialisedTracer , tTxSubmissionTracer = f tTxSubmissionTracer + , tTxSubmission2Tracer = f tTxSubmission2Tracer } where f :: forall a. Semigroup a @@ -331,6 +347,7 @@ nullTracers = Tracers { , tBlockFetchTracer = nullTracer , tBlockFetchSerialisedTracer = nullTracer , tTxSubmissionTracer = nullTracer + , tTxSubmission2Tracer = nullTracer } showTracers :: ( Show blk @@ -348,6 +365,7 @@ showTracers tr = Tracers { , tBlockFetchTracer = showTracing tr , tBlockFetchSerialisedTracer = showTracing tr , tTxSubmissionTracer = showTracing tr + , tTxSubmission2Tracer = showTracing tr } {------------------------------------------------------------------------------- @@ -371,38 +389,45 @@ type ServerApp m peer bytes a = -- | Applications for the node-to-node protocols -- -- See 'Network.Mux.Types.MuxApplication' -data Apps m peer bCS bBF bTX bKA a = Apps { +data Apps m peer bCS bBF bTX bTX2 bKA a = Apps { -- | Start a chain sync client that communicates with the given upstream -- node. - aChainSyncClient :: ClientApp m peer bCS a + aChainSyncClient :: ClientApp m peer bCS a -- | Start a chain sync server. - , aChainSyncServer :: ServerApp m peer bCS a + , aChainSyncServer :: ServerApp m peer bCS a -- | Start a block fetch client that communicates with the given -- upstream node. - , aBlockFetchClient :: ClientApp m peer bBF a + , aBlockFetchClient :: ClientApp m peer bBF a -- | Start a block fetch server. - , aBlockFetchServer :: ServerApp m peer bBF a + , aBlockFetchServer :: ServerApp m peer bBF a -- | Start a transaction submission client that communicates with the -- given upstream node. - , aTxSubmissionClient :: ClientApp m peer bTX a + , aTxSubmissionClient :: ClientApp m peer bTX a -- | Start a transaction submission server. - , aTxSubmissionServer :: ServerApp m peer bTX a + , aTxSubmissionServer :: ServerApp m peer bTX a + + -- | Start a transaction submission v2 client that communicates with the + -- given upstream node. + , aTxSubmission2Client :: ClientApp m peer bTX2 a + + -- | Start a transaction submission v2 server. + , aTxSubmission2Server :: ServerApp m peer bTX2 a -- | Start a keep-alive client. - , aKeepAliveClient :: ClientApp m peer bKA a + , aKeepAliveClient :: ClientApp m peer bKA a -- | Start a keep-alive server. - , aKeepAliveServer :: ServerApp m peer bKA a + , aKeepAliveServer :: ServerApp m peer bKA a } -- | Construct the 'NetworkApplication' for the node-to-node protocols mkApps - :: forall m remotePeer localPeer blk e bCS bBF bTX bKA. + :: forall m remotePeer localPeer blk e bCS bBF bTX bTX2 bKA. ( IOLike m , MonadTimer m , Ord remotePeer @@ -415,10 +440,10 @@ mkApps ) => NodeKernel m remotePeer localPeer blk -- ^ Needed for bracketing only -> Tracers m remotePeer blk e - -> Codecs blk e m bCS bCS bBF bBF bTX bKA + -> Codecs blk e m bCS bCS bBF bBF bTX bTX2 bKA -> m ChainSyncTimeout -> Handlers m remotePeer blk - -> Apps m remotePeer bCS bBF bTX bKA () + -> Apps m remotePeer bCS bBF bTX bTX2 bKA () mkApps kernel Tracers {..} Codecs {..} genChainSyncTimeout Handlers {..} = Apps {..} where @@ -537,6 +562,37 @@ mkApps kernel Tracers {..} Codecs {..} genChainSyncTimeout Handlers {..} = channel (txSubmissionServerPeerPipelined (hTxSubmissionServer version them)) + aTxSubmission2Client + :: NodeToNodeVersion + -> ControlMessageSTM m + -> remotePeer + -> Channel m bTX2 + -> m ((), Maybe bTX2) + aTxSubmission2Client version controlMessageSTM them channel = do + labelThisThread "TxSubmissionClient" + runPeerWithLimits + (contramap (TraceLabelPeer them) tTxSubmission2Tracer) + cTxSubmission2Codec + (byteLimitsTxSubmission2 (const 0)) -- TODO: Real Bytelimits, see #1727 + timeLimitsTxSubmission2 + channel + (Hello.wrapClientPeer (txSubmissionClientPeer (hTxSubmissionClient version controlMessageSTM them))) + + aTxSubmission2Server + :: NodeToNodeVersion + -> remotePeer + -> Channel m bTX2 + -> m ((), Maybe bTX2) + aTxSubmission2Server version them channel = do + labelThisThread "TxSubmissionServer" + runPipelinedPeerWithLimits + (contramap (TraceLabelPeer them) tTxSubmission2Tracer) + cTxSubmission2Codec + (byteLimitsTxSubmission2 (const 0)) -- TODO: Real Bytelimits, see #1727 + timeLimitsTxSubmission2 + channel + (Hello.wrapServerPeerPipelined (txSubmissionServerPeerPipelined (hTxSubmissionServer version them))) + aKeepAliveClient :: NodeToNodeVersion -> ControlMessageSTM m @@ -592,7 +648,7 @@ mkApps kernel Tracers {..} Codecs {..} genChainSyncTimeout Handlers {..} = initiator :: MiniProtocolParameters -> NodeToNodeVersion - -> Apps m (ConnectionId peer) b b b b a + -> Apps m (ConnectionId peer) b b b b b a -> OuroborosApplication 'InitiatorMode peer b m a Void initiator miniProtocolParameters version Apps {..} = nodeToNodeProtocols @@ -609,7 +665,9 @@ initiator miniProtocolParameters version Apps {..} = blockFetchProtocol = (InitiatorProtocolOnly (MuxPeerRaw (aBlockFetchClient version controlMessageSTM them))), txSubmissionProtocol = - (InitiatorProtocolOnly (MuxPeerRaw (aTxSubmissionClient version controlMessageSTM them))), + if version >= NodeToNodeV_6 + then InitiatorProtocolOnly (MuxPeerRaw (aTxSubmission2Client version controlMessageSTM them)) + else InitiatorProtocolOnly (MuxPeerRaw (aTxSubmissionClient version controlMessageSTM them)), keepAliveProtocol = (InitiatorProtocolOnly (MuxPeerRaw (aKeepAliveClient version controlMessageSTM them))) }) @@ -622,7 +680,7 @@ initiator miniProtocolParameters version Apps {..} = responder :: MiniProtocolParameters -> NodeToNodeVersion - -> Apps m (ConnectionId peer) b b b b a + -> Apps m (ConnectionId peer) b b b b b a -> OuroborosApplication 'ResponderMode peer b m Void a responder miniProtocolParameters version Apps {..} = nodeToNodeProtocols @@ -633,7 +691,9 @@ responder miniProtocolParameters version Apps {..} = blockFetchProtocol = (ResponderProtocolOnly (MuxPeerRaw (aBlockFetchServer version them))), txSubmissionProtocol = - (ResponderProtocolOnly (MuxPeerRaw (aTxSubmissionServer version them))), + if version >= NodeToNodeV_6 + then ResponderProtocolOnly (MuxPeerRaw (aTxSubmission2Server version them)) + else ResponderProtocolOnly (MuxPeerRaw (aTxSubmissionServer version them)), keepAliveProtocol = (ResponderProtocolOnly (MuxPeerRaw (aKeepAliveServer version them))) }) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs index 3ea5db88d2e..dc4ae514cfd 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs @@ -313,7 +313,7 @@ runWith RunNodeArgs{..} LowLevelRunNodeArgs{..} = :: NodeKernelArgs m (ConnectionId addrNTN) (ConnectionId addrNTC) blk -> NodeKernel m (ConnectionId addrNTN) (ConnectionId addrNTC) blk -> BlockNodeToNodeVersion blk - -> NTN.Apps m (ConnectionId addrNTN) ByteString ByteString ByteString ByteString () + -> NTN.Apps m (ConnectionId addrNTN) ByteString ByteString ByteString ByteString ByteString () mkNodeToNodeApps nodeKernelArgs nodeKernel version = NTN.mkApps nodeKernel @@ -336,7 +336,7 @@ runWith RunNodeArgs{..} LowLevelRunNodeArgs{..} = mkDiffusionApplications :: MiniProtocolParameters -> ( BlockNodeToNodeVersion blk - -> NTN.Apps m (ConnectionId addrNTN) ByteString ByteString ByteString ByteString () + -> NTN.Apps m (ConnectionId addrNTN) ByteString ByteString ByteString ByteString ByteString () ) -> ( BlockNodeToClientVersion blk -> NTC.Apps m (ConnectionId addrNTC) ByteString ByteString ByteString () diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 463e7687d0f..ea5e9d32905 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -94,6 +94,8 @@ library Ouroboros.Network.Protocol.TxSubmission.Client Ouroboros.Network.Protocol.TxSubmission.Server Ouroboros.Network.Protocol.TxSubmission.Codec + Ouroboros.Network.Protocol.TxSubmission2.Type + Ouroboros.Network.Protocol.TxSubmission2.Codec Ouroboros.Network.Protocol.LocalTxSubmission.Type Ouroboros.Network.Protocol.LocalTxSubmission.Client Ouroboros.Network.Protocol.LocalTxSubmission.Server @@ -102,6 +104,9 @@ library Ouroboros.Network.Protocol.KeepAlive.Client Ouroboros.Network.Protocol.KeepAlive.Server Ouroboros.Network.Protocol.KeepAlive.Codec + Ouroboros.Network.Protocol.Trans.Hello.Type + Ouroboros.Network.Protocol.Trans.Hello.Codec + Ouroboros.Network.Protocol.Trans.Hello.Util Ouroboros.Network.TxSubmission.Inbound Ouroboros.Network.TxSubmission.Mempool.Reader Ouroboros.Network.TxSubmission.Outbound @@ -206,6 +211,7 @@ library ouroboros-protocol-tests Ouroboros.Network.Protocol.TxSubmission.Direct Ouroboros.Network.Protocol.TxSubmission.Examples Ouroboros.Network.Protocol.TxSubmission.Test + Ouroboros.Network.Protocol.TxSubmission2.Test Ouroboros.Network.Protocol.KeepAlive.Direct Ouroboros.Network.Protocol.KeepAlive.Examples Ouroboros.Network.Protocol.KeepAlive.Test diff --git a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/TxSubmission/Test.hs b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/TxSubmission/Test.hs index f5b7ca741ad..9a24fc3e2ae 100644 --- a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/TxSubmission/Test.hs +++ b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/TxSubmission/Test.hs @@ -15,6 +15,11 @@ module Ouroboros.Network.Protocol.TxSubmission.Test ( tests ,TxId (..) ,Tx (..) + ,TxSubmissionTestParams (..) + ,testClient + ,testServer + ,codec + ,DistinctList (..) ) where import Data.List (nub) @@ -66,6 +71,7 @@ tests = , testProperty "connect 1" prop_connect1 , testProperty "connect 2" prop_connect2 , testProperty "codec" prop_codec + , testProperty "codec id" prop_codec_id , testProperty "codec 2-splits" prop_codec_splits2 , testProperty "codec 3-splits" $ withMaxSuccess 30 prop_codec_splits3 @@ -319,6 +325,12 @@ prop_codec :: AnyMessageAndAgency (TxSubmission TxId Tx) -> Bool prop_codec msg = runST (prop_codecM codec msg) +-- | Check the codec round trip property for the id condec. +-- +prop_codec_id :: AnyMessageAndAgency (TxSubmission TxId Tx) -> Bool +prop_codec_id msg = + runST (prop_codecM codecTxSubmissionId msg) + -- | Check for data chunk boundary problems in the codec using 2 chunks. -- prop_codec_splits2 :: AnyMessageAndAgency (TxSubmission TxId Tx) -> Bool diff --git a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/TxSubmission2/Test.hs b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/TxSubmission2/Test.hs new file mode 100644 index 00000000000..aa70e45b8d8 --- /dev/null +++ b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/TxSubmission2/Test.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +module Ouroboros.Network.Protocol.TxSubmission2.Test (tests) where + +import Data.ByteString.Lazy (ByteString) + +import Control.Monad.ST (runST) +import Control.Monad.IOSim +import Control.Tracer (nullTracer) +import Control.Monad.Class.MonadAsync (MonadAsync) +import Control.Monad.Class.MonadST (MonadST) +import Control.Monad.Class.MonadThrow (MonadCatch) + +import qualified Codec.Serialise as Serialise (encode, decode) + +import Network.TypedProtocol.Proofs + +import Ouroboros.Network.Channel +import Ouroboros.Network.Codec hiding (prop_codec) +import Ouroboros.Network.Driver.Simple + (runConnectedPeersPipelined) +import Ouroboros.Network.Protocol.Trans.Hello.Type (Hello) +import qualified Ouroboros.Network.Protocol.Trans.Hello.Type as Hello +import Ouroboros.Network.Protocol.TxSubmission.Client +import Ouroboros.Network.Protocol.TxSubmission.Server +import Ouroboros.Network.Protocol.TxSubmission.Test hiding (tests) +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.Protocol.TxSubmission2.Codec + +import Test.Ouroboros.Network.Testing.Utils (prop_codec_cborM, splits2, splits3) + +import Test.QuickCheck as QC +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + + +-- +-- Test cases +-- + + +tests :: TestTree +tests = + testGroup "Ouroboros.Network.Protocol.TxSubmission2" + [ testProperty "connect 1" prop_connect1 + , testProperty "connect 2" prop_connect2 + , testProperty "codec" prop_codec + , testProperty "codec id" prop_codec_id + , testProperty "codec 2-splits" prop_codec_splits2 + , testProperty "codec 3-splits" $ withMaxSuccess 30 + prop_codec_splits3 + , testProperty "codec cbor" prop_codec_cbor + , testProperty "encodings agree" prop_encodings_agree + , testProperty "channel ST" prop_channel_ST + , testProperty "channel IO" prop_channel_IO + , testProperty "pipe IO" prop_pipe_IO + ] + + +-- | Run a simple tx-submission client and server, going via the 'Peer' +-- representation, but without going via a channel. +-- +-- This test converts the pipelined server peer to a non-pipelined peer +-- before connecting it with the client. +-- +prop_connect1 :: TxSubmissionTestParams -> Bool +prop_connect1 params@TxSubmissionTestParams{testTransactions} = + case runSimOrThrow + (connect + (forgetPipelined $ + wrapServerPeerPipelined $ + txSubmissionServerPeerPipelined $ + testServer nullTracer params) + (wrapClientPeer $ + txSubmissionClientPeer $ + testClient nullTracer params)) of + + (txs', (), TerminalStates (Hello.TokDone TokDone) (Hello.TokDone TokDone)) -> + txs' == fromDistinctList testTransactions + + + +-- | Run a pipelined tx-submission client against a server, going via the +-- 'Peer' representation, but without going via a channel. +-- +-- This test uses the pipelined server, connected to the non-pipelined client. +-- +prop_connect2 :: TxSubmissionTestParams -> [Bool] -> Bool +prop_connect2 params@TxSubmissionTestParams{testTransactions} + choices = + case runSimOrThrow + (connectPipelined choices + (wrapServerPeerPipelined $ + txSubmissionServerPeerPipelined $ + testServer nullTracer params) + (wrapClientPeer $ + txSubmissionClientPeer $ + testClient nullTracer params)) of + + (txs', (), TerminalStates (Hello.TokDone TokDone) (Hello.TokDone TokDone)) -> + txs' == fromDistinctList testTransactions + +-- +-- Properties using a channel +-- + +-- | Run a simple tx-submission client and server using connected channels. +-- +prop_channel :: (MonadAsync m, MonadCatch m, MonadST m) + => m (Channel m ByteString, Channel m ByteString) + -> TxSubmissionTestParams + -> m Bool +prop_channel createChannels params@TxSubmissionTestParams{testTransactions} = + + (\(txs', ()) -> txs' == fromDistinctList testTransactions) <$> + + runConnectedPeersPipelined + createChannels + nullTracer + codec2 + (wrapServerPeerPipelined $ + txSubmissionServerPeerPipelined $ + testServer nullTracer params) + (wrapClientPeer $ + txSubmissionClientPeer $ + testClient nullTracer params) + + +-- | Run 'prop_channel' in the simulation monad. +-- +prop_channel_ST :: TxSubmissionTestParams + -> Bool +prop_channel_ST params = + runSimOrThrow + (prop_channel createConnectedChannels params) + + +-- | Run 'prop_channel' in the IO monad. +-- +prop_channel_IO :: TxSubmissionTestParams -> Property +prop_channel_IO params = + ioProperty (prop_channel createConnectedChannels params) + + +-- | Run 'prop_channel' in the IO monad using local pipes. +-- +prop_pipe_IO :: TxSubmissionTestParams -> Property +prop_pipe_IO params = + ioProperty (prop_channel createPipeConnectedChannels params) + + +instance Arbitrary (AnyMessageAndAgency ps) + => Arbitrary (AnyMessageAndAgency (Hello ps stIdle)) where + arbitrary = + frequency [ (5, f <$> arbitrary) + , (1, pure (AnyMessageAndAgency (ClientAgency Hello.TokHello) Hello.MsgHello)) + ] + where + f :: AnyMessageAndAgency ps -> AnyMessageAndAgency (Hello ps stIdle) + f (AnyMessageAndAgency (ClientAgency tok) msg) = + AnyMessageAndAgency + (ClientAgency (Hello.TokClientTalk tok)) + (Hello.MsgTalk msg) + f (AnyMessageAndAgency (ServerAgency tok) msg) = + AnyMessageAndAgency + (ServerAgency (Hello.TokServerTalk tok)) + (Hello.MsgTalk msg) + + + + +instance Eq (AnyMessageAndAgency ps) + => Eq (AnyMessageAndAgency (Hello ps stIdle)) where + (==) (AnyMessageAndAgency (ClientAgency Hello.TokHello) Hello.MsgHello) + (AnyMessageAndAgency (ClientAgency Hello.TokHello) Hello.MsgHello) + = True + (==) (AnyMessageAndAgency (ClientAgency (Hello.TokClientTalk tok)) (Hello.MsgTalk msg)) + (AnyMessageAndAgency (ClientAgency (Hello.TokClientTalk tok')) (Hello.MsgTalk msg')) + = AnyMessageAndAgency (ClientAgency tok) msg == AnyMessageAndAgency (ClientAgency tok') msg' + (==) (AnyMessageAndAgency (ServerAgency (Hello.TokServerTalk tok)) (Hello.MsgTalk msg)) + (AnyMessageAndAgency (ServerAgency (Hello.TokServerTalk tok')) (Hello.MsgTalk msg')) + = AnyMessageAndAgency (ServerAgency tok) msg == AnyMessageAndAgency (ServerAgency tok') msg' + (==) _ _ = False + + +instance Eq (AnyMessage ps) + => Eq (AnyMessage (Hello ps stIdle)) where + (==) (AnyMessage Hello.MsgHello) + (AnyMessage Hello.MsgHello) = + True + (==) (AnyMessage (Hello.MsgTalk msg)) + (AnyMessage (Hello.MsgTalk msg')) = + AnyMessage msg == AnyMessage msg' + (==) _ _ = False + + + +codec2 :: MonadST m + => Codec (TxSubmission2 TxId Tx) + DeserialiseFailure + m ByteString +codec2 = codecTxSubmission2 + Serialise.encode Serialise.decode + Serialise.encode Serialise.decode + + +-- | Check the codec round trip property. +-- +prop_codec :: AnyMessageAndAgency (TxSubmission2 TxId Tx) -> Bool +prop_codec msg = + runST (prop_codecM codec2 msg) + +-- | Check the codec round trip property for the id condec. +-- +prop_codec_id :: AnyMessageAndAgency (TxSubmission2 TxId Tx) -> Bool +prop_codec_id msg = + runST (prop_codecM codecTxSubmission2Id msg) + +-- | Check for data chunk boundary problems in the codec using 2 chunks. +-- +prop_codec_splits2 :: AnyMessageAndAgency (TxSubmission2 TxId Tx) -> Bool +prop_codec_splits2 msg = + runST (prop_codec_splitsM splits2 codec2 msg) + +-- | Check for data chunk boundary problems in the codec using 3 chunks. +-- +prop_codec_splits3 :: AnyMessageAndAgency (TxSubmission2 TxId Tx) -> Bool +prop_codec_splits3 msg = + runST (prop_codec_splitsM splits3 codec2 msg) + +prop_codec_cbor + :: AnyMessageAndAgency (TxSubmission2 TxId Tx) + -> Bool +prop_codec_cbor msg = + runST (prop_codec_cborM codec2 msg) + +-- | 'codecTxSubmission' and 'codecTxSubmission2' agree on the encoding. This +-- and 'prop_codec' ensures the 'codecTxSubmission2' is backward compatible with +-- 'codecTxSubmission'. +-- +prop_encodings_agree :: AnyMessageAndAgency (TxSubmission TxId Tx) -> Bool +prop_encodings_agree (AnyMessageAndAgency stok@(ClientAgency tok) msg) = + encode (codec @IO) stok msg + == encode (codec2 @IO) + (ClientAgency (Hello.TokClientTalk tok)) + (Hello.MsgTalk msg) +prop_encodings_agree (AnyMessageAndAgency stok@(ServerAgency tok) msg) = + encode (codec @IO) stok msg + == encode (codec2 @IO) + (ServerAgency (Hello.TokServerTalk tok)) + (Hello.MsgTalk msg) diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode/Version.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode/Version.hs index e1f90f71575..8ea42076955 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode/Version.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode/Version.hs @@ -45,6 +45,10 @@ data NodeToNodeVersion -- ^ Changes: -- -- * Enable @CardanoNodeToNodeVersion4@, i.e., Mary + | NodeToNodeV_6 + -- ^ Changes: + -- + -- * Replace 'TxSubmision' with 'Txsubmission2' protocol. deriving (Eq, Ord, Enum, Bounded, Show, Typeable) nodeToNodeVersionCodec :: CodecCBORTerm (Text, Maybe Int) NodeToNodeVersion @@ -55,12 +59,14 @@ nodeToNodeVersionCodec = CodecCBORTerm { encodeTerm, decodeTerm } encodeTerm NodeToNodeV_3 = CBOR.TInt 3 encodeTerm NodeToNodeV_4 = CBOR.TInt 4 encodeTerm NodeToNodeV_5 = CBOR.TInt 5 + encodeTerm NodeToNodeV_6 = CBOR.TInt 6 decodeTerm (CBOR.TInt 1) = Right NodeToNodeV_1 decodeTerm (CBOR.TInt 2) = Right NodeToNodeV_2 decodeTerm (CBOR.TInt 3) = Right NodeToNodeV_3 decodeTerm (CBOR.TInt 4) = Right NodeToNodeV_4 decodeTerm (CBOR.TInt 5) = Right NodeToNodeV_5 + decodeTerm (CBOR.TInt 6) = Right NodeToNodeV_6 decodeTerm (CBOR.TInt n) = Left ( T.pack "decode NodeToNodeVersion: unknonw tag: " <> T.pack (show n) , Just n diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/Trans/Hello/Codec.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/Trans/Hello/Codec.hs new file mode 100644 index 00000000000..624e9ba1bc9 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/Trans/Hello/Codec.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuantifiedConstraints #-} +module Ouroboros.Network.Protocol.Trans.Hello.Codec + ( codecHello + , byteLimitsHello + , timeLimitsHello + , codecHelloId + ) where + + +import Control.Monad.Class.MonadST +import Control.Monad.Class.MonadTime + +import Ouroboros.Network.Codec +import Ouroboros.Network.Driver.Limits +import Ouroboros.Network.Protocol.Trans.Hello.Type +import Ouroboros.Network.Protocol.Limits +import Ouroboros.Network.Util.ShowProxy + +import qualified Data.ByteString.Lazy as LBS + +import Codec.CBOR.Decoding (decodeListLen, decodeWord) +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 Text.Printf + + +byteLimitsHello + :: forall ps (stIdle :: ps) bytes . + ProtocolSizeLimits ps bytes + -> ProtocolSizeLimits (Hello ps stIdle) bytes +byteLimitsHello ProtocolSizeLimits { sizeLimitForState, dataSize } + = ProtocolSizeLimits { + sizeLimitForState = sizeLimitForStateHello, + dataSize + } + where + sizeLimitForStateHello :: forall (pr :: PeerRole) (st :: Hello ps stIdle). + PeerHasAgency pr st -> Word + sizeLimitForStateHello (ClientAgency TokHello) = + smallByteLimit + sizeLimitForStateHello (ClientAgency (TokClientTalk tok)) = + sizeLimitForState (ClientAgency tok) + sizeLimitForStateHello (ServerAgency (TokServerTalk tok)) = + sizeLimitForState (ServerAgency tok) + + +timeLimitsHello + :: forall ps (stIdle :: ps). + ProtocolTimeLimits ps + -> ProtocolTimeLimits (Hello ps stIdle) +timeLimitsHello ProtocolTimeLimits { timeLimitForState } = + ProtocolTimeLimits { + timeLimitForState = timeLimitForStateHello + } + where + timeLimitForStateHello :: forall (pr :: PeerRole) (st :: Hello ps stIdle). + PeerHasAgency pr st -> Maybe DiffTime + timeLimitForStateHello (ClientAgency TokHello) = waitForever + timeLimitForStateHello (ClientAgency (TokClientTalk tok)) = + timeLimitForState (ClientAgency tok) + timeLimitForStateHello (ServerAgency (TokServerTalk tok)) = + timeLimitForState (ServerAgency tok) + + +-- | 'codecHello' provides a flat encoding of the original codec and 'MsgHello'. +-- 'MsgTalk' is invisible. It assumes that the top level encoding of @ps@ +-- protocol is a list of at least one element (the tag of a message). +-- +codecHello + :: forall ps (stIdle :: ps) m. + ( MonadST m + , ShowProxy ps + , ShowProxy stIdle + , forall (st :: ps). Show (ClientHasAgency st) + , forall (st :: ps). Show (ServerHasAgency st) + ) + => Word + -- ^ tag for 'MsgHello' + -> (forall (pr :: PeerRole) (st :: ps) (st' :: ps). + PeerHasAgency pr st + -> Message ps st st' -> CBOR.Encoding) + -> (forall (pr :: PeerRole) (st :: ps) s. + PeerHasAgency pr st + -> Int + -> Word + -> CBOR.Decoder s (SomeMessage st)) + -- ^ continuation which receives agency, tag, and length. Last two are + -- decoded values. + -> Codec (Hello ps stIdle) CBOR.DeserialiseFailure m LBS.ByteString +codecHello helloTag encode decode = mkCodecCborLazyBS encodeHello decodeHello + where + encodeHello :: forall (pr :: PeerRole) + (st :: Hello ps stIdle) + (st' :: Hello ps stIdle). + PeerHasAgency pr st + -> Message (Hello ps stIdle) st st' + -> CBOR.Encoding + encodeHello (ClientAgency TokHello) MsgHello = + encodeListLen 1 <> encodeWord helloTag + encodeHello (ClientAgency (TokClientTalk tok)) (MsgTalk msg) = + encode (ClientAgency tok) msg + encodeHello (ServerAgency (TokServerTalk tok)) (MsgTalk msg) = + encode (ServerAgency tok) msg + + decodeHello :: forall (pr :: PeerRole) (st :: Hello ps stIdle) s. + PeerHasAgency pr st + -> CBOR.Decoder s (SomeMessage st) + decodeHello stok = do + len <- decodeListLen + key <- decodeWord + case (key, len, stok) of + -- 'MsgHello' + (tag, 1, ClientAgency TokHello) | tag == helloTag -> + return (SomeMessage MsgHello) + + -- inlined client messages + (_, _, ClientAgency (TokClientTalk tok)) -> do + SomeMessage msg <- decode (ClientAgency tok) len key + return (SomeMessage (MsgTalk msg)) + + -- inlined server messages + (_, _, ServerAgency (TokServerTalk tok)) -> do + SomeMessage msg <- decode (ServerAgency tok) len key + return (SomeMessage (MsgTalk msg)) + + -- + -- failure per protocol state + -- + (_, _, _) -> + fail (printf "codec (%s) at (%s) unexpected key (%d, %d)" + (showProxy (Proxy :: Proxy (Hello ps stIdle))) + (show stok) + key len) + +codecHelloId + :: forall ps (stIdle :: ps) m. + ( Monad m + , forall (st :: ps). Show (ClientHasAgency st) + , forall (st :: ps). Show (ServerHasAgency st) + ) + => Codec ps CodecFailure m (AnyMessage ps) + -> Codec (Hello ps stIdle) CodecFailure m (AnyMessage (Hello ps stIdle)) +codecHelloId Codec { decode } = + Codec { encode = encodeHello, decode = decodeHello } + where + encodeHello :: forall (pr :: PeerRole) + (st :: Hello ps stIdle) + (st' :: Hello ps stIdle). + PeerHasAgency pr st + -> Message (Hello ps stIdle) st st' + -> AnyMessage (Hello ps stIdle) + encodeHello _ = AnyMessage + + + decodeHello :: forall (pr :: PeerRole) + (st :: Hello ps stIdle). + PeerHasAgency pr st + -> m (DecodeStep (AnyMessage (Hello ps stIdle)) + CodecFailure m (SomeMessage st)) + decodeHello stok = return $ DecodePartial $ \bytes -> case (stok, bytes) of + (ClientAgency TokHello, Just (AnyMessage msg@MsgHello)) -> + return $ DecodeDone (SomeMessage msg) Nothing + + (ClientAgency (TokClientTalk tok), Just (AnyMessage (MsgTalk msg))) -> do + decoder <- decode (ClientAgency tok) + res <- runDecoder [AnyMessage msg] decoder + return $ + case res of + Left failure -> DecodeFail failure + Right (SomeMessage msg') -> DecodeDone (SomeMessage (MsgTalk msg')) Nothing + + (ServerAgency (TokServerTalk tok), Just (AnyMessage (MsgTalk msg))) -> do + decoder <- decode (ServerAgency tok) + res <- runDecoder [AnyMessage msg] decoder + return $ + case res of + Left failure -> DecodeFail failure + Right (SomeMessage msg') -> DecodeDone (SomeMessage (MsgTalk msg')) Nothing + + (ClientAgency tok, _) -> return (DecodeFail (CodecFailure ("codecTxSubmissionId2: no matching message at " ++ show tok))) + (ServerAgency tok, _) -> return (DecodeFail (CodecFailure ("codecTxSubmissionId2: no matching message at " ++ show tok))) diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/Trans/Hello/Type.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/Trans/Hello/Type.hs new file mode 100644 index 00000000000..e355c0b0233 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/Trans/Hello/Type.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Ouroboros.Network.Protocol.Trans.Hello.Type where + +import Data.Void (Void) + +import Network.TypedProtocol.Core +import Ouroboros.Network.Util.ShowProxy + + +-- | The 'Hello' protocol transformer reverses the initial agency of the protocol, +-- from one in which the server has the initial agency to one in which the client +-- has the initial agency. +-- +-- It extends the underlying protocol with an initial extra 'MsgHello' message, +-- which reverses the agency between the two peers. +-- +data Hello ps (stIdle :: ps) where + -- | 'StHello' state is the initial state of the 'Hello' protocol. + -- + StHello :: Hello ps stIdle + + -- | 'StTalk' embeds states of the inner protocol. + -- + StTalk :: ps -> Hello ps stIdle + +instance ( ShowProxy ps + , ShowProxy stIdle + ) + => ShowProxy (Hello ps (stIdle :: ps)) where + showProxy _ = "Hello " + ++ showProxy (Proxy :: Proxy ps) + ++ " " + ++ showProxy (Proxy :: Proxy stIdle) + + + +instance Protocol ps => Protocol (Hello ps stIdle) where + data Message (Hello ps stIdle) from to where + -- | Client side hello message. + -- + MsgHello :: Message (Hello ps stIdle) StHello (StTalk stIdle) + + -- | After initial hello message one proceeds with the wrapped protocol + -- 'ps'. + -- + MsgTalk :: Message ps stInner stInner' + -> Message (Hello ps stIdle) (StTalk stInner) (StTalk stInner') + + + -- | Either intial 'StHello' state or 'ps' protocol states, which have client + -- agency. This is embedding of the 'ps' client states into client states + -- of the wrapper. + -- + data ClientHasAgency (st :: Hello ps stIdle) where + TokHello :: ClientHasAgency StHello + + TokClientTalk :: ClientHasAgency stInner + -> ClientHasAgency (StTalk stInner) + + + -- | States with server side agency are only the wrapped protocol states + -- with server agency. + -- + data ServerHasAgency (st :: Hello ps stIdle) where + TokServerTalk :: ServerHasAgency stInner + -> ServerHasAgency (StTalk stInner) + + + -- | Terminating states are only the terminating states of the wrapped + -- protocol. + -- + data NobodyHasAgency (st :: Hello ps stIdle) where + TokDone :: NobodyHasAgency stInner + -> NobodyHasAgency (StTalk stInner) + + + exclusionLemma_ClientAndServerHaveAgency + :: forall (st :: Hello ps stIdle). + ClientHasAgency st + -> ServerHasAgency st + -> Void + exclusionLemma_ClientAndServerHaveAgency TokHello tok = case tok of {} + exclusionLemma_ClientAndServerHaveAgency (TokClientTalk tokClient) + (TokServerTalk tokServer) = + exclusionLemma_ClientAndServerHaveAgency tokClient tokServer + + + exclusionLemma_NobodyAndClientHaveAgency + :: forall (st :: Hello ps stIdle). + NobodyHasAgency st + -> ClientHasAgency st + -> Void + exclusionLemma_NobodyAndClientHaveAgency (TokDone tokDone) + (TokClientTalk tokClient) = + exclusionLemma_NobodyAndClientHaveAgency tokDone tokClient + + + exclusionLemma_NobodyAndServerHaveAgency + :: forall (st :: Hello ps stIdle). + NobodyHasAgency st + -> ServerHasAgency st + -> Void + exclusionLemma_NobodyAndServerHaveAgency (TokDone tokDone) + (TokServerTalk tokServer) = + exclusionLemma_NobodyAndServerHaveAgency tokDone tokServer + + +instance (forall (from' :: ps) (to' :: ps). Show (Message ps from' to')) + => Show (Message (Hello ps stIdle) from to) where + show MsgHello = "MsgHello" + show (MsgTalk msg) = "MsgTalk " ++ show msg + +instance (forall (st' :: ps). Show (ClientHasAgency st')) + => Show (ClientHasAgency (st :: Hello ps (stIdle :: ps))) where + show TokHello= "TokHello" + show (TokClientTalk tok) = "TokClientTalk " ++ show tok + +instance (forall (st' :: ps). Show (ServerHasAgency st')) + => Show (ServerHasAgency (st :: Hello ps stIdle)) where + show (TokServerTalk tok) = "TokServerTalk " ++ show tok diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/Trans/Hello/Util.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/Trans/Hello/Util.hs new file mode 100644 index 00000000000..2097b84fb4a --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/Trans/Hello/Util.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Utility module which provides wrappers which map a 'Peer' or 'PiplinedPeer' +-- of an original protocol 'ps' into 'Peer' \/ 'PiplinedPeer' of +-- @'Hello' ps stIdle@ protocol. +-- +-- The module should be imported qualified. +-- +module Ouroboros.Network.Protocol.Trans.Hello.Util + ( -- * Wrap 'Peer' in 'Hello' protocol + wrapClientPeer + , wrapServerPeer + + -- * Wrap 'PipelinedPeer' in 'Hello' protcol. + , wrapClientPeerPipelined + , wrapServerPeerPipelined + ) where + +import Network.TypedProtocol.Core +import Network.TypedProtocol.Pipelined +import Ouroboros.Network.Protocol.Trans.Hello.Type + + +-- +-- 'Peer' +-- + + +wrapClientPeer + :: forall ps (stIdle :: ps) m a. + Functor m + => Peer ps AsClient stIdle m a + -> Peer (Hello ps stIdle) AsClient StHello m a +wrapClientPeer peer = Yield (ClientAgency TokHello) MsgHello (wrapPeer peer) + +wrapServerPeer + :: forall ps (stIdle :: ps) m a. + Functor m + => Peer ps AsServer stIdle m a + -> Peer (Hello ps stIdle) AsServer (StTalk stIdle) m a +wrapServerPeer = wrapPeer + + +wrapPeer + :: forall ps (stIdle :: ps) (st :: ps) (pr :: PeerRole) m a. + Functor m + => Peer ps pr st m a + -> Peer (Hello ps stIdle) pr (StTalk st) m a +wrapPeer (Effect mnext) = Effect (wrapPeer <$> mnext) + +wrapPeer (Yield (ClientAgency tok) msg next) = + Yield (ClientAgency (TokClientTalk tok)) (MsgTalk msg) (wrapPeer next) + +wrapPeer (Yield (ServerAgency tok) msg next) = + Yield (ServerAgency (TokServerTalk tok)) (MsgTalk msg) (wrapPeer next) + +wrapPeer (Await (ClientAgency tok) k) = + Await (ClientAgency (TokClientTalk tok)) $ \(MsgTalk msg) -> + wrapPeer (k msg) + +wrapPeer (Await (ServerAgency tok) k) = + Await (ServerAgency (TokServerTalk tok)) $ \(MsgTalk msg) -> + wrapPeer (k msg) + +wrapPeer (Done tok a) = Done (TokDone tok) a + + +-- +-- 'PipelinedPeer' +-- + + +wrapClientPeerPipelined + :: forall ps (stIdle :: ps) m a. + Functor m + => PeerPipelined ps AsClient stIdle m a + -> PeerPipelined (Hello ps stIdle) AsClient StHello m a +wrapClientPeerPipelined (PeerPipelined peer) = + PeerPipelined (SenderYield (ClientAgency TokHello) MsgHello (wrapPeerSender peer)) + + +wrapServerPeerPipelined + :: forall ps (stIdle :: ps) m a. + Functor m + => PeerPipelined ps AsServer stIdle m a + -> PeerPipelined (Hello ps stIdle) AsServer StHello m a +wrapServerPeerPipelined = fmapPeerPipelined f + where + -- We must use 'fmapPeerPipelined'; directly matching on the constructor + -- confuses GHC with the existentially quantified 'c' under + -- 'PeerPipelined'. + f :: PeerSender ps AsServer stIdle Z c m a + -> PeerSender (Hello ps stIdle) AsServer StHello Z c m a + f peer = + SenderAwait (ClientAgency TokHello) $ \msg -> + case msg of + MsgHello -> wrapPeerSender peer + + +wrapPeerSender + :: forall ps (pr :: PeerRole) (stIdle :: ps) (st :: ps) (n :: Outstanding) c m a. + Functor m + => PeerSender ps pr st n c m a + -> PeerSender (Hello ps stIdle) pr (StTalk st) n c m a +wrapPeerSender (SenderEffect mnext) = SenderEffect (wrapPeerSender <$> mnext) + +wrapPeerSender (SenderDone tok a) = SenderDone (TokDone tok) a + +wrapPeerSender (SenderYield (ClientAgency tok) msg next) = + SenderYield (ClientAgency (TokClientTalk tok)) (MsgTalk msg) (wrapPeerSender next) + +wrapPeerSender (SenderYield (ServerAgency tok) msg next) = + SenderYield (ServerAgency (TokServerTalk tok)) (MsgTalk msg) (wrapPeerSender next) + +wrapPeerSender (SenderAwait (ClientAgency tok) k) = + SenderAwait (ClientAgency (TokClientTalk tok)) $ \(MsgTalk msg) -> + wrapPeerSender (k msg) + +wrapPeerSender (SenderAwait (ServerAgency tok) k) = + SenderAwait (ServerAgency (TokServerTalk tok)) $ \(MsgTalk msg) -> + wrapPeerSender (k msg) + +wrapPeerSender (SenderPipeline (ClientAgency tok) msg recv send) = + SenderPipeline (ClientAgency (TokClientTalk tok)) + (MsgTalk msg) + (wrapPeerReceiver recv) + (wrapPeerSender send) + +wrapPeerSender (SenderPipeline (ServerAgency tok) msg recv send) = + SenderPipeline (ServerAgency (TokServerTalk tok)) + (MsgTalk msg) + (wrapPeerReceiver recv) + (wrapPeerSender send) + +wrapPeerSender (SenderCollect pipelineMore collect) = + SenderCollect (wrapPeerSender <$> pipelineMore) + (wrapPeerSender . collect) + + +wrapPeerReceiver + :: forall ps (pr :: PeerRole) (stIdle :: ps) (st :: ps) (stdone :: ps) m c. + Functor m + => PeerReceiver ps pr st stdone m c + -> PeerReceiver (Hello ps stIdle) pr (StTalk st) (StTalk stdone) m c + +wrapPeerReceiver (ReceiverEffect m) = + ReceiverEffect (wrapPeerReceiver <$> m) + +wrapPeerReceiver (ReceiverDone c) = ReceiverDone c + +wrapPeerReceiver (ReceiverAwait (ClientAgency tok) k) = + ReceiverAwait (ClientAgency (TokClientTalk tok)) $ + \(MsgTalk msg) -> wrapPeerReceiver (k msg) + +wrapPeerReceiver (ReceiverAwait (ServerAgency tok) k) = + ReceiverAwait (ServerAgency (TokServerTalk tok)) $ + \(MsgTalk msg) -> wrapPeerReceiver (k msg) diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/TxSubmission/Codec.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/TxSubmission/Codec.hs index 24c19ea0ca7..03167bbd103 100644 --- a/ouroboros-network/src/Ouroboros/Network/Protocol/TxSubmission/Codec.hs +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/TxSubmission/Codec.hs @@ -12,6 +12,8 @@ module Ouroboros.Network.Protocol.TxSubmission.Codec ( codecTxSubmission , codecTxSubmissionId + , encodeTxSubmission + , decodeTxSubmission , byteLimitsTxSubmission , timeLimitsTxSubmission @@ -73,7 +75,27 @@ codecTxSubmission -> Codec (TxSubmission txid tx) CBOR.DeserialiseFailure m ByteString codecTxSubmission encodeTxId decodeTxId encodeTx decodeTx = - mkCodecCborLazyBS encode decode + mkCodecCborLazyBS + (encodeTxSubmission encodeTxId encodeTx) + decode + where + decode :: forall (pr :: PeerRole) (st :: TxSubmission txid tx). + PeerHasAgency pr st + -> forall s. CBOR.Decoder s (SomeMessage st) + decode stok = do + len <- CBOR.decodeListLen + key <- CBOR.decodeWord + decodeTxSubmission decodeTxId decodeTx stok len key + +encodeTxSubmission + :: forall txid tx. + (txid -> CBOR.Encoding) + -> (tx -> CBOR.Encoding) + -> (forall (pr :: PeerRole) (st :: TxSubmission txid tx) (st' :: TxSubmission txid tx). + PeerHasAgency pr st + -> Message (TxSubmission txid tx) st st' + -> CBOR.Encoding) +encodeTxSubmission encodeTxId encodeTx = encode where encode :: forall (pr :: PeerRole) st st'. PeerHasAgency pr st @@ -125,14 +147,24 @@ codecTxSubmission encodeTxId decodeTxId <> CBOR.encodeWord 4 +decodeTxSubmission + :: forall txid tx. + (forall s . CBOR.Decoder s txid) + -> (forall s . CBOR.Decoder s tx) + -> (forall (pr :: PeerRole) (st :: TxSubmission txid tx) s. + PeerHasAgency pr st + -> Int + -> Word + -> CBOR.Decoder s (SomeMessage st)) +decodeTxSubmission decodeTxId decodeTx = decode + where decode :: forall (pr :: PeerRole) s (st :: TxSubmission txid tx). PeerHasAgency pr st + -> Int + -> Word -> CBOR.Decoder s (SomeMessage st) - decode stok = do - len <- CBOR.decodeListLen - key <- CBOR.decodeWord + decode stok len key = do case (stok, len, key) of - (ServerAgency TokIdle, 4, 0) -> do blocking <- CBOR.decodeBool ackNo <- CBOR.decodeWord16 @@ -209,6 +241,7 @@ codecTxSubmissionId = Codec encode decode decode stok = return $ DecodePartial $ \bytes -> return $ case (stok, bytes) of (ServerAgency TokIdle, Just (AnyMessage msg@(MsgRequestTxIds {}))) -> DecodeDone (SomeMessage msg) Nothing (ServerAgency TokIdle, Just (AnyMessage msg@(MsgRequestTxs {}))) -> DecodeDone (SomeMessage msg) Nothing + (ServerAgency TokIdle, Just (AnyMessage msg@(MsgKThxBye {}))) -> DecodeDone (SomeMessage msg) Nothing (ClientAgency TokTxs, Just (AnyMessage msg@(MsgReplyTxs {}))) -> DecodeDone (SomeMessage msg) Nothing (ClientAgency (TokTxIds b), Just (AnyMessage msg)) -> case (b, msg) of (TokBlocking, MsgReplyTxIds (BlockingReply {})) -> DecodeDone (SomeMessage msg) Nothing diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/TxSubmission/Type.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/TxSubmission/Type.hs index 71d138bc48a..45148428c16 100644 --- a/ouroboros-network/src/Ouroboros/Network/Protocol/TxSubmission/Type.hs +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/TxSubmission/Type.hs @@ -76,6 +76,9 @@ instance ( ShowProxy txid , showProxy (Proxy :: Proxy tx) ] +instance ShowProxy (StIdle :: TxSubmission txid tx) where + showProxy _ = "StIdle" + data StBlockingStyle where diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/TxSubmission2/Codec.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/TxSubmission2/Codec.hs new file mode 100644 index 00000000000..a5b9d0b0574 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/TxSubmission2/Codec.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} + +module Ouroboros.Network.Protocol.TxSubmission2.Codec ( + codecTxSubmission2 + , codecTxSubmission2Id + , byteLimitsTxSubmission2 + , timeLimitsTxSubmission2 + ) where + +import Control.Monad.Class.MonadST + +import Data.ByteString.Lazy (ByteString) +import qualified Codec.CBOR.Encoding as CBOR +import qualified Codec.CBOR.Decoding as CBOR +import qualified Codec.CBOR.Read as CBOR + +import Ouroboros.Network.Codec +import Ouroboros.Network.Driver.Limits +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.Protocol.TxSubmission.Codec +import Ouroboros.Network.Protocol.Trans.Hello.Codec +import Ouroboros.Network.Util.ShowProxy + + +-- | Byte Limits. +-- +-- Preserves byte limits of the original 'TxSubmission' protocol, see +-- 'timeLimitsTxSubmission'. 'MsgHello' is using 'smallByteLimit' limit. +-- +byteLimitsTxSubmission2 :: forall bytes txid tx. + (bytes -> Word) + -> ProtocolSizeLimits (TxSubmission2 txid tx) bytes +byteLimitsTxSubmission2 = byteLimitsHello . byteLimitsTxSubmission + + +-- | Time limits. +-- +-- Preserves the timeouts of 'TxSubmission' protocol, see +-- 'timeLimitsTxSubmission'. 'MsgHello' does not have a timeout. +-- +timeLimitsTxSubmission2 :: forall txid tx. ProtocolTimeLimits (TxSubmission2 txid tx) +timeLimitsTxSubmission2 = timeLimitsHello timeLimitsTxSubmission + + +codecTxSubmission2 + :: forall txid tx m. + ( MonadST m + , ShowProxy txid + , ShowProxy tx + ) + => (txid -> CBOR.Encoding) + -> (forall s . CBOR.Decoder s txid) + -> (tx -> CBOR.Encoding) + -> (forall s . CBOR.Decoder s tx) + -> Codec (TxSubmission2 txid tx) CBOR.DeserialiseFailure m ByteString +codecTxSubmission2 encodeTxId decodeTxId + encodeTx decodeTx = + codecHello + 6 + (encodeTxSubmission encodeTxId encodeTx) + (decodeTxSubmission decodeTxId decodeTx) + +codecTxSubmission2Id + :: forall txid tx m. Monad m + => Codec (TxSubmission2 txid tx) CodecFailure m (AnyMessage (TxSubmission2 txid tx)) +codecTxSubmission2Id = codecHelloId codecTxSubmissionId diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/TxSubmission2/Type.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/TxSubmission2/Type.hs new file mode 100644 index 00000000000..05deceb12e3 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/TxSubmission2/Type.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DataKinds #-} + +-- | The transaction submission protocol version 2. +-- +-- This module ony defines the type of the protocol, and exports all useful +-- functions and types. +-- +module Ouroboros.Network.Protocol.TxSubmission2.Type + ( TxSubmission2 + , module TxSubmission + , module Util + ) where + +import Ouroboros.Network.Protocol.TxSubmission.Type as TxSubmission +import Ouroboros.Network.Protocol.Trans.Hello.Type (Hello) +import Ouroboros.Network.Protocol.Trans.Hello.Util as Util + +-- | The new version of transaction submission protocol. +-- +-- Unlike the original 'TxSubmission' protocol, this protocol starts with +-- agency on the client side, like all other mini-protocols. +-- +type TxSubmission2 txid tx = Hello (TxSubmission txid tx) StIdle diff --git a/ouroboros-network/test/Main.hs b/ouroboros-network/test/Main.hs index 8f8b3ce496f..8fac767d6e9 100644 --- a/ouroboros-network/test/Main.hs +++ b/ouroboros-network/test/Main.hs @@ -20,6 +20,7 @@ import qualified Ouroboros.Network.Protocol.ChainSync.Test (tests) import qualified Ouroboros.Network.Protocol.BlockFetch.Test (tests) import qualified Ouroboros.Network.Protocol.Handshake.Test (tests) import qualified Ouroboros.Network.Protocol.TxSubmission.Test (tests) +import qualified Ouroboros.Network.Protocol.TxSubmission2.Test (tests) import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Test (tests) import qualified Ouroboros.Network.Protocol.KeepAlive.Test (tests) import qualified Ouroboros.Network.Protocol.TipSample.Test (tests) @@ -44,6 +45,7 @@ tests = , Ouroboros.Network.Protocol.BlockFetch.Test.tests , Ouroboros.Network.Protocol.LocalTxSubmission.Test.tests , Ouroboros.Network.Protocol.TxSubmission.Test.tests + , Ouroboros.Network.Protocol.TxSubmission2.Test.tests , Ouroboros.Network.Protocol.Handshake.Test.tests , Ouroboros.Network.Protocol.KeepAlive.Test.tests , Ouroboros.Network.Protocol.TipSample.Test.tests diff --git a/typed-protocols/src/Network/TypedProtocol/Core.hs b/typed-protocols/src/Network/TypedProtocol/Core.hs index 6bc7fe2f621..8e937e287bb 100644 --- a/typed-protocols/src/Network/TypedProtocol/Core.hs +++ b/typed-protocols/src/Network/TypedProtocol/Core.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE QuantifiedConstraints #-} @@ -459,3 +461,5 @@ data Peer ps (pr :: PeerRole) (st :: ps) m a where -> (forall st'. Message ps st st' -> Peer ps pr st' m a) -> Peer ps pr st m a + +deriving instance Functor m => Functor (Peer ps (pr :: PeerRole) (st :: ps) m) diff --git a/typed-protocols/src/Network/TypedProtocol/Pipelined.hs b/typed-protocols/src/Network/TypedProtocol/Pipelined.hs index 4673262b074..43a80547b11 100644 --- a/typed-protocols/src/Network/TypedProtocol/Pipelined.hs +++ b/typed-protocols/src/Network/TypedProtocol/Pipelined.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} module Network.TypedProtocol.Pipelined @@ -16,6 +18,7 @@ module Network.TypedProtocol.Pipelined , Nat (Zero, Succ) , natToInt , unsafeIntToNat + , fmapPeerPipelined ) where import Unsafe.Coerce (unsafeCoerce) @@ -36,6 +39,16 @@ data PeerPipelined ps (pr :: PeerRole) (st :: ps) m a where PeerPipelined :: PeerSender ps pr st Z c m a -> PeerPipelined ps pr st m a +deriving instance Functor m => Functor (PeerPipelined ps (pr :: PeerRole) (st :: ps) m) + +-- | More general than 'fmap', as it allows to change the protocol. +-- +fmapPeerPipelined :: (forall c. PeerSender ps pr st Z c m a -> PeerSender ps' pr st' Z c m b) + -> PeerPipelined ps pr st m a + -> PeerPipelined ps' pr st' m b +fmapPeerPipelined f (PeerPipelined peer) = PeerPipelined (f peer) + + -- | This is the pipelined variant of 'Peer'. -- -- In particular it has two extra type arguments: @@ -122,6 +135,8 @@ data PeerSender ps (pr :: PeerRole) (st :: ps) (n :: Outstanding) c m a where -> (c -> PeerSender ps pr (st :: ps) n c m a) -> PeerSender ps pr (st :: ps) (S n) c m a +deriving instance Functor m => Functor (PeerSender ps (pr :: PeerRole) (st :: ps) (n :: Outstanding) c m) + data PeerReceiver ps (pr :: PeerRole) (st :: ps) (stdone :: ps) m c where ReceiverEffect :: m (PeerReceiver ps pr st stdone m c)