diff --git a/network-mux/src/Network/Mux/Bearer/Socket.hs b/network-mux/src/Network/Mux/Bearer/Socket.hs index ecd26842fa5..3a14b4ecd9a 100644 --- a/network-mux/src/Network/Mux/Bearer/Socket.hs +++ b/network-mux/src/Network/Mux/Bearer/Socket.hs @@ -222,7 +222,7 @@ socketAsBearer sduSize batchSize readBuffer_m sduTimeout pollInterval tracer sd let ts32 = Mx.timestampMicrosecondsLow32Bits ts buf = map (Mx.encodeSDU . (\sdu -> Mx.setTimestamp sdu (Mx.RemoteClockModel ts32))) sdus - r <- timeout ((fromIntegral $ length sdus) * sduTimeout) $ + r <- timeout (fromIntegral (length sdus) * sduTimeout) $ Socket.sendMany sd (concatMap BL.toChunks buf) `catch` Mx.handleIOException "sendAll errored" case r of diff --git a/network-mux/src/Network/Mux/Codec.hs b/network-mux/src/Network/Mux/Codec.hs index 0b95bd35c0b..7e5e0c4164d 100644 --- a/network-mux/src/Network/Mux/Codec.hs +++ b/network-mux/src/Network/Mux/Codec.hs @@ -18,13 +18,22 @@ import Network.Mux.Types -- > 0 1 2 3 -- > 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 -- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- > | transmission time | +-- > | transmission time | -- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- > |M| conversation id | length | +-- > |d| mini-protocol number | length | -- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -- -- All fields are in big endian byte order. -- +-- * transmission time: time when the SDU was sent +-- * @d@: mini-protocol direction (`MiniProtocolDir`): +-- +-- * 1 - initiator direction +-- * 0 - responder direction +-- +-- * mini-protocol number (`MiniProtocolNum`) +-- * length: length of the payload +-- encodeSDU :: SDU -> BL.ByteString encodeSDU sdu = let hdr = Bin.runPut enc in diff --git a/ouroboros-network-api/CHANGELOG.md b/ouroboros-network-api/CHANGELOG.md index a5c09c180b8..4a386c928f1 100644 --- a/ouroboros-network-api/CHANGELOG.md +++ b/ouroboros-network-api/CHANGELOG.md @@ -7,6 +7,7 @@ ### Non-breaking changes * `IsLedgerPeer` added to `Ouroboros.Network.LedgerPeers.Types` module. +* Derived `Bounded` instance for `SizeInBytes`. ## 0.13.0.0 -- 2025-02-25 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/CHANGELOG.md b/ouroboros-network-protocols/CHANGELOG.md index b32f24de848..bd43d765dab 100644 --- a/ouroboros-network-protocols/CHANGELOG.md +++ b/ouroboros-network-protocols/CHANGELOG.md @@ -4,6 +4,9 @@ ### Breaking changes +* `CollectPipelined` constructor for `TxSubmission2.Server` was modified: now + one can run a monadic action in the continuation when no message is available. + ### Non-breaking changes ## 0.14.0.0 -- 2025-02-25 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 1b55d318ed4..d59a7dd98f7 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Server.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Server.hs @@ -82,9 +82,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'. @@ -134,6 +134,6 @@ txSubmissionServerPeerPipelined (TxSubmissionServerPipelined server) = (Effect (go <$> k)) go (CollectPipelined mNone collect) = - Collect (fmap go mNone) - (Effect . fmap go . collect) + Collect (Effect . fmap go <$> mNone) + (Effect . fmap go . collect) diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Type.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Type.hs index ef0b59a9dbd..df679c92ced 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Type.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Type.hs @@ -222,6 +222,12 @@ instance Protocol (TxSubmission2 txid tx) where -- * The non-blocking case must be used when there are non-zero remaining -- unacknowledged transactions. -- + -- It is a protocol error to: + -- + -- * make a blocking request with `NumTxIdsToReq 0`; + -- + -- * make a non-blocking request with both `NumTxIdsToAck 0` and `NumTxIdsReq 0`. + -- MsgRequestTxIds :: forall (blocking :: StBlockingStyle) txid tx. SingBlockingStyle blocking 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 2cf0526216a..28118703e9f 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 1b0aa7dbaa1..ac2804aebf7 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-testing/CHANGELOG.md b/ouroboros-network-testing/CHANGELOG.md index 6c66ceaafbd..f88b43e8cc9 100644 --- a/ouroboros-network-testing/CHANGELOG.md +++ b/ouroboros-network-testing/CHANGELOG.md @@ -6,6 +6,10 @@ ### Non-breaking changes +* `renderRanges`: print a range using math notation for open/closed intervals. +* Pretty print `WithName` using `Show` instance. +* Pretty print `WithTime` using `Show` instance. + ## 0.8.1.0 -- 2025-02-25 ### Non-breaking changes diff --git a/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs b/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs index 119b3def13e..d89cec3e4d8 100644 --- a/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs +++ b/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs @@ -52,6 +52,7 @@ import Data.Ratio import Data.Set (Set) import Data.Set qualified as Set import Text.Pretty.Simple (pPrint) +import Text.Printf import Debug.Trace (traceShowM) import Test.QuickCheck @@ -136,7 +137,7 @@ prop_shrink_valid valid (ShrinkCarefully x) = -- | Use in 'tabulate' to help summarise data into buckets. -- renderRanges :: Int -> Int -> String -renderRanges r n = show lower ++ " -- " ++ show upper +renderRanges r n = "[" ++ printf "% 3d" lower ++ ", " ++ printf "% 3d" upper ++ ")" where lower = n - n `mod` r upper = lower + (r-1) @@ -167,13 +168,19 @@ data WithName name event = WithName { wnName :: name, wnEvent :: event } - deriving (Show, Functor) + deriving Functor + +instance (Show name, Show event) => Show (WithName name event) where + show WithName { wnName = name, wnEvent = event } = show name ++ ": " ++ show event data WithTime event = WithTime { wtTime :: Time, wtEvent :: event } - deriving (Show, Functor) + deriving Functor + +instance Show event => Show (WithTime event) where + show WithTime { wtTime = (Time time), wtEvent = event } = show time ++ "@ " ++ show event tracerWithName :: name -> Tracer m (WithName name a) -> Tracer m a tracerWithName name = contramap (WithName name) diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index 6ed6d8abaed..23c59751798 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -10,6 +10,7 @@ are captured by the `DNSPeersKind` type, which also distinguishes the type of ledger peer. * Added `dispatchLookupWithTTL` +* Added `Ouroboros.Network.TxSubmission.Inbound.V2`. ### Breaking changes @@ -38,6 +39,10 @@ - Renamed `Applications` to `DiffusionApplications` - `runM` function now receives `ExtraParameters` as an argument - Configurable Mux Egress Poll Interval +- `Ouroboros.Network.TxSubmission.Inbound` moved to `Ouroboros.Network.TxSubmission.Inbound.V1` +- `Ouroboros.Network.TxSubmission.Inbound.V1.txSubmissionInbound` takes extra argument: `TxSubmissionInitDelay` (previously configurable through `cabal` flags). +- Removed the `txsubmission-delay` cabal flag. +- `ProtocolErrorRequestedTooManyTxids` includes number of unacked txids. ## 0.20.1.0 -- 2025-03-13 diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 14275400a81..93ff158e825 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -20,11 +20,6 @@ flag asserts manual: False default: False -flag txsubmission-delay - description: Delay initial request for transactions from outbound/client peer - manual: True - default: True - source-repository head type: git location: https://github.com/intersectmbo/ouroboros-network @@ -96,7 +91,13 @@ library Ouroboros.Network.PeerSelection.State.LocalRootPeers Ouroboros.Network.PeerSelection.Types Ouroboros.Network.PeerSharing - Ouroboros.Network.TxSubmission.Inbound + Ouroboros.Network.TxSubmission.Inbound.V1 + Ouroboros.Network.TxSubmission.Inbound.V2 + Ouroboros.Network.TxSubmission.Inbound.V2.Decision + Ouroboros.Network.TxSubmission.Inbound.V2.Policy + Ouroboros.Network.TxSubmission.Inbound.V2.Registry + Ouroboros.Network.TxSubmission.Inbound.V2.State + Ouroboros.Network.TxSubmission.Inbound.V2.Types Ouroboros.Network.TxSubmission.Mempool.Reader Ouroboros.Network.TxSubmission.Outbound @@ -169,7 +170,8 @@ library random, si-timers, strict-checked-vars ^>=0.2, - strict-stm >=1.0 && <1.6, + strict-mvar, + strict-stm, transformers, typed-protocols ^>=0.3, typed-protocols-stateful, @@ -181,9 +183,6 @@ library if flag(asserts) ghc-options: -fno-ignore-asserts - if flag(txsubmission-delay) - cpp-options: -DTXSUBMISSION_DELAY - library ouroboros-orphan-instances import: ghc-options visibility: public @@ -321,6 +320,7 @@ library testlib bytestring, cardano-binary, cardano-slotting, + cardano-strict-containers, cborg, containers, contra-tracer, @@ -350,6 +350,7 @@ library testlib random, serialise, si-timers, + strict-mvar, strict-stm, tasty, tasty-hunit, @@ -390,6 +391,10 @@ library testlib Test.Ouroboros.Network.PeerSelection.PeerMetric Test.Ouroboros.Network.PeerSelection.RootPeersDNS Test.Ouroboros.Network.TxSubmission + Test.Ouroboros.Network.TxSubmission.AppV1 + Test.Ouroboros.Network.TxSubmission.AppV2 + Test.Ouroboros.Network.TxSubmission.TxLogic + Test.Ouroboros.Network.TxSubmission.Types Test.Ouroboros.Network.Version -- Simulation tests, and IO tests which don't require native system calls. diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs index 3b13ff265f1..d53fc2adc7c 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs @@ -11,6 +11,7 @@ module Ouroboros.Network.Diffusion.Configuration , defaultDeadlineTargets , defaultDeadlineChurnInterval , defaultBulkChurnInterval + , defaultTxSubmissionLogicVersion -- re-exports , AcceptedConnectionsLimit (..) , BlockFetchConfiguration (..) @@ -20,6 +21,7 @@ module Ouroboros.Network.Diffusion.Configuration , PeerSelectionTargets (..) , PeerSharing (..) , ConsensusMode (..) + , TxSubmissionLogicVersion (..) , defaultConsensusMode , defaultMiniProtocolParameters , deactivateTimeout @@ -57,6 +59,8 @@ import Ouroboros.Network.Protocol.ChainSync.Codec (ChainSyncTimeout (..)) import Ouroboros.Network.Protocol.Handshake (handshake_QUERY_SHUTDOWN_DELAY) import Ouroboros.Network.Protocol.Limits (shortWait) import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) +import Ouroboros.Network.TxSubmission.Inbound.V2.Types + (TxSubmissionLogicVersion (..)) -- |Outbound governor targets -- Targets may vary depending on whether a node is operating in @@ -150,3 +154,7 @@ local_PROTOCOL_IDLE_TIMEOUT = 2 -- 2 seconds local_TIME_WAIT_TIMEOUT :: DiffTime local_TIME_WAIT_TIMEOUT = 0 +-- | The default logic version is the legacy one, the new one is still +-- experimental. +defaultTxSubmissionLogicVersion :: TxSubmissionLogicVersion +defaultTxSubmissionLogicVersion = TxSubmissionLogicV1 diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index bb6001cc1fd..8d26852d8e3 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -99,8 +100,11 @@ import Ouroboros.Network.Protocol.Handshake.Type import Ouroboros.Network.Protocol.Handshake.Version hiding (Accept) import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..)) import Ouroboros.Network.Server.RateLimiting +import Ouroboros.Network.SizeInBytes import Ouroboros.Network.Snocket import Ouroboros.Network.Socket +import Ouroboros.Network.TxSubmission.Inbound.V2.Policy (TxDecisionPolicy (..), + defaultTxDecisionPolicy, max_TX_SIZE) import Ouroboros.Network.Util.ShowProxy (ShowProxy, showProxy) @@ -157,9 +161,8 @@ data MiniProtocolParameters = MiniProtocolParameters { blockFetchPipeliningMax :: !Word16, -- ^ maximal number of pipelined messages in 'block-fetch' mini-protocol. - txSubmissionMaxUnacked :: !NumTxIdsToAck - -- ^ maximal number of unacked tx (pipelining is bounded by twice this - -- number) + txDecisionPolicy :: !TxDecisionPolicy + -- ^ tx submission protocol decision logic parameters } defaultMiniProtocolParameters :: MiniProtocolParameters @@ -167,7 +170,7 @@ defaultMiniProtocolParameters = MiniProtocolParameters { chainSyncPipeliningLowMark = 200 , chainSyncPipeliningHighMark = 300 , blockFetchPipeliningMax = 100 - , txSubmissionMaxUnacked = 10 + , txDecisionPolicy = defaultTxDecisionPolicy } -- | Make an 'OuroborosApplication' for the bundle of mini-protocols that @@ -295,7 +298,9 @@ blockFetchProtocolLimits MiniProtocolParameters { blockFetchPipeliningMax } = Mi max (10 * 2_097_154 :: Int) (fromIntegral blockFetchPipeliningMax * 90_112) } -txSubmissionProtocolLimits MiniProtocolParameters { txSubmissionMaxUnacked } = MiniProtocolLimits { +txSubmissionProtocolLimits MiniProtocolParameters + { txDecisionPolicy = TxDecisionPolicy { maxUnacknowledgedTxIds } + } = MiniProtocolLimits { -- tx-submission server can pipeline both 'MsgRequestTxIds' and -- 'MsgRequestTx'. This means that there can be many -- 'MsgReplyTxIds', 'MsgReplyTxs' messages in an inbound queue (their @@ -353,12 +358,12 @@ txSubmissionProtocolLimits MiniProtocolParameters { txSubmissionMaxUnacked } = M -- queue of 'txSubmissionOutbound' is bounded by the ingress side of -- the 'txSubmissionInbound' -- - -- Currently the value of 'txSubmissionMaxUnacked' is '100', for - -- which the upper bound is `100 * (44 + 65_540) = 6_558_400`, we add + -- Currently the value of 'txSubmissionMaxUnacked' is '10', for + -- which the upper bound is `10 * (44 + 65_540) = 655_840`, we add -- 10% as a safety margin. -- maximumIngressQueue = addSafetyMargin $ - fromIntegral txSubmissionMaxUnacked * (44 + 65_540) + fromIntegral maxUnacknowledgedTxIds * (44 + fromIntegral @SizeInBytes @Int max_TX_SIZE) } keepAliveProtocolLimits _ = diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V1.hs similarity index 89% rename from ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs rename to ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V1.hs index 8970edb2ea5..79c77b45d76 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V1.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} @@ -9,8 +8,9 @@ {-# OPTIONS_GHC -Wno-partial-fields #-} -module Ouroboros.Network.TxSubmission.Inbound +module Ouroboros.Network.TxSubmission.Inbound.V1 ( txSubmissionInbound + , TxSubmissionInitDelay (..) , TxSubmissionMempoolWriter (..) , TraceTxSubmissionInbound (..) , TxSubmissionProtocolError (..) @@ -21,7 +21,6 @@ import Data.Foldable as Foldable (foldl', toList) import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Maybe import Data.Sequence.Strict (StrictSeq) import Data.Sequence.Strict qualified as Seq import Data.Set qualified as Set @@ -36,72 +35,21 @@ import Control.Exception (assert) import Control.Monad (unless) import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, traceWith) import Network.TypedProtocol.Core (N, Nat (..), natToInt) import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion) -import Ouroboros.Network.Protocol.Limits import Ouroboros.Network.Protocol.TxSubmission2.Server import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound.V2.Types (ProcessedTxCount (..), + TraceTxSubmissionInbound (..), TxSubmissionInitDelay (..), + TxSubmissionMempoolWriter (..), TxSubmissionProtocolError (..)) import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..), TxSubmissionMempoolReader (..)) --- | 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 ProcessedTxCount = ProcessedTxCount { - -- | Just accepted this many transactions. - ptxcAccepted :: Int - -- | Just rejected this many transactions. - , ptxcRejected :: Int - } - deriving (Eq, Show) - -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' - | TraceTxInboundTerminated - | TraceTxInboundCanRequestMoreTxs Int - | TraceTxInboundCannotRequestMoreTxs Int - 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." - - -- | Information maintained internally in the 'txSubmissionInbound' server -- implementation. -- @@ -183,18 +131,17 @@ txSubmissionInbound , MonadDelay m ) => Tracer m (TraceTxSubmissionInbound txid tx) + -> TxSubmissionInitDelay -> NumTxIdsToAck -- ^ Maximum number of unacknowledged txids allowed -> TxSubmissionMempoolReader txid tx idx m -> TxSubmissionMempoolWriter txid tx idx m -> NodeToNodeVersion -> TxSubmissionServerPipelined txid tx m () -txSubmissionInbound tracer (NumTxIdsToAck maxUnacked) mpReader mpWriter _version = +txSubmissionInbound tracer initDelay (NumTxIdsToAck maxUnacked) mpReader mpWriter _version = TxSubmissionServerPipelined $ do -#ifdef TXSUBMISSION_DELAY - -- make the client linger before asking for tx's and expending - -- our resources as well, as he may disconnect for some reason - threadDelay (fromMaybe (-1) longWait) -#endif + case initDelay of + TxSubmissionInitDelay delay -> threadDelay delay + NoTxSubmissionInitDelay -> return () continueWithStateM (serverIdle Zero) initialServerState where -- TODO #1656: replace these fixed limits by policies based on @@ -262,7 +209,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 @@ -361,17 +308,21 @@ txSubmissionInbound tracer (NumTxIdsToAck maxUnacked) mpReader mpWriter _version bufferedTxs3 = forceElemsToWHNF $ bufferedTxs2 <> Map.fromList (zip live (repeat Nothing)) - let !collected = length txs traceWith tracer $ - TraceTxSubmissionCollected collected + TraceTxSubmissionCollected (txId `map` txs) + !start <- getMonotonicTime txidsAccepted <- mempoolAddTxs txsReady - + !end <- getMonotonicTime + let duration = diffTime end start + traceWith tracer $ + TraceTxInboundAddedToMempool txidsAccepted duration let !accepted = length txidsAccepted traceWith tracer $ TraceTxSubmissionProcessed ProcessedTxCount { ptxcAccepted = accepted - , ptxcRejected = collected - accepted + , ptxcRejected = length txs - accepted + , ptxcScore = 0 -- This implementatin does not track score } continueWithStateM (serverIdle n) st { diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs new file mode 100644 index 00000000000..8add4ae6ed0 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Network.TxSubmission.Inbound.V2 + ( -- * TxSubmision Inbound client + txSubmissionInboundV2 + -- * PeerTxAPI + , withPeer + , PeerTxAPI + -- * Supporting types + , module V2 + , TxChannelsVar + , newTxChannelsVar + , TxMempoolSem + , newTxMempoolSem + , SharedTxStateVar + , newSharedTxStateVar + , TxDecisionPolicy (..) + , defaultTxDecisionPolicy + ) 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.Exception (assert) +import Control.Monad (unless, when) +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTimer.SI +import Control.Tracer (Tracer, traceWith) + +import Network.TypedProtocol + +import Ouroboros.Network.Protocol.TxSubmission2.Server +import Ouroboros.Network.TxSubmission.Inbound.V2.Policy +import Ouroboros.Network.TxSubmission.Inbound.V2.Registry +import Ouroboros.Network.TxSubmission.Inbound.V2.State +import Ouroboros.Network.TxSubmission.Inbound.V2.Types as V2 + +-- | A tx-submission inbound 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. + ( MonadDelay m + , MonadThrow m + , Ord txid + ) + => Tracer m (TraceTxSubmissionInbound txid tx) + -> TxSubmissionInitDelay + -> TxSubmissionMempoolWriter txid tx idx m + -> PeerTxAPI m txid tx + -> TxSubmissionServerPipelined txid tx m () +txSubmissionInboundV2 + tracer + initDelay + TxSubmissionMempoolWriter { txId } + PeerTxAPI { + readTxDecision, + handleReceivedTxIds, + handleReceivedTxs, + submitTxToMempool + } + = + TxSubmissionServerPipelined $ do + case initDelay of + TxSubmissionInitDelay delay -> threadDelay delay + NoTxSubmissionInitDelay -> return () + serverIdle + where + serverIdle + :: m (ServerStIdle Z txid tx m ()) + serverIdle = do + -- Block on next decision. + txd@TxDecision { txdTxsToRequest = txsToRequest, + txdTxsToMempool = TxsToMempool { listOfTxsToMempool } } + <- readTxDecision + traceWith tracer (TraceTxInboundDecision txd) + + let !collected = length listOfTxsToMempool + + -- Only attempt to add TXs if we have some work to do + when (collected > 0) $ do + -- submitTxToMempool traces: `TraceTxSubmissionProcessed` and + -- `TraceTxInboundAddedToMempool` events + mapM_ (uncurry $ submitTxToMempool tracer) listOfTxsToMempool + + -- 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 txsToRequest + 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 = txdTxsToRequest } = + pure $ SendMsgRequestTxsPipelined (Set.toList txdTxsToRequest) + (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 + + mbe <- handleReceivedTxs requested received + traceWith tracer $ TraceTxSubmissionCollected (txId `map` txs) + case mbe of + -- one of `tx`s had a wrong size + Just e -> throwIO e + Nothing -> k diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs new file mode 100644 index 00000000000..a1982866c51 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs @@ -0,0 +1,551 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Ouroboros.Network.TxSubmission.Inbound.V2.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.Hashable +import Data.List qualified as List +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 System.Random (random) + +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.V2.Policy +import Ouroboros.Network.TxSubmission.Inbound.V2.State +import Ouroboros.Network.TxSubmission.Inbound.V2.Types + + +-- | Make download decisions. +-- +makeDecisions + :: forall peeraddr txid tx. + ( Ord peeraddr + , Ord txid + , Hashable peeraddr + ) + => 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 + } + = let (salt, rng') = random (peerRng st) + st' = st { peerRng = rng' } in + fn + . pickTxsToDownload policy st' + . orderByRejections salt + 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 how useful the TXs they have provided are. +-- +-- TXs delivered late will fail to apply because they where included in +-- a recently adopted block. Peers can race against each other by setting +-- `txInflightMultiplicity` to > 1. In case of a tie a hash of the peeraddr +-- is used as a tie breaker. Since every invocation use a new salt a given +-- peeraddr does not have an advantage over time. +-- +orderByRejections :: Hashable peeraddr + => Int + -> Map peeraddr (PeerTxState txid tx) + -> [ (peeraddr, PeerTxState txid tx)] +orderByRejections salt = + List.sortOn (\(peeraddr, ps) -> (score ps, hashWithSalt salt peeraddr)) + . Map.toList + +-- | 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 = + List.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`. + + stLimboTx :: Set txid + -- ^ TXs on their way to the mempool. Used to prevent issueing new + -- fetch requests for them. + } + + +-- | 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, + limboTxs, + referenceCounts } = + -- outer fold: fold `[(peeraddr, PeerTxState txid tx)]` + List.mapAccumR + accumFn + -- initial state + St { stInflight = inflightTxs, + stInflightSize = inflightTxsSize, + stAcknowledged = Map.empty, + stLimboTx = Map.keysSet limboTxs } + + >>> + 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, + stLimboTx } + ( 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@TxsToMempool { listOfTxsToMempool } + , RefCountDiff { txIdsToAck } + , peerTxState' + ) = acknowledgeTxIds policy sharedState peerTxState + + stAcknowledged' = Map.unionWith (+) stAcknowledged txIdsToAck + stLimboTx' = stLimboTx <> Set.fromList (map fst listOfTxsToMempool) + in + if requestedTxIdsInflight peerTxState' > 0 + then + -- we have txids to request + ( st { stAcknowledged = stAcknowledged' + , stLimboTx = stLimboTx' } + , ( (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 + <> stLimboTx) + + ) + 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@TxsToMempool { listOfTxsToMempool } + , 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 + + stLimboTx' = stLimboTx <> Set.fromList (map fst listOfTxsToMempool) + in + if requestedTxIdsInflight peerTxState'' > 0 + then + -- we can request `txid`s & `tx`s + ( St { stInflight = stInflight', + stInflightSize = sizeInflightOther + requestedTxsInflightSize', + stAcknowledged = stAcknowledged', + stLimboTx = stLimboTx' } + , ( (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', + stLimboTx = stLimboTx' + } + , ( (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 + + limboTxs' = List.foldl' updateLimboTxs limboTxs as + + in ( sharedState { + peerTxStates = peerTxStates', + inflightTxs = stInflight, + inflightTxsSize = stInflightSize, + bufferedTxs = bufferedTxs', + referenceCounts = referenceCounts', + limboTxs = limboTxs'} + , -- exclude empty results + mapMaybe (\((a, _), b) -> case b of + TxDecision { txdTxIdsToAcknowledge = 0, + txdTxIdsToRequest = 0, + txdTxsToRequest, + txdTxsToMempool = TxsToMempool { listOfTxsToMempool } } + | null txdTxsToRequest + , null listOfTxsToMempool + -> Nothing + _ -> Just (a, b) + ) + as + ) + + where + updateLimboTxs :: forall a. + Map txid Int + -> (a, TxDecision txid tx) + -> Map txid Int + updateLimboTxs m (_,TxDecision { txdTxsToMempool } ) = + List.foldl' fn m (listOfTxsToMempool txdTxsToMempool) + where + fn :: Map txid Int + -> (txid,tx) + -> Map txid Int + fn x (txid,_) = Map.alter (\case Nothing -> Just 1 + Just n -> Just $! succ n) txid x + + +-- | 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, + limboTxs } + | inflightTxsSize > maxTxsSizeInflight + = Map.filter fn peerTxStates + | otherwise + = Map.filter gn peerTxStates + where + unrequestable = Map.keysSet (Map.filter (>= txInflightMultiplicity) inflightTxs) + <> Map.keysSet bufferedTxs + + fn :: PeerTxState txid tx -> Bool + fn PeerTxState { unacknowledgedTxIds, + requestedTxIdsInflight, + unknownTxs, + downloadedTxs, + requestedTxsInflight + } = + -- 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 + || txid `Map.member` downloadedTxs) + && txid `Set.notMember` requestedTxsInflight + ) + 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, + downloadedTxs, + unknownTxs } = + ( 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 + `Map.withoutKeys` Map.keysSet limboTxs + + -- 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 + || txid `Map.member` downloadedTxs + && txid `Set.notMember` requestedTxsInflight + ) + 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/V2/Policy.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Policy.hs new file mode 100644 index 00000000000..ce6ea378535 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Policy.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NumericUnderscores #-} + +module Ouroboros.Network.TxSubmission.Inbound.V2.Policy + ( TxDecisionPolicy (..) + , defaultTxDecisionPolicy + , max_TX_SIZE + ) where + +import Control.Monad.Class.MonadTime.SI +import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToReq (..)) +import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) + + +-- | Maximal tx size. +-- +-- Affects: +-- +-- * `TxDecisionPolicy` +-- * `maximumIngressQueue` for `tx-submission` mini-protocol, see +-- `Ouroboros.Network.NodeToNode.txSubmissionProtocolLimits` +-- +max_TX_SIZE :: SizeInBytes +max_TX_SIZE = 65_540 + + +-- | 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 + + bufferedTxsMinLifetime :: !DiffTime, + -- ^ how long TXs that have been added to the mempool will be + -- keept in the `bufferedTxs` cache. + + scoreRate :: !Double, + -- ^ rate at which "rejected" TXs drain. Unit: TX/seconds. + + scoreMax :: !Double + -- ^ Maximum number of "rejections". Unit: seconds + + } + deriving Show + +defaultTxDecisionPolicy :: TxDecisionPolicy +defaultTxDecisionPolicy = + TxDecisionPolicy { + maxNumTxIdsToRequest = 3, + maxUnacknowledgedTxIds = 10, -- must be the same as txSubmissionMaxUnacked + txsSizeInflightPerPeer = max_TX_SIZE * 6, + maxTxsSizeInflight = max_TX_SIZE * 20, + txInflightMultiplicity = 2, + bufferedTxsMinLifetime = 2, + scoreRate = 0.1, + scoreMax = 15 * 60 + } diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs new file mode 100644 index 00000000000..15fa954748f --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs @@ -0,0 +1,510 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Network.TxSubmission.Inbound.V2.Registry + ( TxChannels (..) + , TxChannelsVar + , TxMempoolSem + , SharedTxStateVar + , newSharedTxStateVar + , newTxChannelsVar + , newTxMempoolSem + , PeerTxAPI (..) + , decisionLogicThread + , drainRejectionThread + , withPeer + ) where + +import Control.Concurrent.Class.MonadMVar.Strict +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Concurrent.Class.MonadSTM.TSem +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI + +import Data.Foldable as Foldable (foldl', traverse_) +import Data.Hashable +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.Typeable (Typeable) +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.V2.Decision +import Ouroboros.Network.TxSubmission.Inbound.V2.Policy +import Ouroboros.Network.TxSubmission.Inbound.V2.State +import Ouroboros.Network.TxSubmission.Inbound.V2.Types +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) + +newtype TxMempoolSem m = TxMempoolSem (TSem m) + +newTxMempoolSem :: MonadSTM m => m (TxMempoolSem m) +newTxMempoolSem = TxMempoolSem <$> atomically (newTSem 1) + +-- | 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 (Maybe TxSubmissionProtocolError), + -- ^ handle received txs + + submitTxToMempool :: Tracer m (TraceTxSubmissionInbound txid tx) + -> txid -> tx -> m () + -- ^ submit the given (txid, tx) to the mempool. + } + + +data TxMempoolResult = TxAccepted | TxRejected + +-- | 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 + , MonadMonotonicTime m + , Ord txid + , Show txid + , Typeable txid + , Ord peeraddr + , Show peeraddr + ) + => Tracer m (TraceTxLogic peeraddr txid tx) + -> TxChannelsVar m peeraddr txid tx + -> TxMempoolSem m + -> TxDecisionPolicy + -> SharedTxStateVar m peeraddr txid tx + -> TxSubmissionMempoolReader txid tx idx m + -> TxSubmissionMempoolWriter txid tx idx m + -> (tx -> SizeInBytes) + -> peeraddr + -- ^ new peer + -> (PeerTxAPI m txid tx -> m a) + -- ^ callback which gives access to `PeerTxStateAPI` + -> m a +withPeer tracer + channelsVar + (TxMempoolSem mempoolSem) + policy@TxDecisionPolicy { bufferedTxsMinLifetime } + sharedStateVar + TxSubmissionMempoolReader { mempoolGetSnapshot } + TxSubmissionMempoolWriter { mempoolAddTxs } + txSize + 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, + submitTxToMempool } + ) + + 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, + score = 0, + scoreTs = Time 0, + downloadedTxs = Map.empty, + toMempoolTxs = Map.empty } + peerTxStates + } + + -- TODO: this function needs to be tested! + unregisterPeer :: SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + unregisterPeer st@SharedTxState { peerTxStates, + bufferedTxs, + referenceCounts, + inflightTxs, + inflightTxsSize, + limboTxs } = + st { peerTxStates = peerTxStates', + bufferedTxs = bufferedTxs', + referenceCounts = referenceCounts', + inflightTxs = inflightTxs', + inflightTxsSize = inflightTxsSize', + limboTxs = limboTxs' } + where + (PeerTxState { unacknowledgedTxIds, + requestedTxsInflight, + requestedTxsInflightSize, + toMempoolTxs } + , peerTxStates') + = + Map.alterF + (\case + Nothing -> error ("TxSubmission.withPeer: invariant violation for peer " ++ show peeraddr) + Just a -> (a, Nothing)) + peeraddr + peerTxStates + + referenceCounts' = + Foldable.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 + + inflightTxs' = Foldable.foldl' purgeInflightTxs inflightTxs requestedTxsInflight + inflightTxsSize' = inflightTxsSize - requestedTxsInflightSize + + -- When we unregister a peer, we need to subtract all txs in the + -- `toMempoolTxs`, as they will not be submitted to the mempool. + limboTxs' = + Foldable.foldl' (flip $ Map.update \cnt -> + if cnt > 1 + then Just $! pred cnt + else Nothing + ) + limboTxs + (Map.keysSet toMempoolTxs) + + purgeInflightTxs m txid = Map.alter fn txid m + where + fn (Just n) | n > 1 = Just $! pred n + fn _ = Nothing + + -- + -- PeerTxAPI + -- + + submitTxToMempool :: Tracer m (TraceTxSubmissionInbound txid tx) -> txid -> tx -> m () + submitTxToMempool txTracer txid tx = + bracket_ (atomically $ waitTSem mempoolSem) + (atomically $ signalTSem mempoolSem) + $ do + res <- addTx + start <- getMonotonicTime + atomically $ modifyTVar sharedStateVar (updateBufferedTx start res) + end <- getMonotonicTime + let duration = end `diffTime` start + case res of + TxAccepted -> traceWith txTracer (TraceTxInboundAddedToMempool [txid] duration) + TxRejected -> traceWith txTracer (TraceTxInboundRejectedFromMempool [txid] duration) + + where + -- add the tx to the mempool + addTx :: m TxMempoolResult + addTx = do + mpSnapshot <- atomically mempoolGetSnapshot + + -- Note that checking if the mempool contains a TX before + -- spending several ms attempting to add it to the pool has + -- been judged immoral. + if mempoolHasTx mpSnapshot txid + then do + !now <- getMonotonicTime + !s <- countRejectedTxs now 1 + traceWith txTracer $ TraceTxSubmissionProcessed ProcessedTxCount { + ptxcAccepted = 0 + , ptxcRejected = 1 + , ptxcScore = s + } + return TxRejected + else do + acceptedTxs <- mempoolAddTxs [tx] + end <- getMonotonicTime + if null acceptedTxs + then do + !s <- countRejectedTxs end 1 + traceWith txTracer $ TraceTxSubmissionProcessed ProcessedTxCount { + ptxcAccepted = 0 + , ptxcRejected = 1 + , ptxcScore = s + } + return TxRejected + else do + !s <- countRejectedTxs end 0 + traceWith txTracer $ TraceTxSubmissionProcessed ProcessedTxCount { + ptxcAccepted = 1 + , ptxcRejected = 0 + , ptxcScore = s + } + return TxAccepted + + updateBufferedTx :: Time + -> TxMempoolResult + -> SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + updateBufferedTx _ TxRejected st@SharedTxState { peerTxStates + , limboTxs } = + st { peerTxStates = peerTxStates' + , limboTxs = limboTxs' } + where + limboTxs' = Map.update (\case 1 -> Nothing + n -> Just $! pred n) txid limboTxs + + peerTxStates' = Map.update fn peeraddr peerTxStates + where + fn ps = Just $! ps { toMempoolTxs = Map.delete txid (toMempoolTxs ps)} + + updateBufferedTx now TxAccepted + st@SharedTxState { peerTxStates + , bufferedTxs + , referenceCounts + , timedTxs + , limboTxs } = + st { peerTxStates = peerTxStates' + , bufferedTxs = bufferedTxs' + , timedTxs = timedTxs' + , referenceCounts = referenceCounts' + , limboTxs = limboTxs' + } + where + limboTxs' = Map.update (\case 1 -> Nothing + n -> Just $! pred n) txid limboTxs + + timedTxs' = Map.alter fn (addTime bufferedTxsMinLifetime now) timedTxs + where + fn :: Maybe [txid] -> Maybe [txid] + fn Nothing = Just [txid] + fn (Just txids) = Just $! (txid:txids) + + referenceCounts' = Map.alter fn txid referenceCounts + where + fn :: Maybe Int -> Maybe Int + fn Nothing = Just 1 + fn (Just n) = Just $! succ n + + bufferedTxs' = Map.insert txid (Just tx) bufferedTxs + + peerTxStates' = Map.update fn peeraddr peerTxStates + where + fn ps = Just $! ps { toMempoolTxs = Map.delete txid (toMempoolTxs ps)} + + 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 (Maybe TxSubmissionProtocolError) + handleReceivedTxs txids txs = + collectTxs tracer txSize sharedStateVar peeraddr txids txs + + -- Update `score` & `scoreTs` fields of `PeerTxState`, return the new + -- updated `score`. + -- + -- PRECONDITION: the `Double` argument is non-negative. + countRejectedTxs :: Time + -> Double + -> m Double + countRejectedTxs _ n | n < 0 = + error ("TxSubmission.countRejectedTxs: invariant violation for peer " ++ show peeraddr) + countRejectedTxs now n = atomically $ stateTVar sharedStateVar $ \st -> + let (result, peerTxStates') = Map.alterF fn peeraddr (peerTxStates st) + in (result, st { peerTxStates = peerTxStates' }) + where + fn :: Maybe (PeerTxState txid tx) -> (Double, Maybe (PeerTxState txid tx)) + fn Nothing = error ("TxSubmission.withPeer: invariant violation for peer " ++ show peeraddr) + fn (Just ps) = (score ps', Just $! ps') + where + ps' = updateRejects policy now n ps + + +updateRejects :: TxDecisionPolicy + -> Time + -> Double + -> PeerTxState txid tx + -> PeerTxState txid tx +updateRejects _ now 0 pts | score pts == 0 = pts {scoreTs = now} +updateRejects TxDecisionPolicy { scoreRate, scoreMax } now n + pts@PeerTxState { score, scoreTs } = + let duration = diffTime now scoreTs + !drain = realToFrac duration * scoreRate + !drained = max 0 $ score - drain in + pts { score = min scoreMax $ drained + n + , scoreTs = now + } + + +drainRejectionThread + :: forall m peeraddr txid tx. + ( MonadDelay m + , MonadSTM m + , MonadThread m + , Ord txid + ) + => TxDecisionPolicy + -> SharedTxStateVar m peeraddr txid tx + -> m Void +drainRejectionThread policy sharedStateVar = do + labelThisThread "tx-rejection-drain" + now <- getMonotonicTime + go $ addTime drainInterval now + where + drainInterval :: DiffTime + drainInterval = 7 + + go :: Time -> m Void + go !nextDrain = do + threadDelay 1 + + !now <- getMonotonicTime + atomically $ do + st <- readTVar sharedStateVar + let ptss = if now > nextDrain then Map.map (updateRejects policy now 0) (peerTxStates st) + else peerTxStates st + st' = tickTimedTxs now st + writeTVar sharedStateVar (st' { peerTxStates = ptss }) + + if now > nextDrain + then go $ addTime drainInterval now + else go nextDrain + +decisionLogicThread + :: forall m peeraddr txid tx. + ( MonadDelay m + , MonadMVar m + , MonadSTM m + , MonadMask m + , MonadFork m + , Ord peeraddr + , Ord txid + , Hashable peeraddr + ) + => Tracer m (TraceTxLogic 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 (TraceSharedTxState "decisionLogicThread" st) + traceWith tracer (TraceTxDecisions 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/V2/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs new file mode 100644 index 00000000000..52ef228ceee --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs @@ -0,0 +1,569 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Network.TxSubmission.Inbound.V2.State + ( -- * Core API + SharedTxState (..) + , PeerTxState (..) + , numTxIdsToRequest + , SharedTxStateVar + , newSharedTxStateVar + , receivedTxIds + , collectTxs + , acknowledgeTxIds + , tickTimedTxs + -- * Internals, only exported for testing purposes: + , RefCountDiff (..) + , updateRefCounts + , receivedTxIdsImpl + , collectTxsImpl + ) where + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Exception (assert) +import Control.Monad.Class.MonadTime.SI +import Control.Tracer (Tracer, traceWith) + +import Data.Foldable (fold, toList) +import Data.Foldable qualified as Foldable +import Data.Functor (($>)) +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 Data.Typeable (Typeable) +import System.Random (StdGen) + +import GHC.Stack (HasCallStack) +import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..), + NumTxIdsToReq (..)) +import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) +import Ouroboros.Network.TxSubmission.Inbound.V2.Policy +import Ouroboros.Network.TxSubmission.Inbound.V2.Types +import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..)) + + +-- | 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 + +-- +-- Pure public API +-- + +acknowledgeTxIds + :: forall peeraddr tx txid. + Ord txid + => TxDecisionPolicy + -> SharedTxState peeraddr txid tx + -> PeerTxState txid tx + -> ( NumTxIdsToAck + , NumTxIdsToReq + , TxsToMempool txid tx + , RefCountDiff txid + , PeerTxState txid tx + ) + -- ^ number of txid to acknowledge, requests, txs which we can submit to the + -- mempool, txids to acknowledge with multiplicities, updated PeerTxState. +{-# INLINE acknowledgeTxIds #-} + +acknowledgeTxIds + TxDecisionPolicy { maxNumTxIdsToRequest, + maxUnacknowledgedTxIds } + SharedTxState { bufferedTxs } + ps@PeerTxState { availableTxIds, + unacknowledgedTxIds, + unknownTxs, + requestedTxIdsInflight, + downloadedTxs, + score, + toMempoolTxs, + requestedTxsInflight } + = + -- 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 txsToMempool + , refCountDiff + , ps { unacknowledgedTxIds = unacknowledgedTxIds', + availableTxIds = availableTxIds', + unknownTxs = unknownTxs', + requestedTxIdsInflight = requestedTxIdsInflight + + txIdsToRequest, + downloadedTxs = downloadedTxs', + score = score', + toMempoolTxs = toMempoolTxs' } + ) + else + ( 0 + , 0 + , TxsToMempool txsToMempool + , 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 + || txid `Map.member` downloadedTxs) + && txid `Set.notMember` requestedTxsInflight + ) + unacknowledgedTxIds + + txsToMempool = [ (txid,tx) + | txid <- toList toMempoolTxIds + , tx <- maybeToList $ txid `Map.lookup` downloadedTxs + ] + (toMempoolTxIds, _) = + StrictSeq.spanl (\txid -> txid `Map.member` downloadedTxs + && txid `Map.notMember` bufferedTxs) + acknowledgedTxIds + txsToMempoolMap = Map.fromList txsToMempool + + toMempoolTxs' = toMempoolTxs <> txsToMempoolMap + + (downloadedTxs', ackedDownloadedTxs) = Map.partitionWithKey (\txid _ -> txid `Set.member` liveSet) downloadedTxs + lateTxs = Map.filterWithKey (\txid _ -> txid `Map.notMember` txsToMempoolMap) ackedDownloadedTxs + score' = score + fromIntegral (Map.size lateTxs) + + -- 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 (Map.alter fn) + 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 + +tickTimedTxs :: forall peeraddr tx txid. + (Ord txid) + => Time + -> SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx +tickTimedTxs now st@SharedTxState{ timedTxs + , referenceCounts + , bufferedTxs } = + let (expiredTxs', timedTxs') = + case Map.splitLookup now timedTxs of + (expired, Just txids, timed) -> + (expired, -- Map.split doesn't include the `now` entry in the map + Map.insert now txids timed) + (expired, Nothing, timed) -> + (expired, timed) + refDiff = Map.foldl' fn Map.empty expiredTxs' + referenceCounts' = updateRefCounts referenceCounts (RefCountDiff refDiff) + liveSet = Map.keysSet referenceCounts' + bufferedTxs' = bufferedTxs `Map.restrictKeys` liveSet in + st { timedTxs = timedTxs' + , referenceCounts = referenceCounts' + , bufferedTxs = bufferedTxs' + } + + where + fn :: Map txid Int + -> [txid] + -> Map txid Int + fn m txids = Foldable.foldl' gn m txids + + gn :: Map txid Int + -> txid + -> Map txid Int + gn m txid = Map.alter af txid m + + af :: Maybe Int + -> Maybe Int + af Nothing = Just 1 + af (Just n) = Just $! succ n + +-- +-- 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' = + Foldable.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 peeraddr + , Ord txid + , Show txid + , Typeable txid + ) + => (tx -> SizeInBytes) -- ^ compute tx size + -> peeraddr + -> Set txid -- ^ set of requested txids + -> Map txid tx -- ^ received txs + -> SharedTxState peeraddr txid tx + -> Either TxSubmissionProtocolError + (SharedTxState peeraddr txid tx) + -- ^ Return list of `txid` which sizes didn't match or a new state. + -- If one of the `tx` has wrong size, we return an error. The + -- mini-protocol will throw, which will clean the state map from this peer. +collectTxsImpl txSize 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 + (Right st', peerTxStates') -> + Right st' { peerTxStates = peerTxStates' } + (Left e, _) -> + Left $ ProtocolErrorTxSizeError e + + where + -- Update `PeerTxState` and partially update `SharedTxState` (except of + -- `peerTxStates`). + fn :: PeerTxState txid tx + -> ( Either [(txid, SizeInBytes, SizeInBytes)] + (SharedTxState peeraddr txid tx) + , PeerTxState txid tx + ) + fn ps = + case wrongSizedTxs of + [] -> ( Right st' + , ps'' + ) + _ -> ( Left wrongSizedTxs + , ps + ) + where + wrongSizedTxs :: [(txid, SizeInBytes, SizeInBytes)] + wrongSizedTxs = + map (\(a, (b,c)) -> (a,b,c)) + . Map.toList + $ Map.merge + (Map.mapMaybeMissing \_ _ -> Nothing) + (Map.mapMaybeMissing \_ _ -> Nothing) + (Map.zipWithMaybeMatched \_ receivedSize advertisedSize -> + if receivedSize == advertisedSize + then Nothing + else Just (receivedSize, advertisedSize) + ) + (txSize `Map.map` receivedTxs) + (availableTxIds ps) + + + notReceived = requestedTxIds Set.\\ Map.keysSet receivedTxs + + downloadedTxs' = downloadedTxs ps <> 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 + + -- 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', + downloadedTxs = downloadedTxs' } + +-- +-- Monadic public API +-- + +type SharedTxStateVar m peeraddr txid tx = StrictTVar m (SharedTxState peeraddr txid tx) + +newSharedTxStateVar :: MonadSTM m + => StdGen + -> m (SharedTxStateVar m peeraddr txid tx) +newSharedTxStateVar rng = newTVarIO SharedTxState { peerTxStates = Map.empty, + inflightTxs = Map.empty, + inflightTxsSize = 0, + bufferedTxs = Map.empty, + referenceCounts = Map.empty, + timedTxs = Map.empty, + limboTxs = Map.empty, + peerRng = rng } + + +-- | 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 (TraceTxLogic 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 (TraceSharedTxState "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, + Show txid, Typeable txid) + => Tracer m (TraceTxLogic peeraddr txid tx) + -> (tx -> SizeInBytes) + -> SharedTxStateVar m peeraddr txid tx + -> peeraddr + -> Set txid -- ^ set of requested txids + -> Map txid tx -- ^ received txs + -> m (Maybe TxSubmissionProtocolError) + -- ^ number of txids to be acknowledged and txs to be added to the + -- mempool +collectTxs tracer txSize sharedVar peeraddr txidsRequested txsMap = do + r <- atomically $ do + st <- readTVar sharedVar + case collectTxsImpl txSize peeraddr txidsRequested txsMap st of + r@(Right st') -> writeTVar sharedVar st' + $> r + r@Left {} -> pure r + case r of + Right st -> traceWith tracer (TraceSharedTxState "collectTxs" st) + $> Nothing + Left e -> return (Just e) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs new file mode 100644 index 00000000000..9e0f376f02e --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Ouroboros.Network.TxSubmission.Inbound.V2.Types + ( -- * PeerTxState + PeerTxState (..) + -- * SharedTxState + , SharedTxState (..) + -- * Decisions + , TxsToMempool (..) + , TxDecision (..) + , emptyTxDecision + , SharedDecisionContext (..) + , TraceTxLogic (..) + , TxSubmissionInitDelay (..) + , defaultTxSubmissionInitDelay + -- * Types shared with V1 + -- ** Various + , ProcessedTxCount (..) + , TxSubmissionLogicVersion (..) + -- ** Mempool API + , TxSubmissionMempoolWriter (..) + -- ** Traces + , TraceTxSubmissionInbound (..) + -- ** Protocol Error + , TxSubmissionProtocolError (..) + ) where + +import Control.Exception (Exception (..)) +import Control.Monad.Class.MonadTime.SI +import Data.Map.Strict (Map) +import Data.Sequence.Strict (StrictSeq) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import System.Random (StdGen) + +import NoThunks.Class (NoThunks (..)) + +import Ouroboros.Network.DeltaQ (PeerGSV (..)) +import Ouroboros.Network.Protocol.TxSubmission2.Type + +-- | Flag to enable/disable the usage of the new tx-submission logic. +-- +data TxSubmissionLogicVersion = + -- | the legacy `Ouroboros.Network.TxSubmission.Inbound.V1` + TxSubmissionLogicV1 + -- | the new `Ouroboros.Network.TxSubmission.Inbound.V2` + | TxSubmissionLogicV2 + deriving (Eq, Show) + +-- +-- PeerTxState, SharedTxState +-- + +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), + + -- | Score is a metric that tracks how usefull a peer has been. + -- The larger the value the less usefull peer. It slowly decays towards + -- zero. + score :: !Double, + + -- | Timestamp for the last time `score` was drained. + scoreTs :: !Time, + + -- | A set of TXs downloaded from the peer. They are not yet + -- acknowledged and haven't been sent to the mempool yet. + -- + -- Life cycle of entries: + -- * added when a tx is downloaded (see `collectTxsImpl`) + -- * follows `unacknowledgedTxIds` (see `acknowledgeTxIds`) + -- + downloadedTxs :: !(Map txid tx), + + -- | A set of TXs on their way to the mempool. + -- Tracked here so that we can cleanup `limboTxs` if the peer dies. + -- + -- Life cycle of entries: + -- * added by `acknowledgeTxIds` (where decide which txs can be + -- submitted to the mempool) + -- * removed by `withMempoolSem` + -- + toMempoolTxs :: !(Map txid tx) + + } + deriving (Eq, Show, Generic) + +instance ( NoThunks txid + , NoThunks tx + ) => NoThunks (PeerTxState txid tx) + + +-- | 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 and added to the mempool, + -- * 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 or has a `timedTxs` entry. + -- + -- /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 and timedTxs 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), + + -- | A set of timeouts for txids that have been added to bufferedTxs after being + -- inserted into the mempool. + -- Every txid entry has a reference count in `referenceCounts`. + timedTxs :: Map Time [txid], + + -- | A set of txids that have been downloaded by a peer and are on their + -- way to the mempool. We won't issue further fetch-requests for TXs in + -- this state. We track these txs to not re-download them from another + -- peer. + -- + -- * We subtract from the counter when a given tx is added or rejected by + -- the mempool or do that for all txs in `toMempoolTxs` when a peer is + -- unregistered. + -- * We add to the counter when a given tx is selected to be added to the + -- mempool in `pickTxsToDownload`. + -- + limboTxs :: !(Map txid Int), + + -- | Rng used to randomly order peers + peerRng :: !StdGen + } + deriving (Eq, Show, Generic) + +instance ( NoThunks peeraddr + , NoThunks tx + , NoThunks txid + , NoThunks StdGen + ) => NoThunks (SharedTxState peeraddr txid tx) + + +-- +-- Decisions +-- + +newtype TxsToMempool txid tx = TxsToMempool { listOfTxsToMempool :: [(txid, tx)] } + deriving newtype (Eq, Show, Semigroup, Monoid) + + +-- | 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 :: !(TxsToMempool txid 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' + } + +-- | A no-op decision. +emptyTxDecision :: TxDecision txid tx +emptyTxDecision = TxDecision { + txdTxIdsToAcknowledge = 0, + txdTxIdsToRequest = 0, + txdPipelineTxIds = False, + txdTxsToRequest = Set.empty, + txdTxsToMempool = mempty + } + +data SharedDecisionContext peeraddr txid tx = SharedDecisionContext { + -- TODO: check how to access it. + sdcPeerGSV :: !(Map peeraddr PeerGSV), + + sdcSharedTxState :: !(SharedTxState peeraddr txid tx) + } + deriving Show + + +-- | TxLogic tracer. +-- +data TraceTxLogic peeraddr txid tx = + TraceSharedTxState String (SharedTxState peeraddr txid tx) + | TraceTxDecisions (Map peeraddr (TxDecision txid tx)) + deriving Show + + +data ProcessedTxCount = ProcessedTxCount { + -- | Just accepted this many transactions. + ptxcAccepted :: Int + -- | Just rejected this many transactions. + , ptxcRejected :: Int + , ptxcScore :: Double + } + 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 [txid] + -- | Just processed transaction pass/fail breakdown. + | TraceTxSubmissionProcessed ProcessedTxCount + | TraceTxInboundCanRequestMoreTxs Int + | TraceTxInboundCannotRequestMoreTxs Int + | TraceTxInboundAddedToMempool [txid] DiffTime + | TraceTxInboundRejectedFromMempool [txid] DiffTime + + -- + -- messages emitted by the new implementation of the server in + -- "Ouroboros.Network.TxSubmission.Inbound.Server"; some of them are also + -- used in this module. + -- + + -- | Server received 'MsgDone' + | TraceTxInboundTerminated + | TraceTxInboundDecision (TxDecision txid tx) + deriving (Eq, Show) + + +data TxSubmissionProtocolError = + ProtocolErrorTxNotRequested + | ProtocolErrorTxIdsNotRequested + | forall txid. (Typeable txid, Show txid) + => ProtocolErrorTxSizeError [(txid, SizeInBytes, SizeInBytes)] + -- ^ a list of txid for which the received size and advertised size didn't + -- match. + +deriving instance Show TxSubmissionProtocolError + +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." + displayException (ProtocolErrorTxSizeError txids) = + "The peer received txs with wrong sizes " ++ show txids + +data TxSubmissionInitDelay = + TxSubmissionInitDelay DiffTime + | NoTxSubmissionInitDelay + +defaultTxSubmissionInitDelay :: TxSubmissionInitDelay +defaultTxSubmissionInitDelay = TxSubmissionInitDelay 60 diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Outbound.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Outbound.hs index 19cdfd4d6e4..1af15c9c776 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,9 +55,10 @@ 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 + ++ "total in flight over the limit of " ++ show maxUnacked ++ "." + ++ " Number of unacked txids " ++ show unackedNo displayException ProtocolErrorRequestedNothing = "The peer requested zero txids." @@ -96,15 +98,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. diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs index 4d7154e26b3..f91c01f2ac2 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -42,15 +42,14 @@ import Control.Concurrent.Class.MonadMVar (MonadMVar) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad ((>=>)) import Control.Monad.Class.MonadAsync (MonadAsync (wait, withAsync)) -import Control.Monad.Class.MonadFork (MonadFork) +import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadST (MonadST) -import Control.Monad.Class.MonadThrow (MonadEvaluate, MonadMask, MonadThrow, - SomeException) +import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI (DiffTime, MonadTime, Time (..)) import Control.Monad.Class.MonadTimer.SI (MonadDelay, MonadTimer) import Control.Monad.Fix (MonadFix) -import Control.Tracer (Tracer (..), nullTracer) +import Control.Tracer (Tracer (..), nullTracer, traceWith) import Codec.CBOR.Term qualified as CBOR import Data.Foldable as Foldable (foldl') @@ -61,7 +60,6 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text import Data.Void (Void) -import GHC.Exception (Exception) import Network.DNS (Domain, TYPE) import System.Random (StdGen, mkStdGen, split) @@ -77,6 +75,7 @@ import Ouroboros.Network.AnchoredFragment qualified as AF import Ouroboros.Network.Block (MaxSlotNo (..), maxSlotNoFromWithOrigin, pointSlot) import Ouroboros.Network.BlockFetch +import Ouroboros.Network.BlockFetch.ClientRegistry (readPeerGSVs) import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation (ChainSelStarvationEndedAt)) import Ouroboros.Network.ConnectionManager.State (ConnStateIdSupply) @@ -112,9 +111,14 @@ import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) import Ouroboros.Network.Snocket (MakeBearer, Snocket, TestAddress (..), invalidFileDescriptor) +import Ouroboros.Network.TxSubmission.Inbound.V2.Policy (TxDecisionPolicy) +import Ouroboros.Network.TxSubmission.Inbound.V2.Registry (decisionLogicThread) +import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TraceTxLogic, + TraceTxSubmissionInbound) + import Simulation.Network.Snocket (AddressType (..), FD) -import Test.Ouroboros.Network.Data.Script (Script) +import Test.Ouroboros.Network.Data.Script import Test.Ouroboros.Network.Diffusion.Node.ChainDB (addBlock, getBlockPointSet) import Test.Ouroboros.Network.Diffusion.Node.Kernel (NodeKernel (..), NtCAddr, @@ -124,6 +128,7 @@ import Test.Ouroboros.Network.Diffusion.Node.MiniProtocols qualified as Node import Test.Ouroboros.Network.PeerSelection.RootPeersDNS (DNSLookupDelay, DNSTimeout, DomainAccessPoint (..), MockDNSLookupResult, mockDNSActions) +import Test.Ouroboros.Network.TxSubmission.Types (Tx) data Interfaces extraAPI m = Interfaces @@ -165,6 +170,8 @@ data Arguments extraChurnArgs extraFlags m = Arguments , aDNSLookupDelayScript :: Script DNSLookupDelay , aDebugTracer :: Tracer m String , aExtraChurnArgs :: extraChurnArgs + , aTxDecisionPolicy :: TxDecisionPolicy + , aTxs :: [Tx Int] } -- The 'mockDNSActions' is not using \/ specifying 'resolverException', thus we @@ -253,13 +260,19 @@ run :: forall extraState extraDebugState extraAPI ResolverException extraState extraDebugState extraFlags extraPeers extraCounters m -> Tracer m (TraceLabelPeer NtNAddr (TraceFetchClientState BlockHeader)) + -> Tracer m (TraceTxSubmissionInbound Int (Tx Int)) + -> Tracer m (TraceTxLogic NtNAddr Int (Tx Int)) -> m Void run blockGeneratorArgs limits ni na emptyExtraState emptyExtraCounters extraPeersAPI psArgs psToExtraCounters toExtraPeers requestPublicRootPeers peerChurnGovernor - tracers tracerBlockFetch = - Node.withNodeKernelThread blockGeneratorArgs + tracers tracerBlockFetch tracerTxSubmissionInbound + tracerTxLogic = + handle (\(e :: SomeException) -> traceWith (aDebugTracer na) ("Unhandled exception: " ++ show e) + >> throwIO e) $ do + labelThisThread ("node-" ++ Node.ppNtNAddr (aIPAddress na)) + Node.withNodeKernelThread (aIPAddress na) blockGeneratorArgs (aTxs na) $ \ nodeKernel nodeKernelThread -> do dnsTimeoutScriptVar <- newTVarIO (aDNSTimeoutScript na) dnsLookupDelayScriptVar <- newTVarIO (aDNSLookupDelayScript na) @@ -336,6 +349,8 @@ run blockGeneratorArgs limits ni na apps = Node.applications (aDebugTracer na) + tracerTxSubmissionInbound + tracerTxLogic nodeKernel Node.cborCodecs limits @@ -350,11 +365,19 @@ run blockGeneratorArgs limits ni na apps) $ \ 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 @@ -373,7 +396,7 @@ run blockGeneratorArgs limits ni na bfcSalt = 0 }) - blockFetchPolicy :: NodeKernel BlockHeader Block s m + blockFetchPolicy :: NodeKernel BlockHeader Block s txid m -> BlockFetchConsensusInterface NtNAddr BlockHeader Block m blockFetchPolicy nodeKernel = BlockFetchConsensusInterface { @@ -491,6 +514,7 @@ run blockGeneratorArgs limits ni na , Node.aaChainSyncEarlyExit = aChainSyncEarlyExit na , Node.aaOwnPeerSharing = aOwnPeerSharing na , Node.aaPeerMetrics = peerMetrics + , Node.aaTxDecisionPolicy = aTxDecisionPolicy na } --- Utils diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs index e0273cf5bec..d003e0075f4 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs @@ -13,6 +13,8 @@ module Test.Ouroboros.Network.Diffusion.Node.Kernel , encodeNtNAddr , decodeNtNAddr , ntnAddrToRelayAccessPoint + , ppNtNAddr + , ppNtNConnId , NtNVersion , NtNVersionData (..) , NtCAddr @@ -36,6 +38,7 @@ import Control.Concurrent.Class.MonadSTM.Strict import Control.DeepSeq (NFData (..)) import Control.Monad (replicateM, when) import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI @@ -52,7 +55,7 @@ import Data.Monoid.Synchronisation import Data.Void (Void) import GHC.Generics (Generic) import Numeric.Natural (Natural) -import System.Random (RandomGen, StdGen, randomR, split) +import System.Random (RandomGen, StdGen, mkStdGen, random, randomR, split) import Network.Socket (PortNumber) @@ -60,12 +63,17 @@ import Ouroboros.Network.AnchoredFragment (Anchor (..)) import Ouroboros.Network.Block (HasFullHeader, SlotNo) import Ouroboros.Network.Block qualified as Block import Ouroboros.Network.BlockFetch +import Ouroboros.Network.ConnectionId (ConnectionId (..)) import Ouroboros.Network.Handshake.Acceptable (Accept (..), Acceptable (..)) import Ouroboros.Network.Mock.Chain (Chain (..)) import Ouroboros.Network.Mock.Chain qualified as Chain import Ouroboros.Network.Mock.ConcreteBlock (Block) import Ouroboros.Network.Mock.ConcreteBlock qualified as ConcreteBlock import Ouroboros.Network.Mock.ProducerState + +import Simulation.Network.Snocket (AddressType (..), GlobalAddressScheme (..)) + +import Control.Concurrent.Class.MonadMVar.Strict qualified as Strict import Ouroboros.Network.NodeToNode () import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.PeerSelection (PeerSharing, RelayAccessPoint (..)) @@ -76,12 +84,13 @@ import Ouroboros.Network.PeerSharing (PeerSharingAPI, PeerSharingRegistry (..), ps_POLICY_PEER_SHARE_MAX_PEERS, ps_POLICY_PEER_SHARE_STICKY_TIME) import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Snocket (TestAddress (..)) - -import Simulation.Network.Snocket (AddressType (..), GlobalAddressScheme (..)) - +import Ouroboros.Network.TxSubmission.Inbound.V2.Registry (SharedTxStateVar, + TxChannels (..), TxChannelsVar, TxMempoolSem, newSharedTxStateVar, + newTxMempoolSem) import Test.Ouroboros.Network.Diffusion.Node.ChainDB (ChainDB (..)) import Test.Ouroboros.Network.Diffusion.Node.ChainDB qualified as ChainDB import Test.Ouroboros.Network.Orphans () +import Test.Ouroboros.Network.TxSubmission.Types (Mempool, Tx, newMempool) import Test.QuickCheck (Arbitrary (..), choose, chooseInt, frequency, oneof) @@ -117,6 +126,11 @@ instance Show NtNAddr_ where show (EphemeralIPv6Addr n) = "EphemeralIPv6Addr " ++ show n show (IPAddr ip port) = "IPAddr (read \"" ++ show ip ++ "\") " ++ show port +ppNtNAddr_ :: NtNAddr_ -> String +ppNtNAddr_ (EphemeralIPv4Addr n) = "eph.v4." ++ show n +ppNtNAddr_ (EphemeralIPv6Addr n) = "eph.v6." ++ show n +ppNtNAddr_ (IPAddr ip port) = show ip ++ ":" ++ show port + instance GlobalAddressScheme NtNAddr_ where getAddressType (TestAddress addr) = case addr of @@ -137,6 +151,13 @@ data NtNVersionData = NtNVersionData } deriving Show +ppNtNAddr :: NtNAddr -> String +ppNtNAddr (TestAddress addr) = ppNtNAddr_ addr + +ppNtNConnId :: ConnectionId NtNAddr -> String +ppNtNConnId ConnectionId { localAddress, remoteAddress } = + ppNtNAddr localAddress ++ "→" ++ ppNtNAddr remoteAddress + instance Acceptable NtNVersionData where acceptableVersion NtNVersionData { @@ -263,7 +284,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))), @@ -280,12 +301,27 @@ 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), + + nkTxMempoolSem :: TxMempoolSem m, + + nkSharedTxStateVar :: SharedTxStateVar m NtNAddr txid (Tx txid) } -newNodeKernel :: MonadSTM m - => s -> m (NodeKernel header block s m) -newNodeKernel rng = do +newNodeKernel :: ( MonadSTM m + , Strict.MonadMVar m + , RandomGen s + , Eq txid + ) + => s + -> Int + -> [Tx txid] + -> m (NodeKernel header block s txid m) +newNodeKernel psRng txSeed txs = do publicStateVar <- makePublicPeerSelectionStateVar NodeKernel <$> newTVarIO Map.empty @@ -293,15 +329,19 @@ newNodeKernel rng = do <*> newFetchClientRegistry <*> newPeerSharingRegistry <*> ChainDB.newChainDB - <*> newPeerSharingAPI publicStateVar rng + <*> newPeerSharingAPI publicStateVar psRng ps_POLICY_PEER_SHARE_STICKY_TIME ps_POLICY_PEER_SHARE_MAX_PEERS <*> pure publicStateVar + <*> newMempool txs + <*> Strict.newMVar (TxChannels Map.empty) + <*> newTxMempoolSem + <*> newSharedTxStateVar (mkStdGen txSeed) -- | 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 @@ -313,7 +353,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 $ @@ -365,34 +405,43 @@ 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 + , MonadFork 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) + => NtNAddr + -- ^ just for naming a thread + -> BlockGeneratorArgs block seed + -> [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 } +withNodeKernelThread addr BlockGeneratorArgs { bgaSlotDuration, bgaBlockGenerator, bgaSeed } + txs k = do - kernel <- newNodeKernel psSeed + kernel <- newNodeKernel psSeed txSeed txs withSlotTime bgaSlotDuration $ \waitForSlot -> withAsync (blockProducerThread kernel waitForSlot) (k kernel) where - (bpSeed, psSeed) = split bgaSeed + (bpSeed, rng) = split bgaSeed + (txSeed, psSeed) = random rng - blockProducerThread :: NodeKernel header block seed m + blockProducerThread :: NodeKernel header block seed txid m -> (SlotNo -> STM m SlotNo) -> m Void blockProducerThread NodeKernel { nkChainProducerState, nkChainDB } waitForSlot - = loop (Block.SlotNo 1) bpSeed + = labelThisThread ("krnl-" ++ ppNtNAddr addr) + >> loop (Block.SlotNo 1) bpSeed where loop :: SlotNo -> seed -> m Void loop nextSlot seed = do diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs index d15a7d3eb5d..926a678a950 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -82,10 +83,10 @@ import Ouroboros.Network.Mock.Chain qualified as Chain import Ouroboros.Network.Mock.ConcreteBlock import Ouroboros.Network.Mock.ProducerState import Ouroboros.Network.Mux -import Ouroboros.Network.NodeToNode (blockFetchMiniProtocolNum, - chainSyncMiniProtocolNum, keepAliveMiniProtocolNum, - peerSharingMiniProtocolNum) -import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) +import Ouroboros.Network.NodeToNode (DiffusionMode (..), + blockFetchMiniProtocolNum, chainSyncMiniProtocolNum, + keepAliveMiniProtocolNum, peerSharingMiniProtocolNum, + txSubmissionMiniProtocolNum) import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics) import Ouroboros.Network.PeerSelection.PeerSharing qualified as PSTypes import Ouroboros.Network.PeerSharing (PeerSharingAPI, bracketPeerSharingClient, @@ -94,11 +95,26 @@ 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.RethrowPolicy +import Ouroboros.Network.TxSubmission.Inbound.V2 (TxSubmissionInitDelay (..), + txSubmissionInboundV2) +import Ouroboros.Network.TxSubmission.Inbound.V2.Policy (TxDecisionPolicy (..)) +import Ouroboros.Network.TxSubmission.Inbound.V2.Registry (SharedTxStateVar, + TxChannelsVar, TxMempoolSem, withPeer) +import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TraceTxLogic, + TraceTxSubmissionInbound) +import Ouroboros.Network.TxSubmission.Outbound (txSubmissionOutbound) import Ouroboros.Network.Util.ShowProxy import Ouroboros.Network.Diffusion.Policies (simplePeerSelectionPolicy) import Test.Ouroboros.Network.Diffusion.Node.Kernel +import Test.Ouroboros.Network.TxSubmission.Types (Mempool, Tx (..), + getMempoolReader, getMempoolWriter, txSubmissionCodec2) -- | Protocol codecs. @@ -114,6 +130,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 @@ -127,6 +145,7 @@ cborCodecs = Codecs , keepAliveCodec = codecKeepAlive_v2 , pingPongCodec = codecPingPong , peerSharingCodec = codecPeerSharing encodeNtNAddr decodeNtNAddr + , txSubmissionCodec = txSubmissionCodec2 } @@ -180,6 +199,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 } @@ -210,6 +237,7 @@ data AppArgs header block m = AppArgs :: PSTypes.PeerSharing , aaPeerMetrics :: PeerMetrics m NtNAddr + , aaTxDecisionPolicy :: TxDecisionPolicy } @@ -218,6 +246,7 @@ data AppArgs header block m = AppArgs applications :: forall block header s m. ( Alternative (STM m) , MonadAsync m + , MonadDelay m , MonadFork m , MonadMask m , MonadMVar m @@ -229,13 +258,16 @@ applications :: forall block header s m. , HasHeader header , HasHeader block , HeaderHash header ~ HeaderHash block + , Show header , Show block , ShowProxy block , ShowProxy header , RandomGen s ) => Tracer m String - -> NodeKernel header block s m + -> Tracer m (TraceTxSubmissionInbound Int (Tx Int)) + -> Tracer m (TraceTxLogic NtNAddr Int (Tx Int)) + -> NodeKernel header block s Int m -> Codecs NtNAddr header block m -> LimitsAndTimeouts header block -> AppArgs header block m @@ -243,10 +275,11 @@ applications :: forall block header s m. -> Diffusion.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 @@ -259,6 +292,7 @@ applications debugTracer nodeKernel , aaChainSyncEarlyExit , aaOwnPeerSharing , aaPeerMetrics + , aaTxDecisionPolicy } toHeader = Diffusion.Applications @@ -332,6 +366,19 @@ applications debugTracer nodeKernel blockFetchInitiator blockFetchResponder } + + , MiniProtocol { + miniProtocolNum = txSubmissionMiniProtocolNum, + miniProtocolStart = StartOnDemand, + miniProtocolLimits = txSubmissionLimits limits, + miniProtocolRun = + InitiatorAndResponderProtocol + (txSubmissionInitiator aaTxDecisionPolicy (nkMempool nodeKernel)) + (txSubmissionResponder (nkMempool nodeKernel) + (nkTxChannelsVar nodeKernel) + (nkTxMempoolSem nodeKernel) + (nkSharedTxStateVar nodeKernel)) + } ] , withWarm = WithWarm [ MiniProtocol @@ -416,7 +463,7 @@ applications debugTracer nodeKernel (\_ -> unregisterClientChains nodeKernel (remoteAddress connId)) (\chainVar -> runPeerWithLimits - nullTracer + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) chainSyncCodec (chainSyncSizeLimits limits) (chainSyncTimeLimits limits) @@ -429,10 +476,12 @@ applications debugTracer nodeKernel chainSyncResponder :: MiniProtocolCb (ResponderContext NtNAddr) ByteString m () - chainSyncResponder = MiniProtocolCb $ \_ctx channel -> do + chainSyncResponder = MiniProtocolCb $ + \ ResponderContext { rcConnectionId = connId } + channel -> do labelThisThread "ChainSyncServer" runPeerWithLimits - nullTracer + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) chainSyncCodec (chainSyncSizeLimits limits) (chainSyncTimeLimits limits) @@ -446,7 +495,7 @@ applications debugTracer nodeKernel blockFetchInitiator = MiniProtocolCb $ \ ExpandedInitiatorContext { - eicConnectionId = ConnectionId { remoteAddress }, + eicConnectionId = connId@ConnectionId { remoteAddress }, eicControlMessage = controlMessageSTM } channel @@ -456,7 +505,7 @@ applications debugTracer nodeKernel remoteAddress $ \clientCtx -> runPeerWithLimits - nullTracer + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) blockFetchCodec (blockFetchSizeLimits limits) (blockFetchTimeLimits limits) @@ -468,10 +517,12 @@ applications debugTracer nodeKernel blockFetchResponder :: MiniProtocolCb (ResponderContext NtNAddr) ByteString m () blockFetchResponder = - MiniProtocolCb $ \_ctx channel -> do + MiniProtocolCb $ + \ ResponderContext { rcConnectionId = connId } + channel -> do labelThisThread "BlockFetchServer" runPeerWithLimits - nullTracer + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) blockFetchCodec (blockFetchSizeLimits limits) (blockFetchTimeLimits limits) @@ -500,7 +551,7 @@ applications debugTracer nodeKernel -> do labelThisThread "KeepAliveClient" let kacApp = \ctxVar -> runPeerWithLimits - ((show . (connId,)) `contramap` debugTracer) + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) keepAliveCodec (keepAliveSizeLimits limits) (keepAliveTimeLimits limits) @@ -519,10 +570,12 @@ applications debugTracer nodeKernel keepAliveResponder :: MiniProtocolCb (ResponderContext NtNAddr) ByteString m () - keepAliveResponder = MiniProtocolCb $ \_ctx channel -> do + keepAliveResponder = MiniProtocolCb $ + \ ResponderContext { rcConnectionId = connId } + channel -> do labelThisThread "KeepAliveServer" runPeerWithLimits - nullTracer + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) keepAliveCodec (keepAliveSizeLimits limits) (keepAliveTimeLimits limits) @@ -556,16 +609,16 @@ applications debugTracer nodeKernel -- value (which must be 'False') so it does not matter which branch is -- picked. continue <- atomically $ runFirstToFinish $ - ( FirstToFinish $ do - LazySTM.readTVar v >>= check - continueSTM ) - <> ( FirstToFinish $ do - continueSTM >>= \b -> check (not b) $> b ) + FirstToFinish do + LazySTM.readTVar v >>= check + continueSTM + <> FirstToFinish do + continueSTM >>= \b -> check (not b) $> b if continue then return pingPongClient else return $ PingPong.SendMsgDone () in runPeerWithLimits - ((show . (connId,)) `contramap` debugTracer) + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) pingPongCodec (pingPongSizeLimits limits) (pingPongTimeLimits limits) @@ -577,7 +630,7 @@ applications debugTracer nodeKernel pingPongResponder = MiniProtocolCb $ \ResponderContext { rcConnectionId = connId } channel -> runPeerWithLimits - ((show . (connId,)) `contramap` debugTracer) + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) pingPongCodec (pingPongSizeLimits limits) (pingPongTimeLimits limits) @@ -599,7 +652,7 @@ applications debugTracer nodeKernel $ \controller -> do psClient <- peerSharingClient controlMessageSTM controller runPeerWithLimits - ((show . (connId,)) `contramap` debugTracer) + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) peerSharingCodec (peerSharingSizeLimits limits) (peerSharingTimeLimits limits) @@ -609,10 +662,12 @@ applications debugTracer nodeKernel peerSharingResponder :: PeerSharingAPI NtNAddr s m -> MiniProtocolCb (ResponderContext NtNAddr) ByteString m () - peerSharingResponder psAPI = MiniProtocolCb $ \ResponderContext { rcConnectionId = connId } channel -> do + peerSharingResponder psAPI = MiniProtocolCb $ + \ ResponderContext { rcConnectionId = connId } + channel -> do labelThisThread "PeerSharingServer" runPeerWithLimits - ((show . (connId,)) `contramap` debugTracer) + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) peerSharingCodec (peerSharingSizeLimits limits) (peerSharingTimeLimits limits) @@ -620,6 +675,66 @@ 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 + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) + (NumTxIdsToAck $ getNumTxIdsToReq + $ maxUnacknowledgedTxIds txDecisionPolicy) + (getMempoolReader mempool) + maxBound + controlMessageSTM + labelThisThread "TxSubmissionClient" + runPeerWithLimits + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) + txSubmissionCodec + (txSubmissionSizeLimits limits) + (txSubmissionTimeLimits limits) + channel + (txSubmissionClientPeer client) + + txSubmissionResponder + :: Mempool m Int + -> TxChannelsVar m NtNAddr Int (Tx Int) + -> TxMempoolSem m + -> SharedTxStateVar m NtNAddr Int (Tx Int) + -> MiniProtocolCb (ResponderContext NtNAddr) ByteString m () + txSubmissionResponder mempool txChannelsVar txMempoolSem sharedTxStateVar = + MiniProtocolCb $ + \ ResponderContext { rcConnectionId = connId@ConnectionId { remoteAddress = them }} channel + -> do + withPeer txSubmissionInboundDebug + txChannelsVar + txMempoolSem + aaTxDecisionPolicy + sharedTxStateVar + (getMempoolReader mempool) + (getMempoolWriter mempool) + getTxSize + them $ \api -> do + let server = txSubmissionInboundV2 + txSubmissionInboundTracer + NoTxSubmissionInitDelay + (getMempoolWriter mempool) + api + labelThisThread "TxSubmissionServer" + runPipelinedPeerWithLimits + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) + txSubmissionCodec + (txSubmissionSizeLimits limits) + (txSubmissionTimeLimits limits) + channel + (txSubmissionServerPeerPipelined server) -- -- Orphaned Instances diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs index 2f7835b68af..0c2b1a0d6ff 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -16,7 +16,8 @@ module Test.Ouroboros.Network.Diffusion.Testnet.Cardano (tests) where -import Control.Exception (AssertionFailed (..), catch, evaluate, fromException) +import Control.Exception (AssertionFailed (..), catch, displayException, + evaluate, fromException) import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadTest (exploreRaces) import Control.Monad.Class.MonadTime.SI (DiffTime, Time (Time), addTime, @@ -24,16 +25,19 @@ import Control.Monad.Class.MonadTime.SI (DiffTime, Time (Time), addTime, import Control.Monad.IOSim import Data.Bifoldable (bifoldMap) -import Data.Bifunctor (first) +import Data.Bifunctor (bimap, first) +import Data.Char (ord) import Data.Dynamic (fromDynamic) -import Data.Foldable (fold) +import Data.Foldable (fold, foldr') import Data.IP qualified as IP +import Data.List (intercalate, sort) import Data.List qualified as List import Data.List.Trace qualified as Trace import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, mapMaybe) import Data.Monoid (Sum (..)) +import Data.Ratio (Ratio) import Data.Set (Set) import Data.Set qualified as Set import Data.Time (secondsToDiffTime) @@ -49,16 +53,16 @@ import Network.Mux.Trace qualified as Mx import Cardano.Network.ConsensusMode import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..), requiresBootstrapPeers) -import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) -import Cardano.Network.Types (LedgerStateJudgement, NumberOfBigLedgerPeers (..)) - import Cardano.Network.PeerSelection.ExtraRootPeers qualified as Cardano import Cardano.Network.PeerSelection.ExtraRootPeers qualified as Cardano.ExtraPeers import Cardano.Network.PeerSelection.Governor.PeerSelectionState qualified as Cardano import Cardano.Network.PeerSelection.Governor.PeerSelectionState qualified as Cardano.ExtraState +import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) +import Cardano.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers +import Cardano.Network.Types (LedgerStateJudgement, NumberOfBigLedgerPeers (..)) import Ouroboros.Network.Block (BlockNo (..)) -import Ouroboros.Network.BlockFetch (PraosFetchMode (..), +import Ouroboros.Network.BlockFetch (FetchMode (..), PraosFetchMode (..), TraceFetchClientState (..)) import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace (..)) import Ouroboros.Network.ConnectionId @@ -81,6 +85,14 @@ import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers import Ouroboros.Network.PeerSharing (PeerSharingResult (..)) import Ouroboros.Network.Server qualified as Server +import Ouroboros.Network.TxSubmission.Inbound.V2.Policy + (defaultTxDecisionPolicy, txInflightMultiplicity) +import Ouroboros.Network.TxSubmission.Inbound.V2.State (inflightTxs) +import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TraceTxLogic (..), + TraceTxSubmissionInbound (..)) +import Ouroboros.Network.TxSubmission.Outbound (TxSubmissionProtocolError (..)) + +import Simulation.Network.Snocket (BearerInfo (..), noAttenuation) import Test.Ouroboros.Network.ConnectionManager.Timeouts import Test.Ouroboros.Network.ConnectionManager.Utils @@ -93,16 +105,17 @@ import Test.Ouroboros.Network.Diffusion.Node.Kernel import Test.Ouroboros.Network.Diffusion.Testnet.Cardano.Simulation import Test.Ouroboros.Network.InboundGovernor.Utils import Test.Ouroboros.Network.LedgerPeers (LedgerPools (..)) +import Test.Ouroboros.Network.TxSubmission.TxLogic (ArbTxDecisionPolicy (..)) +import Test.Ouroboros.Network.TxSubmission.Types (Tx (..), TxId) import Test.Ouroboros.Network.Utils hiding (SmallDelay, debugTracer) -import Simulation.Network.Snocket (BearerInfo (..)) -import Cardano.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers import Test.QuickCheck import Test.QuickCheck.Monoids import Test.Tasty import Test.Tasty.QuickCheck (testProperty) + tests :: TestTree tests = testGroup "Ouroboros.Network.Testnet" @@ -157,6 +170,10 @@ tests = prop_only_bootstrap_peers_in_fallback_state_iosimpor , nightlyTest $ testProperty "no non trustable peers before caught up state" prop_no_non_trustable_peers_before_caught_up_state_iosimpor + , testGroup "Tx Submission" + [ nightlyTest $ testProperty "no protocol errors" + prop_no_txSubmission_error_iosimpor + ] , testGroup "Churn" [ nightlyTest $ testProperty "no timeouts" prop_churn_notimeouts_iosimpor @@ -239,6 +256,14 @@ tests = , testProperty "don't peershare the unwilling" prop_no_peershare_unwilling_iosim ] + , testGroup "Tx Submission" + [ testProperty "no protocol errors" + prop_no_txSubmission_error_iosim + , testProperty "all transactions" + unit_txSubmission_allTransactions + , testProperty "inflight coverage" + prop_check_inflight_ratio + ] , testGroup "Churn" [ testProperty "no timeouts" prop_churn_notimeouts_iosim , testProperty "steps" prop_churn_steps_iosim @@ -346,7 +371,7 @@ unit_cm_valid_transitions = , abiSDUSize = LargeSDU } ds = DiffusionScript - (SimArgs 1 10) + (SimArgs 1 10 defaultTxDecisionPolicy) (Script ((Map.empty, ShortDelay) :| [(Map.empty, LongDelay)])) [ ( NodeArgs (-2) @@ -388,7 +413,8 @@ unit_cm_valid_transitions = [DNSLookupDelay {getDNSLookupDelay = 0.072}])) Nothing False - (Script (FetchModeBulkSync :| [FetchModeBulkSync])) + (Script (PraosFetchMode FetchModeBulkSync :| [PraosFetchMode FetchModeBulkSync])) + [] , [JoinNetwork 0.5] ) , ( NodeArgs @@ -429,7 +455,8 @@ unit_cm_valid_transitions = (Script (DNSLookupDelay {getDNSLookupDelay = 0.125} :| [])) (Just (BlockNo 2)) False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [JoinNetwork 1.484_848_484_848] ) ] @@ -564,7 +591,7 @@ unit_connection_manager_trace_coverage = script@(DiffusionScript _ _ nodes) = DiffusionScript - (SimArgs 1 20) + (SimArgs 1 20 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [ -- a relay node (NodeArgs { @@ -592,7 +619,9 @@ unit_connection_manager_trace_coverage = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] + } , [JoinNetwork 0] ) @@ -626,7 +655,8 @@ unit_connection_manager_trace_coverage = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 0] ) @@ -688,7 +718,7 @@ unit_connection_manager_transitions_coverage = script@(DiffusionScript _ _ nodes) = DiffusionScript - (SimArgs 1 20) + (SimArgs 1 20 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [ -- a relay node (NodeArgs { @@ -716,7 +746,8 @@ unit_connection_manager_transitions_coverage = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 0] ) @@ -750,7 +781,8 @@ unit_connection_manager_transitions_coverage = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 0] ) @@ -787,6 +819,261 @@ 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 (IG.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 + +prop_no_txSubmission_error_iosimpor + :: AbsBearerInfo -> DiffusionScript -> Property +prop_no_txSubmission_error_iosimpor + = testWithIOSimPOR prop_no_txSubmission_error short_trace + +prop_no_txSubmission_error_iosim + :: AbsBearerInfo -> DiffusionScript -> Property +prop_no_txSubmission_error_iosim + = testWithIOSim prop_no_txSubmission_error long_trace + + +-- | 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 + -> NonEmptyList (Tx TxId) + -> NonEmptyList (Tx TxId) + -> Property +unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) + (NonEmpty txsA) + (NonEmpty txsB) = + let localRootConfig = LocalRootConfig + DoNotAdvertisePeer + InitiatorAndResponderDiffusionMode + IsNotTrustable + diffScript = + DiffusionScript + (SimArgs 1 10 decisionPolicy) + (singletonTimedScript Map.empty) + [(NodeArgs + (-3) + InitiatorAndResponderDiffusionMode + (Just 224) + Map.empty + PraosMode + (Script (DontUseBootstrapPeers :| [])) + (TestAddress (IPAddr (read "0.0.0.0") 0)) + PeerSharingDisabled + [(2,2,Map.fromList [(RelayAccessAddress "0.0.0.1" 0, localRootConfig)])] + (Script (LedgerPools [] :| [])) + (let targets = + PeerSelectionTargets { + targetNumberOfRootPeers = 1, + targetNumberOfKnownPeers = 1, + targetNumberOfEstablishedPeers = 1, + targetNumberOfActivePeers = 1, + + targetNumberOfKnownBigLedgerPeers = 0, + targetNumberOfEstablishedBigLedgerPeers = 0, + targetNumberOfActiveBigLedgerPeers = 0 + } + in (targets, targets)) + (Script (DNSTimeout {getDNSTimeout = 10} :| [])) + (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) + Nothing + False + (Script (PraosFetchMode FetchModeDeadline :| [])) + uniqueTxsA + , [JoinNetwork 0]) + , (NodeArgs + (-1) + InitiatorAndResponderDiffusionMode + (Just 2) + Map.empty + PraosMode + (Script (DontUseBootstrapPeers :| [])) + (TestAddress (IPAddr (read "0.0.0.1") 0)) + PeerSharingDisabled + [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.0" 0, localRootConfig)])] + (Script (LedgerPools [] :| [])) + (let targets = + PeerSelectionTargets { + targetNumberOfRootPeers = 1, + targetNumberOfKnownPeers = 1, + targetNumberOfEstablishedPeers = 1, + targetNumberOfActivePeers = 1, + + targetNumberOfKnownBigLedgerPeers = 0, + targetNumberOfEstablishedBigLedgerPeers = 0, + targetNumberOfActiveBigLedgerPeers = 0 + } + in (targets, targets) + ) + (Script (DNSTimeout {getDNSTimeout = 10} :| [ ])) + (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) + Nothing + False + (Script (PraosFetchMode FetchModeDeadline :| [])) + uniqueTxsB + , [JoinNetwork 0]) + ] + in checkAllTransactions (runSimTrace + (diffusionSimulation noAttenuation + diffScript + iosimTracer) + ) + 500_000 -- ^ Running for 500k might not be enough. + where + -- We need to make sure the transactions are unique, this simplifies + -- things. + -- + -- TODO: the generator ought to give us unique `TxId`s. + uniqueTxsA = map (\(t, i) -> t { getTxId = List.foldl' (+) 0 (map ord "0.0.0.0") + i }) + (zip txsA [0 :: TxId ..]) + uniqueTxsB = map (\(t, i) -> t { getTxId = List.foldl' (+) 0 (map ord "0.0.0.1") + i }) + (zip txsB [100 :: TxId ..]) + + -- 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 trace = Trace.take traceNumber ioSimTrace + + events = fmap (\(WithTime t (WithName name b)) -> WithName name (WithTime t b)) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + $ trace + + -- Build the accepted (sorted) txids map for each peer + -- + sortedAcceptedTxidsMap :: Map NtNAddr [TxId] + sortedAcceptedTxidsMap = + foldr (\l r -> + List.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 txids) (Just . sort . (txids ++))) n rr + -- if a node would be killed, we could download some txs + -- multiple times, but this is not possible in the schedule + _ -> 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 (Trace.ppTrace show (ppSimEvent 0 0 0) trace) + $ counterexample ("accepted txids map: " ++ show sortedAcceptedTxidsMap) + $ counterexample ("A: unique txs: " ++ show uniqueTxsA) + $ counterexample ("A: valid transactions that should be accepted: " ++ show validSortedTxidsA) + $ counterexample ("B: unique txs: " ++ show uniqueTxsB) + $ counterexample ("B: valid transactions that should be accepted: " ++ show validSortedTxidsB) + $ label ("number of valid tx transferred: " ++ renderRanges 10 (getSum . foldMap (Sum . List.length) $ sortedAcceptedTxidsMap)) + + -- 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 + of + Just acceptedTxidsA -> + counterexample "0.0.0.0" $ + acceptedTxidsA === validSortedTxidsB + Nothing | [] <- validSortedTxidsB -> property True + | otherwise -> counterexample "Didn't found any entry in the map!" False + .&&. + case Map.lookup (TestAddress (IPAddr (read "0.0.0.1") 0)) sortedAcceptedTxidsMap + of + Just acceptedTxidsB -> + counterexample "0.0.0.1" $ + acceptedTxidsB === validSortedTxidsA + Nothing | [] <- validSortedTxidsA -> property True + | otherwise -> counterexample "Didn't found 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 + DiffusionTxLogic (TraceSharedTxState _ 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 @@ -1112,7 +1399,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" 65_535, DoAdvertisePeer)]) @@ -1136,7 +1423,8 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script (Script (DNSLookupDelay {getDNSLookupDelay = 0.067} :| [DNSLookupDelay {getDNSLookupDelay = 0.097},DNSLookupDelay {getDNSLookupDelay = 0.101},DNSLookupDelay {getDNSLookupDelay = 0.096},DNSLookupDelay {getDNSLookupDelay = 0.051}])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [JoinNetwork 1.742_857_142_857 ,Reconfigure 6.333_333_333_33 [(1,1,Map.fromList [(RelayAccessDomain "test2" 65_535,LocalRootConfig DoAdvertisePeer InitiatorAndResponderDiffusionMode IsNotTrustable)]), (1,1,Map.fromList [(RelayAccessAddress "0:6:0:3:0:6:0:5" 65_530,LocalRootConfig DoAdvertisePeer InitiatorAndResponderDiffusionMode IsNotTrustable) @@ -1169,7 +1457,8 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script ])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [JoinNetwork 0.183_783_783_783 ,Reconfigure 4.533_333_333_333 [(1,1,Map.empty)] ] @@ -1754,7 +2043,7 @@ unit_4191 = testWithIOSim prop_diffusion_dns_can_recover long_trace absInfo scri } script = DiffusionScript - (SimArgs 1 20) + (SimArgs 1 20 defaultTxDecisionPolicy) (singletonTimedScript $ Map.fromList [ (("test2", DNS.A), Left [ (read "810b:4c8a:b3b5:741:8c0c:b437:64cf:1bd9", 300) @@ -1819,11 +2108,12 @@ unit_4191 = testWithIOSim prop_diffusion_dns_can_recover long_trace absInfo scri ])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [ JoinNetwork 6.710_144_927_536 , Kill 7.454_545_454_545 , JoinNetwork 10.763_157_894_736 - , Reconfigure 0.415_384_615_384 [(1,1,Map.empty) + , Reconfigure 0.415_384_615_384 [(1,1,Map.fromList []) , (1,1,Map.empty)] , Reconfigure 15.550_561_797_752 [(1,1,Map.empty) , (1,1,Map.fromList [(RelayAccessDomain "test2" 15,LocalRootConfig DoAdvertisePeer InitiatorAndResponderDiffusionMode IsNotTrustable)])] @@ -1881,7 +2171,7 @@ prop_connect_failure (AbsIOError ioerr) = script = DiffusionScript - (SimArgs 1 20) + (SimArgs 1 20 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [ (NodeArgs { naSeed = 0, @@ -1908,7 +2198,8 @@ prop_connect_failure (AbsIOError ioerr) = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 10] ), @@ -1937,7 +2228,8 @@ prop_connect_failure (AbsIOError ioerr) = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 0] ) @@ -1968,13 +2260,15 @@ prop_accept_failure (AbsIOError ioerr) = counterexample (show evs) . (if isFatalAccept ioerr then -- verify that the node was killed by the right exception - any (\case + counterexample ("fatal exception " ++ displayException ioerr ++ " not propagated") + . any (\case TrErrored e | Just e' <- fromException e , e' == ioerr -> True _ -> False) else -- verify that the node was not killed by the `ioerr` exception - all (\case + counterexample ("non-fatal exception " ++ displayException ioerr ++ " propagated") + . all (\case TrErrored {} -> False _ -> True) ) @@ -2007,7 +2301,7 @@ prop_accept_failure (AbsIOError ioerr) = script = DiffusionScript - (SimArgs 1 20) + (SimArgs 1 20 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [ (NodeArgs { naSeed = 0, @@ -2034,7 +2328,8 @@ prop_accept_failure (AbsIOError ioerr) = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 10] ), @@ -2063,7 +2358,8 @@ prop_accept_failure (AbsIOError ioerr) = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 0] ) @@ -3058,7 +3354,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, @@ -3084,7 +3381,8 @@ async_demotion_network_script = naChainSyncEarlyExit = False, naPeerSharing = PeerSharingDisabled, - naFetchModeScript = singletonScript FetchModeDeadline + naFetchModeScript = singletonScript (PraosFetchMode FetchModeDeadline), + naTxs = [] } @@ -3645,7 +3943,7 @@ prop_unit_4258 = abiSDUSize = LargeSDU } diffScript = DiffusionScript - (SimArgs 1 10) + (SimArgs 1 10 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [( NodeArgs (-3) InitiatorAndResponderDiffusionMode (Just 224) Map.empty @@ -3673,7 +3971,8 @@ prop_unit_4258 = (Script (DNSLookupDelay {getDNSLookupDelay = 0.065} :| [])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [ JoinNetwork 4.166_666_666_666, Kill 0.3, JoinNetwork 1.517_857_142_857, @@ -3715,7 +4014,8 @@ prop_unit_4258 = ])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [ JoinNetwork 3.384_615_384_615, Reconfigure 3.583_333_333_333 [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.4" 9,LocalRootConfig DoNotAdvertisePeer InitiatorAndResponderDiffusionMode IsNotTrustable)])], Kill 15.555_555_555_55, @@ -3748,7 +4048,7 @@ prop_unit_reconnect :: Property prop_unit_reconnect = let diffScript = DiffusionScript - (SimArgs 1 10) + (SimArgs 1 10 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [(NodeArgs (-3) @@ -3778,7 +4078,8 @@ prop_unit_reconnect = (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [ JoinNetwork 0 ]) , (NodeArgs @@ -3806,7 +4107,8 @@ prop_unit_reconnect = (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [ JoinNetwork 10 ]) ] @@ -4221,12 +4523,13 @@ unit_peer_sharing = naDNSLookupDelayScript = singletonScript (DNSLookupDelay 0.01), naChainSyncEarlyExit = False, naChainSyncExitOnBlockNo = Nothing, - naFetchModeScript = singletonScript FetchModeDeadline, - naConsensusMode + naFetchModeScript = singletonScript (PraosFetchMode FetchModeDeadline), + naConsensusMode, + naTxs = [] } script = DiffusionScript - (mainnetSimArgs 3) + (mainnetSimArgs 3 defaultTxDecisionPolicy) (singletonScript (mempty, ShortDelay)) [ ( (defaultNodeArgs GenesisMode) { naAddr = ip_0, naLocalRootPeers = [(1, 1, Map.fromList [(ra_1, LocalRootConfig DoNotAdvertisePeer InitiatorAndResponderDiffusionMode IsNotTrustable)])], @@ -4709,7 +5012,7 @@ unit_local_root_diffusion_mode diffusionMode = script = DiffusionScript - (SimArgs 1 20) + (SimArgs 1 20 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [ -- a relay node (NodeArgs { @@ -4737,7 +5040,8 @@ unit_local_root_diffusion_mode diffusionMode = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 0] ) @@ -4771,7 +5075,8 @@ unit_local_root_diffusion_mode diffusionMode = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 0] ) @@ -5003,7 +5308,7 @@ takeUntilEndofTurn n as = labelDiffusionScript :: DiffusionScript -> Property -> Property labelDiffusionScript (DiffusionScript args _ nodes) = label ("sim args: " - ++ show args) + ++ renderSimArgs args) . label ("Nº nodes: " ++ show (length nodes)) . label ("Nº nodes in InitiatorOnlyDiffusionMode: " diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs index 3b4cee431a3..e89d4d8f857 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs @@ -13,6 +13,7 @@ module Test.Ouroboros.Network.Diffusion.Testnet.Cardano.Simulation ( SimArgs (..) + , renderSimArgs , mainnetSimArgs , NodeArgs (..) , ServiceDomainName (..) @@ -26,6 +27,7 @@ module Test.Ouroboros.Network.Diffusion.Testnet.Cardano.Simulation , Command (..) -- * Tracing , DiffusionTestTrace (..) + , ppDiffusionTestTrace , iosimTracer -- * Re-exports , TestAddress (..) @@ -63,7 +65,6 @@ import Data.Proxy (Proxy (..)) import Data.Set (Set) import Data.Set qualified as Set import Data.Time.Clock (secondsToDiffTime) -import Data.Typeable (Typeable) import Data.Void (Void) import Network.DNS (Domain) import Network.DNS qualified as DNS @@ -108,8 +109,8 @@ import Ouroboros.Network.Driver.Limits (ProtocolSizeLimits (..), import Ouroboros.Network.Handshake.Acceptable (Acceptable (acceptableVersion)) import Ouroboros.Network.InboundGovernor (RemoteTransitionTrace) import Ouroboros.Network.InboundGovernor qualified as IG -import Ouroboros.Network.Mock.ConcreteBlock (Block (..), BlockHeader (..)) import Ouroboros.Network.Mux (MiniProtocolLimits (..)) +import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.PeerSelection hiding (peerChurnGovernor, requestPublicRootPeers) import Ouroboros.Network.PeerSelection.Governor qualified as Governor @@ -126,14 +127,23 @@ import Ouroboros.Network.Protocol.KeepAlive.Codec (byteLimitsKeepAlive, import Ouroboros.Network.Protocol.Limits (shortWait, smallByteLimit) import Ouroboros.Network.Protocol.PeerSharing.Codec (byteLimitsPeerSharing, timeLimitsPeerSharing) +import Ouroboros.Network.Protocol.TxSubmission2.Codec (byteLimitsTxSubmission2, + timeLimitsTxSubmission2) import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Snocket (Snocket, TestAddress (..)) +import Ouroboros.Network.TxSubmission.Inbound.V2.Policy (TxDecisionPolicy) +import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TraceTxLogic, + TraceTxSubmissionInbound) +import Ouroboros.Network.Mock.ConcreteBlock (Block (..), BlockHeader (..)) import Simulation.Network.Snocket (BearerInfo (..), FD, SnocketTrace, WithAddr (..), makeFDBearer, withSnocket) import Test.Ouroboros.Network.Data.Script -import Test.Ouroboros.Network.Diffusion.Node as Node +import Test.Ouroboros.Network.Diffusion.Node qualified as Node +import Test.Ouroboros.Network.Diffusion.Node.Kernel (NtCAddr, NtCVersion, + NtCVersionData, NtNAddr, NtNAddr_ (IPAddr), NtNVersion, + NtNVersionData, ppNtNAddr) import Test.Ouroboros.Network.LedgerPeers (LedgerPools (..), genLedgerPoolsFrom) import Test.Ouroboros.Network.PeerSelection.Cardano.Instances () import Test.Ouroboros.Network.PeerSelection.Instances qualified as PeerSelection @@ -142,6 +152,8 @@ import Test.Ouroboros.Network.PeerSelection.RootPeersDNS (DNSLookupDelay (..), DNSTimeout (..), DomainAccessPoint (..), MockDNSMap, genDomainName) import Test.Ouroboros.Network.PeerSelection.RootPeersDNS qualified as PeerSelection hiding (tests) +import Test.Ouroboros.Network.TxSubmission.TxLogic (ArbTxDecisionPolicy (..)) +import Test.Ouroboros.Network.TxSubmission.Types (Tx (..)) import Test.Ouroboros.Network.Utils import Test.QuickCheck @@ -152,17 +164,27 @@ 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 } +-- | Render `SimArgs`, ignores `saTxDecisionPolicy`; useful for quickcheck +-- coverage checking. +-- +renderSimArgs :: SimArgs -> String +renderSimArgs SimArgs { saSlot, saQuota } = + "slotDuration: " ++ show saSlot ++ " quota: " ++ show saQuota + instance Show SimArgs where - show SimArgs { saSlot, saQuota } = + show SimArgs { saSlot, saQuota, saTxDecisionPolicy } = unwords [ "SimArgs" , show saSlot , show saQuota + , "(" ++ show saTxDecisionPolicy ++ ")" ] data ServiceDomainName = @@ -218,7 +240,8 @@ data NodeArgs = -- ^ 'Arguments' 'aDNSLookupDelayScript' value , naChainSyncExitOnBlockNo :: Maybe BlockNo , naChainSyncEarlyExit :: Bool - , naFetchModeScript :: Script PraosFetchMode + , naFetchModeScript :: Script FetchMode + , naTxs :: [Tx Int] } instance Show NodeArgs where @@ -226,7 +249,8 @@ instance Show NodeArgs where naPublicRoots, naAddr, naPeerSharing, naLedgerPeers, naLocalRootPeers, naPeerTargets, naDNSTimeoutScript, naDNSLookupDelayScript, naChainSyncExitOnBlockNo, - naChainSyncEarlyExit, naFetchModeScript, naConsensusMode } = + naChainSyncEarlyExit, naFetchModeScript, naConsensusMode, + naTxs } = unwords [ "NodeArgs" , "(" ++ show naSeed ++ ")" , show naDiffusionMode @@ -244,6 +268,7 @@ instance Show NodeArgs where , "(" ++ show naChainSyncExitOnBlockNo ++ ")" , show naChainSyncEarlyExit , show naFetchModeScript + , show naTxs ] data Command = JoinNetwork DiffTime @@ -313,13 +338,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 } @@ -359,12 +387,14 @@ instance Arbitrary SmallPeerSelectionTargets where -- | Given a NtNAddr generate the necessary things to run a node in -- Simulation -genNodeArgs :: [TestnetRelayInfo] +genNodeArgs :: SimArgs + -> [TestnetRelayInfo] -> Int -> [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig PeerTrustable))] -> TestnetRelayInfo + -> [Tx Int] -> Gen NodeArgs -genNodeArgs relays minConnected localRootPeers self = flip suchThat hasUpstream $ do +genNodeArgs SimArgs {saSlot, saQuota} relays minConnected localRootPeers self txs = flip suchThat hasUpstream $ do -- Slot length needs to be greater than 0 else we get a livelock on -- the IOSim. -- @@ -378,19 +408,12 @@ genNodeArgs relays minConnected localRootPeers self = flip suchThat hasUpstream , (3, pure InitiatorAndResponderDiffusionMode) ] - -- These values approximately correspond to false positive - -- thresholds for streaks of empty slots with 99% probability, - -- 99.9% probability up to 99.999% probability. - -- t = T_s [log (1-Y) / log (1-f)] - -- Y = [0.99, 0.999...] - -- - -- T_s = slot length of 1s. - -- f = 0.05 - -- The timeout is randomly picked per bearer to avoid all bearers - -- going down at the same time in case of a long streak of empty - -- slots. TODO: workaround until peer selection governor. - -- Taken from ouroboros-consensus/src/Ouroboros/Consensus/Node.hs - mustReplyTimeout <- Just <$> oneof (pure <$> [90, 135, 180, 224, 269]) + -- Number of slots for which a single node will not produce a block with + -- probability higher than 99% + (mustReplyTimeoutInSlots :: Double) <- + arbitrary `suchThat` (\x -> x >= log(0.99) / log(1 - fromIntegral saQuota / 100)) + let mustReplyTimeout :: DiffTime + mustReplyTimeout = saSlot * realToFrac mustReplyTimeoutInSlots -- Make sure our targets for active peers cover the maximum of peers -- one generated @@ -428,7 +451,7 @@ genNodeArgs relays minConnected localRootPeers self = flip suchThat hasUpstream ledgerPeersScript_ <- traverse genLedgerPoolsFrom ledgerPeers let ledgerPeersScript = Script (NonEmpty.fromList ledgerPeersScript_) - fetchModeScript <- fmap (bool FetchModeBulkSync FetchModeDeadline) <$> arbitrary + fetchModeScript <- fmap (PraosFetchMode . bool FetchModeBulkSync FetchModeDeadline) <$> arbitrary naConsensusMode <- arbitrary bootstrapPeersDomain <- @@ -440,7 +463,7 @@ genNodeArgs relays minConnected localRootPeers self = flip suchThat hasUpstream $ NodeArgs { naSeed = seed , naDiffusionMode = diffusionMode - , naMbTime = mustReplyTimeout + , naMbTime = Just mustReplyTimeout , naPublicRoots = publicRoots -- TODO: we haven't been using public root peers so far because we set -- `UseLedgerPeers 0`! @@ -456,6 +479,7 @@ genNodeArgs relays minConnected localRootPeers self = flip suchThat hasUpstream , naChainSyncEarlyExit = chainSyncEarlyExit , naPeerSharing = peerSharing , naFetchModeScript = fetchModeScript + , naTxs = txs } where makeRelayAccessPoint (relay, _, _, _) = relay @@ -612,18 +636,34 @@ genDiffusionScript :: ( [TestnetRelayInfo] genDiffusionScript genLocalRootPeers relays = do - let simArgs = mainnetSimArgs (length them) + ArbTxDecisionPolicy txDecisionPolicy <- arbitrary + let simArgs = mainnetSimArgs (length relays') txDecisionPolicy dnsMapScript <- genDomainMapScript relays - nodesWithCommands <- mapM go them + txs <- makeUniqueIds 0 + <$> vectorOf (length relays') (choose (10, 100) >>= \c -> vectorOf c arbitrary) + nodesWithCommands <- mapM (go simArgs) (zip relays' txs) return (simArgs, dnsMapScript, nodesWithCommands) where - them = unTestnetRelays relays - go self = do - let otherRelays = self `delete` them - minConnected = 3 `max` (length them - 1) -- ^ TODO is this ever different from 3? - -- since we generate {2,3} relays? - localRts <- genLocalRootPeers otherRelays self - nodeArgs <- genNodeArgs them minConnected localRts self + relays' = unTestnetRelays relays + + 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 + ) + + go :: SimArgs -> (TestnetRelayInfo, [Tx Int]) -> Gen (NodeArgs, [Command]) + go simArgs (relay, txs) = do + let otherRelays = relay `delete` relays' + minConnected = 3 `max` (length relays' - 1) -- ^ TODO is this ever different from 3? + -- since we generate {2,3} relays? + localRts <- genLocalRootPeers otherRelays relay + nodeArgs <- genNodeArgs simArgs relays' minConnected localRts relay txs commands <- genCommands localRts return (nodeArgs, commands) @@ -881,7 +921,7 @@ data DiffusionSimulationTrace | TrUpdatingDNS | TrRunning | TrErrored SomeException - deriving (Show) + deriving Show -- Warning: be careful with writing properties that rely -- on trace events from multiple components environment. @@ -909,19 +949,43 @@ data DiffusionTestTrace = | DiffusionServerTrace (Server.Trace NtNAddr) | DiffusionFetchTrace (TraceFetchClientState BlockHeader) | DiffusionChurnModeTrace TracerChurnMode + | DiffusionTxSubmissionInbound (TraceTxSubmissionInbound Int (Tx Int)) + | DiffusionTxLogic (TraceTxLogic NtNAddr Int (Tx Int)) | DiffusionDebugTrace String | DiffusionDNSTrace DNSTrace - deriving (Show) + deriving Show + + +ppDiffusionTestTrace :: DiffusionTestTrace -> String +ppDiffusionTestTrace (DiffusionLocalRootPeerTrace tr) = show tr +ppDiffusionTestTrace (DiffusionPublicRootPeerTrace tr) = show tr +ppDiffusionTestTrace (DiffusionLedgerPeersTrace tr) = show tr +ppDiffusionTestTrace (DiffusionPeerSelectionTrace tr) = show tr +ppDiffusionTestTrace (DiffusionPeerSelectionActionsTrace tr) = show tr +ppDiffusionTestTrace (DiffusionDebugPeerSelectionTrace tr) = show tr +ppDiffusionTestTrace (DiffusionConnectionManagerTrace tr) = show tr +ppDiffusionTestTrace (DiffusionDiffusionSimulationTrace tr) = show tr +ppDiffusionTestTrace (DiffusionConnectionManagerTransitionTrace tr) = show tr +ppDiffusionTestTrace (DiffusionInboundGovernorTrace tr) = show tr +ppDiffusionTestTrace (DiffusionInboundGovernorTransitionTrace tr) = show tr +ppDiffusionTestTrace (DiffusionServerTrace tr) = show tr +ppDiffusionTestTrace (DiffusionFetchTrace tr) = show tr +ppDiffusionTestTrace (DiffusionChurnModeTrace tr) = show tr +ppDiffusionTestTrace (DiffusionTxSubmissionInbound tr) = show tr +ppDiffusionTestTrace (DiffusionTxLogic tr) = show tr +ppDiffusionTestTrace (DiffusionDebugTrace tr) = tr +ppDiffusionTestTrace (DiffusionDNSTrace tr) = show tr -- | A debug tracer which embeds events in DiffusionTestTrace. -- -iosimTracer :: forall s a. - ( Show a - , Typeable a - ) - => Tracer (IOSim s) (WithTime (WithName NtNAddr a)) -iosimTracer = Tracer traceM <> sayTracer +iosimTracer :: forall s. + Tracer (IOSim s) (WithTime (WithName NtNAddr DiffusionTestTrace)) +iosimTracer = + Tracer traceM + <> Tracer (\WithTime { wtEvent = WithName { wnName, wnEvent } } -> + -- don't log time, it's in the trace + say $ ppNtNAddr wnName ++ " @ " ++ ppDiffusionTestTrace wnEvent) -- | Run an arbitrary topology diffusionSimulation @@ -960,7 +1024,9 @@ diffusionSimulation $ \ntcSnocket _ -> do dnsMapVar <- fromLazyTVar <$> playTimedScript nullTracer dnsMapScript withAsyncAll - (map ((\(args, commands) -> runCommand Nothing ntnSnocket ntcSnocket dnsMapVar simArgs args connStateIdSupply commands)) + (map ((\(args, commands) -> do + labelThisThread ("ctrl-" ++ ppNtNAddr (naAddr args)) + runCommand Nothing ntnSnocket ntcSnocket dnsMapVar simArgs args connStateIdSupply commands)) nodeArgs) $ \nodes -> do (_, x) <- waitAny nodes @@ -1042,6 +1108,7 @@ diffusionSimulation runNode SimArgs { saSlot = bgaSlotDuration , saQuota = quota + , saTxDecisionPolicy = txDecisionPolicy } NodeArgs { naSeed = seed @@ -1057,6 +1124,7 @@ diffusionSimulation , naChainSyncExitOnBlockNo = chainSyncExitOnBlockNo , naChainSyncEarlyExit = chainSyncEarlyExit , naPeerSharing = peerSharing + , naTxs = txs } ntnSnocket ntcSnocket @@ -1072,7 +1140,7 @@ diffusionSimulation let readUseBootstrapPeers = stepScriptSTM' useBootstrapPeersScriptVar (bgaRng, rng) = Random.split $ mkStdGen seed acceptedConnectionsLimit = - AcceptedConnectionsLimit maxBound maxBound 0 + Node.AcceptedConnectionsLimit maxBound maxBound 0 diffusionMode = InitiatorAndResponderDiffusionMode readLocalRootPeers = readTVar lrpVar readPublicRootPeers = return publicRoots @@ -1101,14 +1169,20 @@ diffusionSimulation limitsAndTimeouts = Node.LimitsAndTimeouts { Node.chainSyncLimits = defaultMiniProtocolsLimit - , Node.chainSyncSizeLimits = byteLimitsChainSync (const 0) + , Node.chainSyncSizeLimits = byteLimitsChainSync (fromIntegral . BL.length) , Node.chainSyncTimeLimits = + -- timeLimitsChainSync ChainSyncTimeout + -- { canAwaitTimeout = Nothing + -- , intersectTimeout = Nothing + -- , mustReplyTimeout = Nothing + -- , idleTimeout = Nothing + -- } timeLimitsChainSync stdChainSyncTimeout , Node.blockFetchLimits = defaultMiniProtocolsLimit - , Node.blockFetchSizeLimits = byteLimitsBlockFetch (const 0) + , Node.blockFetchSizeLimits = byteLimitsBlockFetch (fromIntegral . BL.length) , Node.blockFetchTimeLimits = timeLimitsBlockFetch , Node.keepAliveLimits = defaultMiniProtocolsLimit - , Node.keepAliveSizeLimits = byteLimitsKeepAlive (const 0) + , Node.keepAliveSizeLimits = byteLimitsKeepAlive (fromIntegral . BL.length) , Node.keepAliveTimeLimits = timeLimitsKeepAlive , Node.pingPongLimits = defaultMiniProtocolsLimit , Node.pingPongSizeLimits = byteLimitsPingPong @@ -1123,8 +1197,10 @@ diffusionSimulation , Node.peerSharingTimeLimits = timeLimitsPeerSharing , Node.peerSharingSizeLimits = - byteLimitsPeerSharing (const 0) - + byteLimitsPeerSharing (fromIntegral . BL.length) + , Node.txSubmissionLimits = defaultMiniProtocolsLimit + , Node.txSubmissionTimeLimits = timeLimitsTxSubmission2 + , Node.txSubmissionSizeLimits = byteLimitsTxSubmission2 (fromIntegral . BL.length) } interfaces :: Node.Interfaces (Cardano.LedgerPeersConsensusInterface m) m @@ -1205,9 +1281,12 @@ diffusionSimulation , Node.aTimeWaitTimeout = 30 , Node.aDNSTimeoutScript = dnsTimeout , Node.aDNSLookupDelayScript = dnsLookupDelay - , Node.aDebugTracer = (\s -> WithTime (Time (-1)) (WithName addr (DiffusionDebugTrace s))) - `contramap` nodeTracer + , Node.aDebugTracer = Tracer (\s -> do + t <- getMonotonicTime + traceWith nodeTracer $ WithTime t (WithName addr (DiffusionDebugTrace s))) , Node.aExtraChurnArgs = cardanoChurnArgs + , Node.aTxDecisionPolicy = txDecisionPolicy + , Node.aTxs = txs } tracers = mkTracers addr @@ -1239,6 +1318,14 @@ diffusionSimulation . tracerWithName addr . tracerWithTime $ nodeTracer) + ( contramap DiffusionTxSubmissionInbound + . tracerWithName addr + . tracerWithTime + $ nodeTracer) + ( contramap DiffusionTxLogic + . tracerWithName addr + . tracerWithTime + $ nodeTracer) `catch` \e -> traceWith (diffSimTracer addr) (TrErrored e) >> throwIO e diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs index e16dde5ee6e..ef97a176eaf 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs @@ -1,390 +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.AppV1 qualified as AppV1 +import Test.Ouroboros.Network.TxSubmission.AppV2 qualified as AppV2 +import Test.Ouroboros.Network.TxSubmission.TxLogic qualified as TxLogic -import Test.Ouroboros.Network.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 - , testProperty "x" prop_x +tests = testGroup "Ouroboros.Network.TxSubmission" + [ TxLogic.tests + , AppV1.tests + , AppV2.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 - => [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 - ) - => 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 - ) - => 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 - , MonadLabelledSTM m - , MonadMask m - , MonadSay m - , MonadST m - , MonadTimer m - , MonadThrow (STM m) - , Ord 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) <- createConnectedBufferedChannels - (fromIntegral maxUnacked) - 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) - (maxBound :: NodeToNodeVersion) - controlMessageSTM - - inboundPeer :: Mempool m txid -> TxSubmissionServerPipelined txid (Tx txid) m () - inboundPeer inboundMempool = - txSubmissionInbound - nullTracer - maxUnacked - (getMempoolReader inboundMempool) - (getMempoolWriter inboundMempool) - (maxBound :: NodeToNodeVersion) - - -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 - -prop_x :: Property -prop_x = prop_txSubmission - Positive {getPositive = 3} - NonEmpty {getNonEmpty = [Tx {getTxId = -83, getTxSize = SizeInBytes 62352, getTxValid = True},Tx {getTxId = 66, getTxSize = SizeInBytes 37084, getTxValid = True},Tx {getTxId = 55, getTxSize = SizeInBytes 54825, getTxValid = False},Tx {getTxId = -94, getTxSize = SizeInBytes 54298, getTxValid = True},Tx {getTxId = -83, getTxSize = SizeInBytes 30932, getTxValid = True},Tx {getTxId = 33, getTxSize = SizeInBytes 40377, getTxValid = True},Tx {getTxId = 87, getTxSize = SizeInBytes 42883, getTxValid = False},Tx {getTxId = -87, getTxSize = SizeInBytes 21529, getTxValid = True},Tx {getTxId = 85, getTxSize = SizeInBytes 15222, getTxValid = True},Tx {getTxId = -13, getTxSize = SizeInBytes 529, getTxValid = True},Tx {getTxId = -21, getTxSize = SizeInBytes 14755, getTxValid = True},Tx {getTxId = 37, getTxSize = SizeInBytes 3921, getTxValid = True},Tx {getTxId = -44, getTxSize = SizeInBytes 42390, getTxValid = True},Tx {getTxId = 47, getTxSize = SizeInBytes 27061, getTxValid = False},Tx {getTxId = 64, getTxSize = SizeInBytes 8540, getTxValid = True},Tx {getTxId = -85, getTxSize = SizeInBytes 15138, getTxValid = False},Tx {getTxId = -23, getTxSize = SizeInBytes 16317, getTxValid = False},Tx {getTxId = -35, getTxSize = SizeInBytes 4372, getTxValid = True},Tx {getTxId = -11, getTxSize = SizeInBytes 13524, getTxValid = True},Tx {getTxId = 98, getTxSize = SizeInBytes 62024, getTxValid = True},Tx {getTxId = -42, getTxSize = SizeInBytes 63227, getTxValid = False},Tx {getTxId = 74, getTxSize = SizeInBytes 31476, getTxValid = True},Tx {getTxId = 72, getTxSize = SizeInBytes 42959, getTxValid = True},Tx {getTxId = 72, getTxSize = SizeInBytes 53084, getTxValid = True},Tx {getTxId = 6, getTxSize = SizeInBytes 5013, getTxValid = True},Tx {getTxId = -62, getTxSize = SizeInBytes 52590, getTxValid = True},Tx {getTxId = -18, getTxSize = SizeInBytes 59325, getTxValid = False},Tx {getTxId = 70, getTxSize = SizeInBytes 40956, getTxValid = True},Tx {getTxId = -82, getTxSize = SizeInBytes 33213, getTxValid = True},Tx {getTxId = -73, getTxSize = SizeInBytes 31026, getTxValid = True},Tx {getTxId = -4, getTxSize = SizeInBytes 19421, getTxValid = True},Tx {getTxId = 68, getTxSize = SizeInBytes 37501, getTxValid = False},Tx {getTxId = 47, getTxSize = SizeInBytes 25707, getTxValid = False},Tx {getTxId = -99, getTxSize = SizeInBytes 58538, getTxValid = False},Tx {getTxId = 86, getTxSize = SizeInBytes 63432, getTxValid = False},Tx {getTxId = -73, getTxSize = SizeInBytes 32185, getTxValid = True},Tx {getTxId = 52, getTxSize = SizeInBytes 55174, getTxValid = False},Tx {getTxId = 52, getTxSize = SizeInBytes 20715, getTxValid = False},Tx {getTxId = -21, getTxSize = SizeInBytes 37063, getTxValid = False},Tx {getTxId = 15, getTxSize = SizeInBytes 63172, getTxValid = True},Tx {getTxId = -26, getTxSize = SizeInBytes 51314, getTxValid = True},Tx {getTxId = 19, getTxSize = SizeInBytes 5042, getTxValid = True},Tx {getTxId = 36, getTxSize = SizeInBytes 40532, getTxValid = True},Tx {getTxId = -30, getTxSize = SizeInBytes 18812, getTxValid = True},Tx {getTxId = 22, getTxSize = SizeInBytes 61634, getTxValid = True},Tx {getTxId = 89, getTxSize = SizeInBytes 44309, getTxValid = True},Tx {getTxId = -98, getTxSize = SizeInBytes 61700, getTxValid = True},Tx {getTxId = -17, getTxSize = SizeInBytes 46606, getTxValid = True},Tx {getTxId = -37, getTxSize = SizeInBytes 25004, getTxValid = False},Tx {getTxId = -53, getTxSize = SizeInBytes 51991, getTxValid = False},Tx {getTxId = -88, getTxSize = SizeInBytes 17941, getTxValid = True},Tx {getTxId = 24, getTxSize = SizeInBytes 19866, getTxValid = True},Tx {getTxId = -99, getTxSize = SizeInBytes 52082, getTxValid = True},Tx {getTxId = 50, getTxSize = SizeInBytes 48715, getTxValid = True},Tx {getTxId = -8, getTxSize = SizeInBytes 24522, getTxValid = True},Tx {getTxId = 92, getTxSize = SizeInBytes 53516, getTxValid = True},Tx {getTxId = 59, getTxSize = SizeInBytes 16151, getTxValid = False},Tx {getTxId = -85, getTxSize = SizeInBytes 57386, getTxValid = True},Tx {getTxId = 23, getTxSize = SizeInBytes 36444, getTxValid = False},Tx {getTxId = -59, getTxSize = SizeInBytes 63727, getTxValid = False},Tx {getTxId = -59, getTxSize = SizeInBytes 12656, getTxValid = True},Tx {getTxId = 13, getTxSize = SizeInBytes 19160, getTxValid = False},Tx {getTxId = -35, getTxSize = SizeInBytes 1681, getTxValid = True},Tx {getTxId = -13, getTxSize = SizeInBytes 46705, getTxValid = False}]} - (Just (Positive {getPositive = SmallDelay {getSmallDelay = 4.3}})) - --- 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 - , MonadSay m - , MonadMonotonicTime m - , Show a - ) - => Tracer m a -verboseTracer = threadAndTimeTracer $ showTracing $ Tracer say - -threadAndTimeTracer :: forall a m. - ( MonadAsync 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/testlib/Test/Ouroboros/Network/TxSubmission/AppV1.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV1.hs new file mode 100644 index 00000000000..88899bf8ec1 --- /dev/null +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV1.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Ouroboros.Network.TxSubmission.AppV1 (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.V1 +import Ouroboros.Network.TxSubmission.Outbound +import Ouroboros.Network.Util.ShowProxy + +import Test.QuickCheck +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Test.Ouroboros.Network.TxSubmission.Types +import Test.Ouroboros.Network.Utils + + +tests :: TestTree +tests = testGroup "AppV1" + [ 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) + (maxBound :: NodeToNodeVersion) + controlMessageSTM + + inboundPeer :: Mempool m txid -> TxSubmissionServerPipelined txid (Tx txid) m () + inboundPeer inboundMempool = + txSubmissionInbound + nullTracer + NoTxSubmissionInitDelay + maxUnacked + (getMempoolReader inboundMempool) + (getMempoolWriter inboundMempool) + (maxBound :: NodeToNodeVersion) + +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/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs new file mode 100644 index 00000000000..622bfea1210 --- /dev/null +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs @@ -0,0 +1,414 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Ouroboros.Network.TxSubmission.AppV2 (tests) where + +import Prelude hiding (seq) + +import NoThunks.Class + +import Control.Concurrent.Class.MonadMVar.Strict +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad (forM) +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.Foldable (traverse_) +import Data.Function (on) +import Data.Hashable +import Data.List (nubBy) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Void (Void) +import System.Random (mkStdGen) + +import Ouroboros.Network.Channel +import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM) +import Ouroboros.Network.DeltaQ (PeerGSV) +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.V2 (TxSubmissionInitDelay (..), + txSubmissionInboundV2) +import Ouroboros.Network.TxSubmission.Inbound.V2.Policy +import Ouroboros.Network.TxSubmission.Inbound.V2.Registry +import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TraceTxLogic) +import Ouroboros.Network.TxSubmission.Outbound +import Ouroboros.Network.Util.ShowProxy + +import Test.Ouroboros.Network.TxSubmission.TxLogic hiding (tests) +import Test.Ouroboros.Network.TxSubmission.Types +import Test.Ouroboros.Network.Utils hiding (debugTracer) + +import Test.QuickCheck +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + + +tests :: TestTree +tests = testGroup "AppV2" + [ testProperty "txSubmission" prop_txSubmission + , testProperty "txSubmission inflight" prop_txSubmission_inflight + ] + +data TxSubmissionState = + TxSubmissionState { + 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 TxSubmissionState 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 <- zipWith (curry (\(a, (b, c)) -> (a, b, c))) txs + <$> vectorOf peersN arbitrary + return TxSubmissionState { peerMap = Map.fromList (zip peers peersState), + decisionPolicy + } + shrink TxSubmissionState { peerMap, decisionPolicy } = + TxSubmissionState <$> 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] + +runTxSubmission + :: 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 + , Hashable peeraddr + + , txid ~ Int + ) + => Tracer m (String, TraceSendRecv (TxSubmission2 txid (Tx txid))) + -> Tracer m (TraceTxLogic peeraddr txid (Tx txid)) + -> Map peeraddr ( [Tx txid] + , ControlMessageSTM m + , Maybe DiffTime + , Maybe DiffTime + ) + -> TxDecisionPolicy + -> m ([Tx txid], [[Tx txid]]) +runTxSubmission tracer 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 + let txRng = mkStdGen 42 -- TODO + + txChannelsMVar <- newMVar (TxChannels Map.empty) + txMempoolSem <- newTxMempoolSem + sharedTxStateVar <- newSharedTxStateVar txRng + labelTVarIO sharedTxStateVar "shared-tx-state" + gsvVar <- newTVarIO Map.empty + labelTVarIO gsvVar "gsv" + + run state' + txChannelsMVar + txMempoolSem + 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 + run :: 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) + -> TxMempoolSem m + -> 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 + run st txChannelsVar txMempoolSem sharedTxStateVar + inboundMempool gsvVar k = + withAsync (decisionLogicThread tracerTxLogic txDecisionPolicy (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) + (maxBound :: NodeToNodeVersion) + 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 tracerTxLogic + txChannelsVar + txMempoolSem + txDecisionPolicy + sharedTxStateVar + (getMempoolReader inboundMempool) + (getMempoolWriter inboundMempool) + getTxSize + addr $ \api -> do + let server = txSubmissionInboundV2 verboseTracer + NoTxSubmissionInitDelay + (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) + +txSubmissionSimulation :: forall s . TxSubmissionState -> IOSim s ([Tx Int], [[Tx Int]]) +txSubmissionSimulation (TxSubmissionState 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 + runTxSubmission 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 :: TxSubmissionState -> Property +prop_txSubmission st = + let tr = runSimTrace (txSubmissionSimulation 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 :: TxSubmissionState -> Property +prop_txSubmission_inflight st@(TxSubmissionState state _) = + let trace = runSimTrace (txSubmissionSimulation 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/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs new file mode 100644 index 00000000000..d8fc68966bd --- /dev/null +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs @@ -0,0 +1,1633 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Ouroboros.Network.TxSubmission.TxLogic where + +import Prelude hiding (seq) + +import Control.Exception (assert) +import Control.Monad.Class.MonadTime.SI (Time (..)) + +import Data.Foldable as Foldable (fold, foldl', toList) +import Data.List (intercalate, isPrefixOf, isSuffixOf, mapAccumR, nub, + 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) +import Data.Monoid (Sum (..)) +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Typeable +import System.Random (StdGen, mkStdGen) + +import NoThunks.Class + +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound.V2.Decision + (SharedDecisionContext (..), TxDecision (..)) +import Ouroboros.Network.TxSubmission.Inbound.V2.Decision qualified as TXS +import Ouroboros.Network.TxSubmission.Inbound.V2.Policy +import Ouroboros.Network.TxSubmission.Inbound.V2.State (PeerTxState (..), + SharedTxState (..)) +import Ouroboros.Network.TxSubmission.Inbound.V2.State qualified as TXS +import Ouroboros.Network.TxSubmission.Inbound.V2.Types qualified as TXS + +import Test.Ouroboros.Network.BlockFetch (PeerGSVT (..)) +import Test.Ouroboros.Network.TxSubmission.Types + +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 + + +tests :: TestTree +tests = testGroup "TxLogic" + [ 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 + ] + , testGroup "Registry" + [ testGroup "filterActivePeers" + [ testProperty "not limiting decisions" prop_filterActivePeers_not_limitting_decisions + ] + ] + ] + + +-- +-- InboundState properties +-- + +type PeerAddr = Int + +-- | 'InboundState` invariant. +-- +sharedTxStateInvariant + :: forall peeraddr txid tx. + ( Ord txid + , Show txid + , Show tx + ) + => 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 + === + Foldable.foldl' + (\m PeerTxState { unacknowledgedTxIds = unacked } -> + Foldable.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 + Set.\\ downloadedTxsSet)) + (unacknowledgedTxIdsSet + Set.\\ availableTxIdsSet + Set.\\ unknownTxs + Set.\\ downloadedTxsSet + `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) + + downloadedTxsSet :: Set txid + downloadedTxsSet = Set.unions $ map (Map.keysSet . downloadedTxs) txStates + + 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, + score = 0, + scoreTs = Time 0, + downloadedTxs = Map.empty, + toMempoolTxs = Map.empty } + (Set.fromList $ Map.elems inflightMap) + bufferedMap + where + mempoolHasTx = apply mempoolHasTxFun + availableTxIds = Map.fromList + [ (txid, getTxAdvSize 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 getTxAdvSize 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) + seed <- arbitrary + + 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 = Foldable.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, + timedTxs = Map.empty, + limboTxs = Map.empty, + peerRng = mkStdGen seed + } + + 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' = + Foldable.foldl' + (\m PeerTxState { unacknowledgedTxIds } -> + Foldable.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.TxsToMempool txIdsTxs, 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 :: Set TxId + acked = Set.fromList $ take (fromIntegral numTxIdsToAck) (toList $ unacknowledgedTxIds ps) + in property $ Set.isSubsetOf (Set.fromList $ map fst txIdsTxs) 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 + -- real size, which might be different from + -- the advertised size + size <- frequency [ (9, pure (availableTxIds Map.! txid)) + , (1, chooseEnum (0, maxTxSize)) + ] + + valid <- frequency [(4, pure True), (1, pure False)] + pure $ Tx { getTxId = txid, + getTxSize = size, + -- `availableTxIds` contains advertised sizes + getTxAdvSize = availableTxIds Map.! txid, + getTxValid = valid }) + + pure $ assert (foldMap getTxAdvSize 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)) $ + label ("hasTxSizeError " ++ show hasTxSizeErr) $ + + case TXS.collectTxsImpl getTxSize peeraddr txidsRequested txsReceived st of + Right st' | not hasTxSizeErr -> + let ps' = peerTxStates st' Map.! peeraddr in + -- 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' + ) + + Right _ -> + counterexample "collectTxsImpl should return Left" + . counterexample (show txsReceived) + $ False + Left _ | not hasTxSizeErr -> + counterexample "collectTxsImpl should return Right" False + + Left (TXS.ProtocolErrorTxSizeError as) -> + counterexample (show as) + $ Set.fromList ((\(txid, _, _) -> coerceTxId txid) `map` as) + === + Map.keysSet (Map.filter (\tx -> getTxSize tx /= getTxAdvSize tx) txsReceived) + Left e -> + counterexample ("unexpected error: " ++ show e) False + where + hasTxSizeErr = any (\tx -> getTxSize tx /= getTxAdvSize tx) txsReceived + + -- The `ProtocolErrorTxSizeError` type is an existential type. We know that + -- the type of `txid` is `TxId`, we just don't have evidence for it. + coerceTxId :: Typeable txid => txid -> TxId + coerceTxId txid = case cast txid of + Just a -> a + Nothing -> error "impossible happened! Is the test still using `TxId` for `txid`?" + + + +deriving via OnlyCheckWhnfNamed "StdGen" StdGen instance NoThunks StdGen + +-- | 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 TXS.collectTxsImpl getTxSize peeraddr txidsRequested txsReceived st of + Right st' -> case unsafeNoThunks $! st' of + Nothing -> property True + Just ctx -> counterexample (show ctx) False + Left _ -> property True + + +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) + <*> (realToFrac <$> choose (0 :: Double, 2)) + <*> (choose (0, 1)) + <*> (choose (0, 1800))) + + 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') + + downTxsNum <- choose (0, length txIdsToAck') + let downloadedTxs = Foldable.foldl' pruneTx Map.empty $ take downTxsNum $ Map.toList (bufferedTxs st') + ps'' = ps' { downloadedTxs = downloadedTxs } + + 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 + } + where + pruneTx :: Map TxId tx -> (TxId, Maybe tx) -> Map TxId tx + pruneTx m (_, Nothing) = m + pruneTx m (txid, Just tx) = Map.insert txid tx m + + 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 + ] + + +-- | `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/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs new file mode 100644 index 00000000000..06c622254fb --- /dev/null +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Ouroboros.Network.TxSubmission.Types where + +import Prelude hiding (seq) + +import NoThunks.Class + +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 (..), 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, foldl', toList) +import Data.Function (on) +import Data.List (nubBy) +import Data.Maybe (isJust) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +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.V1 +import Ouroboros.Network.TxSubmission.Mempool.Reader +import Ouroboros.Network.Util.ShowProxy + +import Test.QuickCheck +import Text.Printf + + +data Tx txid = Tx { + getTxId :: !txid, + getTxSize :: !SizeInBytes, + getTxAdvSize :: !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 = do + -- note: + -- generating small tx sizes avoids overflow error when semigroup + -- instance of `SizeInBytes` is used (summing up all inflight tx + -- sizes). + (size, advSize) <- frequency [ (9, (\a -> (a,a)) <$> chooseEnum (0, maxTxSize)) + , (1, (,) <$> chooseEnum (0, maxTxSize) <*> chooseEnum (0, maxTxSize)) + ] + Tx <$> arbitrary + <*> pure size + <*> pure advSize + <*> 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, getTxAdvSize, getTxValid} = + CBOR.encodeListLen 4 + <> CBOR.encodeInt getTxId + <> CBOR.encodeWord32 (getSizeInBytes getTxSize) + <> CBOR.encodeWord32 (getSizeInBytes getTxAdvSize) + <> CBOR.encodeBool getTxValid + + decodeTx = do + _ <- CBOR.decodeListLen + Tx <$> CBOR.decodeInt + <*> (SizeInBytes <$> CBOR.decodeWord32) + <*> (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 diff --git a/scripts/ci/check-stylish-ignore b/scripts/ci/check-stylish-ignore index 10f9da46dea..af52d6153d3 100644 --- a/scripts/ci/check-stylish-ignore +++ b/scripts/ci/check-stylish-ignore @@ -1,9 +1,7 @@ */Setup.hs ouroboros-network-api/src/Ouroboros/Network/Protocol/Type.hs ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Genesis.hs -ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs -ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs network-mux/src/Network/Mux/TCPInfo.hs network-mux/src/Network/Mux/Bearer.hs network-mux/src/Network/Mux/Bearer/Pipe.hs