diff --git a/ouroboros-network-api/src/Ouroboros/Network/SizeInBytes.hs b/ouroboros-network-api/src/Ouroboros/Network/SizeInBytes.hs index e92259d8de0..c7c9e018d77 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/SizeInBytes.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/SizeInBytes.hs @@ -17,6 +17,7 @@ import Quiet (Quiet (..)) newtype SizeInBytes = SizeInBytes { getSizeInBytes :: Word32 } deriving (Eq, Ord) deriving Show via Quiet SizeInBytes + deriving Bounded via Word32 deriving Enum via Word32 deriving Num via Word32 deriving Real via Word32 diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Server.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Server.hs index c29517ca208..92c767462f5 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Server.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Server.hs @@ -83,9 +83,9 @@ data ServerStIdle (n :: N) txid tx m a where -- | Collect a pipelined result. -- CollectPipelined - :: Maybe (ServerStIdle (S n) txid tx m a) - -> (Collect txid tx -> m (ServerStIdle n txid tx m a)) - -> ServerStIdle (S n) txid tx m a + :: Maybe (m (ServerStIdle (S n) txid tx m a)) + -> (Collect txid tx -> m ( ServerStIdle n txid tx m a)) + -> ServerStIdle (S n) txid tx m a -- | Transform a 'TxSubmissionServerPipelined' into a 'PeerPipelined'. @@ -145,6 +145,5 @@ txSubmissionServerPeerPipelined (TxSubmissionServerPipelined server) = go (CollectPipelined mNone collect) = SenderCollect - (fmap go mNone) - (SenderEffect . fmap go . collect) - + (SenderEffect . fmap go <$> mNone) + (SenderEffect . fmap go . collect) diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Direct.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Direct.hs index 6530d3d8b71..3f97d8611e2 100644 --- a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Direct.hs +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Direct.hs @@ -54,7 +54,8 @@ directPipelined (TxSubmissionServerPipelined mserver) SendMsgReplyTxs txs client' <- recvMsgRequestTxs txids directSender (enqueue (CollectTxs txids txs) q) server' client' - directSender q (CollectPipelined (Just server') _) client = + directSender q (CollectPipelined (Just server) _) client = do + server' <- server directSender q server' client directSender (ConsQ c q) (CollectPipelined _ collect) client = do diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Examples.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Examples.hs index 2c9fab3ecc0..cef659fd3aa 100644 --- a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Examples.hs +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Examples.hs @@ -272,7 +272,7 @@ txSubmissionServer tracer txId maxUnacked maxTxIdsToRequest maxTxToRequest = -- | canRequestMoreTxs st = CollectPipelined - (Just (serverReqTxs accum (Succ n) st)) + (Just (pure $ serverReqTxs accum (Succ n) st)) (handleReply accum n st) -- In this case there is nothing else to do so we block until we diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 21a100f95ac..c21277d7f22 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -69,6 +69,12 @@ library Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers Ouroboros.Network.PeerSharing Ouroboros.Network.TxSubmission.Inbound + Ouroboros.Network.TxSubmission.Inbound.Decision + Ouroboros.Network.TxSubmission.Inbound.Policy + Ouroboros.Network.TxSubmission.Inbound.Registry + Ouroboros.Network.TxSubmission.Inbound.Server + Ouroboros.Network.TxSubmission.Inbound.State + Ouroboros.Network.TxSubmission.Inbound.Types Ouroboros.Network.TxSubmission.Mempool.Reader Ouroboros.Network.TxSubmission.Outbound other-modules: Ouroboros.Network.Diffusion.Common @@ -139,6 +145,7 @@ library io-classes-mtl ^>=0.1, network-mux, si-timers, + strict-mvar, ouroboros-network-api ^>=0.9.0, ouroboros-network-framework ^>=0.13.2.2, ouroboros-network-protocols ^>=0.10, @@ -198,6 +205,7 @@ library sim-tests-lib cardano-prelude, cardano-slotting, + cardano-strict-containers, contra-tracer, nothunks, @@ -215,6 +223,7 @@ library sim-tests-lib ouroboros-network-testing ^>= 0.7.0, si-timers, strict-stm, + strict-mvar, typed-protocols, typed-protocols-examples, exposed-modules: Ouroboros.Network.BlockFetch.Examples @@ -246,6 +255,9 @@ library sim-tests-lib Test.Ouroboros.Network.Testnet Test.Ouroboros.Network.Testnet.Simulation.Node Test.Ouroboros.Network.TxSubmission + Test.Ouroboros.Network.TxSubmission.Common + Test.Ouroboros.Network.TxSubmission.TxSubmissionV1 + Test.Ouroboros.Network.TxSubmission.TxSubmissionV2 Test.Ouroboros.Network.Version ghc-options: -Wall diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs index 45ef32e909d..411b3ea95cd 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -92,6 +92,7 @@ import Ouroboros.Network.Testing.Data.Script (Script (..), stepScriptSTM') import Simulation.Network.Snocket (AddressType (..), FD) +import Ouroboros.Network.BlockFetch.ClientRegistry (readPeerGSVs) import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers) import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeersConsensusInterface, @@ -105,6 +106,11 @@ import Ouroboros.Network.PeerSelection.RelayAccessPoint (DomainAccessPoint, import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSLookupType) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, WarmValency) +import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy) +import Ouroboros.Network.TxSubmission.Inbound.Registry (DebugTxLogic, + decisionLogicThread) +import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState) +import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxSubmissionInbound) import Test.Ouroboros.Network.Diffusion.Node.ChainDB (addBlock, getBlockPointSet) import Test.Ouroboros.Network.Diffusion.Node.MiniProtocols qualified as Node @@ -114,6 +120,7 @@ import Test.Ouroboros.Network.Diffusion.Node.NodeKernel (NodeKernel (..), import Test.Ouroboros.Network.Diffusion.Node.NodeKernel qualified as Node import Test.Ouroboros.Network.PeerSelection.RootPeersDNS (DNSLookupDelay, DNSTimeout, mockDNSActions) +import Test.Ouroboros.Network.TxSubmission.Common (Tx) data Interfaces m = Interfaces @@ -158,6 +165,8 @@ data Arguments m = Arguments , aDNSTimeoutScript :: Script DNSTimeout , aDNSLookupDelayScript :: Script DNSLookupDelay , aDebugTracer :: Tracer m String + , aTxDecisionPolicy :: TxDecisionPolicy + , aTxs :: [Tx Int] } -- The 'mockDNSActions' is not using \/ specifying 'resolverException', thus we @@ -195,9 +204,12 @@ run :: forall resolver m. NtCAddr NtCVersion NtCVersionData ResolverException m -> Tracer m (TraceLabelPeer NtNAddr (TraceFetchClientState BlockHeader)) + -> Tracer m (TraceTxSubmissionInbound Int (Tx Int)) + -> Tracer m (DebugSharedTxState NtNAddr Int (Tx Int)) + -> Tracer m (DebugTxLogic NtNAddr Int (Tx Int)) -> m Void -run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = - Node.withNodeKernelThread blockGeneratorArgs +run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch tracerTxSubmissionInbound tracerTxSubmissionDebug tracerTxLogic = + Node.withNodeKernelThread blockGeneratorArgs (aTxs na) $ \ nodeKernel nodeKernelThread -> do dnsTimeoutScriptVar <- newTVarIO (aDNSTimeoutScript na) dnsLookupDelayScriptVar <- newTVarIO (aDNSLookupDelayScript na) @@ -270,7 +282,7 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = , Diff.P2P.daPeerSharingRegistry = nkPeerSharingRegistry nodeKernel } - let apps = Node.applications (aDebugTracer na) nodeKernel Node.cborCodecs limits appArgs blockHeader + let apps = Node.applications (aDebugTracer na) tracerTxSubmissionInbound tracerTxSubmissionDebug nodeKernel Node.cborCodecs limits appArgs blockHeader withAsync (Diff.P2P.runM interfaces @@ -280,11 +292,19 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = (mkArgsExtra useBootstrapPeersScriptVar) apps appsExtra) $ \ diffusionThread -> withAsync (blockFetch nodeKernel) $ \blockFetchLogicThread -> - wait diffusionThread - <> wait blockFetchLogicThread - <> wait nodeKernelThread + + withAsync (decisionLogicThread + tracerTxLogic + (aTxDecisionPolicy na) + (readPeerGSVs (nkFetchClientRegistry nodeKernel)) + (nkTxChannelsVar nodeKernel) + (nkSharedTxStateVar nodeKernel)) $ \decLogicThread -> + wait diffusionThread + <> wait blockFetchLogicThread + <> wait nodeKernelThread + <> wait decLogicThread where - blockFetch :: NodeKernel BlockHeader Block s m + blockFetch :: NodeKernel BlockHeader Block s txid m -> m Void blockFetch nodeKernel = do blockFetchLogic @@ -300,7 +320,7 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = bfcSalt = 0 }) - blockFetchPolicy :: NodeKernel BlockHeader Block s m + blockFetchPolicy :: NodeKernel BlockHeader Block s txid m -> BlockFetchConsensusInterface NtNAddr BlockHeader Block m blockFetchPolicy nodeKernel = BlockFetchConsensusInterface { @@ -422,6 +442,7 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = , Node.aaOwnPeerSharing = aOwnPeerSharing na , Node.aaUpdateOutboundConnectionsState = iUpdateOutboundConnectionsState ni + , Node.aaTxDecisionPolicy = aTxDecisionPolicy na } --- Utils diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs index e79f6e158a4..32aed916ed6 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -86,7 +86,7 @@ import Pipes qualified import Ouroboros.Network.NodeToNode (blockFetchMiniProtocolNum, chainSyncMiniProtocolNum, keepAliveMiniProtocolNum, - peerSharingMiniProtocolNum) + peerSharingMiniProtocolNum, txSubmissionMiniProtocolNum) import Ouroboros.Network.PeerSelection.LedgerPeers import Ouroboros.Network.PeerSelection.LocalRootPeers (OutboundConnectionsState) import Ouroboros.Network.PeerSelection.PeerSharing qualified as PSTypes @@ -96,7 +96,21 @@ import Ouroboros.Network.Protocol.PeerSharing.Client (peerSharingClientPeer) import Ouroboros.Network.Protocol.PeerSharing.Codec (codecPeerSharing) import Ouroboros.Network.Protocol.PeerSharing.Server (peerSharingServerPeer) import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharing) +import Ouroboros.Network.Protocol.TxSubmission2.Client (txSubmissionClientPeer) +import Ouroboros.Network.Protocol.TxSubmission2.Server + (txSubmissionServerPeerPipelined) +import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..), + NumTxIdsToReq (..), TxSubmission2) +import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy (..)) +import Ouroboros.Network.TxSubmission.Inbound.Registry (SharedTxStateVar, + TxChannelsVar, withPeer) +import Ouroboros.Network.TxSubmission.Inbound.Server (txSubmissionInboundV2) +import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState) +import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxSubmissionInbound) +import Ouroboros.Network.TxSubmission.Outbound (txSubmissionOutbound) import Test.Ouroboros.Network.Diffusion.Node.NodeKernel +import Test.Ouroboros.Network.TxSubmission.Common (Mempool, Tx, + getMempoolReader, getMempoolWriter, txSubmissionCodec2) -- | Protocol codecs. @@ -112,6 +126,8 @@ data Codecs addr header block m = Codecs CBOR.DeserialiseFailure m ByteString , peerSharingCodec :: Codec (PeerSharing addr) CBOR.DeserialiseFailure m ByteString + , txSubmissionCodec :: Codec (TxSubmission2 Int (Tx Int)) + CBOR.DeserialiseFailure m ByteString } cborCodecs :: MonadST m => Codecs NtNAddr BlockHeader Block m @@ -125,6 +141,7 @@ cborCodecs = Codecs , keepAliveCodec = codecKeepAlive_v2 , pingPongCodec = codecPingPong , peerSharingCodec = codecPeerSharing encodeNtNAddr decodeNtNAddr + , txSubmissionCodec = txSubmissionCodec2 } @@ -178,6 +195,14 @@ data LimitsAndTimeouts header block = LimitsAndTimeouts :: ProtocolTimeLimits (PeerSharing NtNAddr) , peerSharingSizeLimits :: ProtocolSizeLimits (PeerSharing NtNAddr) ByteString + + -- tx submission + , txSubmissionLimits + :: MiniProtocolLimits + , txSubmissionTimeLimits + :: ProtocolTimeLimits (TxSubmission2 Int (Tx Int)) + , txSubmissionSizeLimits + :: ProtocolSizeLimits (TxSubmission2 Int (Tx Int)) ByteString } @@ -208,6 +233,8 @@ data AppArgs header block m = AppArgs :: PSTypes.PeerSharing , aaUpdateOutboundConnectionsState :: OutboundConnectionsState -> STM m () + + , aaTxDecisionPolicy :: TxDecisionPolicy } @@ -233,7 +260,9 @@ applications :: forall block header s m. , RandomGen s ) => Tracer m String - -> NodeKernel header block s m + -> Tracer m (TraceTxSubmissionInbound Int (Tx Int)) + -> Tracer m (DebugSharedTxState NtNAddr Int (Tx Int)) + -> NodeKernel header block s Int m -> Codecs NtNAddr header block m -> LimitsAndTimeouts header block -> AppArgs header block m @@ -241,10 +270,11 @@ applications :: forall block header s m. -> Diff.Applications NtNAddr NtNVersion NtNVersionData NtCAddr NtCVersion NtCVersionData m () -applications debugTracer nodeKernel +applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug nodeKernel Codecs { chainSyncCodec, blockFetchCodec , keepAliveCodec, pingPongCodec , peerSharingCodec + , txSubmissionCodec } limits AppArgs @@ -257,6 +287,7 @@ applications debugTracer nodeKernel , aaChainSyncEarlyExit , aaOwnPeerSharing , aaUpdateOutboundConnectionsState + , aaTxDecisionPolicy } toHeader = Diff.Applications @@ -316,6 +347,17 @@ applications debugTracer nodeKernel blockFetchInitiator blockFetchResponder } + + , MiniProtocol { + miniProtocolNum = txSubmissionMiniProtocolNum, + miniProtocolLimits = txSubmissionLimits limits, + miniProtocolRun = + InitiatorAndResponderProtocol + (txSubmissionInitiator aaTxDecisionPolicy (nkMempool nodeKernel)) + (txSubmissionResponder (nkMempool nodeKernel) + (nkTxChannelsVar nodeKernel) + (nkSharedTxStateVar nodeKernel)) + } ] , withWarm = WithWarm [ MiniProtocol @@ -600,6 +642,61 @@ applications debugTracer nodeKernel $ peerSharingServerPeer $ peerSharingServer psAPI + txSubmissionInitiator + :: TxDecisionPolicy + -> Mempool m Int + -> MiniProtocolCb (ExpandedInitiatorContext NtNAddr m) ByteString m () + txSubmissionInitiator txDecisionPolicy mempool = + MiniProtocolCb $ + \ ExpandedInitiatorContext { + eicConnectionId = connId, + eicControlMessage = controlMessageSTM + } + channel + -> do + let client = txSubmissionOutbound + ((show . (connId,)) `contramap` debugTracer) + (NumTxIdsToAck $ getNumTxIdsToReq + $ maxUnacknowledgedTxIds + $ txDecisionPolicy) + (getMempoolReader mempool) + maxBound + controlMessageSTM + labelThisThread "TxSubmissionClient" + runPeerWithLimits + ((show . (connId,)) `contramap` debugTracer) + txSubmissionCodec + (txSubmissionSizeLimits limits) + (txSubmissionTimeLimits limits) + channel + (txSubmissionClientPeer client) + + txSubmissionResponder + :: Mempool m Int + -> TxChannelsVar m NtNAddr Int (Tx Int) + -> SharedTxStateVar m NtNAddr Int (Tx Int) + -> MiniProtocolCb (ResponderContext NtNAddr) ByteString m () + txSubmissionResponder mempool txChannelsVar sharedTxStateVar = + MiniProtocolCb $ + \ ResponderContext { rcConnectionId = connId@ConnectionId { remoteAddress = them }} channel + -> do + withPeer txSubmissionInboundDebug + txChannelsVar + sharedTxStateVar + (getMempoolReader mempool) + them $ \api -> do + let server = txSubmissionInboundV2 + txSubmissionInboundTracer + (getMempoolWriter mempool) + api + labelThisThread "TxSubmissionServer" + runPipelinedPeerWithLimits + ((show . (connId,)) `contramap` debugTracer) + txSubmissionCodec + (txSubmissionSizeLimits limits) + (txSubmissionTimeLimits limits) + channel + (txSubmissionServerPeerPipelined server) -- -- Orphaned Instances diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs index c0781481a0d..098c6042420 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs @@ -76,6 +76,7 @@ import Test.Ouroboros.Network.Orphans () import Codec.CBOR.Decoding qualified as CBOR import Codec.CBOR.Encoding qualified as CBOR +import Control.Concurrent.Class.MonadMVar.Strict qualified as Strict import Ouroboros.Network.Mock.Chain (Chain (..)) import Ouroboros.Network.NodeToNode () import Ouroboros.Network.PeerSelection.Governor (PublicPeerSelectionState, @@ -85,8 +86,11 @@ import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) import Ouroboros.Network.PeerSharing (PeerSharingAPI, PeerSharingRegistry (..), newPeerSharingAPI, newPeerSharingRegistry, ps_POLICY_PEER_SHARE_MAX_PEERS, ps_POLICY_PEER_SHARE_STICKY_TIME) +import Ouroboros.Network.TxSubmission.Inbound.Registry (SharedTxStateVar, + TxChannels (..), TxChannelsVar, newSharedTxStateVar) import Test.Ouroboros.Network.Diffusion.Node.ChainDB (ChainDB (..)) import Test.Ouroboros.Network.Diffusion.Node.ChainDB qualified as ChainDB +import Test.Ouroboros.Network.TxSubmission.Common (Mempool, Tx, newMempool) import Test.QuickCheck (Arbitrary (..), choose, chooseInt, frequency, oneof) @@ -251,7 +255,7 @@ randomBlockGenerationArgs bgaSlotDuration bgaSeed quota = , bgaSeed } -data NodeKernel header block s m = NodeKernel { +data NodeKernel header block s txid m = NodeKernel { -- | upstream chains nkClientChains :: StrictTVar m (Map NtNAddr (StrictTVar m (Chain header))), @@ -268,14 +272,24 @@ data NodeKernel header block s m = NodeKernel { nkPeerSharingAPI :: PeerSharingAPI NtNAddr s m, - nkPublicPeerSelectionVar :: StrictTVar m (PublicPeerSelectionState NtNAddr) + nkPublicPeerSelectionVar :: StrictTVar m (PublicPeerSelectionState NtNAddr), + + nkMempool :: Mempool m txid, + + nkTxChannelsVar :: TxChannelsVar m NtNAddr txid (Tx txid), + + nkSharedTxStateVar :: SharedTxStateVar m NtNAddr txid (Tx txid) } newNodeKernel :: ( MonadSTM m + , Strict.MonadMVar m , RandomGen s + , Eq txid ) - => s -> m (NodeKernel header block s m) -newNodeKernel rng = do + => s + -> [Tx txid] + -> m (NodeKernel header block s txid m) +newNodeKernel rng txs = do publicStateVar <- makePublicPeerSelectionStateVar NodeKernel <$> newTVarIO Map.empty @@ -287,11 +301,14 @@ newNodeKernel rng = do ps_POLICY_PEER_SHARE_STICKY_TIME ps_POLICY_PEER_SHARE_MAX_PEERS <*> pure publicStateVar + <*> newMempool txs + <*> Strict.newMVar (TxChannels Map.empty) + <*> newSharedTxStateVar -- | Register a new upstream chain-sync client. -- registerClientChains :: MonadSTM m - => NodeKernel header block s m + => NodeKernel header block s txid m -> NtNAddr -> m (StrictTVar m (Chain header)) registerClientChains NodeKernel { nkClientChains } peerAddr = atomically $ do @@ -303,7 +320,7 @@ registerClientChains NodeKernel { nkClientChains } peerAddr = atomically $ do -- | Unregister an upstream chain-sync client. -- unregisterClientChains :: MonadSTM m - => NodeKernel header block s m + => NodeKernel header block s txid m -> NtNAddr -> m () unregisterClientChains NodeKernel { nkClientChains } peerAddr = atomically $ @@ -356,7 +373,7 @@ instance Exception NodeKernelError where -- | Run chain selection \/ block production thread. -- withNodeKernelThread - :: forall block header m seed a. + :: forall block header m seed txid a. ( Alternative (STM m) , MonadAsync m , MonadDelay m @@ -364,23 +381,27 @@ withNodeKernelThread , MonadTimer m , MonadThrow m , MonadThrow (STM m) + , Strict.MonadMVar m , HasFullHeader block , RandomGen seed + , Eq txid ) => BlockGeneratorArgs block seed - -> (NodeKernel header block seed m -> Async m Void -> m a) + -> [Tx txid] + -> (NodeKernel header block seed txid m -> Async m Void -> m a) -- ^ The continuation which has a handle to the chain selection \/ block -- production thread. The thread might throw an exception. -> m a withNodeKernelThread BlockGeneratorArgs { bgaSlotDuration, bgaBlockGenerator, bgaSeed } + txs k = do - kernel <- newNodeKernel psSeed + kernel <- newNodeKernel psSeed txs withSlotTime bgaSlotDuration $ \waitForSlot -> withAsync (blockProducerThread kernel waitForSlot) (k kernel) where (bpSeed, psSeed) = split bgaSeed - blockProducerThread :: NodeKernel header block seed m + blockProducerThread :: NodeKernel header block seed txid m -> (SlotNo -> STM m SlotNo) -> m Void blockProducerThread NodeKernel { nkChainProducerState, nkChainDB } diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs index ef9fa856e61..a8ac7006987 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} #if defined(mingw32_HOST_OS) @@ -21,9 +22,9 @@ import Control.Monad.Class.MonadTime.SI (DiffTime, Time (Time), addTime, import Control.Monad.IOSim import Data.Bifoldable (bifoldMap) -import Data.Foldable (fold) +import Data.Foldable (fold, foldr') import Data.IP qualified as IP -import Data.List as List (find, foldl', intercalate, tails) +import Data.List as List (find, foldl', intercalate, sort, tails) import Data.List.Trace qualified as Trace import Data.Map (Map) import Data.Map qualified as Map @@ -56,11 +57,11 @@ import Ouroboros.Network.PeerSelection.Types import Ouroboros.Network.Server2 (ServerTrace (..)) import Ouroboros.Network.Testing.Data.AbsBearerInfo import Ouroboros.Network.Testing.Data.Script -import Ouroboros.Network.Testing.Data.Signal +import Ouroboros.Network.Testing.Data.Signal hiding (nub, nubBy) import Ouroboros.Network.Testing.Data.Signal qualified as Signal import Ouroboros.Network.Testing.Utils hiding (SmallDelay, debugTracer) -import Simulation.Network.Snocket (BearerInfo (..)) +import Simulation.Network.Snocket (BearerInfo (..), noAttenuation) import Test.Ouroboros.Network.Diffusion.Node (config_REPROMOTE_DELAY) import Test.Ouroboros.Network.Diffusion.Node.NodeKernel @@ -70,7 +71,7 @@ import Test.QuickCheck.Monoids import Test.Tasty import Test.Tasty.QuickCheck (testProperty) -import Control.Exception (AssertionFailed (..), catch, evaluate) +import Control.Exception (AssertionFailed (..), catch, evaluate, fromException) import Ouroboros.Network.BlockFetch (FetchMode (..), TraceFetchClientState (..)) import Ouroboros.Network.ConnectionManager.Test.Timeouts (TestProperty (..), classifyActivityType, classifyEffectiveDataFlow, @@ -99,8 +100,20 @@ import Ouroboros.Network.PeerSharing (PeerSharingResult (..)) import Test.Ouroboros.Network.LedgerPeers (LedgerPools (..)) import Control.Monad.Class.MonadTest (exploreRaces) +import Data.Bifunctor (bimap) +import Data.Char (ord) +import Data.Ratio (Ratio) import Ouroboros.Network.PeerSelection.Bootstrap (requiresBootstrapPeers) import Ouroboros.Network.PeerSelection.LedgerPeers +import Ouroboros.Network.TxSubmission.Inbound.Policy (defaultTxDecisionPolicy, + txInflightMultiplicity) +import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState (..), + inflightTxs) +import Ouroboros.Network.TxSubmission.Inbound.Types + (TraceTxSubmissionInbound (..)) +import Ouroboros.Network.TxSubmission.Outbound (TxSubmissionProtocolError (..)) +import Test.Ouroboros.Network.TxSubmission.Common (ArbTxDecisionPolicy (..), + Tx (..)) tests :: TestTree tests = @@ -156,6 +169,10 @@ tests = (testWithIOSimPOR prop_only_bootstrap_peers_in_fallback_state 10000) , nightlyTest $ testProperty "no non trustable peers before caught up state" (testWithIOSimPOR prop_no_non_trustable_peers_before_caught_up_state 10000) + , testGroup "Tx Submission" + [ nightlyTest $ testProperty "no protocol errors" + (testWithIOSimPOR prop_no_txSubmission_error 125000) + ] , testGroup "Churn" [ nightlyTest $ testProperty "no timeouts" (testWithIOSimPOR prop_churn_notimeouts 10000) @@ -221,6 +238,14 @@ tests = [ testProperty "share a peer" unit_peer_sharing ] + , testGroup "Tx Submission" + [ testProperty "no protocol errors" + (testWithIOSim prop_no_txSubmission_error 125000) + , testProperty "all transactions" + unit_txSubmission_allTransactions + , testProperty "inflight coverage" + prop_check_inflight_ratio + ] , testGroup "Churn" [ testProperty "no timeouts" (testWithIOSim prop_churn_notimeouts 125000) @@ -418,6 +443,231 @@ prop_inbound_governor_trace_coverage defaultBearerInfo diffScript = in tabulate "inbound governor trace" eventsSeenNames True +-- | This test check that we don't have any tx submission protocol error +-- +prop_no_txSubmission_error :: SimTrace Void + -> Int + -> Property +prop_no_txSubmission_error ioSimTrace traceNumber = + let events = Trace.toList + . fmap (\(WithTime t (WithName _ b)) -> (t, b)) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.take traceNumber + $ ioSimTrace + + in counterexample (intercalate "\n" $ map show $ events) + $ all (\case + (_, DiffusionInboundGovernorTrace (TrMuxErrored _ err)) -> + case fromException err of + Just ProtocolErrorRequestBlocking -> False + Just ProtocolErrorRequestedNothing -> False + Just ProtocolErrorAckedTooManyTxids -> False + Just (ProtocolErrorRequestedTooManyTxids _ _ _) -> False + Just ProtocolErrorRequestNonBlocking -> False + Just ProtocolErrorRequestedUnavailableTx -> False + _ -> True + _ -> True + ) + events + +-- | This test checks that even in a scenario where nodes keep disconnecting, +-- but eventually stay online. We manage to get all transactions. +-- +unit_txSubmission_allTransactions :: ArbTxDecisionPolicy + -> TurbulentCommands + -> (NonEmptyList (Tx Int), NonEmptyList (Tx Int)) + -> Property +unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) + (TurbulentCommands commands) + (NonEmpty txsA, NonEmpty txsB) = + let diffScript = + DiffusionScript + (SimArgs 1 10 decisionPolicy) + (singletonTimedScript Map.empty) + [(NodeArgs + (-3) + InitiatorAndResponderDiffusionMode + (Just 224) + Map.empty + (Script (DontUseBootstrapPeers :| [])) + (TestAddress (IPAddr (read "0.0.0.0") 0)) + PeerSharingDisabled + [ (2,2,Map.fromList [ (RelayAccessAddress "0.0.0.1" 0,(DoNotAdvertisePeer, IsNotTrustable)) + , (RelayAccessAddress "0.0.0.2" 0,(DoNotAdvertisePeer, IsNotTrustable)) + ]) + ] + (Script (LedgerPools [] :| [])) + PeerSelectionTargets { + targetNumberOfRootPeers = 1, + targetNumberOfKnownPeers = 1, + targetNumberOfEstablishedPeers = 1, + targetNumberOfActivePeers = 1, + + targetNumberOfKnownBigLedgerPeers = 0, + targetNumberOfEstablishedBigLedgerPeers = 0, + targetNumberOfActiveBigLedgerPeers = 0 + } + (Script (DNSTimeout {getDNSTimeout = 10} :| [])) + (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) + Nothing + False + (Script (FetchModeDeadline :| [])) + uniqueTxsA + , [ JoinNetwork 0 + ]) + , (NodeArgs + (-1) + InitiatorAndResponderDiffusionMode + (Just 2) + Map.empty + (Script (DontUseBootstrapPeers :| [])) + (TestAddress (IPAddr (read "0.0.0.1") 0)) + PeerSharingDisabled + [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.0" 0,(DoNotAdvertisePeer, IsNotTrustable))])] + (Script (LedgerPools [] :| [])) + PeerSelectionTargets { + targetNumberOfRootPeers = 1, + targetNumberOfKnownPeers = 1, + targetNumberOfEstablishedPeers = 1, + targetNumberOfActivePeers = 1, + + targetNumberOfKnownBigLedgerPeers = 0, + targetNumberOfEstablishedBigLedgerPeers = 0, + targetNumberOfActiveBigLedgerPeers = 0 + } + (Script (DNSTimeout {getDNSTimeout = 10} :| [ ])) + (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) + Nothing + False + (Script (FetchModeDeadline :| [])) + uniqueTxsB + , commands) + ] + in checkAllTransactions (runSimTrace + (diffusionSimulation noAttenuation + diffScript + iosimTracer) + ) + 500000 -- ^ Running for 500k might not be enough. + where + -- We need to make sure the transactions are unique, this simplifies + -- things. + uniqueTxsA = map (\(t, i) -> t { getTxId = (foldl' (+) 0 $ map ord "0.0.0.0") + i }) + (zip txsA [0 :: Int ..]) + uniqueTxsB = map (\(t, i) -> t { getTxId = (foldl' (+) 0 $ map ord "0.0.0.1") + i }) + (zip txsB [100 :: Int ..]) + + -- This checks the property that after running the simulation for a while + -- both nodes manage to get all valid transactions. + -- + checkAllTransactions :: SimTrace Void + -> Int + -> Property + checkAllTransactions ioSimTrace traceNumber = + let events = fmap (\(WithTime t (WithName name b)) -> WithName name (WithTime t b)) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.take traceNumber + $ ioSimTrace + + -- Build the accepted (sorted) txids map for each peer + -- + sortedAcceptedTxidsMap :: Map NtNAddr [Int] + sortedAcceptedTxidsMap = + foldr (\l r -> + foldl' (\rr (WithName n (WithTime _ x)) -> + case x of + -- When we add txids to the mempool, we collect them + -- into the map + DiffusionTxSubmissionInbound (TraceTxInboundAddedToMempool txids) -> + Map.alter (maybe (Just []) (Just . sort . (txids ++))) n rr + -- When the node is shutdown we have to reset the accepted + -- txids list + DiffusionDiffusionSimulationTrace TrKillingNode -> + Map.alter (Just . const []) n rr + _ -> rr) r l + ) Map.empty + . Trace.toList + . splitWithNameTrace + $ events + + -- Construct the list of valid (sorted) txs from peer A and peer B. + -- This is essentially our goal lists + -- + (validSortedTxidsA, validSortedTxidsB) = + let f = sort + . map (\Tx {getTxId} -> getTxId) + . filter (\Tx {getTxValid} -> getTxValid) + in bimap f f (uniqueTxsA, uniqueTxsB) + + in counterexample (intercalate "\n" $ map show $ Trace.toList $ events) + $ counterexample ("unique txs: " ++ show uniqueTxsA ++ " " ++ show uniqueTxsB) + $ counterexample ("accepted txids map: " ++ show sortedAcceptedTxidsMap) + $ counterexample ("valid transactions that should be accepted: " + ++ show validSortedTxidsA ++ " " ++ show validSortedTxidsB) + + -- Success criteria, after running for 500k events, we check the map + -- for the two nodes involved in the simulation and verify that indeed + -- each peer managed to learn about the other peer' transactions. + -- + $ case ( Map.lookup (TestAddress (IPAddr (read "0.0.0.0") 0)) sortedAcceptedTxidsMap + , Map.lookup (TestAddress (IPAddr (read "0.0.0.1") 0)) sortedAcceptedTxidsMap + ) of + (Just acceptedTxidsA, Just acceptedTxidsB) -> + acceptedTxidsA === validSortedTxidsB + .&&. acceptedTxidsB === validSortedTxidsA + _ -> counterexample "Didn't find any entry in the map!" + $ False + +-- | This test checks the ratio of the inflight txs against the allowed by the +-- TxDecisionPolicy. +-- +prop_check_inflight_ratio :: AbsBearerInfo + -> DiffusionScript + -> Property +prop_check_inflight_ratio bi ds@(DiffusionScript simArgs _ _) = + let sim :: forall s . IOSim s Void + sim = diffusionSimulation (toBearerInfo bi) + ds + iosimTracer + + events :: Events DiffusionTestTrace + events = Signal.eventsFromList + . Trace.toList + . fmap ( (\(WithTime t (WithName _ b)) -> (t, b)) + ) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.take 500000 + $ runSimTrace + $ sim + + inflightTxsMap = + foldr' + (\(_, m) r -> Map.unionWith (max) m r + ) + Map.empty + $ Signal.eventsToList + $ Signal.selectEvents + (\case + DiffusionTxSubmissionDebug (DebugSharedTxState _ d) -> Just (inflightTxs d) + _ -> Nothing + ) + $ events + + txDecisionPolicy = saTxDecisionPolicy simArgs + + in tabulate "Max observeed ratio of inflight multiplicity by the max stipulated by the policy" + (map (\m -> "has " ++ show m ++ " in flight - ratio: " + ++ show @(Ratio Int) (fromIntegral m / fromIntegral (txInflightMultiplicity txDecisionPolicy)) + ) + (Map.elems inflightTxsMap)) + $ True + -- | This test coverage of InboundGovernor transitions. -- prop_inbound_governor_transitions_coverage :: AbsBearerInfo @@ -714,7 +964,7 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script where script :: DiffusionScript script = - DiffusionScript (SimArgs 1 10) + DiffusionScript (SimArgs 1 10 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [ ( NodeArgs (-6) InitiatorAndResponderDiffusionMode (Just 180) (Map.fromList [(RelayAccessDomain "test2" 65535, DoAdvertisePeer)]) @@ -741,6 +991,7 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script Nothing False (Script (FetchModeDeadline :| [])) + [] , [JoinNetwork 1.742857142857 ,Reconfigure 6.33333333333 [(1,1,Map.fromList [(RelayAccessDomain "test2" 65535,(DoAdvertisePeer, IsNotTrustable))]), (1,1,Map.fromList [(RelayAccessAddress "0:6:0:3:0:6:0:5" 65530,(DoAdvertisePeer, IsNotTrustable)) @@ -775,6 +1026,7 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script Nothing False (Script (FetchModeDeadline :| [])) + [] , [JoinNetwork 0.183783783783 ,Reconfigure 4.533333333333 [(1,1,Map.fromList [])] ] @@ -1294,7 +1546,7 @@ unit_4191 = testWithIOSim prop_diffusion_dns_can_recover 125000 absInfo script } script = DiffusionScript - (SimArgs 1 20) + (SimArgs 1 20 defaultTxDecisionPolicy) (singletonTimedScript $ Map.fromList [ ("test2", [ (read "810b:4c8a:b3b5:741:8c0c:b437:64cf:1bd9", 300) @@ -1361,6 +1613,7 @@ unit_4191 = testWithIOSim prop_diffusion_dns_can_recover 125000 absInfo script Nothing False (Script (FetchModeDeadline :| [])) + [] , [ JoinNetwork 6.710144927536 , Kill 7.454545454545 , JoinNetwork 10.763157894736 @@ -2285,7 +2538,8 @@ async_demotion_network_script = simArgs = SimArgs { saSlot = secondsToDiffTime 1, - saQuota = 5 -- 5% chance of producing a block + saQuota = 5, -- 5% chance of producing a block + saTxDecisionPolicy = defaultTxDecisionPolicy } peerTargets = Governor.nullPeerSelectionTargets { targetNumberOfKnownPeers = 1, @@ -2313,7 +2567,8 @@ async_demotion_network_script = naChainSyncEarlyExit = False, naPeerSharing = PeerSharingDisabled, - naFetchModeScript = singletonScript FetchModeDeadline + naFetchModeScript = singletonScript FetchModeDeadline, + naTxs = [] } @@ -2730,7 +2985,7 @@ prop_unit_4258 = abiSDUSize = LargeSDU } diffScript = DiffusionScript - (SimArgs 1 10) + (SimArgs 1 10 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [( NodeArgs (-3) InitiatorAndResponderDiffusionMode (Just 224) (Map.fromList []) @@ -2760,6 +3015,7 @@ prop_unit_4258 = Nothing False (Script (FetchModeDeadline :| [])) + [] , [ JoinNetwork 4.166666666666, Kill 0.3, JoinNetwork 1.517857142857, @@ -2803,6 +3059,7 @@ prop_unit_4258 = Nothing False (Script (FetchModeDeadline :| [])) + [] , [ JoinNetwork 3.384615384615, Reconfigure 3.583333333333 [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.4" 9,(DoNotAdvertisePeer, IsNotTrustable))])], Kill 15.55555555555, @@ -2835,7 +3092,7 @@ prop_unit_reconnect :: Property prop_unit_reconnect = let diffScript = DiffusionScript - (SimArgs 1 10) + (SimArgs 1 10 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [(NodeArgs (-3) @@ -2867,6 +3124,7 @@ prop_unit_reconnect = Nothing False (Script (FetchModeDeadline :| [])) + [] , [ JoinNetwork 0 ]) , (NodeArgs @@ -2896,6 +3154,7 @@ prop_unit_reconnect = Nothing False (Script (FetchModeDeadline :| [])) + [] , [ JoinNetwork 10 ]) ] @@ -3305,11 +3564,12 @@ unit_peer_sharing = naChainSyncEarlyExit = False, naChainSyncExitOnBlockNo = Nothing, naFetchModeScript = singletonScript FetchModeDeadline, - naConsensusMode + naConsensusMode, + naTxs = [] } script = DiffusionScript - (mainnetSimArgs 3) + (mainnetSimArgs 3 defaultTxDecisionPolicy) (singletonScript (mempty, ShortDelay)) [ ( (defaultNodeArgs GenesisMode) { naAddr = ip_0, naLocalRootPeers = [(1, 1, Map.fromList [(ra_1, (DoNotAdvertisePeer, IsNotTrustable))])], diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Simulation/Node.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Simulation/Node.hs index 9ce912e6aeb..70c647bf298 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Simulation/Node.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Simulation/Node.hs @@ -22,6 +22,7 @@ module Test.Ouroboros.Network.Testnet.Simulation.Node , fixupCommands , diffusionSimulation , Command (..) + , TurbulentCommands (..) -- * Tracing , DiffusionTestTrace (..) , iosimTracer @@ -140,8 +141,16 @@ import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), WarmValency (..)) import Ouroboros.Network.Protocol.PeerSharing.Codec (byteLimitsPeerSharing, timeLimitsPeerSharing) +import Ouroboros.Network.Protocol.TxSubmission2.Codec (byteLimitsTxSubmission2, + timeLimitsTxSubmission2) +import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy) +import Ouroboros.Network.TxSubmission.Inbound.Registry (DebugTxLogic) +import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState) +import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxSubmissionInbound) import Test.Ouroboros.Network.LedgerPeers (LedgerPools (..), genLedgerPoolsFrom) import Test.Ouroboros.Network.PeerSelection.LocalRootPeers () +import Test.Ouroboros.Network.TxSubmission.Common (ArbTxDecisionPolicy (..), + Tx (..)) import Test.QuickCheck -- | Diffusion Simulator Arguments @@ -151,17 +160,20 @@ import Test.QuickCheck -- data SimArgs = SimArgs - { saSlot :: DiffTime + { saSlot :: DiffTime -- ^ 'randomBlockGenerationArgs' slot duration argument - , saQuota :: Int + , saQuota :: Int -- ^ 'randomBlockGenerationArgs' quota value + , saTxDecisionPolicy :: TxDecisionPolicy + -- ^ Decision policy for tx submission protocol } instance Show SimArgs where - show SimArgs { saSlot, saQuota } = + show SimArgs { saSlot, saQuota, saTxDecisionPolicy } = unwords [ "SimArgs" , show saSlot , show saQuota + , "(" ++ show saTxDecisionPolicy ++ ")" ] data ServiceDomainName = @@ -219,13 +231,14 @@ data NodeArgs = , naChainSyncExitOnBlockNo :: Maybe BlockNo , naChainSyncEarlyExit :: Bool , naFetchModeScript :: Script FetchMode + , naTxs :: [Tx Int] } instance Show NodeArgs where show NodeArgs { naSeed, naDiffusionMode, naMbTime, naBootstrapPeers, naPublicRoots, naAddr, naPeerSharing, naLocalRootPeers, naPeerTargets, naDNSTimeoutScript, naDNSLookupDelayScript, naChainSyncExitOnBlockNo, - naChainSyncEarlyExit, naFetchModeScript, naConsensusMode } = + naChainSyncEarlyExit, naFetchModeScript, naConsensusMode, naTxs } = unwords [ "NodeArgs" , "(" ++ show naSeed ++ ")" , show naDiffusionMode @@ -242,6 +255,7 @@ instance Show NodeArgs where , "(" ++ show naChainSyncExitOnBlockNo ++ ")" , show naChainSyncEarlyExit , show naFetchModeScript + , show naTxs , "============================================\n" ] @@ -306,6 +320,48 @@ fixupCommands (jn@(JoinNetwork _):t) = jn : go jn t _ -> cmd : go cmd cmds fixupCommands (_:t) = fixupCommands t +-- | Turbulent commands have some turbulence by connecting and disconnecting +-- the node, but eventually keeping the node online. +-- +newtype TurbulentCommands = TurbulentCommands [Command] + deriving (Eq, Show) + +instance Arbitrary TurbulentCommands where + arbitrary = do + turbulenceNumber <- choose (2, 7) + -- Make sure turbulenceNumber is an even number + -- This simplifies making sure we keep the node online. + let turbulenceNumber' = + if odd turbulenceNumber + then turbulenceNumber + 1 + else turbulenceNumber + delays <- vectorOf turbulenceNumber' delay + let commands = zipWith (\f d -> f d) (cycle [JoinNetwork, Kill]) delays + ++ [JoinNetwork 0] + return (TurbulentCommands commands) + where + delay = frequency [ (3, genDelayWithPrecision 65) + , (1, (/ 10) <$> genDelayWithPrecision 60) + ] + shrink (TurbulentCommands xs) = + [ TurbulentCommands xs' | xs' <- shrinkList shrinkCommand xs, invariant xs' ] ++ + [ TurbulentCommands (take n xs) | n <- [0, length xs - 3], n `mod` 3 == 0, invariant (take n xs) ] + + where + shrinkDelay = map fromRational . shrink . toRational + + shrinkCommand :: Command -> [Command] + shrinkCommand (JoinNetwork d) = JoinNetwork <$> shrinkDelay d + shrinkCommand (Kill d) = Kill <$> shrinkDelay d + shrinkCommand (Reconfigure d lrp) = Reconfigure <$> shrinkDelay d + <*> pure lrp + + invariant :: [Command] -> Bool + invariant [JoinNetwork _] = True + invariant [JoinNetwork _, Kill _, JoinNetwork _] = True + invariant (JoinNetwork _ : Kill _ : JoinNetwork _ : rest) = invariant rest + invariant _ = False + -- | Simulation arguments. -- -- Slot length needs to be greater than 0 else we get a livelock on the IOSim. @@ -313,13 +369,16 @@ fixupCommands (_:t) = fixupCommands t -- Quota values matches mainnet, so a slot length of 1s and 1 / 20 chance that -- someone gets to make a block. -- -mainnetSimArgs :: Int -> SimArgs -mainnetSimArgs numberOfNodes = +mainnetSimArgs :: Int + -> TxDecisionPolicy + -> SimArgs +mainnetSimArgs numberOfNodes txDecisionPolicy = SimArgs { saSlot = secondsToDiffTime 1, saQuota = if numberOfNodes > 0 then 20 `div` numberOfNodes - else 100 + else 100, + saTxDecisionPolicy = txDecisionPolicy } @@ -363,8 +422,9 @@ genNodeArgs :: [RelayAccessInfo] -> Int -> [(HotValency, WarmValency, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))] -> RelayAccessInfo + -> [Tx Int] -> Gen NodeArgs -genNodeArgs relays minConnected localRootPeers relay = flip suchThat hasUpstream $ do +genNodeArgs relays minConnected localRootPeers relay txs = flip suchThat hasUpstream $ do -- Slot length needs to be greater than 0 else we get a livelock on -- the IOSim. -- @@ -457,6 +517,7 @@ genNodeArgs relays minConnected localRootPeers relay = flip suchThat hasUpstream , naChainSyncEarlyExit = chainSyncEarlyExit , naPeerSharing = peerSharing , naFetchModeScript = fetchModeScript + , naTxs = txs } where hasActive :: SmallPeerSelectionTargets -> Bool @@ -686,10 +747,24 @@ genDiffusionScript :: ([RelayAccessInfo] genDiffusionScript genLocalRootPeers (RelayAccessInfosWithDNS relays dnsMapScript) = do - let simArgs = mainnetSimArgs (length relays') - nodesWithCommands <- mapM go (nubBy ((==) `on` getRelayIP) relays') + ArbTxDecisionPolicy txDecisionPolicy <- arbitrary + let simArgs = mainnetSimArgs (length relays') txDecisionPolicy + txs <- makeUniqueIds 0 + <$> vectorOf (length relays') (choose (10, 100) >>= \c -> vectorOf c arbitrary) + nodesWithCommands <- mapM go (zip (nubBy ((==) `on` getRelayIP) relays') txs) return (simArgs, dnsMapScript, nodesWithCommands) where + makeUniqueIds :: Int -> [[Tx Int]] -> [[Tx Int]] + makeUniqueIds _ [] = [] + makeUniqueIds i (l:ls) = + let (r, i') = makeUniqueIds' l i + in r : makeUniqueIds i' ls + + makeUniqueIds' :: [Tx Int] -> Int -> ([Tx Int], Int) + makeUniqueIds' l i = ( map (\(tx, x) -> tx {getTxId = x}) (zip l [i..]) + , i + length l + 1 + ) + getRelayIP :: RelayAccessInfo -> IP getRelayIP (RelayAddrInfo ip _ _) = ip getRelayIP (RelayDomainInfo _ ip _ _) = ip @@ -697,12 +772,12 @@ genDiffusionScript genLocalRootPeers relays' :: [RelayAccessInfo] relays' = getRelayAccessInfos relays - go :: RelayAccessInfo -> Gen (NodeArgs, [Command]) - go relay = do + go :: (RelayAccessInfo, [Tx Int]) -> Gen (NodeArgs, [Command]) + go (relay, txs) = do let otherRelays = relay `delete` relays' minConnected = 3 `max` (length relays' - 1) localRts <- genLocalRootPeers otherRelays relay - nodeArgs <- genNodeArgs relays' minConnected localRts relay + nodeArgs <- genNodeArgs relays' minConnected localRts relay txs commands <- genCommands localRts return (nodeArgs, commands) @@ -928,6 +1003,9 @@ data DiffusionTestTrace = | DiffusionInboundGovernorTrace (InboundGovernorTrace NtNAddr) | DiffusionServerTrace (ServerTrace NtNAddr) | DiffusionFetchTrace (TraceFetchClientState BlockHeader) + | DiffusionTxSubmissionInbound (TraceTxSubmissionInbound Int (Tx Int)) + | DiffusionTxSubmissionDebug (DebugSharedTxState NtNAddr Int (Tx Int)) + | DiffusionTxLogicDebug (DebugTxLogic NtNAddr Int (Tx Int)) | DiffusionDebugTrace String deriving (Show) @@ -1057,6 +1135,7 @@ diffusionSimulation runNode SimArgs { saSlot = bgaSlotDuration , saQuota = quota + , saTxDecisionPolicy = txDecisionPolicy } NodeArgs { naSeed = seed @@ -1072,6 +1151,7 @@ diffusionSimulation , naChainSyncExitOnBlockNo = chainSyncExitOnBlockNo , naChainSyncEarlyExit = chainSyncEarlyExit , naPeerSharing = peerSharing + , naTxs = txs } ntnSnocket ntcSnocket @@ -1113,14 +1193,14 @@ diffusionSimulation limitsAndTimeouts = NodeKernel.LimitsAndTimeouts { NodeKernel.chainSyncLimits = defaultMiniProtocolsLimit - , NodeKernel.chainSyncSizeLimits = byteLimitsChainSync (const 0) + , NodeKernel.chainSyncSizeLimits = byteLimitsChainSync (fromIntegral . BL.length) , NodeKernel.chainSyncTimeLimits = timeLimitsChainSync stdChainSyncTimeout , NodeKernel.blockFetchLimits = defaultMiniProtocolsLimit - , NodeKernel.blockFetchSizeLimits = byteLimitsBlockFetch (const 0) + , NodeKernel.blockFetchSizeLimits = byteLimitsBlockFetch (fromIntegral . BL.length) , NodeKernel.blockFetchTimeLimits = timeLimitsBlockFetch , NodeKernel.keepAliveLimits = defaultMiniProtocolsLimit - , NodeKernel.keepAliveSizeLimits = byteLimitsKeepAlive (const 0) + , NodeKernel.keepAliveSizeLimits = byteLimitsKeepAlive (fromIntegral . BL.length) , NodeKernel.keepAliveTimeLimits = timeLimitsKeepAlive , NodeKernel.pingPongLimits = defaultMiniProtocolsLimit , NodeKernel.pingPongSizeLimits = byteLimitsPingPong @@ -1135,8 +1215,10 @@ diffusionSimulation , NodeKernel.peerSharingTimeLimits = timeLimitsPeerSharing , NodeKernel.peerSharingSizeLimits = - byteLimitsPeerSharing (const 0) - + byteLimitsPeerSharing (fromIntegral . BL.length) + , NodeKernel.txSubmissionLimits = defaultMiniProtocolsLimit + , NodeKernel.txSubmissionTimeLimits = timeLimitsTxSubmission2 + , NodeKernel.txSubmissionSizeLimits = byteLimitsTxSubmission2 (fromIntegral . BL.length) } interfaces :: NodeKernel.Interfaces m @@ -1206,6 +1288,8 @@ diffusionSimulation , NodeKernel.aDNSLookupDelayScript = dnsLookupDelay , NodeKernel.aDebugTracer = (\s -> WithTime (Time (-1)) (WithName addr (DiffusionDebugTrace s))) `contramap` nodeTracer + , NodeKernel.aTxDecisionPolicy = txDecisionPolicy + , NodeKernel.aTxs = txs } NodeKernel.run blockGeneratorArgs @@ -1217,6 +1301,18 @@ diffusionSimulation . tracerWithName addr . tracerWithTime $ nodeTracer) + ( contramap DiffusionTxSubmissionInbound + . tracerWithName addr + . tracerWithTime + $ nodeTracer) + ( contramap DiffusionTxSubmissionDebug + . tracerWithName addr + . tracerWithTime + $ nodeTracer) + ( contramap DiffusionTxLogicDebug + . tracerWithName addr + . tracerWithTime + $ nodeTracer) domainResolver :: StrictTVar m (Map Domain [(IP, TTL)]) -> DNSLookupType diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission.hs index 83d1c76ff09..a09c6742e9f 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission.hs @@ -1,392 +1,14 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} - module Test.Ouroboros.Network.TxSubmission (tests) where -import Prelude hiding (seq) - -import NoThunks.Class (NoThunks) - -import Control.Concurrent.Class.MonadSTM -import Control.Exception (SomeException (..)) -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadFork -import Control.Monad.Class.MonadSay -import Control.Monad.Class.MonadST -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer.SI -import Control.Monad.IOSim hiding (SimResult) -import Control.Tracer (Tracer (..), contramap, nullTracer, showTracing, - traceWith) - -import Codec.CBOR.Decoding qualified as CBOR -import Codec.CBOR.Encoding qualified as CBOR -import Codec.CBOR.Read qualified as CBOR - -import Data.ByteString.Lazy (ByteString) -import Data.ByteString.Lazy qualified as BSL -import Data.Foldable as Foldable (find, foldl', toList) -import Data.Function (on) -import Data.List (intercalate, nubBy) -import Data.Maybe (fromMaybe, isJust) -import Data.Sequence (Seq) -import Data.Sequence qualified as Seq -import Data.Set qualified as Set -import Data.Word (Word16) -import GHC.Generics (Generic) - -import Network.TypedProtocol.Codec - -import Ouroboros.Network.Channel -import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM) -import Ouroboros.Network.Driver -import Ouroboros.Network.NodeToNode (NodeToNodeVersion (..)) -import Ouroboros.Network.Protocol.TxSubmission2.Client -import Ouroboros.Network.Protocol.TxSubmission2.Codec -import Ouroboros.Network.Protocol.TxSubmission2.Server -import Ouroboros.Network.Protocol.TxSubmission2.Type -import Ouroboros.Network.TxSubmission.Inbound -import Ouroboros.Network.TxSubmission.Mempool.Reader -import Ouroboros.Network.TxSubmission.Outbound -import Ouroboros.Network.Util.ShowProxy +import Test.Ouroboros.Network.TxSubmission.Common qualified as Common +import Test.Ouroboros.Network.TxSubmission.TxSubmissionV1 qualified as V1 +import Test.Ouroboros.Network.TxSubmission.TxSubmissionV2 qualified as V2 -import Ouroboros.Network.Testing.Utils - -import Test.QuickCheck import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (testProperty) -import Text.Printf - tests :: TestTree -tests = testGroup "TxSubmission" - [ testProperty "txSubmission" prop_txSubmission +tests = testGroup "Ouroboros.Network.TxSubmission" + [ Common.tests + , V1.tests + , V2.tests ] - - -data Tx txid = Tx { - getTxId :: txid, - getTxSize :: SizeInBytes, - -- | If false this means that when this tx will be submitted to a remote - -- mempool it will not be valid. The outbound mempool might contain - -- invalid tx's in this sense. - getTxValid :: Bool - } - deriving (Eq, Show, Generic) - -instance NoThunks txid => NoThunks (Tx txid) -instance ShowProxy txid => ShowProxy (Tx txid) where - showProxy _ = "Tx " ++ showProxy (Proxy :: Proxy txid) - -instance Arbitrary txid => Arbitrary (Tx txid) where - arbitrary = - Tx <$> arbitrary - <*> chooseEnum (0, maxTxSize) - -- note: - -- generating small tx sizes avoids overflow error when semigroup - -- instance of `SizeInBytes` is used (summing up all inflight tx - -- sizes). - <*> frequency [ (3, pure True) - , (1, pure False) - ] - - --- maximal tx size -maxTxSize :: SizeInBytes -maxTxSize = 65536 - - -newtype Mempool m txid = Mempool (TVar m (Seq (Tx txid))) - - -emptyMempool :: MonadSTM m => m (Mempool m txid) -emptyMempool = Mempool <$> newTVarIO Seq.empty - -newMempool :: ( MonadSTM m - , Eq txid - ) - => [Tx txid] - -> m (Mempool m txid) -newMempool = fmap Mempool - . newTVarIO - . Seq.fromList - -readMempool :: MonadSTM m => Mempool m txid -> m [Tx txid] -readMempool (Mempool mempool) = toList <$> readTVarIO mempool - - -getMempoolReader :: forall txid m. - ( MonadSTM m - , Eq txid - , Show txid - ) - => Mempool m txid - -> TxSubmissionMempoolReader txid (Tx txid) Int m -getMempoolReader (Mempool mempool) = - TxSubmissionMempoolReader { mempoolGetSnapshot, mempoolZeroIdx = 0 } - where - mempoolGetSnapshot :: STM m (MempoolSnapshot txid (Tx txid) Int) - mempoolGetSnapshot = getSnapshot <$> readTVar mempool - - getSnapshot :: Seq (Tx txid) - -> MempoolSnapshot txid (Tx txid) Int - getSnapshot seq = - MempoolSnapshot { - mempoolTxIdsAfter = - \idx -> zipWith f [idx + 1 ..] (toList $ Seq.drop idx seq), - -- why do I need to use `pred`? - mempoolLookupTx = flip Seq.lookup seq . pred, - mempoolHasTx = \txid -> isJust $ find (\tx -> getTxId tx == txid) seq - } - - f :: Int -> Tx txid -> (txid, Int, SizeInBytes) - f idx Tx {getTxId, getTxSize} = (getTxId, idx, getTxSize) - - -getMempoolWriter :: forall txid m. - ( MonadSTM m - , Ord txid - , Eq txid - ) - => Mempool m txid - -> TxSubmissionMempoolWriter txid (Tx txid) Int m -getMempoolWriter (Mempool mempool) = - TxSubmissionMempoolWriter { - txId = getTxId, - - mempoolAddTxs = \txs -> do - atomically $ do - mempoolTxs <- readTVar mempool - let currentIds = Set.fromList (map getTxId (toList mempoolTxs)) - validTxs = nubBy (on (==) getTxId) - $ filter - (\Tx { getTxId, getTxValid } -> - getTxValid - && getTxId `Set.notMember` currentIds) - $ txs - mempoolTxs' = Foldable.foldl' (Seq.|>) mempoolTxs validTxs - writeTVar mempool mempoolTxs' - return (map getTxId validTxs) - } - - -txSubmissionCodec2 :: MonadST m - => Codec (TxSubmission2 Int (Tx Int)) - CBOR.DeserialiseFailure m ByteString -txSubmissionCodec2 = - codecTxSubmission2 CBOR.encodeInt CBOR.decodeInt - encodeTx decodeTx - where - encodeTx Tx {getTxId, getTxSize, getTxValid} = - CBOR.encodeListLen 3 - <> CBOR.encodeInt getTxId - <> CBOR.encodeWord32 (getSizeInBytes getTxSize) - <> CBOR.encodeBool getTxValid - - decodeTx = do - _ <- CBOR.decodeListLen - Tx <$> CBOR.decodeInt - <*> (SizeInBytes <$> CBOR.decodeWord32) - <*> CBOR.decodeBool - - -txSubmissionSimulation - :: forall m txid. - ( MonadAsync m - , MonadDelay m - , MonadFork m - , MonadMask m - , MonadSay m - , MonadST m - , MonadSTM m - , MonadTimer m - , MonadThrow m - , MonadThrow (STM m) - , MonadMonotonicTime m - , Ord txid - , Eq txid - , ShowProxy txid - , NoThunks (Tx txid) - - , txid ~ Int - ) - => NumTxIdsToAck - -> [Tx txid] - -> ControlMessageSTM m - -> Maybe DiffTime - -> Maybe DiffTime - -> m ([Tx txid], [Tx txid]) -txSubmissionSimulation maxUnacked outboundTxs - controlMessageSTM - inboundDelay outboundDelay = do - - inboundMempool <- emptyMempool - outboundMempool <- newMempool outboundTxs - (outboundChannel, inboundChannel) <- createConnectedChannels - outboundAsync <- - async $ runPeerWithLimits - (("OUTBOUND",) `contramap` verboseTracer) - txSubmissionCodec2 - (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) - timeLimitsTxSubmission2 - (maybe id delayChannel outboundDelay outboundChannel) - (txSubmissionClientPeer (outboundPeer outboundMempool)) - - inboundAsync <- - async $ runPipelinedPeerWithLimits - (("INBOUND",) `contramap` verboseTracer) - txSubmissionCodec2 - (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) - timeLimitsTxSubmission2 - (maybe id delayChannel inboundDelay inboundChannel) - (txSubmissionServerPeerPipelined (inboundPeer inboundMempool)) - - _ <- waitAnyCancel [ outboundAsync, inboundAsync ] - - inmp <- readMempool inboundMempool - outmp <- readMempool outboundMempool - return (inmp, outmp) - where - - outboundPeer :: Mempool m txid -> TxSubmissionClient txid (Tx txid) m () - outboundPeer outboundMempool = - txSubmissionOutbound - nullTracer - maxUnacked - (getMempoolReader outboundMempool) - NodeToNodeV_7 - controlMessageSTM - - inboundPeer :: Mempool m txid -> TxSubmissionServerPipelined txid (Tx txid) m () - inboundPeer inboundMempool = - txSubmissionInbound - nullTracer - maxUnacked - (getMempoolReader inboundMempool) - (getMempoolWriter inboundMempool) - NodeToNodeV_7 - - -newtype LargeNonEmptyList a = LargeNonEmpty { getLargeNonEmpty :: [a] } - deriving Show - -instance Arbitrary a => Arbitrary (LargeNonEmptyList a) where - arbitrary = - LargeNonEmpty <$> suchThat (resize 500 (listOf arbitrary)) ((>25) . length) - -prop_txSubmission :: Positive Word16 - -> NonEmptyList (Tx Int) - -> Maybe (Positive SmallDelay) - -- ^ The delay must be smaller (<) than 5s, so that overall - -- delay is less than 10s, otherwise 'smallDelay' in - -- 'timeLimitsTxSubmission2' will kick in. - -> Property -prop_txSubmission (Positive maxUnacked) (NonEmpty outboundTxs) delay = - let mbDelayTime = getSmallDelay . getPositive <$> delay - tr = (runSimTrace $ do - controlMessageVar <- newTVarIO Continue - _ <- - async $ do - threadDelay - (fromMaybe 1 mbDelayTime - * realToFrac (length outboundTxs `div` 4)) - atomically (writeTVar controlMessageVar Terminate) - txSubmissionSimulation - (NumTxIdsToAck maxUnacked) outboundTxs - (readTVar controlMessageVar) - mbDelayTime mbDelayTime - ) in - ioProperty $ do - tr' <- evaluateTrace tr - case tr' of - SimException e trace -> do - return $ counterexample (intercalate "\n" $ show e : trace) False - SimDeadLock trace -> do - return $ counterexample (intercalate "\n" $ "Deadlock" : trace) False - SimReturn (inmp, outmp) _trace -> do - -- printf "Log: %s\n" (intercalate "\n" _trace) - let outUniqueTxIds = nubBy (on (==) getTxId) outmp - outValidTxs = filter getTxValid outmp - case (length outUniqueTxIds == length outmp, length outValidTxs == length outmp) of - (True, True) -> - -- If we are presented with a stream of unique txids for valid - -- transactions the inbound transactions should match the outbound - -- transactions exactly. - return $ inmp === take (length inmp) outValidTxs - (True, False) -> - -- If we are presented with a stream of unique txids then we should have - -- fetched all valid transactions. - return $ inmp === take (length inmp) outValidTxs - (False, True) -> - -- If we are presented with a stream of valid txids then we should have - -- fetched some version of those transactions. - return $ map getTxId inmp === take (length inmp) (map getTxId $ - filter getTxValid outUniqueTxIds) - (False, False) - -- If we are presented with a stream of valid and invalid Txs with - -- duplicate txids we're content with completing the protocol - -- without error. - -> return $ property True - - --- TODO: Belongs in iosim. -data SimResult a = SimReturn a [String] - | SimException SomeException [String] - | SimDeadLock [String] - --- Traverses a list of trace events and returns the result along with all log messages. --- Incase of a pure exception, ie an assert, all tracers evaluated so far are returned. -evaluateTrace :: SimTrace a -> IO (SimResult a) -evaluateTrace = go [] - where - go as tr = do - r <- try (evaluate tr) - case r of - Right (SimTrace _ _ _ (EventSay s) tr') -> go (s : as) tr' - Right (SimTrace _ _ _ _ tr' ) -> go as tr' - Right (SimPORTrace _ _ _ _ (EventSay s) tr') -> go (s : as) tr' - Right (SimPORTrace _ _ _ _ _ tr' ) -> go as tr' - Right (TraceMainReturn _ _ a _) -> pure $ SimReturn a (reverse as) - Right (TraceMainException _ _ e _) -> pure $ SimException e (reverse as) - Right (TraceDeadlock _ _) -> pure $ SimDeadLock (reverse as) - Right TraceLoop -> error "IOSimPOR step time limit exceeded" - Right (TraceInternalError e) -> error ("IOSim: " ++ e) - Left (SomeException e) -> pure $ SimException (SomeException e) (reverse as) - -data WithThreadAndTime a = WithThreadAndTime { - wtatOccuredAt :: !Time - , wtatWithinThread :: !String - , wtatEvent :: !a - } - -instance (Show a) => Show (WithThreadAndTime a) where - show WithThreadAndTime {wtatOccuredAt, wtatWithinThread, wtatEvent} = - printf "%s: %s: %s" (show wtatOccuredAt) (show wtatWithinThread) (show wtatEvent) - -verboseTracer :: forall a m. - ( MonadAsync m - , MonadDelay m - , MonadSay m - , MonadMonotonicTime m - , Show a - ) - => Tracer m a -verboseTracer = threadAndTimeTracer $ showTracing $ Tracer say - -threadAndTimeTracer :: forall a m. - ( MonadAsync m - , MonadDelay m - , MonadMonotonicTime m - ) - => Tracer m (WithThreadAndTime a) -> Tracer m a -threadAndTimeTracer tr = Tracer $ \s -> do - !now <- getMonotonicTime - !tid <- myThreadId - traceWith tr $ WithThreadAndTime now (show tid) s diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/Common.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/Common.hs new file mode 100644 index 00000000000..f8a2d517954 --- /dev/null +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/Common.hs @@ -0,0 +1,2086 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Ouroboros.Network.TxSubmission.Common where + +import Prelude hiding (seq) + +import NoThunks.Class + +import Control.Concurrent.Class.MonadSTM +import Control.Exception (SomeException (..), assert) +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadSay +import Control.Monad.Class.MonadST +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI +import Control.Monad.IOSim hiding (SimResult) +import Control.Tracer (Tracer (..), showTracing, traceWith) + +import Codec.CBOR.Decoding qualified as CBOR +import Codec.CBOR.Encoding qualified as CBOR +import Codec.CBOR.Read qualified as CBOR + +import Data.ByteString.Lazy (ByteString) +import Data.Foldable as Foldable (find, fold, foldl', toList) +import Data.Function (on) +import Data.List (intercalate, isPrefixOf, isSuffixOf, mapAccumR, nub, nubBy, + stripPrefix) +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, isJust, maybeToList) +import Data.Monoid (Sum (..)) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Generics (Generic) + +import Network.TypedProtocol.Codec + +import Ouroboros.Network.Protocol.TxSubmission2.Codec +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound +import Ouroboros.Network.TxSubmission.Inbound.Decision qualified as TXS +import Ouroboros.Network.TxSubmission.Inbound.State (PeerTxState (..), + SharedTxState (..)) +import Ouroboros.Network.TxSubmission.Inbound.State qualified as TXS +import Ouroboros.Network.TxSubmission.Mempool.Reader +import Ouroboros.Network.Util.ShowProxy + +import Test.Ouroboros.Network.BlockFetch (PeerGSVT (..)) + +import Test.QuickCheck +import Test.QuickCheck.Function (apply) +import Test.QuickCheck.Monoids (All (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Text.Pretty.Simple +import Text.Printf + +import GHC.Stack (HasCallStack) + +tests :: TestTree +tests = testGroup "Ouroboros.Network.TxSubmission.Common" + [ testGroup "State" + [ testGroup "Arbitrary" + [ testGroup "ArbSharedTxState" + [ testProperty "generator" prop_SharedTxState_generator + , testProperty "shrinker" $ withMaxSuccess 10 + prop_SharedTxState_shrinker + , testProperty "nothunks" prop_SharedTxState_nothunks + ] + , testGroup "ArbReceivedTxIds" + [ testProperty "generator" prop_receivedTxIds_generator + ] + , testGroup "ArbCollectTxs" + [ testProperty "generator" prop_collectTxs_generator + , testProperty "shrinker" $ withMaxSuccess 10 + prop_collectTxs_shrinker + ] + ] + , testProperty "acknowledgeTxIds" prop_acknowledgeTxIds + , testProperty "receivedTxIdsImpl" prop_receivedTxIdsImpl + , testProperty "collectTxsImpl" prop_collectTxsImpl + , testProperty "numTxIdsToRequest" prop_numTxIdsToRequest + , testGroup "NoThunks" + [ testProperty "receivedTxIdsImpl" prop_receivedTxIdsImpl_nothunks + , testProperty "collectTxsImpl" prop_collectTxsImpl_nothunks + ] + ] + , testGroup "Decisions" + [ testGroup "ArbDecisionContexts" + [ testProperty "generator" prop_ArbDecisionContexts_generator + , testProperty "shrinker" $ withMaxSuccess 33 + prop_ArbDecisionContexts_shrinker + ] + , testProperty "shared state invariant" prop_makeDecisions_sharedstate + , testProperty "inflight" prop_makeDecisions_inflight + , testProperty "policy" prop_makeDecisions_policy + , testProperty "acknowledged" prop_makeDecisions_acknowledged + , testProperty "exhaustive" prop_makeDecisions_exhaustive + , testProperty "receivedTxIds" prop_makeDecisions_receivedTxIds + , testProperty "collectTxs" prop_makeDecisions_collectTxs + ] + , testGroup "Registry" + [ testGroup "filterActivePeers" + [ testProperty "not limiting decisions" prop_filterActivePeers_not_limitting_decisions + ] + ] + ] + +data Tx txid = Tx { + getTxId :: !txid, + getTxSize :: !SizeInBytes, + -- | If false this means that when this tx will be submitted to a remote + -- mempool it will not be valid. The outbound mempool might contain + -- invalid tx's in this sense. + getTxValid :: !Bool + } + deriving (Eq, Ord, Show, Generic) + +instance NoThunks txid => NoThunks (Tx txid) +instance ShowProxy txid => ShowProxy (Tx txid) where + showProxy _ = "Tx " ++ showProxy (Proxy :: Proxy txid) + +instance Arbitrary txid => Arbitrary (Tx txid) where + arbitrary = + Tx <$> arbitrary + <*> chooseEnum (0, maxTxSize) + -- note: + -- generating small tx sizes avoids overflow error when semigroup + -- instance of `SizeInBytes` is used (summing up all inflight tx + -- sizes). + <*> frequency [ (3, pure True) + , (1, pure False) + ] + +-- maximal tx size +maxTxSize :: SizeInBytes +maxTxSize = 65536 + +type TxId = Int + +newtype Mempool m txid = Mempool (TVar m (Seq (Tx txid))) + + +emptyMempool :: MonadSTM m => m (Mempool m txid) +emptyMempool = Mempool <$> newTVarIO Seq.empty + +newMempool :: ( MonadSTM m + , Eq txid + ) + => [Tx txid] + -> m (Mempool m txid) +newMempool = fmap Mempool + . newTVarIO + . Seq.fromList + +readMempool :: MonadSTM m => Mempool m txid -> m [Tx txid] +readMempool (Mempool mempool) = toList <$> readTVarIO mempool + + +getMempoolReader :: forall txid m. + ( MonadSTM m + , Eq txid + , Show txid + ) + => Mempool m txid + -> TxSubmissionMempoolReader txid (Tx txid) Int m +getMempoolReader (Mempool mempool) = + TxSubmissionMempoolReader { mempoolGetSnapshot, mempoolZeroIdx = 0 } + where + mempoolGetSnapshot :: STM m (MempoolSnapshot txid (Tx txid) Int) + mempoolGetSnapshot = getSnapshot <$> readTVar mempool + + getSnapshot :: Seq (Tx txid) + -> MempoolSnapshot txid (Tx txid) Int + getSnapshot seq = + MempoolSnapshot { + mempoolTxIdsAfter = + \idx -> zipWith f [idx + 1 ..] (toList $ Seq.drop idx seq), + -- why do I need to use `pred`? + mempoolLookupTx = flip Seq.lookup seq . pred, + mempoolHasTx = \txid -> isJust $ find (\tx -> getTxId tx == txid) seq + } + + f :: Int -> Tx txid -> (txid, Int, SizeInBytes) + f idx Tx {getTxId, getTxSize} = (getTxId, idx, getTxSize) + + +getMempoolWriter :: forall txid m. + ( MonadSTM m + , Ord txid + , Eq txid + ) + => Mempool m txid + -> TxSubmissionMempoolWriter txid (Tx txid) Int m +getMempoolWriter (Mempool mempool) = + TxSubmissionMempoolWriter { + txId = getTxId, + + mempoolAddTxs = \txs -> do + atomically $ do + mempoolTxs <- readTVar mempool + let currentIds = Set.fromList (map getTxId (toList mempoolTxs)) + validTxs = nubBy (on (==) getTxId) + $ filter + (\Tx { getTxId, getTxValid } -> + getTxValid + && getTxId `Set.notMember` currentIds) + txs + mempoolTxs' = Foldable.foldl' (Seq.|>) mempoolTxs validTxs + writeTVar mempool mempoolTxs' + return (map getTxId validTxs) + } + + +txSubmissionCodec2 :: MonadST m + => Codec (TxSubmission2 Int (Tx Int)) + CBOR.DeserialiseFailure m ByteString +txSubmissionCodec2 = + codecTxSubmission2 CBOR.encodeInt CBOR.decodeInt + encodeTx decodeTx + where + encodeTx Tx {getTxId, getTxSize, getTxValid} = + CBOR.encodeListLen 3 + <> CBOR.encodeInt getTxId + <> CBOR.encodeWord32 (getSizeInBytes getTxSize) + <> CBOR.encodeBool getTxValid + + decodeTx = do + _ <- CBOR.decodeListLen + Tx <$> CBOR.decodeInt + <*> (SizeInBytes <$> CBOR.decodeWord32) + <*> CBOR.decodeBool + + +newtype LargeNonEmptyList a = LargeNonEmpty { getLargeNonEmpty :: [a] } + deriving Show + +instance Arbitrary a => Arbitrary (LargeNonEmptyList a) where + arbitrary = + LargeNonEmpty <$> suchThat (resize 500 (listOf arbitrary)) ((>25) . length) + + +-- TODO: Belongs in iosim. +data SimResults a = SimReturn a [String] + | SimException SomeException [String] + | SimDeadLock [String] + +-- Traverses a list of trace events and returns the result along with all log messages. +-- Incase of a pure exception, ie an assert, all tracers evaluated so far are returned. +evaluateTrace :: SimTrace a -> IO (SimResults a) +evaluateTrace = go [] + where + go as tr = do + r <- try (evaluate tr) + case r of + Right (SimTrace _ _ _ (EventSay s) tr') -> go (s : as) tr' + Right (SimTrace _ _ _ _ tr' ) -> go as tr' + Right (SimPORTrace _ _ _ _ (EventSay s) tr') -> go (s : as) tr' + Right (SimPORTrace _ _ _ _ _ tr' ) -> go as tr' + Right (TraceMainReturn _ _ a _) -> pure $ SimReturn a (reverse as) + Right (TraceMainException _ _ e _) -> pure $ SimException e (reverse as) + Right (TraceDeadlock _ _) -> pure $ SimDeadLock (reverse as) + Right TraceLoop -> error "IOSimPOR step time limit exceeded" + Right (TraceInternalError e) -> error ("IOSim: " ++ e) + Left (SomeException e) -> pure $ SimException (SomeException e) (reverse as) + +data WithThreadAndTime a = WithThreadAndTime { + wtatOccuredAt :: !Time + , wtatWithinThread :: !String + , wtatEvent :: !a + } + +instance (Show a) => Show (WithThreadAndTime a) where + show WithThreadAndTime {wtatOccuredAt, wtatWithinThread, wtatEvent} = + printf "%s: %s: %s" (show wtatOccuredAt) (show wtatWithinThread) (show wtatEvent) + +verboseTracer :: forall a m. + ( MonadAsync m + , MonadDelay m + , MonadSay m + , MonadMonotonicTime m + , Show a + ) + => Tracer m a +verboseTracer = threadAndTimeTracer $ showTracing $ Tracer say + +debugTracer :: forall a s. Show a => Tracer (IOSim s) a +debugTracer = threadAndTimeTracer $ showTracing $ Tracer (traceM . show) + +threadAndTimeTracer :: forall a m. + ( MonadAsync m + , MonadDelay m + , MonadMonotonicTime m + ) + => Tracer m (WithThreadAndTime a) -> Tracer m a +threadAndTimeTracer tr = Tracer $ \s -> do + !now <- getMonotonicTime + !tid <- myThreadId + traceWith tr $ WithThreadAndTime now (show tid) s + + +-- +-- InboundState properties +-- + +type PeerAddr = Int + +-- | 'InboundState` invariant. +-- +sharedTxStateInvariant + :: forall peeraddr txid tx. + ( Ord txid + , Show txid + ) + => SharedTxState peeraddr txid tx + -> Property +sharedTxStateInvariant SharedTxState { + peerTxStates, + inflightTxs, + inflightTxsSize, + bufferedTxs, + referenceCounts + } = + + -- -- `inflightTxs` and `bufferedTxs` are disjoint + -- counterexample "inflightTxs not disjoint with bufferedTxs" + -- (null (inflightTxsSet `Set.intersection` bufferedTxsSet)) + + -- the set of buffered txids is equal to sum of the sets of + -- unacknowledged txids. + counterexample "bufferedTxs txid not a subset of unacknoledged txids" + (bufferedTxsSet + `Set.isSubsetOf` + foldr (\PeerTxState { unacknowledgedTxIds } r -> + r <> Set.fromList (toList unacknowledgedTxIds)) + Set.empty txStates) + + .&&. counterexample "referenceCounts invariant violation" + ( referenceCounts + === + foldl' + (\m PeerTxState { unacknowledgedTxIds = unacked } -> + foldl' + (flip $ + Map.alter (\case + Nothing -> Just $! 1 + Just cnt -> Just $! succ cnt) + ) + m + unacked + ) + Map.empty txStates + ) + + .&&. counterexample ("bufferedTxs contain tx which should be gc-ed: " + ++ show (Map.keysSet bufferedTxs `Set.difference` liveSet)) + (Map.keysSet bufferedTxs `Set.isSubsetOf` liveSet) + + .&&. counterexample "inflightTxs must be a sum of requestedTxInflight sets" + (inflightTxs + === + foldr (\PeerTxState { requestedTxsInflight } m -> + Map.unionWith (+) (Map.fromSet (\_ -> 1) requestedTxsInflight) m) + Map.empty + peerTxStates) + + -- PeerTxState invariants + .&&. counterexample "PeerTxState invariant violation" + (foldMap (\ps -> All + . counterexample (show ps) + . peerTxStateInvariant + $ ps + ) + peerTxStates) + + .&&. counterexample "inflightTxsSize invariant violation" + (inflightTxsSize === foldMap requestedTxsInflightSize peerTxStates) + + + + where + peerTxStateInvariant :: PeerTxState txid tx -> Property + peerTxStateInvariant PeerTxState { availableTxIds, + unacknowledgedTxIds, + unknownTxs, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize } = + + + counterexample ("unknownTxs is not a subset of unacknowledgedTxIds: " + ++ show (unknownTxs Set.\\ unacknowledgedTxIdsSet)) + (unknownTxs `Set.isSubsetOf` unacknowledgedTxIdsSet) + + .&&. counterexample ("availableTxs is not a subset of unacknowledgedTxIds: " + ++ show (availableTxIdsSet Set.\\ unacknowledgedTxIdsSet)) + (availableTxIdsSet `Set.isSubsetOf` unacknowledgedTxIdsSet) + + .&&. counterexample ("unacknowledged tx must be either available, unknown or buffered: " + ++ show (unacknowledgedTxIdsSet + Set.\\ availableTxIdsSet + Set.\\ unknownTxs + Set.\\ bufferedTxsSet)) + (unacknowledgedTxIdsSet + Set.\\ availableTxIdsSet + Set.\\ unknownTxs + `Set.isSubsetOf` + bufferedTxsSet + ) + + .&&. counterexample "requestedTxIdsInflight invariant violation" + (requestedTxIdsInflight >= 0) + + -- a requested tx is either available or buffered + .&&. counterexample ("requestedTxsInflight invariant violation: " + ++ show (requestedTxsInflight + Set.\\ availableTxIdsSet + Set.\\ bufferedTxsSet)) + (requestedTxsInflight Set.\\ availableTxIdsSet `Set.isSubsetOf` bufferedTxsSet) + + .&&. counterexample "requestedTxsInfightSize" + (requestedTxsInflightSize + === + fold (availableTxIds `Map.restrictKeys` requestedTxsInflight)) + + where + availableTxIdsSet :: Set txid + availableTxIdsSet = Map.keysSet availableTxIds + + unacknowledgedTxIdsSet :: Set txid + unacknowledgedTxIdsSet = Set.fromList (toList unacknowledgedTxIds) + + bufferedTxsSet = Map.keysSet bufferedTxs :: Set txid + liveSet = Map.keysSet referenceCounts :: Set txid + txStates = Map.elems peerTxStates :: [PeerTxState txid tx] + +-- +-- Generate `InboundState` +-- + +-- | PeerTxState generator. +-- +-- `mkArbPeerTxState` is the smart constructor. +-- +data ArbPeerTxState txid tx = + ArbPeerTxState { arbPeerTxState :: PeerTxState txid tx, + arbInflightSet :: Set tx, + -- ^ in-flight txs + arbBufferedMap :: Map txid (Maybe tx) + } + +data TxStatus = Available | Inflight | Unknown + +instance Arbitrary TxStatus where + arbitrary = oneof [ pure Available + , pure Inflight + , pure Unknown + ] + +data TxMask tx = TxAvailable tx TxStatus + -- ^ available txid with its size, the Bool indicates if it's + -- in-flight or not + | TxBuffered tx + +fixupTxMask :: txid -> TxMask (Tx txid) -> TxMask (Tx txid) +fixupTxMask txid (TxAvailable tx status) = TxAvailable tx { getTxId = txid } status +fixupTxMask txid (TxBuffered tx) = TxBuffered tx { getTxId = txid } + + +instance Arbitrary tx => Arbitrary (TxMask tx) where + arbitrary = oneof [ TxAvailable + <$> arbitrary + <*> arbitrary + , TxBuffered <$> arbitrary + ] + + -- TODO: implement shrinker; this can be done by writing an inverse of + -- `mkArbPeerTxState` and shrinking the unacknowledged txs & mask map. + + +-- | Smart constructor for `ArbPeerTxState`. +-- +mkArbPeerTxState :: Ord txid + => Fun txid Bool + -> Int -- ^ txids in-flight + -> [txid] + -> Map txid (TxMask (Tx txid)) + -> ArbPeerTxState txid (Tx txid) +mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMaskMap = + ArbPeerTxState + PeerTxState { unacknowledgedTxIds = StrictSeq.fromList unacked, + availableTxIds, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize, + unknownTxs } + (Set.fromList $ Map.elems inflightMap) + bufferedMap + where + mempoolHasTx = apply mempoolHasTxFun + availableTxIds = Map.fromList + [ (txid, getTxSize tx) | (txid, TxAvailable tx _) <- Map.assocs txMaskMap + , not (mempoolHasTx txid) + ] + unknownTxs = Set.fromList + [ txid | (txid, TxAvailable _ Unknown) <- Map.assocs txMaskMap + , not (mempoolHasTx txid) + ] + + requestedTxIdsInflight = fromIntegral txIdsInflight + requestedTxsInflightSize = foldMap getTxSize inflightMap + requestedTxsInflight = Map.keysSet inflightMap + + -- exclude `txid`s which are already in the mempool, we never request such + -- `txid`s + -- + -- TODO: this should be lifted, we might have the same txid in-flight from + -- multiple peers, one will win the race and land in the mempool first + inflightMap = Map.fromList + [ (txid, tx) + | (txid, TxAvailable tx Inflight) <- Map.assocs txMaskMap + , not (mempoolHasTx txid) + ] + + bufferedMap = Map.fromList + [ (txid, Nothing) + | txid <- Map.keys txMaskMap + , mempoolHasTx txid + ] + `Map.union` + Map.fromList + [ (txid, mtx) + | (txid, TxBuffered tx) <- Map.assocs txMaskMap + , let !mtx = if mempoolHasTx txid + then Nothing + else Just $! tx { getTxId = txid } + ] + + +genArbPeerTxState + :: forall txid. + ( Arbitrary txid + , Ord txid + ) + => Fun txid Bool + -> Int -- ^ max txids inflight + -> Gen (ArbPeerTxState txid (Tx txid)) +genArbPeerTxState mempoolHasTxFun maxTxIdsInflight = do + -- unacknowledged sequence + unacked <- arbitrary + -- generate `Map txid (TxMask tx)` + txIdsInflight <- choose (0, maxTxIdsInflight) + txMap <- Map.fromList + <$> traverse (\txid -> (\a -> (txid, fixupTxMask txid a)) <$> arbitrary) + (nub unacked) + return $ mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMap + + +genSharedTxState + :: forall txid. + ( Arbitrary txid + , Ord txid + , Function txid + , CoArbitrary txid + ) + => Int -- ^ max txids inflight + -> Gen ( Fun txid Bool + , (PeerAddr, PeerTxState txid (Tx txid)) + , SharedTxState PeerAddr txid (Tx txid) + , Map PeerAddr (ArbPeerTxState txid (Tx txid)) + ) +genSharedTxState maxTxIdsInflight = do + _mempoolHasTxFun@(Fun (_, _, x) _) <- arbitrary :: Gen (Fun Bool Bool) + let mempoolHasTxFun = Fun (function (const False), False, x) (const False) + pss <- listOf1 (genArbPeerTxState mempoolHasTxFun maxTxIdsInflight) + + let pss' :: [(PeerAddr, ArbPeerTxState txid (Tx txid))] + pss' = [0..] `zip` pss + + peer <- choose (0, length pss - 1) + + let st :: SharedTxState PeerAddr txid (Tx txid) + st = fixupSharedTxState + (apply mempoolHasTxFun) + SharedTxState { + peerTxStates = Map.fromList + [ (peeraddr, arbPeerTxState) + | (peeraddr, ArbPeerTxState { arbPeerTxState }) + <- pss' + ], + inflightTxs = foldl' (Map.unionWith (+)) Map.empty + [ Map.fromSet (const 1) (Set.map getTxId arbInflightSet) + | ArbPeerTxState { arbInflightSet } + <- pss + ], + inflightTxsSize = 0, -- It is set by fixupSharedTxState + bufferedTxs = fold + [ arbBufferedMap + | ArbPeerTxState { arbBufferedMap } + <- pss + ], + referenceCounts = Map.empty + } + + return ( mempoolHasTxFun + , (peer, peerTxStates st Map.! peer) + , st + , Map.fromList pss' + ) + + +-- | Make sure `SharedTxState` is well formed. +-- +fixupSharedTxState + :: Ord txid + => (txid -> Bool) -- ^ mempoolHasTx + -> SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx +fixupSharedTxState _mempoolHasTx st@SharedTxState { peerTxStates } = + st { peerTxStates = peerTxStates', + inflightTxs = inflightTxs', + inflightTxsSize = foldMap requestedTxsInflightSize peerTxStates', + bufferedTxs = bufferedTxs', + referenceCounts = referenceCounts' + } + where + peerTxStates' = + Map.map (\ps@PeerTxState { availableTxIds, + requestedTxsInflight } -> + + let -- requested txs must not be buffered + requestedTxsInflight' = requestedTxsInflight + Set.\\ Map.keysSet bufferedTxs' + requestedTxsInflightSize' = fold $ availableTxIds + `Map.restrictKeys` + requestedTxsInflight' + + in ps { requestedTxsInflight = requestedTxsInflight', + requestedTxsInflightSize = requestedTxsInflightSize' } + ) + peerTxStates + + inflightTxs' = foldr (\PeerTxState { requestedTxsInflight } m -> + Map.unionWith (+) + (Map.fromSet (const 1) requestedTxsInflight) + m + ) + Map.empty + peerTxStates' + + bufferedTxs' = + bufferedTxs st + `Map.restrictKeys` + foldr (\PeerTxState {unacknowledgedTxIds = unacked } r -> + r <> Set.fromList (toList unacked)) + Set.empty (Map.elems peerTxStates) + + + referenceCounts' = + foldl' + (\m PeerTxState { unacknowledgedTxIds } -> + foldl' + (flip $ + Map.alter (\case + Nothing -> Just $! 1 + Just cnt -> Just $! succ cnt) + ) + m + unacknowledgedTxIds + ) + Map.empty + (Map.elems peerTxStates) + + +shrinkSharedTxState :: ( Arbitrary txid + , Ord txid + , Function txid + , Ord peeraddr + ) + => (txid -> Bool) + -> SharedTxState peeraddr txid (Tx txid) + -> [SharedTxState peeraddr txid (Tx txid)] +shrinkSharedTxState mempoolHasTx st@SharedTxState { peerTxStates, + inflightTxs, + bufferedTxs } = + [ st' + | peerTxStates' <- Map.fromList <$> shrinkList (\_ -> []) (Map.toList peerTxStates) + , not (Map.null peerTxStates') + , let st' = fixupSharedTxState mempoolHasTx st { peerTxStates = peerTxStates' } + , st' /= st + ] + ++ + [ fixupSharedTxState mempoolHasTx st { inflightTxs = inflightTxs' } + | inflightTxs' <- Map.fromList <$> shrinkList (\_ -> []) (Map.toList inflightTxs) + ] + ++ + [ st + | bufferedTxs' <- Map.fromList + <$> shrinkList (\_ -> []) (Map.assocs bufferedTxs) + , let minBuffered = + foldMap + (\PeerTxState { + unacknowledgedTxIds, + availableTxIds, + unknownTxs + } + -> + Set.fromList (toList unacknowledgedTxIds) + Set.\\ Map.keysSet availableTxIds + Set.\\ unknownTxs + ) + peerTxStates + bufferedTxs'' = bufferedTxs' + `Map.union` + (bufferedTxs `Map.restrictKeys` minBuffered) + st' = fixupSharedTxState mempoolHasTx st { bufferedTxs = bufferedTxs'' } + , st' /= st + ] + +-- +-- Arbitrary `SharaedTxState` instance +-- + +data ArbSharedTxState = + ArbSharedTxState + (Fun TxId Bool) + (SharedTxState PeerAddr TxId (Tx TxId)) + deriving Show + +instance Arbitrary ArbSharedTxState where + arbitrary = do + Small maxTxIdsInflight <- arbitrary + (mempoolHasTx, _, sharedTxState, _) <- genSharedTxState maxTxIdsInflight + return $ ArbSharedTxState mempoolHasTx sharedTxState + + shrink (ArbSharedTxState mempoolHasTx st) = + [ ArbSharedTxState mempoolHasTx st' + | st' <- shrinkSharedTxState (apply mempoolHasTx) st + ] + + +-- | Verify that generated `SharedTxState` has no thunks if it's evaluated to +-- WHNF. +-- +prop_SharedTxState_nothunks :: ArbSharedTxState -> Property +prop_SharedTxState_nothunks (ArbSharedTxState _ !st) = + case unsafeNoThunks st of + Nothing -> property True + Just ctx -> counterexample (show ctx) False + + +prop_SharedTxState_generator + :: ArbSharedTxState + -> Property +prop_SharedTxState_generator (ArbSharedTxState _ st) = sharedTxStateInvariant st + + +prop_SharedTxState_shrinker + :: Fixed ArbSharedTxState + -> Property +prop_SharedTxState_shrinker = + property + . foldMap (\(ArbSharedTxState _ st) -> All $ sharedTxStateInvariant st) + . shrink + . getFixed + + +-- +-- `receivedTxIdsImpl` properties +-- + + +data ArbReceivedTxIds = + ArbReceivedTxIds (Fun TxId Bool) -- ^ mempoolHasTx + [Tx TxId] -- ^ some txs to acknowledge + PeerAddr -- ^ peer address + (PeerTxState TxId (Tx TxId)) + -- ^ peer state + (SharedTxState PeerAddr TxId (Tx TxId)) + -- ^ initial state + deriving Show + +instance Arbitrary ArbReceivedTxIds where + arbitrary = do + Small maxTxIdsInflight <- arbitrary + (mempoolHasTxFun, (peeraddr, ps), st, psMap) <- genSharedTxState maxTxIdsInflight + txsToAck <- sublistOf (Set.toList $ arbInflightSet (psMap Map.! peeraddr)) + pure $ ArbReceivedTxIds + mempoolHasTxFun + txsToAck + peeraddr + ps + st + + shrink (ArbReceivedTxIds mempoolHasTxFun txs peeraddr ps st) = + [ ArbReceivedTxIds mempoolHasTxFun txs' peeraddr ps st + | txs' <- shrink txs + ] + ++ + [ ArbReceivedTxIds + mempoolHasTxFun' txs peeraddr ps + (fixupSharedTxState (apply mempoolHasTxFun') st) + | mempoolHasTxFun' <- shrink mempoolHasTxFun + ] + + +prop_receivedTxIds_generator + :: ArbReceivedTxIds + -> Property +prop_receivedTxIds_generator (ArbReceivedTxIds _ someTxsToAck _peeraddr _ps st) = + label ("numToAck " ++ labelInt 100 10 (length someTxsToAck)) + . counterexample (show st) + $ sharedTxStateInvariant st + + +-- | This property verifies that `acknowledgeTxIds` acknowledges a prefix of +-- unacknowledged txs, and that the `numTxIdsToAck` as well as `RefCoundDiff` +-- are correct. +-- +-- It doesn't validate the returned `PeerTxState` holds it's properties as this +-- needs to be done in the context of updated `SharedTxState`. This is verified +-- by `prop_receivedTxIdsImpl`, `prop_collectTxsImpl` and +-- `prop_makeDecisions_acknowledged`. +-- +prop_acknowledgeTxIds :: ArbDecisionContextWithReceivedTxIds + -> Property +prop_acknowledgeTxIds (ArbDecisionContextWithReceivedTxIds policy SharedDecisionContext { sdcSharedTxState = st } ps _ _ _) = + case TXS.acknowledgeTxIds policy st ps of + (numTxIdsToAck, txIdsToRequest, txs, TXS.RefCountDiff { TXS.txIdsToAck }, ps') | txIdsToRequest > 0 -> + counterexample "number of tx ids to ack must agree with RefCountDiff" + ( fromIntegral numTxIdsToAck + === + getSum (foldMap Sum txIdsToAck) + ) + + .&&. counterexample "acknowledged txs must form a prefix" + let unacked = toList (unacknowledgedTxIds ps) + unacked' = toList (unacknowledgedTxIds ps') + in case unacked `stripSuffix` unacked' of + Nothing -> counterexample "acknowledged txs are not a prefix" False + Just txIdsToAck' -> + txIdsToAck + === + Map.fromListWith (+) ((,1) <$> txIdsToAck') + + .&&. counterexample "acknowledged txs" (counterexample ("numTxIdsToAck = " ++ show numTxIdsToAck) + let acked :: [TxId] + acked = [ txid + | txid <- take (fromIntegral numTxIdsToAck) (toList $ unacknowledgedTxIds ps) + , Just _ <- maybeToList $ txid `Map.lookup` bufferedTxs st + ] + in getTxId `map` txs === acked) + _otherwise -> property True + where + stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] + stripSuffix as suffix = + reverse <$> reverse suffix `stripPrefix` reverse as + + +-- | Verify 'inboundStateInvariant' when acknowledging a sequence of txs. +-- +prop_receivedTxIdsImpl + :: ArbReceivedTxIds + -> Property +prop_receivedTxIdsImpl (ArbReceivedTxIds mempoolHasTxFun txs peeraddr ps st) = + -- InboundState invariant + counterexample + ( "Unacknowledged in mempool: " ++ + show (apply mempoolHasTxFun <$> toList (unacknowledgedTxIds ps)) ++ "\n" + ++ "InboundState invariant violation:\n" ++ + show st' + ) + (sharedTxStateInvariant st') + + -- unacknowledged txs are well formed + .&&. counterexample "unacknowledged txids are not well formed" + ( let unacked = toList $ unacknowledgedTxIds ps <> txidSeq + unacked' = toList $ unacknowledgedTxIds ps' + in counterexample ("old & received: " ++ show unacked ++ "\n" ++ + "new: " ++ show unacked') $ + unacked' `isSuffixOf` unacked + ) + + .&&. -- `receivedTxIdsImpl` doesn't acknowledge any `txids` + counterexample "acknowledged property violation" + ( let unacked = toList $ unacknowledgedTxIds ps + unacked' = toList $ unacknowledgedTxIds ps' + in unacked `isPrefixOf` unacked' + ) + where + st' = TXS.receivedTxIdsImpl (apply mempoolHasTxFun) + peeraddr 0 txidSeq txidMap st + ps' = peerTxStates st' Map.! peeraddr + + txidSeq = StrictSeq.fromList (getTxId <$> txs) + txidMap = Map.fromList [ (getTxId tx, getTxSize tx) | tx <- txs ] + + +-- | Verify that `SharedTxState` returned by `receivedTxIdsImpl` if evaluated +-- to WHNF it doesn't contain any thunks. +-- +prop_receivedTxIdsImpl_nothunks + :: ArbReceivedTxIds + -> Property +prop_receivedTxIdsImpl_nothunks (ArbReceivedTxIds mempoolHasTxFun txs peeraddr _ st) = + case TXS.receivedTxIdsImpl (apply mempoolHasTxFun) + peeraddr 0 txidSeq txidMap st of + !st' -> case unsafeNoThunks st' of + Nothing -> property True + Just ctx -> counterexample (show ctx) False + where + txidSeq = StrictSeq.fromList (getTxId <$> txs) + txidMap = Map.fromList [ (getTxId tx, getTxSize tx) | tx <- txs ] + + +-- +-- `collectTxs` properties +-- + + +data ArbCollectTxs = + ArbCollectTxs (Fun TxId Bool) -- ^ mempoolHasTx + (Set TxId) -- ^ requested txid's + (Map TxId (Tx TxId)) -- ^ received txs + PeerAddr -- ^ peeraddr + (PeerTxState TxId (Tx TxId)) + (SharedTxState PeerAddr TxId (Tx TxId)) + -- ^ 'InboundState' + deriving Show + + +instance Arbitrary ArbCollectTxs where + arbitrary = do + Small maxTxIdsInflight <- arbitrary + ( mempoolHasTxFun + , (peeraddr, ps@PeerTxState { availableTxIds, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize }) + , st + , _ + ) + <- genSharedTxState maxTxIdsInflight + requestedTxIds <- take (fromIntegral requestedTxIdsInflight) + <$> sublistOf (toList requestedTxsInflight) + + -- Limit the requested `txid`s to satisfy `requestedTxsInflightSize`. + let requestedTxIds' = fmap fst + . takeWhile (\(_,s) -> s <= requestedTxsInflightSize) + $ zip requestedTxIds + (scanl1 (<>) [availableTxIds Map.! txid | txid <- requestedTxIds ]) + + receivedTx <- sublistOf requestedTxIds' + >>= traverse (\txid -> do + valid <- frequency [(4, pure True), (1, pure False)] + pure $ Tx { getTxId = txid, + getTxSize = availableTxIds Map.! txid, + getTxValid = valid }) + + pure $ assert (foldMap getTxSize receivedTx <= requestedTxsInflightSize) + $ ArbCollectTxs mempoolHasTxFun + (Set.fromList requestedTxIds') + (Map.fromList [ (getTxId tx, tx) | tx <- receivedTx ]) + peeraddr + ps + st + + shrink (ArbCollectTxs mempoolHasTx requestedTxs receivedTxs peeraddr ps st) = + [ ArbCollectTxs mempoolHasTx + requestedTxs' + (receivedTxs `Map.restrictKeys` requestedTxs') + peeraddr ps st + | requestedTxs' <- Set.fromList <$> shrinkList (\_ -> []) (Set.toList requestedTxs) + ] + ++ + [ ArbCollectTxs mempoolHasTx + requestedTxs + (receivedTxs `Map.restrictKeys` receivedTxIds) + peeraddr ps st + | receivedTxIds <- Set.fromList <$> shrinkList (\_ -> []) (Map.keys receivedTxs) + ] + ++ + [ ArbCollectTxs mempoolHasTx + (requestedTxs + `Set.intersection` unacked + `Set.intersection` inflightTxSet) + (receivedTxs + `Map.restrictKeys` unacked + `Map.restrictKeys` inflightTxSet) + peeraddr ps + st' + | let unacked = Set.fromList + . toList + . unacknowledgedTxIds + $ ps + , st'@SharedTxState { inflightTxs } <- shrinkSharedTxState (apply mempoolHasTx) st + , let inflightTxSet = Map.keysSet inflightTxs + , peeraddr `Map.member` peerTxStates st' + , st' /= st + ] + + +prop_collectTxs_generator + :: ArbCollectTxs + -> Property +prop_collectTxs_generator (ArbCollectTxs _ requestedTxIds receivedTxs peeraddr + ps@PeerTxState { availableTxIds, + requestedTxsInflightSize } + st) = + counterexample "size of requested txs must not be larger than requestedTxsInflightSize" + (requestedSize <= requestedTxsInflightSize) + .&&. counterexample "inflightTxsSize must be greater than requestedSize" + (inflightTxsSize st >= requestedSize) + .&&. counterexample ("receivedTxs must be a subset of requestedTxIds " + ++ show (Map.keysSet receivedTxs Set.\\ requestedTxIds)) + (Map.keysSet receivedTxs `Set.isSubsetOf` requestedTxIds) + .&&. counterexample "peerTxState" + (Map.lookup peeraddr (peerTxStates st) === Just ps) + where + requestedSize = fold (availableTxIds `Map.restrictKeys` requestedTxIds) + + +prop_collectTxs_shrinker + :: Fixed ArbCollectTxs + -- ^ disabled shrinking + -> Property +prop_collectTxs_shrinker (Fixed txs) = + property $ foldMap (\a@(ArbCollectTxs _ _ _ _ _ st) -> + All . counterexample (show st) $ + f a =/= f txs + .&&. sharedTxStateInvariant st + ) (shrink txs) + where + f (ArbCollectTxs _ reqSet recvMap peeraddr ps st) = (reqSet, recvMap, peeraddr, ps, st) + + +-- | Verify `collectTxsImpl` properties: +-- +-- * verify `SharedTxState` invariant; +-- * unacknowledged txids after `collectTxsImpl` must be a suffix of the +-- original ones; +-- * progress property: we acknowledge as many `txid`s as possible +-- +prop_collectTxsImpl + :: ArbCollectTxs + -> Property +prop_collectTxsImpl (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived peeraddr ps st) = + + label ("number of txids inflight " ++ labelInt 25 5 (Map.size $ inflightTxs st)) $ + label ("number of txids requested " ++ labelInt 25 5 (Set.size txidsRequested)) $ + label ("number of txids received " ++ labelInt 10 2 (Map.size txsReceived)) $ + + -- InboundState invariant + counterexample + ( "InboundState invariant violation:\n" ++ show st' ++ "\n" + ++ show ps' + ) + (sharedTxStateInvariant st') + + .&&. + -- `collectTxsImpl` doesn't modify unacknowledged TxId's + counterexample "acknowledged property violation" + ( let unacked = toList $ unacknowledgedTxIds ps + unacked' = toList $ unacknowledgedTxIds ps' + in unacked === unacked' + ) + where + st' = TXS.collectTxsImpl peeraddr txidsRequested txsReceived st + ps' = peerTxStates st' Map.! peeraddr + + +-- | Verify that `SharedTxState` returned by `collectTxsImpl` if evaluated to +-- WHNF, it doesn't contain any thunks. +-- +prop_collectTxsImpl_nothunks + :: ArbCollectTxs + -> Property +prop_collectTxsImpl_nothunks (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived peeraddr _ st) = + case unsafeNoThunks $! st' of + Nothing -> property True + Just ctx -> counterexample (show ctx) False + where + st' = TXS.collectTxsImpl peeraddr txidsRequested txsReceived st + + +newtype ArbTxDecisionPolicy = ArbTxDecisionPolicy TxDecisionPolicy + deriving Show + +instance Arbitrary ArbTxDecisionPolicy where + arbitrary = + ArbTxDecisionPolicy . fixupTxDecisionPolicy + <$> ( TxDecisionPolicy + <$> (getSmall . getPositive <$> arbitrary) + <*> (getSmall . getPositive <$> arbitrary) + <*> (SizeInBytes . getPositive <$> arbitrary) + <*> (SizeInBytes . getPositive <$> arbitrary) + <*> (getSmall . getPositive <$> arbitrary)) + + shrink (ArbTxDecisionPolicy a@TxDecisionPolicy { + maxNumTxIdsToRequest, + txsSizeInflightPerPeer, + maxTxsSizeInflight, + txInflightMultiplicity }) = + [ ArbTxDecisionPolicy a { maxNumTxIdsToRequest = NumTxIdsToReq x } + | (Positive (Small x)) <- shrink (Positive (Small (getNumTxIdsToReq maxNumTxIdsToRequest))) + ] + ++ + [ ArbTxDecisionPolicy . fixupTxDecisionPolicy + $ a { txsSizeInflightPerPeer = SizeInBytes s } + | Positive s <- shrink (Positive (getSizeInBytes txsSizeInflightPerPeer)) + ] + ++ + [ ArbTxDecisionPolicy . fixupTxDecisionPolicy + $ a { maxTxsSizeInflight = SizeInBytes s } + | Positive s <- shrink (Positive (getSizeInBytes maxTxsSizeInflight)) + ] + ++ + [ ArbTxDecisionPolicy . fixupTxDecisionPolicy + $ a { txInflightMultiplicity = x } + | Positive (Small x) <- shrink (Positive (Small txInflightMultiplicity)) + ] + + +fixupTxDecisionPolicy :: TxDecisionPolicy -> TxDecisionPolicy +fixupTxDecisionPolicy a@TxDecisionPolicy { txsSizeInflightPerPeer, + maxTxsSizeInflight } + = a { txsSizeInflightPerPeer = txsSizeInflightPerPeer', + maxTxsSizeInflight = maxTxsSizeInflight' } + where + txsSizeInflightPerPeer' = min txsSizeInflightPerPeer maxTxsSizeInflight + maxTxsSizeInflight' = max txsSizeInflightPerPeer maxTxsSizeInflight + + +-- | Generate `TxDecisionPolicy` and a valid `PeerTxState` with respect to +-- that policy. +-- +data ArbPeerTxStateWithPolicy = + ArbPeerTxStateWithPolicy { + ptspState :: PeerTxState TxId (Tx TxId), + ptspPolicy :: TxDecisionPolicy + } + deriving Show + +-- | Fix-up `PeerTxState` according to `TxDecisionPolicy`. +-- +fixupPeerTxStateWithPolicy :: Ord txid + => TxDecisionPolicy + -> PeerTxState txid tx + -> PeerTxState txid tx +fixupPeerTxStateWithPolicy + TxDecisionPolicy { maxUnacknowledgedTxIds, + maxNumTxIdsToRequest } + ps@PeerTxState { unacknowledgedTxIds, + availableTxIds, + requestedTxsInflight, + requestedTxIdsInflight, + unknownTxs + } + = + ps { unacknowledgedTxIds = unacknowledgedTxIds', + availableTxIds = availableTxIds', + requestedTxsInflight = requestedTxsInflight', + requestedTxIdsInflight = requestedTxIdsInflight', + unknownTxs = unknownTxs' + } + where + -- limit the number of unacknowledged txids, and then fix-up all the other + -- sets. + unacknowledgedTxIds' = StrictSeq.take (fromIntegral maxUnacknowledgedTxIds) + unacknowledgedTxIds + unackedSet = Set.fromList (toList unacknowledgedTxIds') + availableTxIds' = availableTxIds `Map.restrictKeys` unackedSet + requestedTxsInflight' = requestedTxsInflight `Set.intersection` unackedSet + -- requestedTxIdsInflight must be smaller than `maxNumTxIdsToRequest, and + -- also `requestedTxIdsInflight` and the number of `unacknowledgedTxIds'` + -- must be smaller or equal to `maxUnacknowledgedTxIds`. + requestedTxIdsInflight' = requestedTxIdsInflight + `min` maxNumTxIdsToRequest + `min` (maxUnacknowledgedTxIds - fromIntegral (StrictSeq.length unacknowledgedTxIds')) + unknownTxs' = unknownTxs `Set.intersection` unackedSet + + +instance Arbitrary ArbPeerTxStateWithPolicy where + arbitrary = do + mempoolHasTx <- arbitrary + ArbTxDecisionPolicy policy + <- arbitrary + ArbPeerTxState { arbPeerTxState = ps } + <- genArbPeerTxState + mempoolHasTx + (fromIntegral (maxUnacknowledgedTxIds policy)) + return ArbPeerTxStateWithPolicy { ptspState = fixupPeerTxStateWithPolicy policy ps, + ptspPolicy = policy + } + + +prop_numTxIdsToRequest + :: ArbPeerTxStateWithPolicy + -> Property +prop_numTxIdsToRequest + ArbPeerTxStateWithPolicy { + ptspPolicy = policy@TxDecisionPolicy { maxNumTxIdsToRequest, + maxUnacknowledgedTxIds }, + ptspState = ps + } + = + case TXS.numTxIdsToRequest policy ps of + (numToReq, ps') -> + numToReq <= maxNumTxIdsToRequest + .&&. numToReq + requestedTxIdsInflight ps === requestedTxIdsInflight ps' + .&&. fromIntegral (StrictSeq.length (unacknowledgedTxIds ps')) + + requestedTxIdsInflight ps' + <= maxUnacknowledgedTxIds + + +data ArbDecisionContexts txid = ArbDecisionContexts { + arbDecisionPolicy :: TxDecisionPolicy, + + arbSharedContext :: SharedDecisionContext PeerAddr txid (Tx txid), + + arbMempoolHasTx :: Fun txid Bool + -- ^ needed just for shrinking + } + +instance Show txid => Show (ArbDecisionContexts txid) where + show ArbDecisionContexts { + arbDecisionPolicy, + arbSharedContext = SharedDecisionContext { + sdcPeerGSV = gsv, + sdcSharedTxState = st + }, + arbMempoolHasTx + } + = + intercalate "\n\t" + [ "ArbDecisionContext" + , show arbDecisionPolicy + , show gsv + , show st + , show arbMempoolHasTx + ] + + +-- | Fix-up `SharedTxState` so it satisfies `TxDecisionPolicy`. +-- +fixupSharedTxStateForPolicy + :: forall peeraddr txid tx. + Ord txid + => (txid -> Bool) -- ^ mempoolHasTx + -> TxDecisionPolicy + -> SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx +fixupSharedTxStateForPolicy + mempoolHasTx + policy@TxDecisionPolicy { + txsSizeInflightPerPeer, + maxTxsSizeInflight, + txInflightMultiplicity + } + st@SharedTxState { peerTxStates } + = + fixupSharedTxState + mempoolHasTx + st { peerTxStates = snd . mapAccumR fn (0, Map.empty) $ peerTxStates } + where + -- fixup `PeerTxState` and accumulate size of all `tx`'s in-flight across + -- all peers. + fn :: (SizeInBytes, Map txid Int) + -> PeerTxState txid tx + -> ((SizeInBytes, Map txid Int), PeerTxState txid tx) + fn + (sizeInflightAll, inflightMap) + ps + = + ( ( sizeInflightAll + requestedTxsInflightSize' + , inflightMap' + ) + , ps' { requestedTxsInflight = requestedTxsInflight', + requestedTxsInflightSize = requestedTxsInflightSize' + } + ) + where + ps' = fixupPeerTxStateWithPolicy policy ps + + (requestedTxsInflightSize', requestedTxsInflight', inflightMap') = + Map.foldrWithKey + (\txid txSize r@(!inflightSize, !inflightSet, !inflight) -> + let (multiplicity, inflight') = + Map.alterF + (\case + Nothing -> (1, Just 1) + Just x -> let x' = x + 1 in (x', Just $! x')) + txid inflight + in if inflightSize <= txsSizeInflightPerPeer + && sizeInflightAll + inflightSize <= maxTxsSizeInflight + && multiplicity <= txInflightMultiplicity + then (txSize + inflightSize, Set.insert txid inflightSet, inflight') + else r + ) + (0, Set.empty, inflightMap) + (availableTxIds ps' `Map.restrictKeys` requestedTxsInflight ps') + +instance (Arbitrary txid, Ord txid, Function txid, CoArbitrary txid) + => Arbitrary (ArbDecisionContexts txid) where + + arbitrary = do + ArbTxDecisionPolicy policy <- arbitrary + (mempoolHasTx, _ps, st, _) <- + genSharedTxState (fromIntegral $ maxNumTxIdsToRequest policy) + let pss = Map.toList (peerTxStates st) + peers = fst `map` pss + -- each peer must have a GSV + gsvs <- zip peers + <$> infiniteListOf (unPeerGSVT <$> arbitrary) + let st' = fixupSharedTxStateForPolicy + (apply mempoolHasTx) policy st + + return $ ArbDecisionContexts { + arbDecisionPolicy = policy, + arbMempoolHasTx = mempoolHasTx, + arbSharedContext = SharedDecisionContext { + sdcPeerGSV = Map.fromList gsvs, + sdcSharedTxState = st' + } + } + + shrink a@ArbDecisionContexts { + arbDecisionPolicy = policy, + arbMempoolHasTx = mempoolHasTx, + arbSharedContext = b@SharedDecisionContext { + sdcPeerGSV = gsvs, + sdcSharedTxState = sharedState + } + } = + -- shrink shared state + [ a { arbSharedContext = b { sdcSharedTxState = sharedState'' } } + | sharedState' <- shrinkSharedTxState (apply mempoolHasTx) sharedState + , let sharedState'' = fixupSharedTxStateForPolicy + (apply mempoolHasTx) policy sharedState' + , sharedState'' /= sharedState + ] + ++ + -- shrink peers; note all peers are present in `sdcPeerGSV`. + [ a { arbSharedContext = SharedDecisionContext { + sdcPeerGSV = gsvs', + sdcSharedTxState = sharedState' + } } + | -- shrink the set of peers + peers' <- Set.fromList <$> shrinkList (const []) (Map.keys gsvs) + , let gsvs' = gsvs `Map.restrictKeys` peers' + sharedState' = + fixupSharedTxStateForPolicy + (apply mempoolHasTx) policy + $ sharedState { peerTxStates = peerTxStates sharedState + `Map.restrictKeys` + peers' + } + , sharedState' /= sharedState + ] + + +prop_ArbDecisionContexts_generator + :: ArbDecisionContexts TxId + -> Property +prop_ArbDecisionContexts_generator + ArbDecisionContexts { arbSharedContext = SharedDecisionContext { sdcSharedTxState = st } } + = + -- whenFail (pPrint a) $ + sharedTxStateInvariant st + + +prop_ArbDecisionContexts_shrinker + :: ArbDecisionContexts TxId + -> All +prop_ArbDecisionContexts_shrinker + ctx + = + foldMap (\a -> + All + . counterexample (show a) + . sharedTxStateInvariant + . sdcSharedTxState + . arbSharedContext + $ a) + $ shrink ctx + + +-- | Verify that `makeDecisions` preserves the `SharedTxState` invariant. +-- +prop_makeDecisions_sharedstate + :: ArbDecisionContexts TxId + -> Property +prop_makeDecisions_sharedstate + ArbDecisionContexts { arbDecisionPolicy = policy, + arbSharedContext = sharedCtx } = + let (sharedState, decisions) = TXS.makeDecisions policy sharedCtx (peerTxStates (sdcSharedTxState sharedCtx)) + in counterexample (show sharedState) + $ counterexample (show decisions) + $ sharedTxStateInvariant sharedState + + +-- | Verify that `makeDecisions`: +-- +-- * modifies `inflightTxs` map by adding `tx`s which are inflight; +-- * updates `requestedTxsInflightSize` correctly; +-- * in-flight `tx`s set is disjoint with `bufferedTxs`; +-- * requested `tx`s are coming from `availableTxIds`. +-- +prop_makeDecisions_inflight + :: ArbDecisionContexts TxId + -> Property +prop_makeDecisions_inflight + ArbDecisionContexts { + arbDecisionPolicy = policy, + arbSharedContext = sharedCtx@SharedDecisionContext { + sdcSharedTxState = sharedState + } + } + = + let (sharedState', decisions) = TXS.makeDecisions policy sharedCtx (peerTxStates sharedState) + + inflightSet :: Set TxId + inflightSet = foldMap txdTxsToRequest decisions + + inflightSize :: Map PeerAddr SizeInBytes + inflightSize = Map.foldrWithKey + (\peer TxDecision { txdTxsToRequest } m -> + Map.insert peer + (foldMap (\txid -> fromMaybe 0 $ Map.lookup peer (peerTxStates sharedState) + >>= Map.lookup txid . availableTxIds) + txdTxsToRequest) + m + ) Map.empty decisions + + bufferedSet :: Set TxId + bufferedSet = Map.keysSet (bufferedTxs sharedState) + in + counterexample (show sharedState') $ + counterexample (show decisions) $ + + -- 'inflightTxs' set is increased by exactly the requested txs + counterexample (concat + [ show inflightSet + , " not a subset of " + , show (inflightTxs sharedState') + ]) + ( inflightSet <> Map.keysSet (inflightTxs sharedState') + === + Map.keysSet (inflightTxs sharedState') + ) + + .&&. + + -- for each peer size in flight is equal to the original size in flight + -- plus size of all requested txs + property + (fold + (Map.merge + (Map.mapMaybeMissing + (\peer a -> + Just ( All + . counterexample + ("missing peer in requestedTxsInflightSize: " ++ show peer) + $ (a === 0)))) + (Map.mapMaybeMissing (\_ _ -> Nothing)) + (Map.zipWithMaybeMatched + (\peer delta PeerTxState { requestedTxsInflightSize } -> + let original = + case Map.lookup peer (peerTxStates sharedState) of + Nothing -> 0 + Just PeerTxState { requestedTxsInflightSize = a } -> a + in Just ( All + . counterexample (show peer) + $ original + delta + === + requestedTxsInflightSize + ) + )) + inflightSize + (peerTxStates sharedState'))) + + .&&. counterexample ("requested txs must not be buffered: " + ++ show (inflightSet `Set.intersection` bufferedSet)) + (inflightSet `Set.disjoint` bufferedSet) + + .&&. counterexample "requested txs must be available" + ( fold $ + Map.merge + (Map.mapMissing (\peeraddr _ -> + All $ + counterexample ("peer missing in peerTxStates " ++ show peeraddr) + False)) + (Map.mapMissing (\_ _ -> All True)) + (Map.zipWithMatched (\peeraddr a b -> All + . counterexample (show peeraddr) + $ a `Set.isSubsetOf` b)) + -- map of requested txs + (Map.fromList [ (peeraddr, txids) + | (peeraddr, TxDecision { txdTxsToRequest = txids }) + <- Map.assocs decisions + ]) + -- map of available txs + (Map.map (Map.keysSet . availableTxIds) + (peerTxStates sharedState))) + + +-- | Verify that `makeTxDecisions` obeys `TxDecisionPolicy`. +-- +prop_makeDecisions_policy + :: ArbDecisionContexts TxId + -> Property +prop_makeDecisions_policy + ArbDecisionContexts { + arbDecisionPolicy = policy@TxDecisionPolicy { maxTxsSizeInflight, + txsSizeInflightPerPeer, + txInflightMultiplicity }, + arbSharedContext = sharedCtx@SharedDecisionContext { sdcSharedTxState = sharedState } + } = + let (sharedState', _decisions) = TXS.makeDecisions policy sharedCtx (peerTxStates sharedState) + maxTxsSizeInflightEff = maxTxsSizeInflight + maxTxSize + txsSizeInflightPerPeerEff = txsSizeInflightPerPeer + maxTxSize + + sizeInflight = + foldMap (\PeerTxState { availableTxIds, requestedTxsInflight } -> + fold (availableTxIds `Map.restrictKeys` requestedTxsInflight)) + (peerTxStates sharedState') + + in counterexample (show sharedState') $ + + -- size of txs inflight cannot exceed `maxTxsSizeInflight` by more + -- than maximal tx size. + counterexample ("txs inflight exceed limit " ++ show (sizeInflight, maxTxsSizeInflightEff)) + (sizeInflight <= maxTxsSizeInflightEff) + .&&. + -- size in flight for each peer cannot exceed `txsSizeInflightPerPeer` + counterexample "size in flight per peer vaiolation" ( + foldMap + (\PeerTxState { availableTxIds, requestedTxsInflight } -> + let inflight = fold (availableTxIds `Map.restrictKeys` requestedTxsInflight) + in All $ counterexample (show (inflight, txsSizeInflightPerPeerEff)) $ + inflight + <= + txsSizeInflightPerPeerEff + ) + (peerTxStates sharedState') + ) + + .&&. + ( + -- none of the multiplicities should go above the + -- `txInflightMultiplicity` + let inflight = inflightTxs sharedState' + in + counterexample ("multiplicities violation: " ++ show inflight) + . foldMap (All . (<= txInflightMultiplicity)) + $ inflight + ) + + +-- | Verify that `makeDecisions` and `acknowledgeTxIds` are compatible. +-- +prop_makeDecisions_acknowledged + :: ArbDecisionContexts TxId + -> Property +prop_makeDecisions_acknowledged + ArbDecisionContexts { arbDecisionPolicy = policy, + arbSharedContext = + sharedCtx@SharedDecisionContext { + sdcSharedTxState = sharedTxState + } + } = + whenFail (pPrintOpt CheckColorTty defaultOutputOptionsDarkBg { outputOptionsCompact = True } sharedTxState) $ + let (_, decisions) = TXS.makeDecisions policy sharedCtx (peerTxStates sharedTxState) + + ackFromDecisions :: Map PeerAddr NumTxIdsToAck + ackFromDecisions = Map.fromList + [ (peer, txdTxIdsToAcknowledge) + | (peer, TxDecision { txdTxIdsToAcknowledge }) + <- Map.assocs decisions + ] + + ackFromState :: Map PeerAddr NumTxIdsToAck + ackFromState = + Map.map (\ps -> case TXS.acknowledgeTxIds policy sharedTxState ps of + (a, _, _, _, _) -> a) + . peerTxStates + $ sharedTxState + + in counterexample (show (ackFromDecisions, ackFromState)) + . fold + $ Map.merge + -- it is an error if `ackFromDecisions` contains a result which is + -- missing in `ackFromState` + (Map.mapMissing (\addr num -> All $ counterexample ("missing " ++ show (addr, num)) False)) + -- if `ackFromState` contains an enty which is missing in + -- `ackFromDecisions` it must be `0`; `makeDecisions` might want to + -- download some `tx`s even if there's nothing to acknowledge + (Map.mapMissing (\_ d -> All (d === 0))) + -- if both entries exists they must be equal + (Map.zipWithMatched (\_ a b -> All (a === b))) + ackFromDecisions + ackFromState + + +-- | `makeDecision` is exhaustive in the sense that it returns an empty +-- decision list on a state returned by a prior call of `makeDecision`. +-- +prop_makeDecisions_exhaustive + :: ArbDecisionContexts TxId + -> Property +prop_makeDecisions_exhaustive + ArbDecisionContexts { + arbDecisionPolicy = policy, + arbSharedContext = + sharedCtx@SharedDecisionContext { + sdcSharedTxState = sharedTxState + } + } + = + let (sharedTxState', decisions') + = TXS.makeDecisions policy + sharedCtx + (peerTxStates sharedTxState) + (sharedTxState'', decisions'') + = TXS.makeDecisions policy + sharedCtx { sdcSharedTxState = sharedTxState' } + (peerTxStates sharedTxState') + in counterexample ("decisions': " ++ show decisions') + . counterexample ("state': " ++ show sharedTxState') + . counterexample ("decisions'': " ++ show decisions'') + . counterexample ("state'': " ++ show sharedTxState'') + $ null decisions'' + + +data ArbDecisionContextWithReceivedTxIds = ArbDecisionContextWithReceivedTxIds { + adcrDecisionPolicy :: TxDecisionPolicy, + adcrSharedContext :: SharedDecisionContext PeerAddr TxId (Tx TxId), + adcrPeerTxState :: PeerTxState TxId (Tx TxId), + adcrMempoolHasTx :: Fun TxId Bool, + adcrTxsToAck :: [Tx TxId], + -- txids to acknowledge + adcrPeerAddr :: PeerAddr + -- the peer which owns the acknowledged txids + } + deriving Show + + +instance Arbitrary ArbDecisionContextWithReceivedTxIds where + arbitrary = do + ArbTxDecisionPolicy policy <- arbitrary + ArbReceivedTxIds mempoolHasTx + txIdsToAck + peeraddr + ps + st + <- arbitrary + + let st' = fixupSharedTxStateForPolicy + (apply mempoolHasTx) + policy st + ps' = fixupPeerTxStateWithPolicy policy ps + txIdsToAck' = take (fromIntegral (TXS.requestedTxIdsInflight $ peerTxStates st' Map.! peeraddr)) txIdsToAck + peers = Map.keys (peerTxStates st') + + gsvs <- zip peers + <$> infiniteListOf (unPeerGSVT <$> arbitrary) + + return ArbDecisionContextWithReceivedTxIds { + adcrDecisionPolicy = policy, + adcrSharedContext = SharedDecisionContext { + sdcPeerGSV = Map.fromList gsvs, + sdcSharedTxState = st' + }, + adcrPeerTxState = ps', + adcrMempoolHasTx = mempoolHasTx, + adcrTxsToAck = txIdsToAck', + adcrPeerAddr = peeraddr + } + + shrink ArbDecisionContextWithReceivedTxIds { + adcrDecisionPolicy = policy, + adcrSharedContext = ctx, + adcrPeerTxState = ps, + adcrMempoolHasTx = mempoolHasTx, + adcrTxsToAck = txIdsToAck, + adcrPeerAddr = peeraddr + } + = + [ ArbDecisionContextWithReceivedTxIds { + adcrDecisionPolicy = policy', + adcrSharedContext = ctx', + adcrPeerTxState = ps, + adcrMempoolHasTx = mempoolHasTx', + adcrTxsToAck = txIdsToAck', + adcrPeerAddr = peeraddr + } + | ArbDecisionContexts { + arbDecisionPolicy = policy', + arbSharedContext = ctx'@SharedDecisionContext { sdcSharedTxState = st' }, + arbMempoolHasTx = mempoolHasTx' + } + <- shrink ArbDecisionContexts { + arbDecisionPolicy = policy, + arbSharedContext = ctx, + arbMempoolHasTx = mempoolHasTx + } + , peeraddr `Map.member` peerTxStates st' + , let txIdsToAck' = take ( fromIntegral + . TXS.requestedTxIdsInflight + $ peerTxStates st' Map.! peeraddr + ) + txIdsToAck + ] + + +-- | `receivedTxIdsImpl` and `makeDecisions` have a non trivial commutator (e.g. +-- they don't commute in an interesting way). +-- +prop_makeDecisions_receivedTxIds + :: HasCallStack + => ArbDecisionContextWithReceivedTxIds + -> Property +prop_makeDecisions_receivedTxIds + ArbDecisionContextWithReceivedTxIds { + adcrDecisionPolicy = policy, + adcrSharedContext = ctx@SharedDecisionContext { + sdcSharedTxState = st + }, + adcrMempoolHasTx = mempoolHasTx, + adcrTxsToAck = txs, + adcrPeerAddr = peeraddr + } + = + counterexample ("st' = " ++ show st') $ + counterexample ("st'' = " ++ show st'') $ + counterexample ("stA' = " ++ show stA') $ + counterexample ("stA'' = " ++ show stA'') $ + counterexample ("txDecisions = " ++ show txDecisions) $ + counterexample ("txDecisionsA = " ++ show txDecisionsA) $ + + counterexample "state property failure" ( + -- States should be comparable; although not identical: + -- 1. number of txids in-flight might be smaller if we first `makeDecision` + -- and then `receivedTxIdsImpl`. + -- 2. it could happen that we acknowledge and GC a txid which is then added + -- by `receivedTxIdsImpl`, which leads to a missing txid in `bufferedTxs` + -- compared to do the other way around + -- 3. `availableTxs` might be smaller if we first `makeDecision` because we + -- might acknowledge a txid which is removed from `availableTxs` and after + -- calling `receivedTxIdsImpl` we won't get back the `txid` entry in + -- `availableTxs` + -- 4. `unacknowledgedTxs` might be smaller if we call `makeDecision` first, + -- simply because some of `txids` might be removed from `bufferedTxs`. + -- + -- For simplicity we ignore differences in `bufferedTxs` and + -- `referenceCounts` and thus we set them to empty maps. + st'' { bufferedTxs = Map.empty, + referenceCounts = Map.empty + } + === + stA'' { peerTxStates = + let fn :: PeerTxState TxId (Tx TxId) -> PeerTxState TxId (Tx TxId) + fn ps = snd . TXS.numTxIdsToRequest policy -- ad 2. + $ ps { unacknowledgedTxIds = unacknowledgedTxIds', + availableTxIds = (availableTxIds ps <> txidMap) -- ad 3. + `Map.restrictKeys` + Set.fromList (toList unacknowledgedTxIds') + } + where + unacknowledgedTxIds' = StrictSeq.dropWhileL + (\txid -> txid `Map.member` bufferedTxs st -- ad 4. + || applyFun mempoolHasTx txid) + $ unacknowledgedTxIds ps + in + Map.adjust fn peeraddr (peerTxStates stA''), + bufferedTxs = Map.empty, + referenceCounts = Map.empty + } + ) + + .&&. + + counterexample "unacknowledgedTxIds property failure" ( + Map.findWithDefault 0 peeraddr (Map.map txdTxIdsToAcknowledge txDecisions) + === + Map.findWithDefault 0 peeraddr (Map.map txdTxIdsToAcknowledge txDecisionsA) + -- account for txids which could be acknowledged because they were + -- buffered in `st` + + foldr (\txid x -> if txid `Map.member` bufferedTxs st + then x + 1 + else 0) 0 + (TXS.unacknowledgedTxIds (peerTxStates stA'' Map.! peeraddr)) + + ) + + .&&. + + counterexample "txdTxsToRequest proporety failure" ( + Map.filter (not . Set.null) (Map.map txdTxsToRequest txDecisions) + === + Map.filter (not . Set.null) (Map.map txdTxsToRequest txDecisionsA) + ) + + where + txidSeq = StrictSeq.fromList (getTxId <$> txs) + txidMap = Map.fromList [ (getTxId tx, getTxSize tx) | tx <- txs ] + + st' = TXS.receivedTxIdsImpl + (apply mempoolHasTx) + peeraddr + (fromIntegral $ StrictSeq.length txidSeq) + txidSeq txidMap + st + + (st'', txDecisions) = TXS.makeDecisions + policy ctx { sdcSharedTxState = st' } + (filterActivePeers policy st') + + + (stA', txDecisionsA) = TXS.makeDecisions + policy ctx + (filterActivePeers policy st) + + stA'' = TXS.receivedTxIdsImpl + (apply mempoolHasTx) + peeraddr + (fromIntegral $ StrictSeq.length txidSeq) + txidSeq txidMap + stA' + + +data ArbDecisionContextWithCollectTxs = ArbDecisionContextWithCollectTxs { + adccDecisionPolicy :: TxDecisionPolicy, + adccSharedContext :: SharedDecisionContext PeerAddr TxId (Tx TxId), + adccMempoolHasTx :: Fun TxId Bool, + adccRequestedTxIds :: Set TxId, + adccReceivedTxs :: Map TxId (Tx TxId), + adccPeer :: PeerAddr + } + deriving Show + +instance Arbitrary ArbDecisionContextWithCollectTxs where + arbitrary = do + ArbTxDecisionPolicy policy <- arbitrary + ArbCollectTxs mempoolHasTx + requestedTxIds + receivedTxs + peeraddr + _ + st + <- arbitrary + + let st' = fixupSharedTxStateForPolicy + (apply mempoolHasTx) + policy st + ps' = peerTxStates st' Map.! peeraddr + peers = Map.keys (peerTxStates st') + + requestedTxIds' = requestedTxIds + `Set.intersection` + requestedTxsInflight ps' + receivedTxs' = receivedTxs + `Map.restrictKeys` + requestedTxIds' + + gsvs <- zip peers + <$> infiniteListOf (unPeerGSVT <$> arbitrary) + + return $ ArbDecisionContextWithCollectTxs { + adccDecisionPolicy = policy, + adccSharedContext = SharedDecisionContext { + sdcPeerGSV = Map.fromList gsvs, + sdcSharedTxState = st' + }, + adccMempoolHasTx = mempoolHasTx, + adccRequestedTxIds = requestedTxIds', + adccReceivedTxs = receivedTxs', + adccPeer = peeraddr + } + + shrink ctx@ArbDecisionContextWithCollectTxs { + adccDecisionPolicy = decisionPolicy, + adccSharedContext = sharedCtx, + adccRequestedTxIds = requestedTxIds, + adccReceivedTxs = receivedTxs, + adccMempoolHasTx = mempoolHasTx, + adccPeer = peer + } = + [ ctx { adccDecisionPolicy = decisionPolicy + , adccSharedContext = sharedCtx { sdcSharedTxState = st } + , adccRequestedTxIds = requestedTxIds' + , adccReceivedTxs = receivedTxs' + } + | ArbTxDecisionPolicy decisionPolicy' <- shrink (ArbTxDecisionPolicy decisionPolicy) + , let st = fixupSharedTxStateForPolicy + (apply mempoolHasTx) + decisionPolicy' + (sdcSharedTxState sharedCtx) + ps = peerTxStates st Map.! peer + requestedTxIds' = requestedTxIds + `Set.intersection` + requestedTxsInflight ps + receivedTxs' = receivedTxs + `Map.restrictKeys` + requestedTxIds' + , st /= sdcSharedTxState sharedCtx + ] + ++ + [ ctx { adccDecisionPolicy = policy + , adccSharedContext = sharedCtx' { sdcSharedTxState = st } + , adccRequestedTxIds = requestedTxIds' + , adccReceivedTxs = receivedTxs' + , adccMempoolHasTx = mempoolHasTx' + } + | ArbDecisionContexts { + arbDecisionPolicy = policy, + arbSharedContext = sharedCtx'@SharedDecisionContext { sdcSharedTxState = st }, + arbMempoolHasTx = mempoolHasTx' + } + <- shrink ArbDecisionContexts { + arbDecisionPolicy = decisionPolicy, + arbSharedContext = sharedCtx, + arbMempoolHasTx = mempoolHasTx + } + , Just ps <- [peer `Map.lookup` peerTxStates st] + , let requestedTxIds' = requestedTxIds + `Set.intersection` + requestedTxsInflight ps + receivedTxs' = receivedTxs + `Map.restrictKeys` + requestedTxIds' + ] + ++ + [ ctx { adccRequestedTxIds = requestedTxIds' + , adccReceivedTxs = receivedTxs' + } + | -- Don't shrink `TxId`s. + -- NOTE: if `TxId` would be a newtype an arbitrary instance would not + -- be provided and thus `shrink requestedTxIds` would not compile. + requestedTxIds' <- map Set.fromList $ shrinkList (\_ -> []) (Set.toList requestedTxIds) + , let receivedTxs' = receivedTxs + `Map.restrictKeys` + requestedTxIds' + ] + +prop_makeDecisions_collectTxs + :: ArbDecisionContextWithCollectTxs + -> Property +prop_makeDecisions_collectTxs + ArbDecisionContextWithCollectTxs { + adccDecisionPolicy = policy, + adccSharedContext = ctx@SharedDecisionContext { sdcSharedTxState = st }, + adccRequestedTxIds = requestedTxIds, + adccReceivedTxs = receivedTxs, + adccPeer = peeraddr + } + = + counterexample ("st' = " ++ show st') $ + counterexample ("st'' = " ++ show st'') $ + counterexample ("stA' = " ++ show stA') $ + counterexample ("stA'' = " ++ show stA'') $ + counterexample ("txDecisions = " ++ show txDecisions) $ + counterexample ("txDecisionsA = " ++ show txDecisionsA) $ + + counterexample "acknowledged txids property failure" ( + -- remove all decisions which do not acknowledge any txids; adjust number + -- of acknowledged txids by peeraddr. + let m = Map.filter (/= 0) + . Map.map txdTxIdsToAcknowledge + $ txDecisions + mA = Map.filter (/= 0) + . Map.map txdTxIdsToAcknowledge + $ txDecisionsA + in + and + -- when we first collect then make a decision, we might acknowledged + -- more txids; e.g. if we received a `tx`, then it can be acknowledged + -- for all peers while `collectTxIds` only acknowledges it for one + -- peer - this is reflected by the following merge function. + $ Map.merge + (Map.mapMaybeMissing \_ _ -> Just True) + (Map.mapMaybeMissing \_ _ -> Just False) + (Map.zipWithMaybeMatched \_ x y -> Just $ x >= y) + m mA + ) + + .&&. + + ( counterexample "txs to be added to the mempool" + . counterexample (show txs) + . counterexample (show txsA) + $ txsA + `Set.isSubsetOf` + txs + ) + + where + st' = TXS.collectTxsImpl + peeraddr requestedTxIds + receivedTxs st + (st'', txDecisions) = TXS.makeDecisions + policy + ctx { sdcSharedTxState = st' } + (filterActivePeers policy st') + txs = foldMap (Set.fromList . txdTxsToMempool) txDecisions + + (stA', txDecisionsA) = TXS.makeDecisions + policy ctx + (filterActivePeers policy st) + txsA = foldMap (Set.fromList . txdTxsToMempool) txDecisionsA + stA'' = TXS.collectTxsImpl + peeraddr requestedTxIds + receivedTxs stA' + + +-- | `filterActivePeers` should not change decisions made by `makeDecisions` +-- +prop_filterActivePeers_not_limitting_decisions + :: ArbDecisionContexts TxId + -> Property +prop_filterActivePeers_not_limitting_decisions + ArbDecisionContexts { + arbDecisionPolicy = policy, + arbSharedContext = + sharedCtx@SharedDecisionContext { sdcSharedTxState = st } + } + = + counterexample (unlines + ["decisions: " ++ show decisions + ," " ++ show decisionPeers + ,"active decisions: " ++ show decisionsOfActivePeers + ," " ++ show activePeers]) $ + + counterexample ("active peers does not restrict the total number of valid decisions available" + ++ show (decisionsOfActivePeers Map.\\ decisions) + ) + (Map.keysSet decisionsOfActivePeers `Set.isSubsetOf` Map.keysSet decisions) + where + activePeersMap = TXS.filterActivePeers policy st + activePeers = Map.keysSet activePeersMap + (_, decisionsOfActivePeers) + = TXS.makeDecisions policy sharedCtx activePeersMap + + (_, decisions) = TXS.makeDecisions policy sharedCtx (peerTxStates st) + decisionPeers = Map.keysSet decisions + + +-- TODO: makeDecisions property: all peers which have txid's to ack are +-- included, this would catch the other bug, and it's important for the system +-- to run well. + +-- +-- Auxiliary functions +-- + +labelInt :: (Integral a, Eq a, Ord a, Show a) + => a -- ^ upper bound + -> a -- ^ width + -> a -- ^ value + -> String +labelInt _ _ 0 = "[0, 0]" +labelInt bound _ b | b >= bound = "[" ++ show bound ++ ", inf)" +labelInt _ a b = + let l = a * (b `div` a) + u = l + a + in (if l == 0 then "(" else "[") + ++ show l ++ ", " + ++ show u ++ ")" diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV1.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV1.hs new file mode 100644 index 00000000000..648f831b5e2 --- /dev/null +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV1.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Ouroboros.Network.TxSubmission.TxSubmissionV1 (tests) where + +import Prelude hiding (seq) + +import NoThunks.Class + +import Control.Concurrent.Class.MonadMVar (MonadMVar) +import Control.Concurrent.Class.MonadSTM +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadSay +import Control.Monad.Class.MonadST +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI +import Control.Monad.IOSim hiding (SimResult) +import Control.Tracer (Tracer (..), contramap, nullTracer) + +import Data.ByteString.Lazy qualified as BSL +import Data.Function (on) +import Data.List (intercalate, nubBy) +import Data.Maybe (fromMaybe) +import Data.Word (Word16) + +import Ouroboros.Network.Channel +import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM) +import Ouroboros.Network.Driver +import Ouroboros.Network.NodeToNode (NodeToNodeVersion (..)) +import Ouroboros.Network.Protocol.TxSubmission2.Client +import Ouroboros.Network.Protocol.TxSubmission2.Codec +import Ouroboros.Network.Protocol.TxSubmission2.Server +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound +import Ouroboros.Network.TxSubmission.Outbound +import Ouroboros.Network.Util.ShowProxy + +import Ouroboros.Network.Testing.Utils + +import Test.QuickCheck +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Test.Ouroboros.Network.TxSubmission.Common hiding (tests) + + +tests :: TestTree +tests = testGroup "Ouroboros.Network.TxSubmission.TxSubmissionV1" + [ testProperty "txSubmission" prop_txSubmission + ] + +txSubmissionSimulation + :: forall m txid. + ( MonadAsync m + , MonadDelay m + , MonadFork m + , MonadMask m + , MonadMVar m + , MonadSay m + , MonadST m + , MonadSTM m + , MonadTimer m + , MonadThrow m + , MonadThrow (STM m) + , MonadMonotonicTime m + , Ord txid + , Eq txid + , ShowProxy txid + , NoThunks (Tx txid) + + , txid ~ Int + ) + => Tracer m (String, TraceSendRecv (TxSubmission2 txid (Tx txid))) + -> NumTxIdsToAck + -> [Tx txid] + -> ControlMessageSTM m + -> Maybe DiffTime + -> Maybe DiffTime + -> m ([Tx txid], [Tx txid]) +txSubmissionSimulation tracer maxUnacked outboundTxs + controlMessageSTM + inboundDelay outboundDelay = do + + inboundMempool <- emptyMempool + outboundMempool <- newMempool outboundTxs + (outboundChannel, inboundChannel) <- createConnectedChannels + outboundAsync <- + async $ runPeerWithLimits + (("OUTBOUND",) `contramap` tracer) + txSubmissionCodec2 + (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) + timeLimitsTxSubmission2 + (maybe id delayChannel outboundDelay outboundChannel) + (txSubmissionClientPeer (outboundPeer outboundMempool)) + + inboundAsync <- + async $ runPipelinedPeerWithLimits + (("INBOUND",) `contramap` verboseTracer) + txSubmissionCodec2 + (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) + timeLimitsTxSubmission2 + (maybe id delayChannel inboundDelay inboundChannel) + (txSubmissionServerPeerPipelined (inboundPeer inboundMempool)) + + _ <- waitAnyCancel [ outboundAsync, inboundAsync ] + + inmp <- readMempool inboundMempool + outmp <- readMempool outboundMempool + return (inmp, outmp) + where + + outboundPeer :: Mempool m txid -> TxSubmissionClient txid (Tx txid) m () + outboundPeer outboundMempool = + txSubmissionOutbound + nullTracer + maxUnacked + (getMempoolReader outboundMempool) + NodeToNodeV_7 + controlMessageSTM + + inboundPeer :: Mempool m txid -> TxSubmissionServerPipelined txid (Tx txid) m () + inboundPeer inboundMempool = + txSubmissionInbound + nullTracer + maxUnacked + (getMempoolReader inboundMempool) + (getMempoolWriter inboundMempool) + NodeToNodeV_7 + +prop_txSubmission :: Positive Word16 + -> NonEmptyList (Tx Int) + -> Maybe (Positive SmallDelay) + -- ^ The delay must be smaller (<) than 5s, so that overall + -- delay is less than 10s, otherwise 'smallDelay' in + -- 'timeLimitsTxSubmission2' will kick in. + -> Property +prop_txSubmission (Positive maxUnacked) (NonEmpty outboundTxs) delay = + let mbDelayTime = getSmallDelay . getPositive <$> delay + tr = (runSimTrace $ do + controlMessageVar <- newTVarIO Continue + _ <- + async $ do + threadDelay + (fromMaybe 1 mbDelayTime + * realToFrac (length outboundTxs `div` 4)) + atomically (writeTVar controlMessageVar Terminate) + txSubmissionSimulation + verboseTracer + (NumTxIdsToAck maxUnacked) outboundTxs + (readTVar controlMessageVar) + mbDelayTime mbDelayTime + ) in + ioProperty $ do + tr' <- evaluateTrace tr + case tr' of + SimException e trace -> do + return $ counterexample (intercalate "\n" $ show e : trace) False + SimDeadLock trace -> do + return $ counterexample (intercalate "\n" $ "Deadlock" : trace) False + SimReturn (inmp, outmp) _trace -> do + -- printf "Log: %s\n" (intercalate "\n" _trace) + let outUniqueTxIds = nubBy (on (==) getTxId) outmp + outValidTxs = filter getTxValid outmp + case (length outUniqueTxIds == length outmp, length outValidTxs == length outmp) of + (True, True) -> + -- If we are presented with a stream of unique txids for valid + -- transactions the inbound transactions should match the outbound + -- transactions exactly. + return $ inmp === take (length inmp) outValidTxs + (True, False) -> + -- If we are presented with a stream of unique txids then we should have + -- fetched all valid transactions. + return $ inmp === take (length inmp) outValidTxs + (False, True) -> + -- If we are presented with a stream of valid txids then we should have + -- fetched some version of those transactions. + return $ map getTxId inmp === take (length inmp) (map getTxId $ + filter getTxValid outUniqueTxIds) + (False, False) + -- If we are presented with a stream of valid and invalid Txs with + -- duplicate txids we're content with completing the protocol + -- without error. + -> return $ property True diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs new file mode 100644 index 00000000000..ea138c3c4c2 --- /dev/null +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Ouroboros.Network.TxSubmission.TxSubmissionV2 (tests) where + +import Prelude hiding (seq) + +import NoThunks.Class + +import Control.Concurrent.Class.MonadMVar (MonadMVar) +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadSay +import Control.Monad.Class.MonadST +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI +import Control.Monad.IOSim hiding (SimResult) +import Control.Tracer (Tracer (..), contramap) + + +import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lazy qualified as BSL +import Data.Function (on) +import Data.List (nubBy) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) + + +import Ouroboros.Network.Channel +import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM) +import Ouroboros.Network.Driver +import Ouroboros.Network.NodeToNode (NodeToNodeVersion (..)) +import Ouroboros.Network.Protocol.TxSubmission2.Client +import Ouroboros.Network.Protocol.TxSubmission2.Codec +import Ouroboros.Network.Protocol.TxSubmission2.Server +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound.Policy +import Ouroboros.Network.TxSubmission.Outbound +import Ouroboros.Network.Util.ShowProxy + +import Ouroboros.Network.Testing.Utils hiding (debugTracer) + +import Test.QuickCheck +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Control.Concurrent.Class.MonadMVar.Strict qualified as Strict +import Control.Concurrent.Class.MonadSTM.Strict qualified as Strict +import Control.Monad (forM) +import Data.Foldable (traverse_) +import Data.Void (Void) +import Ouroboros.Network.DeltaQ (PeerGSV) +import Ouroboros.Network.TxSubmission.Inbound.Registry +import Ouroboros.Network.TxSubmission.Inbound.Server (txSubmissionInboundV2) +import Ouroboros.Network.TxSubmission.Inbound.State +import Test.Ouroboros.Network.TxSubmission.Common hiding (tests) + + +tests :: TestTree +tests = testGroup "Ouroboros.Network.TxSubmission.TxSubmissionV2" + [ testProperty "txSubmission" prop_txSubmission + , testProperty "txSubmission inflight" prop_txSubmission_inflight + ] + +data TxSubmissionV2State = + TxSubmissionV2State { + peerMap :: Map Int ( [Tx Int] + , Maybe (Positive SmallDelay) + , Maybe (Positive SmallDelay) + -- ^ The delay must be smaller (<) than 5s, so that overall + -- delay is less than 10s, otherwise 'smallDelay' in + -- 'timeLimitsTxSubmission2' will kick in. + ) + , decisionPolicy :: TxDecisionPolicy + } deriving (Show) + +instance Arbitrary TxSubmissionV2State where + arbitrary = do + ArbTxDecisionPolicy decisionPolicy <- arbitrary + peersN <- choose (1, 10) + txsN <- choose (1, 10) + txs <- divvy txsN . nubBy (on (==) getTxId) <$> vectorOf (peersN * txsN) arbitrary + peers <- vectorOf peersN arbitrary + peersState <- map (\(a, (b, c)) -> (a, b, c)) + . zip txs + <$> vectorOf peersN arbitrary + return (TxSubmissionV2State (Map.fromList (zip peers peersState)) decisionPolicy) + shrink (TxSubmissionV2State peerMap decisionPolicy) = + TxSubmissionV2State <$> shrinkMap1 peerMap + <*> [ policy + | ArbTxDecisionPolicy policy <- shrink (ArbTxDecisionPolicy decisionPolicy) + ] + where + shrinkMap1 :: (Ord k, Arbitrary k, Arbitrary v) => Map k v -> [Map k v] + shrinkMap1 m + | Map.size m <= 1 = [m] + | otherwise = [Map.delete k m | k <- Map.keys m] ++ singletonMaps + where + singletonMaps = [Map.singleton k v | (k, v) <- Map.toList m] + +runTxSubmissionV2 + :: forall m peeraddr txid. + ( MonadAsync m + , MonadDelay m + , MonadFork m + , MonadMask m + , MonadMVar m + , MonadSay m + , MonadST m + , MonadLabelledSTM m + , MonadTimer m + , MonadThrow m + , MonadThrow (STM m) + , MonadMonotonicTime m + , Ord txid + , Eq txid + , ShowProxy txid + , NoThunks (Tx txid) + , Show peeraddr + , Ord peeraddr + + , txid ~ Int + ) + => Tracer m (String, TraceSendRecv (TxSubmission2 txid (Tx txid))) + -> Tracer m (DebugSharedTxState peeraddr txid (Tx txid)) + -> Tracer m (DebugTxLogic peeraddr txid (Tx txid)) + -> Map peeraddr ( [Tx txid] + , ControlMessageSTM m + , Maybe DiffTime + , Maybe DiffTime + ) + -> TxDecisionPolicy + -> m ([Tx txid], [[Tx txid]]) +runTxSubmissionV2 tracer tracerDST tracerTxLogic state txDecisionPolicy = do + + state' <- traverse (\(b, c, d, e) -> do + mempool <- newMempool b + (outChannel, inChannel) <- createConnectedChannels + return (mempool, c, d, e, outChannel, inChannel) + ) state + + inboundMempool <- emptyMempool + + txChannelsMVar <- Strict.newMVar (TxChannels Map.empty) + sharedTxStateVar <- newSharedTxStateVar + labelTVarIO sharedTxStateVar "shared-tx-state" + gsvVar <- Strict.newTVarIO Map.empty + labelTVarIO gsvVar "gsv" + + runTxSubmission state' + txChannelsMVar + sharedTxStateVar + inboundMempool + gsvVar + (\(a, as) -> do + _ <- waitAnyCancel as + cancel a + + inmp <- readMempool inboundMempool + outmp <- forM (Map.elems state') + (\(outMempool, _, _, _, _, _) -> readMempool outMempool) + return (inmp, outmp) + ) + + where + runTxSubmission :: Map peeraddr ( Mempool m txid -- ^ Outbound mempool + , ControlMessageSTM m + , Maybe DiffTime -- ^ Outbound delay + , Maybe DiffTime -- ^ Inbound delay + , Channel m ByteString -- ^ Outbound channel + , Channel m ByteString -- ^ Inbound channel + ) + -> TxChannelsVar m peeraddr txid (Tx txid) + -> SharedTxStateVar m peeraddr txid (Tx txid) + -> Mempool m txid -- ^ Inbound mempool + -> StrictTVar m (Map peeraddr PeerGSV) + -> ((Async m Void, [Async m ((), Maybe ByteString)]) -> m b) + -> m b + runTxSubmission st txChannelsVar sharedTxStateVar + inboundMempool gsvVar k = + withAsync (decisionLogicThread tracerTxLogic txDecisionPolicy (Strict.readTVar gsvVar) txChannelsVar sharedTxStateVar) $ \a -> do + -- Construct txSubmission outbound client + let clients = (\(addr, (mempool, ctrlMsgSTM, outDelay, _, outChannel, _)) -> do + let client = txSubmissionOutbound (Tracer $ say . show) + (NumTxIdsToAck $ getNumTxIdsToReq + $ maxUnacknowledgedTxIds + $ txDecisionPolicy) + (getMempoolReader mempool) + NodeToNodeV_7 + ctrlMsgSTM + runPeerWithLimits (("OUTBOUND " ++ show addr,) `contramap` tracer) + txSubmissionCodec2 + (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) + timeLimitsTxSubmission2 + (maybe id delayChannel outDelay outChannel) + (txSubmissionClientPeer client) + ) + <$> Map.assocs st + + -- Construct txSubmission inbound server + servers = (\(addr, (_, _, _, inDelay, _, inChannel)) -> + withPeer tracerDST + txChannelsVar + sharedTxStateVar + (getMempoolReader inboundMempool) + addr $ \api -> do + let server = txSubmissionInboundV2 verboseTracer + (getMempoolWriter inboundMempool) + api + runPipelinedPeerWithLimits + (("INBOUND " ++ show addr,) `contramap` verboseTracer) + txSubmissionCodec2 + (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) + timeLimitsTxSubmission2 + (maybe id delayChannel inDelay inChannel) + (txSubmissionServerPeerPipelined server) + ) <$> Map.assocs st + + -- Run clients and servers + withAsyncAll (clients ++ servers) (\asyncs -> k (a, asyncs)) + + withAsyncAll :: MonadAsync m => [m a] -> ([Async m a] -> m b) -> m b + withAsyncAll xs0 action = go [] xs0 + where + go as [] = action (reverse as) + go as (x:xs) = withAsync x (\a -> go (a:as) xs) + +txSubmissionV2Simulation :: forall s . TxSubmissionV2State -> IOSim s ([Tx Int], [[Tx Int]]) +txSubmissionV2Simulation (TxSubmissionV2State state txDecisionPolicy) = do + state' <- traverse (\(txs, mbOutDelay, mbInDelay) -> do + let mbOutDelayTime = getSmallDelay . getPositive <$> mbOutDelay + mbInDelayTime = getSmallDelay . getPositive <$> mbInDelay + controlMessageVar <- newTVarIO Continue + return ( txs + , controlMessageVar + , mbOutDelayTime + , mbInDelayTime + ) + ) + state + + state'' <- traverse (\(txs, var, mbOutDelay, mbInDelay) -> do + return ( txs + , readTVar var + , mbOutDelay + , mbInDelay + ) + ) + state' + + let simDelayTime = Map.foldl' (\m (txs, _, mbInDelay, mbOutDelay) -> + max m ( fromMaybe 1 (max <$> mbInDelay <*> mbOutDelay) + * realToFrac (length txs `div` 4) + ) + ) + 0 + $ state'' + controlMessageVars = (\(_, x, _, _) -> x) + <$> Map.elems state' + + _ <- async do + threadDelay (simDelayTime + 1000) + atomically (traverse_ (`writeTVar` Terminate) controlMessageVars) + + let tracer :: forall a. Show a => Tracer (IOSim s) a + tracer = verboseTracer <> debugTracer + runTxSubmissionV2 tracer tracer tracer state'' txDecisionPolicy + +-- | Tests overall tx submission semantics. The properties checked in this +-- property test are the same as for tx submission v1. We need this to know we +-- didn't regress. +-- +prop_txSubmission :: TxSubmissionV2State -> Property +prop_txSubmission st = + let tr = runSimTrace (txSubmissionV2Simulation st) in + case traceResult True tr of + Left e -> + counterexample (show e) + . counterexample (ppTrace tr) + $ False + Right (inmp, outmps) -> + counterexample (ppTrace tr) + $ conjoin (validate inmp `map` outmps) + where + validate :: [Tx Int] -- the inbound mempool + -> [Tx Int] -- one of the outbound mempools + -> Property + validate inmp outmp = + let outUniqueTxIds = nubBy (on (==) getTxId) outmp + outValidTxs = filter getTxValid outmp + in + case ( length outUniqueTxIds == length outmp + , length outValidTxs == length outmp + ) of + x@(True, True) -> + -- If we are presented with a stream of unique txids for valid + -- transactions the inbound transactions should match the outbound + -- transactions exactly. + counterexample (show x) + . counterexample (show inmp) + . counterexample (show outmp) + $ checkMempools inmp (take (length inmp) outValidTxs) + + x@(True, False) -> + -- If we are presented with a stream of unique txids then we should have + -- fetched all valid transactions. + counterexample (show x) + . counterexample (show inmp) + . counterexample (show outmp) + $ checkMempools inmp (take (length inmp) outValidTxs) + + x@(False, True) -> + -- If we are presented with a stream of valid txids then we should have + -- fetched some version of those transactions. + counterexample (show x) + . counterexample (show inmp) + . counterexample (show outmp) + $ checkMempools (map getTxId inmp) + (take (length inmp) + (map getTxId $ filter getTxValid outUniqueTxIds)) + + (False, False) -> + -- If we are presented with a stream of valid and invalid Txs with + -- duplicate txids we're content with completing the protocol + -- without error. + property True + +-- | This test checks that all txs are downloaded from all available peers if +-- available. +-- +-- This test takes advantage of the fact that the mempool implementation +-- allows duplicates. +-- +prop_txSubmission_inflight :: TxSubmissionV2State -> Property +prop_txSubmission_inflight st@(TxSubmissionV2State state _) = + let trace = runSimTrace (txSubmissionV2Simulation st) + maxRepeatedValidTxs = Map.foldr (\(txs, _, _) r -> + foldr (\tx rr -> + if Map.member tx rr && getTxValid tx + then Map.update (Just . succ @Int) tx rr + else if getTxValid tx + then Map.insert tx 1 rr + else rr + ) + r + txs + ) + Map.empty + state + + in case traceResult True trace of + Left err -> counterexample (ppTrace trace) + $ counterexample (show err) + $ property False + Right (inmp, _) -> + let resultRepeatedValidTxs = + foldr (\tx rr -> + if Map.member tx rr && getTxValid tx + then Map.update (Just . succ @Int) tx rr + else if getTxValid tx + then Map.insert tx 1 rr + else rr + ) + Map.empty + inmp + in resultRepeatedValidTxs === maxRepeatedValidTxs + + +-- | Check that the inbound mempool contains all outbound `tx`s as a proper +-- subsequence. It might contain more `tx`s from other peers. +-- +checkMempools :: Eq tx + => [tx] -- inbound mempool + -> [tx] -- outbound mempool + -> Bool +checkMempools _ [] = True -- all outbound `tx` were found in the inbound + -- mempool +checkMempools [] (_:_) = False -- outbound mempool contains `tx`s which were + -- not transferred to the inbound mempool +checkMempools (i : is') os@(o : os') + | i == o + = checkMempools is' os' + + | otherwise + -- `_i` is not present in the outbound mempool, we can skip it. + = checkMempools is' os + + +-- | Split a list into sub list of at most `n` elements. +-- +divvy :: Int -> [a] -> [[a]] +divvy _ [] = [] +divvy n as = take n as : divvy n (drop n as) diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index e312067a84b..b3a0871ee2d 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -74,6 +74,7 @@ module Ouroboros.Network.NodeToNode , RemoteAddress , RemoteConnectionId , IsBigLedgerPeer (..) + , NumTxIdsToAck (..) , ProtocolLimitFailure , Handshake , LocalAddresses (..) @@ -137,6 +138,7 @@ import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Type import Ouroboros.Network.Protocol.Handshake.Version hiding (Accept) +import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..)) import Ouroboros.Network.Snocket import Ouroboros.Network.Socket import Ouroboros.Network.Subscription.Dns (DnsSubscriptionParams, @@ -207,7 +209,7 @@ data MiniProtocolParameters = MiniProtocolParameters { blockFetchPipeliningMax :: !Word16, -- ^ maximal number of pipelined messages in 'block-fetch' mini-protocol. - txSubmissionMaxUnacked :: !Word16 + txSubmissionMaxUnacked :: !NumTxIdsToAck -- ^ maximal number of unacked tx (pipelining is bounded by twice this -- number) } diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs index d727294101b..24427cb4087 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs @@ -262,7 +262,7 @@ txSubmissionInbound tracer (NumTxIdsToAck maxUnacked) mpReader mpWriter _version -- traceWith tracer (TraceTxInboundCanRequestMoreTxs (natToInt n)) pure $ CollectPipelined - (Just (continueWithState (serverReqTxs (Succ n')) st)) + (Just (pure $ continueWithState (serverReqTxs (Succ n')) st)) (collectAndContinueWithState (handleReply n') st) else do diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs new file mode 100644 index 00000000000..e7e2a8f01de --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs @@ -0,0 +1,559 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Ouroboros.Network.TxSubmission.Inbound.Decision + ( TxDecision (..) + , emptyTxDecision + -- * Internal API exposed for testing + , makeDecisions + , filterActivePeers + , SharedDecisionContext (..) + , pickTxsToDownload + ) where + +import Control.Arrow ((>>>)) +import Control.Exception (assert) + +import Data.Bifunctor (second) +import Data.List (mapAccumR, sortOn) +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import Data.Set qualified as Set + +import Data.Sequence.Strict qualified as StrictSeq +import Ouroboros.Network.DeltaQ (PeerGSV (..), defaultGSV, + gsvRequestResponseDuration) +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound.Policy +import Ouroboros.Network.TxSubmission.Inbound.State + + +-- | Decision made by the decision logic. Each peer will receive a 'Decision'. +-- +-- /note:/ it is rather non-standard to represent a choice between requesting +-- `txid`s and `tx`'s as a product rather than a sum type. The client will +-- need to download `tx`s first and then send a request for more txids (and +-- acknowledge some `txid`s). Due to pipelining each client will request +-- decision from the decision logic quite often (every two pipelined requests), +-- but with this design a decision once taken will make the peer non-active +-- (e.g. it won't be returned by `filterActivePeers`) for longer, and thus the +-- expensive `makeDecision` computation will not need to take that peer into +-- account. +-- +data TxDecision txid tx = TxDecision { + txdTxIdsToAcknowledge :: !NumTxIdsToAck, + -- ^ txid's to acknowledge + + txdTxIdsToRequest :: !NumTxIdsToReq, + -- ^ number of txid's to request + + txdPipelineTxIds :: !Bool, + -- ^ the tx-submission protocol only allows to pipeline `txid`'s requests + -- if we have non-acknowledged `txid`s. + + txdTxsToRequest :: !(Set txid), + -- ^ txid's to download. + + txdTxsToMempool :: ![tx] + -- ^ list of `tx`s to submit to the mempool. + } + deriving (Show, Eq) + +-- | A non-commutative semigroup instance. +-- +-- /note:/ this instance must be consistent with `pickTxsToDownload` and how +-- `PeerTxState` is updated. It is designed to work with `TMergeVar`s. +-- +instance Ord txid => Semigroup (TxDecision txid tx) where + TxDecision { txdTxIdsToAcknowledge, + txdTxIdsToRequest, + txdPipelineTxIds = _ignored, + txdTxsToRequest, + txdTxsToMempool } + <> + TxDecision { txdTxIdsToAcknowledge = txdTxIdsToAcknowledge', + txdTxIdsToRequest = txdTxIdsToRequest', + txdPipelineTxIds = txdPipelineTxIds', + txdTxsToRequest = txdTxsToRequest', + txdTxsToMempool = txdTxsToMempool' } + = + TxDecision { txdTxIdsToAcknowledge = txdTxIdsToAcknowledge + txdTxIdsToAcknowledge', + txdTxIdsToRequest = txdTxIdsToRequest + txdTxIdsToRequest', + txdPipelineTxIds = txdPipelineTxIds', + txdTxsToRequest = txdTxsToRequest <> txdTxsToRequest', + txdTxsToMempool = txdTxsToMempool ++ txdTxsToMempool' + } + +emptyTxDecision :: TxDecision txid tx +emptyTxDecision = TxDecision { + txdTxIdsToAcknowledge = 0, + txdTxIdsToRequest = 0, + txdPipelineTxIds = False, + txdTxsToRequest = Set.empty, + txdTxsToMempool = [] + } + +data SharedDecisionContext peeraddr txid tx = SharedDecisionContext { + -- TODO: check how to access it. + sdcPeerGSV :: !(Map peeraddr PeerGSV), + + sdcSharedTxState :: !(SharedTxState peeraddr txid tx) + } + deriving Show + +-- +-- Decision Logic +-- + +-- | Make download decisions. +-- +makeDecisions + :: forall peeraddr txid tx. + ( Ord peeraddr + , Ord txid + ) + => TxDecisionPolicy + -- ^ decision policy + -> SharedDecisionContext peeraddr txid tx + -- ^ decision context + -> Map peeraddr (PeerTxState txid tx) + -- ^ list of available peers. + -- + -- This is a subset of `peerTxStates` of peers which either: + -- * can be used to download a `tx`, + -- * can acknowledge some `txid`s. + -- + -> ( SharedTxState peeraddr txid tx + , Map peeraddr (TxDecision txid tx) + ) +makeDecisions policy SharedDecisionContext { + sdcPeerGSV = peerGSV, + sdcSharedTxState = st + } + = fn + . pickTxsToDownload policy st + . orderByDeltaQ peerGSV + where + fn :: forall a. + (a, [(peeraddr, TxDecision txid tx)]) + -> (a, Map peeraddr (TxDecision txid tx)) + fn (a, as) = (a, Map.fromList as) + + +-- | Order peers by `DeltaQ`. +-- +orderByDeltaQ :: forall peeraddr txid tx. + Ord peeraddr + => Map peeraddr PeerGSV + -> Map peeraddr (PeerTxState txid tx) + -> [(peeraddr, PeerTxState txid tx)] +orderByDeltaQ dq = + sortOn (\(peeraddr, _) -> + gsvRequestResponseDuration + (Map.findWithDefault defaultGSV peeraddr dq) + reqSize + respSize + ) + . Map.toList + where + -- according to calculations in `txSubmissionProtocolLimits`: sizes of + -- `MsgRequestTx` with a single `txid` and `MsgReplyTxs` with a single + -- `tx`. + reqSize :: SizeInBytes + reqSize = 36 -- 32 + 4 (MsgRequestTxs overhead) + + respSize :: SizeInBytes + respSize = 65540 + + +-- | Internal state of `pickTxsToDownload` computation. +-- +data St peeraddr txid tx = + St { stInflightSize :: !SizeInBytes, + -- ^ size of all `tx`s in-flight. + + stInflight :: !(Map txid Int), + -- ^ `txid`s in-flight. + + stAcknowledged :: !(Map txid Int) + -- ^ acknowledged `txid` with multiplicities. It is used to update + -- `referenceCounts`. + } + + +-- | Distribute `tx`'s to download among available peers. Peers are considered +-- in the given order. +-- +-- * pick txs from the set of available tx's (in `txid` order, note these sets +-- might be different for different peers). +-- * pick txs until the peers in-flight limit (we can go over the limit by one tx) +-- (`txsSizeInflightPerPeer` limit) +-- * pick txs until the overall in-flight limit (we can go over the limit by one tx) +-- (`maxTxsSizeInflight` limit) +-- * each tx can be downloaded simultaneously from at most +-- `txInflightMultiplicity` peers. +-- +pickTxsToDownload + :: forall peeraddr txid tx. + ( Ord peeraddr + , Ord txid + ) + => TxDecisionPolicy + -- ^ decision policy + -> SharedTxState peeraddr txid tx + -- ^ shared state + + -> [(peeraddr, PeerTxState txid tx)] + -> ( SharedTxState peeraddr txid tx + , [(peeraddr, TxDecision txid tx)] + ) + +pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, + maxTxsSizeInflight, + txInflightMultiplicity } + sharedState@SharedTxState { peerTxStates, + inflightTxs, + inflightTxsSize, + bufferedTxs, + referenceCounts } = + -- outer fold: fold `[(peeraddr, PeerTxState txid tx)]` + mapAccumR + accumFn + -- initial state + St { stInflight = inflightTxs, + stInflightSize = inflightTxsSize, + stAcknowledged = Map.empty } + + >>> + gn + where + accumFn :: St peeraddr txid tx + -> (peeraddr, PeerTxState txid tx) + -> ( St peeraddr txid tx + , ( (peeraddr, PeerTxState txid tx) + , TxDecision txid tx + ) + ) + accumFn + st@St { stInflight, + stInflightSize, + stAcknowledged } + ( peeraddr + , peerTxState@PeerTxState { availableTxIds, + unknownTxs, + requestedTxsInflight, + requestedTxsInflightSize + } + ) + = + let sizeInflightAll :: SizeInBytes + sizeInflightOther :: SizeInBytes + + sizeInflightAll = stInflightSize + sizeInflightOther = sizeInflightAll - requestedTxsInflightSize + + in if sizeInflightAll >= maxTxsSizeInflight + then let (numTxIdsToAck, numTxIdsToReq, txsToMempool, RefCountDiff { txIdsToAck }, peerTxState') = + acknowledgeTxIds policy sharedState peerTxState + + stAcknowledged' = Map.unionWith (+) stAcknowledged txIdsToAck + in + if requestedTxIdsInflight peerTxState' > 0 + then + -- we have txids to request + ( st { stAcknowledged = stAcknowledged' } + , ( (peeraddr, peerTxState') + , TxDecision { txdTxIdsToAcknowledge = numTxIdsToAck, + txdTxIdsToRequest = numTxIdsToReq, + txdPipelineTxIds = not + . StrictSeq.null + . unacknowledgedTxIds + $ peerTxState', + txdTxsToRequest = Set.empty, + txdTxsToMempool = txsToMempool + } + ) + ) + else + -- there are no `txid`s to request, nor we can request `tx`s due + -- to in-flight size limits + ( st + , ( (peeraddr, peerTxState') + , emptyTxDecision + ) + ) + else + let requestedTxsInflightSize' :: SizeInBytes + txsToRequest :: Set txid + + (requestedTxsInflightSize', txsToRequest) = + -- inner fold: fold available `txid`s + -- + -- Note: although `Map.foldrWithKey` could be used here, it + -- does not allow to short circuit the fold, unlike + -- `foldWithState`. + foldWithState + (\(txid, (txSize, inflightMultiplicity)) sizeInflight -> + if -- note that we pick `txid`'s as long the `s` is + -- smaller or equal to `txsSizeInflightPerPeer`. + sizeInflight <= txsSizeInflightPerPeer + -- overall `tx`'s in-flight must be smaller than + -- `maxTxsSizeInflight` + && sizeInflight + sizeInflightOther <= maxTxsSizeInflight + -- the transaction must not be downloaded from more + -- than `txInflightMultiplicity` peers simultaneously + && inflightMultiplicity < txInflightMultiplicity + -- TODO: we must validate that `txSize` is smaller than + -- maximum txs size + then Just (sizeInflight + txSize, txid) + else Nothing + ) + (Map.assocs $ + -- merge `availableTxIds` with `stInflight`, so we don't + -- need to lookup into `stInflight` on every `txid` which + -- is in `availableTxIds`. + Map.merge (Map.mapMaybeMissing \_txid -> Just . (,0)) + Map.dropMissing + (Map.zipWithMatched \_txid -> (,)) + + availableTxIds + stInflight + -- remove `tx`s which were already downloaded by some + -- other peer or are in-flight or unknown by this peer. + `Map.withoutKeys` + (Map.keysSet bufferedTxs <> requestedTxsInflight <> unknownTxs) + + ) + requestedTxsInflightSize + -- pick from `txid`'s which are available from that given + -- peer. Since we are folding a dictionary each `txid` + -- will be selected only once from a given peer (at least + -- in each round). + + peerTxState' = peerTxState { + requestedTxsInflightSize = requestedTxsInflightSize', + requestedTxsInflight = requestedTxsInflight + <> txsToRequest + } + + (numTxIdsToAck, numTxIdsToReq, txsToMempool, RefCountDiff { txIdsToAck }, peerTxState'') = + acknowledgeTxIds policy sharedState peerTxState' + + stAcknowledged' = Map.unionWith (+) stAcknowledged txIdsToAck + + stInflightDelta :: Map txid Int + stInflightDelta = Map.fromSet (\_ -> 1) txsToRequest + -- note: this is right since every `txid` + -- could be picked at most once + + stInflight' :: Map txid Int + stInflight' = Map.unionWith (+) stInflightDelta stInflight + in + if requestedTxIdsInflight peerTxState'' > 0 + then + -- we can request `txid`s & `tx`s + ( St { stInflight = stInflight', + stInflightSize = sizeInflightOther + requestedTxsInflightSize', + stAcknowledged = stAcknowledged' } + , ( (peeraddr, peerTxState'') + , TxDecision { txdTxIdsToAcknowledge = numTxIdsToAck, + txdPipelineTxIds = not + . StrictSeq.null + . unacknowledgedTxIds + $ peerTxState'', + txdTxIdsToRequest = numTxIdsToReq, + txdTxsToRequest = txsToRequest, + txdTxsToMempool = txsToMempool + } + ) + ) + else + -- there are no `txid`s to request, only `tx`s. + ( st { stInflight = stInflight', + stInflightSize = sizeInflightOther + requestedTxsInflightSize' + } + , ( (peeraddr, peerTxState'') + , emptyTxDecision { txdTxsToRequest = txsToRequest } + ) + ) + + gn :: ( St peeraddr txid tx + , [((peeraddr, PeerTxState txid tx), TxDecision txid tx)] + ) + -> ( SharedTxState peeraddr txid tx + , [(peeraddr, TxDecision txid tx)] + ) + gn + ( St { stInflight, + stInflightSize, + stAcknowledged } + , as + ) + = + let peerTxStates' = Map.fromList ((\(a,_) -> a) <$> as) + <> peerTxStates + + referenceCounts' = + Map.merge (Map.mapMaybeMissing \_ x -> Just x) + (Map.mapMaybeMissing \_ _ -> assert False Nothing) + (Map.zipWithMaybeMatched \_ x y -> if x > y then Just $! x - y + else Nothing) + referenceCounts + stAcknowledged + + liveSet = Map.keysSet referenceCounts' + + bufferedTxs' = bufferedTxs + `Map.restrictKeys` + liveSet + + in ( sharedState { + peerTxStates = peerTxStates', + inflightTxs = stInflight, + inflightTxsSize = stInflightSize, + bufferedTxs = bufferedTxs', + referenceCounts = referenceCounts' } + , -- exclude empty results + mapMaybe (\((a, _), b) -> case b of + TxDecision { txdTxIdsToAcknowledge = 0, + txdTxIdsToRequest = 0, + txdTxsToRequest, + txdTxsToMempool } + | null txdTxsToRequest + , null txdTxsToMempool + -> Nothing + _ -> Just (a, b) + ) + as + ) + + + +-- | Filter peers which can either download a `tx` or acknowledge `txid`s. +-- +filterActivePeers + :: forall peeraddr txid tx. + Ord txid + => TxDecisionPolicy + -> SharedTxState peeraddr txid tx + -> Map peeraddr (PeerTxState txid tx) +filterActivePeers + TxDecisionPolicy { maxUnacknowledgedTxIds, + txsSizeInflightPerPeer, + maxTxsSizeInflight, + txInflightMultiplicity, + maxNumTxIdsToRequest + } + SharedTxState { peerTxStates, + bufferedTxs, + inflightTxs, + inflightTxsSize } + | overLimit + = Map.filter fn peerTxStates + | otherwise + = Map.filter gn peerTxStates + where + overLimit = inflightTxsSize > maxTxsSizeInflight + unrequestable = Map.keysSet (Map.filter (>= txInflightMultiplicity) inflightTxs) + <> Map.keysSet bufferedTxs + + fn :: PeerTxState txid tx -> Bool + fn PeerTxState { unacknowledgedTxIds, + requestedTxIdsInflight, + unknownTxs + } = + -- hasTxIdsToAcknowledge st ps || + requestedTxIdsInflight == 0 -- document why it's not <= maxTxIdsInFlightPerPeer + && requestedTxIdsInflight + numOfUnacked <= maxUnacknowledgedTxIds + && txIdsToRequest > 0 + where + -- Split `unacknowledgedTxIds'` into the longest prefix of `txid`s which + -- can be acknowledged and the unacknowledged `txid`s. + (acknowledgedTxIds, _) = + StrictSeq.spanl (\txid -> txid `Map.member` bufferedTxs + || txid `Set.member` unknownTxs + ) + unacknowledgedTxIds + numOfUnacked = fromIntegral (StrictSeq.length unacknowledgedTxIds) + numOfAcked = StrictSeq.length acknowledgedTxIds + unackedAndRequested = numOfUnacked + requestedTxIdsInflight + txIdsToRequest = + assert (unackedAndRequested <= maxUnacknowledgedTxIds) $ + assert (requestedTxIdsInflight <= maxNumTxIdsToRequest) $ + (maxUnacknowledgedTxIds - unackedAndRequested + fromIntegral numOfAcked) + `min` + (maxNumTxIdsToRequest - requestedTxIdsInflight) + + gn :: PeerTxState txid tx -> Bool + gn PeerTxState { unacknowledgedTxIds, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize, + availableTxIds, + unknownTxs } = + -- hasTxIdsToAcknowledge st ps || + ( requestedTxIdsInflight == 0 + && requestedTxIdsInflight + numOfUnacked <= maxUnacknowledgedTxIds + && txIdsToRequest > 0 + ) + || (underSizeLimit && not (Map.null downloadable)) + where + numOfUnacked = fromIntegral (StrictSeq.length unacknowledgedTxIds) + underSizeLimit = requestedTxsInflightSize <= txsSizeInflightPerPeer + downloadable = availableTxIds + `Map.withoutKeys` requestedTxsInflight + `Map.withoutKeys` unknownTxs + `Map.withoutKeys` unrequestable + + -- Split `unacknowledgedTxIds'` into the longest prefix of `txid`s which + -- can be acknowledged and the unacknowledged `txid`s. + (acknowledgedTxIds, _) = + StrictSeq.spanl (\txid -> txid `Map.member` bufferedTxs + || txid `Set.member` unknownTxs + ) + unacknowledgedTxIds + numOfAcked = StrictSeq.length acknowledgedTxIds + unackedAndRequested = numOfUnacked + requestedTxIdsInflight + txIdsToRequest = + assert (unackedAndRequested <= maxUnacknowledgedTxIds) $ + assert (requestedTxIdsInflight <= maxNumTxIdsToRequest) $ + (maxUnacknowledgedTxIds - unackedAndRequested + fromIntegral numOfAcked) + `min` + (maxNumTxIdsToRequest - requestedTxIdsInflight) + +-- +-- Auxiliary functions +-- + +-- | A fold with state implemented as a `foldr` to take advantage of fold-build +-- fusion optimisation. +-- +foldWithState + :: forall s a b. + Ord b + => (a -> s -> Maybe (s, b)) + -> [a] -> s -> (s, Set b) +{-# INLINE foldWithState #-} + +foldWithState f = foldr cons nil + where + cons :: a + -> (s -> (s, Set b)) + -> (s -> (s, Set b)) + cons a k = \ !s -> + case f a s of + Nothing -> nil s + Just (!s', !b) -> + case Set.insert b `second` k s' of + r@(!_s, !_bs) -> r + + nil :: s -> (s, Set b) + nil = \ !s -> (s, Set.empty) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs new file mode 100644 index 00000000000..7f6fb1569e0 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs @@ -0,0 +1,45 @@ +module Ouroboros.Network.TxSubmission.Inbound.Policy + ( TxDecisionPolicy (..) + , defaultTxDecisionPolicy + ) where + +import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToReq (..)) +import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) + +-- | Policy for making decisions +-- +data TxDecisionPolicy = TxDecisionPolicy { + maxNumTxIdsToRequest :: !NumTxIdsToReq, + -- ^ a maximal number of txids requested at once. + + maxUnacknowledgedTxIds :: !NumTxIdsToReq, + -- ^ maximal number of unacknowledgedTxIds. Measured in `NumTxIdsToReq` + -- since we enforce this policy by requesting not more txids than what + -- this limit allows. + + -- + -- Configuration of tx decision logic. + -- + + txsSizeInflightPerPeer :: !SizeInBytes, + -- ^ a limit of tx size in-flight from a single peer. + -- It can be exceed by max tx size. + + maxTxsSizeInflight :: !SizeInBytes, + -- ^ a limit of tx size in-flight from all peers. + -- It can be exceed by max tx size. + + txInflightMultiplicity :: !Int + -- ^ from how many peers download the `txid` simultaneously + } + deriving Show + +defaultTxDecisionPolicy :: TxDecisionPolicy +defaultTxDecisionPolicy = + TxDecisionPolicy { + maxNumTxIdsToRequest = 1, + maxUnacknowledgedTxIds = 2, + txsSizeInflightPerPeer = 2, + maxTxsSizeInflight = maxBound, + txInflightMultiplicity = 2 + } diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs new file mode 100644 index 00000000000..9eb12459f00 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Network.TxSubmission.Inbound.Registry + ( TxChannels (..) + , TxChannelsVar + , SharedTxStateVar + , newSharedTxStateVar + , newTxChannelsVar + , PeerTxAPI (..) + , decisionLogicThread + , DebugTxLogic (..) + , withPeer + ) where + +import Control.Concurrent.Class.MonadMVar.Strict +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTimer.SI + +import Data.Foldable (traverse_) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Void (Void) + +import Control.Tracer (Tracer, traceWith) +import Ouroboros.Network.DeltaQ (PeerGSV (..)) +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound.Decision +import Ouroboros.Network.TxSubmission.Inbound.Policy +import Ouroboros.Network.TxSubmission.Inbound.State +import Ouroboros.Network.TxSubmission.Mempool.Reader + +-- | Communication channels between `TxSubmission` client mini-protocol and +-- decision logic. +-- +newtype TxChannels m peeraddr txid tx = TxChannels { + txChannelMap :: Map peeraddr (StrictMVar m (TxDecision txid tx)) + } + +type TxChannelsVar m peeraddr txid tx = StrictMVar m (TxChannels m peeraddr txid tx) + +newTxChannelsVar :: MonadMVar m => m (TxChannelsVar m peeraddr txid tx) +newTxChannelsVar = newMVar (TxChannels Map.empty) + +-- | API to access `PeerTxState` inside `PeerTxStateVar`. +-- +data PeerTxAPI m txid tx = PeerTxAPI { + readTxDecision :: m (TxDecision txid tx), + -- ^ a blocking action which reads `TxDecision` + + handleReceivedTxIds :: NumTxIdsToReq + -> StrictSeq txid + -- ^ received txids + -> Map txid SizeInBytes + -- ^ received sizes of advertised tx's + -> m (), + -- ^ handle received txids + + handleReceivedTxs :: Set txid + -- ^ requested txids + -> Map txid tx + -- ^ received txs + -> m () + -- ^ handle received txs + } + + +data TraceDecision peeraddr txid tx = + TraceDecisions (Map peeraddr (TxDecision txid tx)) + deriving (Eq, Show) + +-- | A bracket function which registers / de-registers a new peer in +-- `SharedTxStateVar` and `PeerTxStateVar`s, which exposes `PeerTxStateAPI`. +-- `PeerTxStateAPI` is only safe inside the `withPeer` scope. +-- +withPeer + :: forall tx peeraddr txid idx m a. + ( MonadMask m + , MonadMVar m + , MonadSTM m + , Ord txid + , Ord peeraddr + , Show peeraddr + ) + => Tracer m (DebugSharedTxState peeraddr txid tx) + -> TxChannelsVar m peeraddr txid tx + -> SharedTxStateVar m peeraddr txid tx + -> TxSubmissionMempoolReader txid tx idx m + -> peeraddr + -- ^ new peer + -> (PeerTxAPI m txid tx -> m a) + -- ^ callback which gives access to `PeerTxStateAPI` + -> m a +withPeer tracer + channelsVar + sharedStateVar + TxSubmissionMempoolReader { mempoolGetSnapshot } + peeraddr io = + bracket + (do -- create a communication channel + !peerTxAPI <- + modifyMVar channelsVar + \ TxChannels { txChannelMap } -> do + chann <- newEmptyMVar + let (chann', txChannelMap') = + Map.alterF (\mbChann -> + let !chann'' = fromMaybe chann mbChann + in (chann'', Just chann'')) + peeraddr + txChannelMap + return + ( TxChannels { txChannelMap = txChannelMap' } + , PeerTxAPI { readTxDecision = takeMVar chann', + handleReceivedTxIds, + handleReceivedTxs } + ) + + atomically $ modifyTVar sharedStateVar registerPeer + return peerTxAPI + ) + -- the handler is a short blocking operation, thus we need to use + -- `uninterruptibleMask_` + (\_ -> uninterruptibleMask_ do + atomically $ modifyTVar sharedStateVar unregisterPeer + modifyMVar_ channelsVar + \ TxChannels { txChannelMap } -> + return TxChannels { txChannelMap = Map.delete peeraddr txChannelMap } + ) + io + where + registerPeer :: SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + registerPeer st@SharedTxState { peerTxStates } = + st { peerTxStates = + Map.insert + peeraddr + PeerTxState { + availableTxIds = Map.empty, + requestedTxIdsInflight = 0, + requestedTxsInflightSize = 0, + requestedTxsInflight = Set.empty, + unacknowledgedTxIds = StrictSeq.empty, + unknownTxs = Set.empty } + peerTxStates + } + + -- TODO: this function needs to be tested! + unregisterPeer :: SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + unregisterPeer st@SharedTxState { peerTxStates, + bufferedTxs, + referenceCounts } = + st { peerTxStates = peerTxStates', + bufferedTxs = bufferedTxs', + referenceCounts = referenceCounts' } + where + (PeerTxState { unacknowledgedTxIds }, peerTxStates') = + Map.alterF + (\case + Nothing -> error ("TxSubmission.withPeer: invariant violation for peer " ++ show peeraddr) + Just a -> (a, Nothing)) + peeraddr + peerTxStates + + referenceCounts' = + foldl' (flip $ Map.update + \cnt -> if cnt > 1 + then Just $! pred cnt + else Nothing) + referenceCounts + unacknowledgedTxIds + + liveSet = Map.keysSet referenceCounts' + + bufferedTxs' = bufferedTxs + `Map.restrictKeys` + liveSet + + -- + -- PeerTxAPI + -- + + handleReceivedTxIds :: NumTxIdsToReq + -> StrictSeq txid + -> Map txid SizeInBytes + -> m () + handleReceivedTxIds numTxIdsToReq txidsSeq txidsMap = + receivedTxIds tracer + sharedStateVar + mempoolGetSnapshot + peeraddr + numTxIdsToReq + txidsSeq + txidsMap + + + handleReceivedTxs :: Set txid + -- ^ requested txids + -> Map txid tx + -- ^ received txs + -> m () + handleReceivedTxs txids txs = + collectTxs tracer sharedStateVar peeraddr txids txs + + +-- | TODO: reorganise modules so there's just one `Debug` tracer. +data DebugTxLogic peeraddr txid tx = + DebugTxLogicSharedTxState (SharedTxState peeraddr txid tx) + | DebugTxLogicDecisions (Map peeraddr (TxDecision txid tx)) + deriving Show + + +decisionLogicThread + :: forall m peeraddr txid tx. + ( MonadDelay m + , MonadMVar m + , MonadSTM m + , MonadMask m + , MonadFork m + , Ord peeraddr + , Ord txid + ) + => Tracer m (DebugTxLogic peeraddr txid tx) + -> TxDecisionPolicy + -> STM m (Map peeraddr PeerGSV) + -> TxChannelsVar m peeraddr txid tx + -> SharedTxStateVar m peeraddr txid tx + -> m Void +decisionLogicThread tracer policy readGSVVar txChannelsVar sharedStateVar = do + labelThisThread "tx-decision" + go + where + go :: m Void + go = do + -- We rate limit the decision making process, it could overwhelm the CPU + -- if there are too many inbound connections. + threadDelay 0.005 -- 5ms + + (decisions, st) <- atomically do + sharedCtx <- + SharedDecisionContext + <$> readGSVVar + <*> readTVar sharedStateVar + let activePeers = filterActivePeers policy (sdcSharedTxState sharedCtx) + + -- block until at least one peer is active + check (not (Map.null activePeers)) + + let (sharedState, decisions) = makeDecisions policy sharedCtx activePeers + writeTVar sharedStateVar sharedState + return (decisions, sharedState) + traceWith tracer (DebugTxLogicSharedTxState st) + traceWith tracer (DebugTxLogicDecisions decisions) + TxChannels { txChannelMap } <- readMVar txChannelsVar + traverse_ + (\(mvar, d) -> modifyMVarWithDefault_ mvar d (\d' -> pure (d' <> d))) + (Map.intersectionWith (,) + txChannelMap + decisions) + go + + -- Variant of modifyMVar_ that puts a default value if the MVar is empty. + modifyMVarWithDefault_ :: StrictMVar m a -> a -> (a -> m a) -> m () + modifyMVarWithDefault_ m d io = + mask $ \restore -> do + mbA <- tryTakeMVar m + case mbA of + Just a -> do + a' <- restore (io a) `onException` putMVar m a + putMVar m a' + Nothing -> putMVar m d diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs new file mode 100644 index 00000000000..812322a1f18 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Network.TxSubmission.Inbound.Server where + +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set qualified as Set + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Exception (assert) +import Control.Monad.Class.MonadThrow +import Control.Tracer (Tracer, traceWith) + +import Network.TypedProtocol.Pipelined + +import Control.Monad (unless) +import Ouroboros.Network.Protocol.TxSubmission2.Server +import Ouroboros.Network.TxSubmission.Inbound.Decision (TxDecision (..)) +import Ouroboros.Network.TxSubmission.Inbound.Registry (PeerTxAPI (..)) +import Ouroboros.Network.TxSubmission.Inbound.Types + + +-- | A tx-submission outbound side (server, sic!). +-- +-- The server blocks on receiving `TxDecision` from the decision logic. If +-- there are tx's to download it pipelines two requests: first for tx's second +-- for txid's. If there are no tx's to download, it either sends a blocking or +-- non-blocking request for txid's. +-- +txSubmissionInboundV2 + :: forall txid tx idx m. + ( MonadSTM m + , MonadThrow m + , Ord txid + ) + => Tracer m (TraceTxSubmissionInbound txid tx) + -> TxSubmissionMempoolWriter txid tx idx m + -> PeerTxAPI m txid tx + -> TxSubmissionServerPipelined txid tx m () +txSubmissionInboundV2 + tracer + TxSubmissionMempoolWriter { + txId, + mempoolAddTxs + } + PeerTxAPI { + readTxDecision, + handleReceivedTxIds, + handleReceivedTxs + } + = + TxSubmissionServerPipelined serverIdle + where + serverIdle + :: m (ServerStIdle Z txid tx m ()) + serverIdle = do + -- Block on next decision. + txd@TxDecision { txdTxsToRequest = txsToReq, txdTxsToMempool = txs } + <- readTxDecision + traceWith tracer (TraceTxInboundDecision txd) + txidsAccepted <- mempoolAddTxs txs + traceWith tracer $ + TraceTxInboundAddedToMempool txidsAccepted + let !collected = length txidsAccepted + traceWith tracer $ + TraceTxSubmissionCollected collected + -- TODO: + -- We can update the state so that other `tx-submission` servers will + -- not try to add these txs to the mempool. + if Set.null txsToReq + then serverReqTxIds Zero txd + else serverReqTxs txd + + + -- Pipelined request of txs + serverReqTxs :: TxDecision txid tx + -> m (ServerStIdle Z txid tx m ()) + serverReqTxs txd@TxDecision { txdTxsToRequest = txsToReq } = + pure $ SendMsgRequestTxsPipelined (Set.toList txsToReq) + (serverReqTxIds (Succ Zero) txd) + + + serverReqTxIds :: forall (n :: N). + Nat n + -> TxDecision txid tx + -> m (ServerStIdle n txid tx m ()) + serverReqTxIds + n TxDecision { txdTxIdsToRequest = 0 } + = + case n of + Zero -> serverIdle + Succ _ -> handleReplies n + + serverReqTxIds + -- if there are no unacknowledged txids, the protocol requires sending + -- a blocking `MsgRequestTxIds` request. This is important, as otherwise + -- the client side wouldn't have a chance to terminate the + -- mini-protocol. + Zero TxDecision { txdTxIdsToAcknowledge = txIdsToAck, + txdPipelineTxIds = False, + txdTxIdsToRequest = txIdsToReq + } + = + pure $ SendMsgRequestTxIdsBlocking + txIdsToAck txIdsToReq + -- Our result if the client terminates the protocol + (traceWith tracer TraceTxInboundTerminated) + (\txids -> do + let txids' = NonEmpty.toList txids + txidsSeq = StrictSeq.fromList $ fst <$> txids' + txidsMap = Map.fromList txids' + unless (StrictSeq.length txidsSeq <= fromIntegral txIdsToReq) $ + throwIO ProtocolErrorTxIdsNotRequested + handleReceivedTxIds txIdsToReq txidsSeq txidsMap + serverIdle + ) + + serverReqTxIds + n@Zero TxDecision { txdTxIdsToAcknowledge = txIdsToAck, + txdPipelineTxIds = True, + txdTxIdsToRequest = txIdsToReq + } + = + pure $ SendMsgRequestTxIdsPipelined + txIdsToAck txIdsToReq + (handleReplies (Succ n)) + + serverReqTxIds + n@Succ{} TxDecision { txdTxIdsToAcknowledge = txIdsToAck, + txdPipelineTxIds, + txdTxIdsToRequest = txIdsToReq + } + = + -- it is impossible that we have had `tx`'s to request (Succ{} - is an + -- evidence for that), but no unacknowledged `txid`s. + assert txdPipelineTxIds $ + pure $ SendMsgRequestTxIdsPipelined + txIdsToAck txIdsToReq + (handleReplies (Succ n)) + + + handleReplies :: forall (n :: N). + Nat (S n) + -> m (ServerStIdle (S n) txid tx m ()) + handleReplies (Succ n'@Succ{}) = + pure $ CollectPipelined + Nothing + (handleReply (handleReplies n')) + + handleReplies (Succ Zero) = + pure $ CollectPipelined + Nothing + (handleReply serverIdle) + + handleReply :: forall (n :: N). + m (ServerStIdle n txid tx m ()) + -- continuation + -> Collect txid tx + -> m (ServerStIdle n txid tx m ()) + handleReply k = \case + CollectTxIds txIdsToReq txids -> do + let txidsSeq = StrictSeq.fromList $ fst <$> txids + txidsMap = Map.fromList txids + unless (StrictSeq.length txidsSeq <= fromIntegral txIdsToReq) $ + throwIO ProtocolErrorTxIdsNotRequested + handleReceivedTxIds txIdsToReq txidsSeq txidsMap + k + CollectTxs txids txs -> do + let requested = Set.fromList txids + received = Map.fromList [ (txId tx, tx) | tx <- txs ] + + unless (Map.keysSet received `Set.isSubsetOf` requested) $ + throwIO ProtocolErrorTxNotRequested + -- TODO: all sizes of txs which were announced earlier with + -- `MsgReplyTxIds` must be verified. + + handleReceivedTxs requested received + k diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs new file mode 100644 index 00000000000..2b6263ca198 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs @@ -0,0 +1,599 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Network.TxSubmission.Inbound.State + ( -- * Core API + SharedTxState (..) + , PeerTxState (..) + , numTxIdsToRequest + , SharedTxStateVar + , newSharedTxStateVar + , receivedTxIds + , collectTxs + , acknowledgeTxIds + -- * Debug output + , DebugSharedTxState (..) + -- * Internals, only exported for testing purposes: + , RefCountDiff (..) + , updateRefCounts + , receivedTxIdsImpl + , collectTxsImpl + ) where + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Exception (assert) +import Control.Tracer (Tracer, traceWith) + +import Data.Foldable (fold, foldl', toList) +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromJust, maybeToList) +import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Generics (Generic) + +import NoThunks.Class (NoThunks (..)) + +import GHC.Stack (HasCallStack) +import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..), + NumTxIdsToReq (..)) +import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) +import Ouroboros.Network.TxSubmission.Inbound.Policy +import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..)) + + +data PeerTxState txid tx = PeerTxState { + -- | Those transactions (by their identifier) that the client has told + -- us about, and which we have not yet acknowledged. This is kept in + -- the order in which the client gave them to us. This is the same order + -- in which we submit them to the mempool (or for this example, the final + -- result order). It is also the order we acknowledge in. + -- + unacknowledgedTxIds :: !(StrictSeq txid), + + -- | Set of known transaction ids which can be requested from this peer. + -- + availableTxIds :: !(Map txid SizeInBytes), + + -- | The number of transaction identifiers that we have requested but + -- which have not yet been replied to. We need to track this it keep + -- our requests within the limit on the number of unacknowledged txids. + -- + requestedTxIdsInflight :: !NumTxIdsToReq, + + -- | The size in bytes of transactions that we have requested but which + -- have not yet been replied to. We need to track this it keep our + -- requests within the limit on the number of unacknowledged txids. + -- + requestedTxsInflightSize :: !SizeInBytes, + + -- | The set of requested `txid`s. + -- + requestedTxsInflight :: !(Set txid), + + -- | A subset of `unacknowledgedTxIds` which were unknown to the peer. + -- We need to track these `txid`s since they need to be acknowledged. + -- + -- We track these `txid` per peer, rather than in `bufferedTxs` map, + -- since that could potentially lead to corrupting the node, not being + -- able to download a `tx` which is needed & available from other nodes. + -- + unknownTxs :: !(Set txid) + } + deriving (Eq, Show, Generic) + +instance ( NoThunks txid + , NoThunks tx + ) => NoThunks (PeerTxState txid tx) + + +-- | Compute number of `txids` to request respecting `TxDecisionPolicy`; update +-- `PeerTxState`. +-- +numTxIdsToRequest :: TxDecisionPolicy + -> PeerTxState txid tx + -> (NumTxIdsToReq, PeerTxState txid tx) +numTxIdsToRequest + TxDecisionPolicy { maxNumTxIdsToRequest, + maxUnacknowledgedTxIds } + ps@PeerTxState { unacknowledgedTxIds, + requestedTxIdsInflight } + = + ( txIdsToRequest + , ps { requestedTxIdsInflight = requestedTxIdsInflight + + txIdsToRequest } + ) + where + -- we are forcing two invariants here: + -- * there are at most `maxUnacknowledgedTxIds` (what we request is added to + -- `unacknowledgedTxIds`) + -- * there are at most `maxNumTxIdsToRequest` txid requests at a time per + -- peer + -- + -- TODO: both conditions provide an upper bound for overall requests for + -- `txid`s to all inbound peers. + txIdsToRequest, unacked, unackedAndRequested :: NumTxIdsToReq + + txIdsToRequest = + assert (unackedAndRequested <= maxUnacknowledgedTxIds) $ + assert (requestedTxIdsInflight <= maxNumTxIdsToRequest) $ + (maxUnacknowledgedTxIds - unackedAndRequested) + `min` (maxNumTxIdsToRequest - requestedTxIdsInflight) + + unackedAndRequested = unacked + requestedTxIdsInflight + unacked = fromIntegral $ StrictSeq.length unacknowledgedTxIds + + +-- | Shared state of all `TxSubmission` clients. +-- +-- New `txid` enters `unacknowledgedTxIds` it is also added to `availableTxIds` +-- and `referenceCounts` (see `acknowledgeTxIdsImpl`). +-- +-- When a `txid` id is selected to be downloaded, it's added to +-- `requestedTxsInflightSize` (see +-- `Ouroboros.Network.TxSubmission.Inbound.Decision.pickTxsToDownload`). +-- +-- When the request arrives, the `txid` is removed from `inflightTxs`. It +-- might be added to `unknownTxs` if the server didn't have that `txid`, or +-- it's added to `bufferedTxs` (see `collectTxsImpl`). +-- +-- Whenever we choose `txid` to acknowledge (either in `acknowledtxsIdsImpl`, +-- `collectTxsImpl` or +-- `Ouroboros.Network.TxSubmission.Inbound.Decision.pickTxsToDownload`, we also +-- recalculate `referenceCounts` and only keep live `txid`s in other maps (e.g. +-- `availableTxIds`, `bufferedTxs`, `unknownTxs`). +-- +data SharedTxState peeraddr txid tx = SharedTxState { + + -- | Map of peer states. + -- + -- /Invariant:/ for peeraddr's which are registered using `withPeer`, + -- there's always an entry in this map even if the set of `txid`s is + -- empty. + -- + peerTxStates :: !(Map peeraddr (PeerTxState txid tx)), + + -- | Set of transactions which are in-flight (have already been + -- requested) together with multiplicities (from how many peers it is + -- currently in-flight) + -- + -- This set can intersect with `availableTxIds`. + -- + inflightTxs :: !(Map txid Int), + + -- | Overall size of all `tx`s in-flight. + -- + inflightTxsSize :: !SizeInBytes, + + -- | Map of `tx` which: + -- + -- * were downloaded, + -- * are already in the mempool (`Nothing` is inserted in that case), + -- + -- We only keep live `txid`, e.g. ones which `txid` is unacknowledged by + -- at least one peer. + -- + -- /Note:/ `txid`s which `tx` were unknown by a peer are tracked + -- separately in `unknownTxs`. + -- + -- /Note:/ previous implementation also needed to explicitly tracked + -- `txid`s which were already acknowledged, but are still unacknowledged. + -- In this implementation, this is done due to reference counting. + -- + -- This map is useful to acknowledge `txid`s, it's basically taking the + -- longest prefix which contains entries in `bufferedTxs` or `unknownTxs`. + -- + bufferedTxs :: !(Map txid (Maybe tx)), + + -- | We track reference counts of all unacknowledged txids. Once the + -- count reaches 0, a tx is removed from `bufferedTxs`. + -- + -- The `bufferedTx` map contains a subset of `txid` which + -- `referenceCounts` contains. + -- + -- /Invariants:/ + -- + -- * the txid count is equal to multiplicity of txid in all + -- `unacknowledgedTxIds` sequences; + -- * @Map.keysSet bufferedTxs `Set.isSubsetOf` Map.keysSet referenceCounts@; + -- * all counts are positive integers. + -- + referenceCounts :: !(Map txid Int) + } + deriving (Eq, Show, Generic) + +instance ( NoThunks peeraddr + , NoThunks tx + , NoThunks txid + ) => NoThunks (SharedTxState peeraddr txid tx) + +-- +-- Pure public API +-- + +acknowledgeTxIds + :: forall peeraddr tx txid. + Ord txid + => TxDecisionPolicy + -> SharedTxState peeraddr txid tx + -> PeerTxState txid tx + -> (NumTxIdsToAck, NumTxIdsToReq, [tx], RefCountDiff txid, PeerTxState txid tx) + -- ^ number of txid to acknowledge, txids to acknowledge with multiplicities, + -- updated PeerTxState. +{-# INLINE acknowledgeTxIds #-} + +acknowledgeTxIds + TxDecisionPolicy { maxNumTxIdsToRequest, + maxUnacknowledgedTxIds } + SharedTxState { bufferedTxs } + ps@PeerTxState { availableTxIds, + unacknowledgedTxIds, + unknownTxs, + requestedTxIdsInflight } + = + -- We can only acknowledge txids when we can request new ones, since + -- a `MsgRequestTxIds` for 0 txids is a protocol error. + if txIdsToRequest > 0 + then + ( txIdsToAcknowledge + , txIdsToRequest + , txsToMempool + , refCountDiff + , ps { unacknowledgedTxIds = unacknowledgedTxIds', + availableTxIds = availableTxIds', + unknownTxs = unknownTxs', + requestedTxIdsInflight = requestedTxIdsInflight + + txIdsToRequest } + ) + else + ( 0 + , 0 + , [] + , RefCountDiff Map.empty + , ps + ) + where + -- Split `unacknowledgedTxIds'` into the longest prefix of `txid`s which + -- can be acknowledged and the unacknowledged `txid`s. + (acknowledgedTxIds, unacknowledgedTxIds') = + StrictSeq.spanl (\txid -> txid `Map.member` bufferedTxs + || txid `Set.member` unknownTxs + ) + unacknowledgedTxIds + + txsToMempool :: [tx] + txsToMempool = [ tx + | txid <- toList acknowledgedTxIds + , Just tx <- maybeToList $ txid `Map.lookup` bufferedTxs + ] + + -- the set of live `txids` + liveSet = Set.fromList (toList unacknowledgedTxIds') + + availableTxIds' = availableTxIds + `Map.restrictKeys` + liveSet + + -- We remove all acknowledged `txid`s which are not in + -- `unacknowledgedTxIds''`, but also return the unknown set before any + -- modifications (which is used to compute `unacknowledgedTxIds''` + -- above). + unknownTxs' = unknownTxs `Set.intersection` liveSet + + refCountDiff = RefCountDiff + $ foldr (\txid -> Map.alter fn txid) + Map.empty acknowledgedTxIds + where + fn :: Maybe Int -> Maybe Int + fn Nothing = Just 1 + fn (Just n) = Just $! n + 1 + + txIdsToAcknowledge :: NumTxIdsToAck + txIdsToAcknowledge = fromIntegral $ StrictSeq.length acknowledgedTxIds + + txIdsToRequest, unacked, unackedAndRequested :: NumTxIdsToReq + + txIdsToRequest = + assert (unackedAndRequested <= maxUnacknowledgedTxIds) $ + assert (requestedTxIdsInflight <= maxNumTxIdsToRequest) $ + (maxUnacknowledgedTxIds - unackedAndRequested + fromIntegral txIdsToAcknowledge) + `min` + (maxNumTxIdsToRequest - requestedTxIdsInflight) + + unackedAndRequested = unacked + requestedTxIdsInflight + unacked = fromIntegral $ StrictSeq.length unacknowledgedTxIds + + +-- | `RefCountDiff` represents a map of `txid` which can be acknowledged +-- together with their multiplicities. +-- +newtype RefCountDiff txid = RefCountDiff { + txIdsToAck :: Map txid Int + } + +updateRefCounts :: Ord txid + => Map txid Int + -> RefCountDiff txid + -> Map txid Int +updateRefCounts referenceCounts (RefCountDiff diff) = + Map.merge (Map.mapMaybeMissing \_ x -> Just x) + (Map.mapMaybeMissing \_ _ -> Nothing) + (Map.zipWithMaybeMatched \_ x y -> assert (x >= y) + if x > y then Just $! x - y + else Nothing) + referenceCounts + diff + + +-- +-- Pure internal API +-- + +-- | Insert received `txid`s and return the number of txids to be acknowledged +-- and the updated `SharedTxState`. +-- +receivedTxIdsImpl + :: forall peeraddr tx txid. + (Ord txid, Ord peeraddr, HasCallStack) + => (txid -> Bool) -- ^ check if txid is in the mempool, ref 'mempoolHasTx' + -> peeraddr + -> NumTxIdsToReq + -- ^ number of requests to subtract from + -- `requestedTxIdsInflight` + + -> StrictSeq txid + -- ^ sequence of received `txids` + -> Map txid SizeInBytes + -- ^ received `txid`s with sizes + + -> SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + +receivedTxIdsImpl + mempoolHasTx + peeraddr reqNo txidsSeq txidsMap + st@SharedTxState{ peerTxStates, + bufferedTxs, + referenceCounts } + = + -- using `alterF` so the update of `PeerTxState` is done in one lookup + case Map.alterF (fmap Just . fn . fromJust) + peeraddr + peerTxStates of + ( st', peerTxStates' ) -> + st' { peerTxStates = peerTxStates' } + + where + -- update `PeerTxState` and return number of `txid`s to acknowledged and + -- updated `SharedTxState`. + fn :: PeerTxState txid tx + -> ( SharedTxState peeraddr txid tx + , PeerTxState txid tx + ) + fn ps@PeerTxState { availableTxIds, + requestedTxIdsInflight, + unacknowledgedTxIds } = + (st', ps') + where + -- + -- Handle new `txid`s + -- + + -- Divide the new txids in two: those that are already in the mempool + -- and those that are not. We'll request some txs from the latter. + (ignoredTxIds, availableTxIdsMap) = + Map.partitionWithKey + (\txid _ -> mempoolHasTx txid) + txidsMap + + -- Add all `txids` from `availableTxIdsMap` which are not + -- unacknowledged or already buffered. Unacknowledged txids must have + -- already been added to `availableTxIds` map before. + availableTxIds' = + Map.foldlWithKey + (\m txid sizeInBytes -> Map.insert txid sizeInBytes m) + availableTxIds + (Map.filterWithKey + (\txid _ -> txid `notElem` unacknowledgedTxIds + && txid `Map.notMember` bufferedTxs) + availableTxIdsMap) + + -- Add received txids to `unacknowledgedTxIds`. + unacknowledgedTxIds' = unacknowledgedTxIds <> txidsSeq + + -- Add ignored `txs` to buffered ones. + -- Note: we prefer to keep the `tx` if it's already in `bufferedTxs`. + bufferedTxs' = bufferedTxs + <> Map.map (const Nothing) ignoredTxIds + + referenceCounts' = + foldl' (flip $ Map.alter (\case + Nothing -> Just $! 1 + Just cnt -> Just $! succ cnt)) + referenceCounts + txidsSeq + + st' = st { bufferedTxs = bufferedTxs', + referenceCounts = referenceCounts' } + ps' = assert (requestedTxIdsInflight >= reqNo) + ps { availableTxIds = availableTxIds', + unacknowledgedTxIds = unacknowledgedTxIds', + requestedTxIdsInflight = requestedTxIdsInflight - reqNo } + + +collectTxsImpl + :: forall peeraddr tx txid. + (Ord txid, Ord peeraddr) + => peeraddr + -> Set txid -- ^ set of requested txids + -> Map txid tx -- ^ received txs + -> SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + -- ^ number of `txid`s to be acknowledged, `tx`s to be added to + -- the mempool and updated state. +collectTxsImpl peeraddr requestedTxIds receivedTxs + st@SharedTxState { peerTxStates } = + + -- using `alterF` so the update of `PeerTxState` is done in one lookup + case Map.alterF (fmap Just . fn . fromJust) + peeraddr + peerTxStates of + (st', peerTxStates') -> + st' { peerTxStates = peerTxStates' } + + where + -- Update `PeerTxState` and partially update `SharedTxState` (except of + -- `peerTxStates`). + fn :: PeerTxState txid tx + -> ( SharedTxState peeraddr txid tx + , PeerTxState txid tx + ) + fn ps = (st'', ps'') + where + notReceived = requestedTxIds Set.\\ Map.keysSet receivedTxs + + -- add received `tx`s to buffered map + bufferedTxs' = bufferedTxs st + <> Map.map Just receivedTxs + + -- Add not received txs to `unknownTxs` before acknowledging txids. + unknownTxs' = unknownTxs ps <> notReceived + + requestedTxsInflight' = + assert (requestedTxIds `Set.isSubsetOf` requestedTxsInflight ps) $ + requestedTxsInflight ps Set.\\ requestedTxIds + + requestedSize = fold $ availableTxIds ps `Map.restrictKeys` requestedTxIds + requestedTxsInflightSize' = + -- TODO: VALIDATE size of received txs against what was announced + -- earlier; + assert (requestedTxsInflightSize ps >= requestedSize) $ + requestedTxsInflightSize ps - requestedSize + + st' = st { bufferedTxs = bufferedTxs' } + + -- subtract requested from in-flight + inflightTxs'' = + Map.merge + (Map.mapMaybeMissing \_ x -> Just x) + (Map.mapMaybeMissing \_ _ -> assert False Nothing) + (Map.zipWithMaybeMatched \_ x y -> assert (x >= y) + let z = x - y in + if z > 0 + then Just z + else Nothing) + (inflightTxs st') + (Map.fromSet (const 1) requestedTxIds) + + inflightTxsSize'' = assert (inflightTxsSize st' >= requestedSize) $ + inflightTxsSize st' - requestedSize + + st'' = st' { inflightTxs = inflightTxs'', + inflightTxsSize = inflightTxsSize'' + } + + -- + -- Update PeerTxState + -- + + -- Remove the downloaded `txid`s from the availableTxIds map, this + -- guarantees that we won't attempt to download the `txids` from this peer + -- once we collect the `txid`s. Also restrict keys to `liveSet`. + -- + -- NOTE: we could remove `notReceived` from `availableTxIds`; and + -- possibly avoid using `unknownTxs` field at all. + -- + availableTxIds'' = availableTxIds ps + `Map.withoutKeys` + requestedTxIds + + -- Remove all acknowledged `txid`s from unknown set, but only those + -- which are not present in `unacknowledgedTxIds'` + unknownTxs'' = unknownTxs' + `Set.intersection` + live + where + -- We cannot use `liveSet` as `unknown <> notReceived` might + -- contain `txids` which are in `liveSet` but are not `live`. + live = Set.fromList (toList (unacknowledgedTxIds ps)) + + ps'' = ps { availableTxIds = availableTxIds'', + unknownTxs = unknownTxs'', + requestedTxsInflightSize = requestedTxsInflightSize', + requestedTxsInflight = requestedTxsInflight' } + +-- +-- Monadic public API +-- + +type SharedTxStateVar m peeraddr txid tx = StrictTVar m (SharedTxState peeraddr txid tx) + +newSharedTxStateVar :: MonadSTM m + => m (SharedTxStateVar m peeraddr txid tx) +newSharedTxStateVar = newTVarIO SharedTxState { peerTxStates = Map.empty, + inflightTxs = Map.empty, + inflightTxsSize = 0, + bufferedTxs = Map.empty, + referenceCounts = Map.empty } + + +-- | Acknowledge `txid`s, return the number of `txids` to be acknowledged to the +-- remote side. +-- +receivedTxIds + :: forall m peeraddr idx tx txid. + (MonadSTM m, Ord txid, Ord peeraddr) + => Tracer m (DebugSharedTxState peeraddr txid tx) + -> SharedTxStateVar m peeraddr txid tx + -> STM m (MempoolSnapshot txid tx idx) + -> peeraddr + -> NumTxIdsToReq + -- ^ number of requests to subtract from + -- `requestedTxIdsInflight` + -> StrictSeq txid + -- ^ sequence of received `txids` + -> Map txid SizeInBytes + -- ^ received `txid`s with sizes + -> m () +receivedTxIds tracer sharedVar getMempoolSnapshot peeraddr reqNo txidsSeq txidsMap = do + st <- atomically $ do + MempoolSnapshot{mempoolHasTx} <- getMempoolSnapshot + stateTVar sharedVar ((\a -> (a,a)) . receivedTxIdsImpl mempoolHasTx peeraddr reqNo txidsSeq txidsMap) + traceWith tracer (DebugSharedTxState "receivedTxIds" st) + + +-- | Include received `tx`s in `SharedTxState`. Return number of `txids` +-- to be acknowledged and list of `tx` to be added to the mempool. +-- +collectTxs + :: forall m peeraddr tx txid. + (MonadSTM m, Ord txid, Ord peeraddr) + => Tracer m (DebugSharedTxState peeraddr txid tx) + -> SharedTxStateVar m peeraddr txid tx + -> peeraddr + -> Set txid -- ^ set of requested txids + -> Map txid tx -- ^ received txs + -> m () + -- ^ number of txids to be acknowledged and txs to be added to the + -- mempool +collectTxs tracer sharedVar peeraddr txidsRequested txsMap = do + st <- atomically $ + stateTVar sharedVar + ((\a -> (a,a)) . collectTxsImpl peeraddr txidsRequested txsMap) + traceWith tracer (DebugSharedTxState "collectTxs" st) + +-- +-- +-- + +-- | Debug tracer. +-- +data DebugSharedTxState peeraddr txid tx = DebugSharedTxState String (SharedTxState peeraddr txid tx) + deriving Show diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs new file mode 100644 index 00000000000..74224b535d3 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs @@ -0,0 +1,76 @@ +module Ouroboros.Network.TxSubmission.Inbound.Types + ( ProcessedTxCount (..) + , TxSubmissionMempoolWriter (..) + , TraceTxSubmissionInbound (..) + , TxSubmissionProtocolError (..) + ) where + +import Control.Exception (Exception (..)) + +import Ouroboros.Network.TxSubmission.Inbound.Decision (TxDecision (..)) + + +data ProcessedTxCount = ProcessedTxCount { + -- | Just accepted this many transactions. + ptxcAccepted :: Int + -- | Just rejected this many transactions. + , ptxcRejected :: Int + } + deriving (Eq, Show) + + +-- | The consensus layer functionality that the inbound side of the tx +-- submission logic requires. +-- +-- This is provided to the tx submission logic by the consensus layer. +-- +data TxSubmissionMempoolWriter txid tx idx m = + TxSubmissionMempoolWriter { + + -- | Compute the transaction id from a transaction. + -- + -- This is used in the protocol handler to verify a full transaction + -- matches a previously given transaction id. + -- + txId :: tx -> txid, + + -- | Supply a batch of transactions to the mempool. They are either + -- accepted or rejected individually, but in the order supplied. + -- + -- The 'txid's of all transactions that were added successfully are + -- returned. + mempoolAddTxs :: [tx] -> m [txid] + } + + +data TraceTxSubmissionInbound txid tx = + -- | Number of transactions just about to be inserted. + TraceTxSubmissionCollected Int + -- | Just processed transaction pass/fail breakdown. + | TraceTxSubmissionProcessed ProcessedTxCount + -- | Server received 'MsgDone' + | TraceTxInboundCanRequestMoreTxs Int + | TraceTxInboundCannotRequestMoreTxs Int + | TraceTxInboundAddedToMempool [txid] + + -- + -- messages emitted by the new implementation of the server in + -- "Ouroboros.Network.TxSubmission.Inbound.Server"; some of them are also + -- used in this module. + -- + + | TraceTxInboundTerminated + | TraceTxInboundDecision (TxDecision txid tx) + deriving (Eq, Show) + + +data TxSubmissionProtocolError = + ProtocolErrorTxNotRequested + | ProtocolErrorTxIdsNotRequested + deriving Show + +instance Exception TxSubmissionProtocolError where + displayException ProtocolErrorTxNotRequested = + "The peer replied with a transaction we did not ask for." + displayException ProtocolErrorTxIdsNotRequested = + "The peer replied with more txids than we asked for." diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Outbound.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Outbound.hs index d5cac825788..29814d78e2f 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Outbound.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Outbound.hs @@ -15,12 +15,13 @@ import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe (catMaybes, isNothing, mapMaybe) import Data.Sequence.Strict (StrictSeq) import Data.Sequence.Strict qualified as Seq +import Data.Word (Word16) import Control.Exception (assert) import Control.Monad (unless, when) import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow -import Control.Tracer (Tracer, traceWith) +import Control.Tracer (Tracer (..), traceWith) import Ouroboros.Network.ControlMessage (ControlMessage, ControlMessageSTM, timeoutWithControlMessage) @@ -44,7 +45,7 @@ data TraceTxSubmissionOutbound txid tx data TxSubmissionProtocolError = ProtocolErrorAckedTooManyTxids | ProtocolErrorRequestedNothing - | ProtocolErrorRequestedTooManyTxids NumTxIdsToReq NumTxIdsToAck + | ProtocolErrorRequestedTooManyTxids NumTxIdsToReq Word16 NumTxIdsToAck | ProtocolErrorRequestBlocking | ProtocolErrorRequestNonBlocking | ProtocolErrorRequestedUnavailableTx @@ -54,7 +55,7 @@ instance Exception TxSubmissionProtocolError where displayException ProtocolErrorAckedTooManyTxids = "The peer tried to acknowledged more txids than are available to do so." - displayException (ProtocolErrorRequestedTooManyTxids reqNo maxUnacked) = + displayException (ProtocolErrorRequestedTooManyTxids reqNo _unackedNo maxUnacked) = "The peer requested " ++ show reqNo ++ " txids which would put the " ++ "total in flight over the limit of " ++ show maxUnacked @@ -96,15 +97,15 @@ txSubmissionOutbound tracer maxUnacked TxSubmissionMempoolReader{..} _version co -> NumTxIdsToReq -> m (ClientStTxIds blocking txid tx m ()) recvMsgRequestTxIds blocking ackNo reqNo = do - when (getNumTxIdsToAck ackNo > fromIntegral (Seq.length unackedSeq)) $ throwIO ProtocolErrorAckedTooManyTxids - when ( fromIntegral (Seq.length unackedSeq) + let unackedNo = fromIntegral (Seq.length unackedSeq) + when ( unackedNo - getNumTxIdsToAck ackNo + getNumTxIdsToReq reqNo > getNumTxIdsToAck maxUnacked) $ - throwIO (ProtocolErrorRequestedTooManyTxids reqNo maxUnacked) + throwIO (ProtocolErrorRequestedTooManyTxids reqNo unackedNo maxUnacked) -- Update our tracking state to remove the number of txids that the -- peer has acknowledged.