From 83070dd805852b4ae803a873a6550ffe22f5252a Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 21 Nov 2023 08:59:24 +0100 Subject: [PATCH 01/54] tx-submission: PeerTxState & SharedTxState --- ouroboros-network/ouroboros-network.cabal | 2 + .../Network/TxSubmission/Inbound/State.hs | 535 +++++++++++ .../Test/Ouroboros/Network/TxSubmission.hs | 877 +++++++++++++++++- scripts/ci/check-stylish-ignore | 1 + 4 files changed, 1405 insertions(+), 10 deletions(-) create mode 100644 ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 14275400a81..616b82b484a 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -97,6 +97,7 @@ library Ouroboros.Network.PeerSelection.Types Ouroboros.Network.PeerSharing Ouroboros.Network.TxSubmission.Inbound + Ouroboros.Network.TxSubmission.Inbound.State Ouroboros.Network.TxSubmission.Mempool.Reader Ouroboros.Network.TxSubmission.Outbound @@ -321,6 +322,7 @@ library testlib bytestring, cardano-binary, cardano-slotting, + cardano-strict-containers, cborg, containers, contra-tracer, diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs new file mode 100644 index 00000000000..8537748109e --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs @@ -0,0 +1,535 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Network.TxSubmission.Inbound.State + ( -- * Core API + SharedTxState (..) + , PeerTxState (..) + , SharedTxStateVar + , newSharedTxStateVar + , receivedTxIds + , collectTxs + , acknowledgeTxIds + , hasTxIdsToAcknowledge + -- * Internals, only exported for testing purposes: + , RefCountDiff (..) + , updateRefCounts + , receivedTxIdsImpl + , collectTxsImpl + ) where + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Exception (assert) + +import Data.Foldable (fold, +#if !MIN_VERSION_base(4,20,0) + foldl', +#endif + toList) +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromJust, maybeToList) +import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Generics (Generic) + +import NoThunks.Class (NoThunks (..)) + +import GHC.Stack (HasCallStack) +import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..), + NumTxIdsToReq (..)) +import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) +import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..)) + + +data PeerTxState txid tx = PeerTxState { + -- | Those transactions (by their identifier) that the client has told + -- us about, and which we have not yet acknowledged. This is kept in + -- the order in which the client gave them to us. This is the same order + -- in which we submit them to the mempool (or for this example, the final + -- result order). It is also the order we acknowledge in. + -- + unacknowledgedTxIds :: !(StrictSeq txid), + + -- | Set of known transaction ids which can be requested from this peer. + -- + availableTxIds :: !(Map txid SizeInBytes), + + -- | The number of transaction identifiers that we have requested but + -- which have not yet been replied to. We need to track this it keep + -- our requests within the limit on the number of unacknowledged txids. + -- + requestedTxIdsInflight :: !NumTxIdsToReq, + + -- | The size in bytes of transactions that we have requested but which + -- have not yet been replied to. We need to track this it keep our + -- requests within the limit on the number of unacknowledged txids. + -- + requestedTxsInflightSize :: !SizeInBytes, + + -- | The set of requested `txid`s. + -- + requestedTxsInflight :: !(Set txid), + + -- | A subset of `unacknowledgedTxIds` which were unknown to the peer. + -- We need to track these `txid`s since they need to be acknowledged. + -- + -- We track these `txid` per peer, rather than in `bufferedTxs` map, + -- since that could potentially lead to corrupting the node, not being + -- able to download a `tx` which is needed & available from other nodes. + -- + unknownTxs :: !(Set txid) + } + deriving (Eq, Show, Generic) + +instance ( NoThunks txid + , NoThunks tx + ) => NoThunks (PeerTxState txid tx) + + +-- | Shared state of all `TxSubmission` clients. +-- +-- New `txid` enters `unacknowledgedTxIds` it is also added to `availableTxIds` +-- and `referenceCounts` (see `acknowledgeTxIdsImpl`). +-- +-- When a `txid` id is selected to be downloaded, it's added to +-- `requestedTxsInflightSize` (see +-- `Ouroboros.Network.TxSubmission.Inbound.Decision.pickTxsToDownload`). +-- +-- When the request arrives, the `txid` is removed from `inflightTxs`. It +-- might be added to `unknownTxs` if the server didn't have that `txid`, or +-- it's added to `bufferedTxs` (see `collectTxsImpl`). +-- +-- Whenever we choose `txid` to acknowledge (either in `acknowledtxsIdsImpl`, +-- `collectTxsImpl` or +-- `Ouroboros.Network.TxSubmission.Inbound.Decision.pickTxsToDownload`, we also +-- recalculate `referenceCounts` and only keep live `txid`s in other maps (e.g. +-- `availableTxIds`, `bufferedTxs`, `unknownTxs`). +-- +data SharedTxState peeraddr txid tx = SharedTxState { + + -- | Map of peer states. + -- + -- /Invariant:/ for peeraddr's which are registered using `withPeer`, + -- there's always an entry in this map even if the set of `txid`s is + -- empty. + -- + peerTxStates :: !(Map peeraddr (PeerTxState txid tx)), + + -- | Set of transactions which are in-flight (have already been + -- requested) together with multiplicities (from how many peers it is + -- currently in-flight) + -- + -- This set can intersect with `availableTxIds`. + -- + inflightTxs :: !(Map txid Int), + + -- | Overall size of all `tx`s in-flight. + -- + inflightTxsSize :: !SizeInBytes, + + -- | Map of `tx` which: + -- + -- * were downloaded, + -- * are already in the mempool (`Nothing` is inserted in that case), + -- + -- We only keep live `txid`, e.g. ones which `txid` is unacknowledged by + -- at least one peer. + -- + -- /Note:/ `txid`s which `tx` were unknown by a peer are tracked + -- separately in `unknownTxs`. + -- + -- /Note:/ previous implementation also needed to explicitly tracked + -- `txid`s which were already acknowledged, but are still unacknowledged. + -- In this implementation, this is done due to reference counting. + -- + -- This map is useful to acknowledge `txid`s, it's basically taking the + -- longest prefix which contains entries in `bufferedTxs` or `unknownTxs`. + -- + bufferedTxs :: !(Map txid (Maybe tx)), + + -- | We track reference counts of all unacknowledged txids. Once the + -- count reaches 0, a tx is removed from `bufferedTxs`. + -- + -- The `bufferedTx` map contains a subset of `txid` which + -- `referenceCounts` contains. + -- + -- /Invariants:/ + -- + -- * the txid count is equal to multiplicity of txid in all + -- `unacknowledgedTxIds` sequences; + -- * @Map.keysSet bufferedTxs `Set.isSubsetOf` Map.keysSet referenceCounts@; + -- * all counts are positive integers. + -- + referenceCounts :: !(Map txid Int) + } + deriving (Eq, Show, Generic) + +instance ( NoThunks peeraddr + , NoThunks tx + , NoThunks txid + ) => NoThunks (SharedTxState peeraddr txid tx) + +-- +-- Pure public API +-- + +-- | Check if a peer can acknowledge at least one `txid`. +-- +hasTxIdsToAcknowledge + :: forall peeraddr txid tx. + Ord txid + => SharedTxState peeraddr txid tx + -> PeerTxState txid tx + -> Bool +hasTxIdsToAcknowledge + SharedTxState { bufferedTxs } + PeerTxState { unacknowledgedTxIds, unknownTxs } + = + -- We just need to look at the front of the unacknowledged `txid`s. + case unacknowledgedTxIds of + txid StrictSeq.:<| _ -> txid `Map.member` bufferedTxs + || txid `Set.member` unknownTxs + _ -> False + + +acknowledgeTxIds + :: forall peeraddr tx txid. + Ord txid + => SharedTxState peeraddr txid tx + -> PeerTxState txid tx + -> (NumTxIdsToAck, [tx], RefCountDiff txid, PeerTxState txid tx) + -- ^ number of txid to acknowledge, txids to acknowledge with multiplicities, + -- updated PeerTxState. +{-# INLINE acknowledgeTxIds #-} + +acknowledgeTxIds + SharedTxState { bufferedTxs } + ps@PeerTxState { availableTxIds, + unacknowledgedTxIds, + unknownTxs } + = + ( fromIntegral $ StrictSeq.length acknowledgedTxIds + , txsToMempool + , refCountDiff + , ps { unacknowledgedTxIds = unacknowledgedTxIds', + availableTxIds = availableTxIds', + unknownTxs = unknownTxs' } + ) + where + -- Split `unacknowledgedTxIds'` into the longest prefix of `txid`s which + -- can be acknowledged and the unacknowledged `txid`s. + (acknowledgedTxIds, unacknowledgedTxIds') = + StrictSeq.spanl (\txid -> txid `Map.member` bufferedTxs + || txid `Set.member` unknownTxs + ) + unacknowledgedTxIds + + txsToMempool :: [tx] + txsToMempool = [ tx + | txid <- toList acknowledgedTxIds + , Just tx <- maybeToList $ txid `Map.lookup` bufferedTxs + ] + + -- the set of live `txids` + liveSet = Set.fromList (toList unacknowledgedTxIds') + + availableTxIds' = availableTxIds + `Map.restrictKeys` + liveSet + + -- We remove all acknowledged `txid`s which are not in + -- `unacknowledgedTxIds''`, but also return the unknown set before any + -- modifications (which is used to compute `unacknowledgedTxIds''` + -- above). + unknownTxs' = unknownTxs `Set.intersection` liveSet + + refCountDiff = RefCountDiff + $ foldr (\txid -> Map.alter fn txid) + Map.empty acknowledgedTxIds + where + fn :: Maybe Int -> Maybe Int + fn Nothing = Just 1 + fn (Just n) = Just $! n + 1 + + +-- | `RefCountDiff` represents a map of `txid` which can be acknowledged +-- together with their multiplicities. +-- +newtype RefCountDiff txid = RefCountDiff { + txIdsToAck :: Map txid Int + } + +updateRefCounts :: Ord txid + => Map txid Int + -> RefCountDiff txid + -> Map txid Int +updateRefCounts referenceCounts (RefCountDiff diff) = + Map.merge (Map.mapMaybeMissing \_ x -> Just x) + (Map.mapMaybeMissing \_ _ -> Nothing) + (Map.zipWithMaybeMatched \_ x y -> assert (x >= y) + if x > y then Just $! x - y + else Nothing) + referenceCounts + diff + + +-- +-- Pure internal API +-- + +-- | Insert received `txid`s and return the number of txids to be acknowledged +-- and the updated `SharedTxState`. +-- +receivedTxIdsImpl + :: forall peeraddr tx txid. + (Ord txid, Ord peeraddr, HasCallStack) + => (txid -> Bool) -- ^ check if txid is in the mempool, ref 'mempoolHasTx' + -> peeraddr + -> NumTxIdsToReq + -- ^ number of requests to subtract from + -- `requestedTxIdsInflight` + + -> StrictSeq txid + -- ^ sequence of received `txids` + -> Map txid SizeInBytes + -- ^ received `txid`s with sizes + + -> SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + +receivedTxIdsImpl + mempoolHasTx + peeraddr reqNo txidsSeq txidsMap + st@SharedTxState{ peerTxStates, + bufferedTxs, + referenceCounts } + = + -- using `alterF` so the update of `PeerTxState` is done in one lookup + case Map.alterF (fmap Just . fn . fromJust) + peeraddr + peerTxStates of + ( st', peerTxStates' ) -> + st' { peerTxStates = peerTxStates' } + + where + -- update `PeerTxState` and return number of `txid`s to acknowledged and + -- updated `SharedTxState`. + fn :: PeerTxState txid tx + -> ( SharedTxState peeraddr txid tx + , PeerTxState txid tx + ) + fn ps@PeerTxState { availableTxIds, + requestedTxIdsInflight, + unacknowledgedTxIds } = + (st', ps') + where + -- + -- Handle new `txid`s + -- + + -- Divide the new txids in two: those that are already in the mempool + -- and those that are not. We'll request some txs from the latter. + (ignoredTxIds, availableTxIdsMap) = + Map.partitionWithKey + (\txid _ -> mempoolHasTx txid) + txidsMap + + -- Add all `txids` from `availableTxIdsMap` which are not + -- unacknowledged or already buffered. Unacknowledged txids must have + -- already been added to `availableTxIds` map before. + availableTxIds' = + Map.foldlWithKey + (\m txid sizeInBytes -> Map.insert txid sizeInBytes m) + availableTxIds + (Map.filterWithKey + (\txid _ -> txid `notElem` unacknowledgedTxIds + && txid `Map.notMember` bufferedTxs) + availableTxIdsMap) + + -- Add received txids to `unacknowledgedTxIds`. + unacknowledgedTxIds' = unacknowledgedTxIds <> txidsSeq + + -- Add ignored `txs` to buffered ones. + -- Note: we prefer to keep the `tx` if it's already in `bufferedTxs`. + bufferedTxs' = bufferedTxs + <> Map.map (const Nothing) ignoredTxIds + + referenceCounts' = + foldl' (flip $ Map.alter (\case + Nothing -> Just $! 1 + Just cnt -> Just $! succ cnt)) + referenceCounts + txidsSeq + + st' = st { bufferedTxs = bufferedTxs', + referenceCounts = referenceCounts' } + ps' = assert (requestedTxIdsInflight >= reqNo) + ps { availableTxIds = availableTxIds', + unacknowledgedTxIds = unacknowledgedTxIds', + requestedTxIdsInflight = requestedTxIdsInflight - reqNo } + + +collectTxsImpl + :: forall peeraddr tx txid. + (Ord txid, Ord peeraddr) + => peeraddr + -> Set txid -- ^ set of requested txids + -> Map txid tx -- ^ received txs + -> SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + -- ^ number of `txid`s to be acknowledged, `tx`s to be added to + -- the mempool and updated state. +collectTxsImpl peeraddr requestedTxIds receivedTxs + st@SharedTxState { peerTxStates } = + + -- using `alterF` so the update of `PeerTxState` is done in one lookup + case Map.alterF (fmap Just . fn . fromJust) + peeraddr + peerTxStates of + (st', peerTxStates') -> + st' { peerTxStates = peerTxStates' } + + where + -- Update `PeerTxState` and partially update `SharedTxState` (except of + -- `peerTxStates`). + fn :: PeerTxState txid tx + -> ( SharedTxState peeraddr txid tx + , PeerTxState txid tx + ) + fn ps = (st'', ps'') + where + notReceived = requestedTxIds Set.\\ Map.keysSet receivedTxs + + -- add received `tx`s to buffered map + bufferedTxs' = bufferedTxs st + <> Map.map Just receivedTxs + + -- Add not received txs to `unknownTxs` before acknowledging txids. + unknownTxs' = unknownTxs ps <> notReceived + + requestedTxsInflight' = + assert (requestedTxIds `Set.isSubsetOf` requestedTxsInflight ps) $ + requestedTxsInflight ps Set.\\ requestedTxIds + + requestedSize = fold $ availableTxIds ps `Map.restrictKeys` requestedTxIds + requestedTxsInflightSize' = + -- TODO: VALIDATE size of received txs against what was announced + -- earlier; + assert (requestedTxsInflightSize ps >= requestedSize) $ + requestedTxsInflightSize ps - requestedSize + + st' = st { bufferedTxs = bufferedTxs' } + + -- subtract requested from in-flight + inflightTxs'' = + Map.merge + (Map.mapMaybeMissing \_ x -> Just x) + (Map.mapMaybeMissing \_ _ -> assert False Nothing) + (Map.zipWithMaybeMatched \_ x y -> assert (x >= y) + let z = x - y in + if z > 0 + then Just z + else Nothing) + (inflightTxs st') + (Map.fromSet (const 1) requestedTxIds) + + inflightTxsSize'' = assert (inflightTxsSize st' >= requestedSize) $ + inflightTxsSize st' - requestedSize + + st'' = st' { inflightTxs = inflightTxs'', + inflightTxsSize = inflightTxsSize'' + } + + -- + -- Update PeerTxState + -- + + -- Remove the downloaded `txid`s from the availableTxIds map, this + -- guarantees that we won't attempt to download the `txids` from this peer + -- once we collect the `txid`s. Also restrict keys to `liveSet`. + -- + -- NOTE: we could remove `notReceived` from `availableTxIds`; and + -- possibly avoid using `unknownTxs` field at all. + -- + availableTxIds'' = availableTxIds ps + `Map.withoutKeys` + requestedTxIds + + -- Remove all acknowledged `txid`s from unknown set, but only those + -- which are not present in `unacknowledgedTxIds'` + unknownTxs'' = unknownTxs' + `Set.intersection` + live + where + -- We cannot use `liveSet` as `unknown <> notReceived` might + -- contain `txids` which are in `liveSet` but are not `live`. + live = Set.fromList (toList (unacknowledgedTxIds ps)) + + ps'' = ps { availableTxIds = availableTxIds'', + unknownTxs = unknownTxs'', + requestedTxsInflightSize = requestedTxsInflightSize', + requestedTxsInflight = requestedTxsInflight' } + +-- +-- Monadic public API +-- + +type SharedTxStateVar m peeraddr txid tx = StrictTVar m (SharedTxState peeraddr txid tx) + +newSharedTxStateVar :: MonadSTM m + => m (SharedTxStateVar m peeraddr txid tx) +newSharedTxStateVar = newTVarIO SharedTxState { peerTxStates = Map.empty, + inflightTxs = Map.empty, + inflightTxsSize = 0, + bufferedTxs = Map.empty, + referenceCounts = Map.empty } + + +-- | Acknowledge `txid`s, return the number of `txids` to be acknowledged to the +-- remote side. +-- +receivedTxIds + :: forall m peeraddr idx tx txid. + (MonadSTM m, Ord txid, Ord peeraddr) + => SharedTxStateVar m peeraddr txid tx + -> 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 sharedVar MempoolSnapshot{mempoolHasTx} peeraddr reqNo txidsSeq txidsMap = + atomically $ + modifyTVar sharedVar (receivedTxIdsImpl mempoolHasTx peeraddr reqNo txidsSeq txidsMap) + + +-- | 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) + => SharedTxStateVar m peeraddr txid tx + -> peeraddr + -> Set txid -- ^ set of requested txids + -> Map txid tx -- ^ received txs + -> m () + -- ^ number of txids to be acknowledged and txs to be added to the + -- mempool +collectTxs sharedVar peeraddr txidsRequested txsMap = + atomically $ + modifyTVar sharedVar + (collectTxsImpl peeraddr txidsRequested txsMap) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs index e16dde5ee6e..bf374344a2b 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs @@ -1,20 +1,25 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module Test.Ouroboros.Network.TxSubmission (tests) where import Prelude hiding (seq) -import NoThunks.Class (NoThunks) +import NoThunks.Class import Control.Concurrent.Class.MonadSTM -import Control.Exception (SomeException (..)) +import Control.Exception (SomeException (..), assert) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay @@ -32,12 +37,17 @@ 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.Foldable as Foldable (find, fold, foldl', toList) import Data.Function (on) -import Data.List (intercalate, nubBy) -import Data.Maybe (fromMaybe, isJust) +import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, nubBy, stripPrefix) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, isJust, maybeToList) +import Data.Monoid (Sum (..)) import Data.Sequence (Seq) import Data.Sequence qualified as Seq +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set (Set) import Data.Set qualified as Set import Data.Word (Word16) import GHC.Generics (Generic) @@ -53,6 +63,9 @@ 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.Inbound.State (PeerTxState (..), + SharedTxState (..)) +import Ouroboros.Network.TxSubmission.Inbound.State qualified as TXS import Ouroboros.Network.TxSubmission.Mempool.Reader import Ouroboros.Network.TxSubmission.Outbound import Ouroboros.Network.Util.ShowProxy @@ -60,27 +73,55 @@ import Ouroboros.Network.Util.ShowProxy import Test.Ouroboros.Network.Utils 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.Printf tests :: TestTree -tests = testGroup "TxSubmission" +tests = testGroup "Ouroboros.Network.TxSubmission" [ testProperty "txSubmission" prop_txSubmission , testProperty "x" prop_x + , 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 "hasTxIdsToAcknowledge" prop_hasTxIdsToAcknowledge + , testProperty "receivedTxIdsImpl" prop_receivedTxIdsImpl + , testProperty "collectTxsImpl" prop_collectTxsImpl + , testGroup "NoThunks" + [ testProperty "receivedTxIdsImpl" prop_receivedTxIdsImpl_nothunks + , testProperty "collectTxsImpl" prop_collectTxsImpl_nothunks + ] + ] ] data Tx txid = Tx { - getTxId :: txid, + 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 + getTxValid :: !Bool } - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) instance NoThunks txid => NoThunks (Tx txid) instance ShowProxy txid => ShowProxy (Tx txid) where @@ -103,6 +144,7 @@ instance Arbitrary txid => Arbitrary (Tx txid) where maxTxSize :: SizeInBytes maxTxSize = 65536 +type TxId = Int newtype Mempool m txid = Mempool (TVar m (Seq (Tx txid))) @@ -167,7 +209,7 @@ getMempoolWriter (Mempool mempool) = (\Tx { getTxId, getTxValid } -> getTxValid && getTxId `Set.notMember` currentIds) - $ txs + txs mempoolTxs' = Foldable.foldl' (Seq.|>) mempoolTxs validTxs writeTVar mempool mempoolTxs' return (map getTxId validTxs) @@ -388,3 +430,818 @@ threadAndTimeTracer tr = Tracer $ \s -> do !now <- getMonotonicTime !tid <- myThreadId traceWith tr $ WithThreadAndTime now (show tid) s + + +-- +-- InboundState properties +-- + +type PeerAddr = Int + +-- | 'InboundState` invariant. +-- +sharedTxStateInvariant + :: forall peeraddr txid tx. + ( Ord txid + , Show txid + ) + => SharedTxState peeraddr txid tx + -> Property +sharedTxStateInvariant SharedTxState { + peerTxStates, + inflightTxs, + inflightTxsSize, + bufferedTxs, + referenceCounts + } = + + -- -- `inflightTxs` and `bufferedTxs` are disjoint + -- counterexample "inflightTxs not disjoint with bufferedTxs" + -- (null (inflightTxsSet `Set.intersection` bufferedTxsSet)) + + -- the set of buffered txids is equal to sum of the sets of + -- unacknowledged txids. + counterexample "bufferedTxs txid not a subset of unacknoledged txids" + (bufferedTxsSet + `Set.isSubsetOf` + foldr (\PeerTxState { unacknowledgedTxIds } r -> + r <> Set.fromList (toList unacknowledgedTxIds)) + Set.empty txStates) + + .&&. counterexample "referenceCounts invariant violation" + ( referenceCounts + === + foldl' + (\m PeerTxState { unacknowledgedTxIds = unacked } -> + foldl' + (flip $ + Map.alter (\case + Nothing -> Just $! 1 + Just cnt -> Just $! succ cnt) + ) + m + unacked + ) + Map.empty txStates + ) + + .&&. counterexample ("bufferedTxs contain tx which should be gc-ed: " + ++ show (Map.keysSet bufferedTxs `Set.difference` liveSet)) + (Map.keysSet bufferedTxs `Set.isSubsetOf` liveSet) + + .&&. counterexample "inflightTxs must be a sum of requestedTxInflight sets" + (inflightTxs + === + foldr (\PeerTxState { requestedTxsInflight } m -> + Map.unionWith (+) (Map.fromSet (\_ -> 1) requestedTxsInflight) m) + Map.empty + peerTxStates) + + -- PeerTxState invariants + .&&. counterexample "PeerTxState invariant violation" + (foldMap (\ps -> All + . counterexample (show ps) + . peerTxStateInvariant + $ ps + ) + peerTxStates) + + .&&. counterexample "inflightTxsSize invariant violation" + (inflightTxsSize === foldMap requestedTxsInflightSize peerTxStates) + + + + where + peerTxStateInvariant :: PeerTxState txid tx -> Property + peerTxStateInvariant PeerTxState { availableTxIds, + unacknowledgedTxIds, + unknownTxs, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize } = + + + counterexample ("unknownTxs is not a subset of unacknowledgedTxIds: " + ++ show (unknownTxs Set.\\ unacknowledgedTxIdsSet)) + (unknownTxs `Set.isSubsetOf` unacknowledgedTxIdsSet) + + .&&. counterexample ("availableTxs is not a subset of unacknowledgedTxIds: " + ++ show (availableTxIdsSet Set.\\ unacknowledgedTxIdsSet)) + (availableTxIdsSet `Set.isSubsetOf` unacknowledgedTxIdsSet) + + .&&. counterexample ("unacknowledged tx must be either available, unknown or buffered: " + ++ show (unacknowledgedTxIdsSet + Set.\\ availableTxIdsSet + Set.\\ unknownTxs + Set.\\ bufferedTxsSet)) + (unacknowledgedTxIdsSet + Set.\\ availableTxIdsSet + Set.\\ unknownTxs + `Set.isSubsetOf` + bufferedTxsSet + ) + + .&&. counterexample "requestedTxIdsInflight invariant violation" + (requestedTxIdsInflight >= 0) + + -- a requested tx is either available or buffered + .&&. counterexample ("requestedTxsInflight invariant violation: " + ++ show (requestedTxsInflight + Set.\\ availableTxIdsSet + Set.\\ bufferedTxsSet)) + (requestedTxsInflight Set.\\ availableTxIdsSet `Set.isSubsetOf` bufferedTxsSet) + + .&&. counterexample "requestedTxsInfightSize" + (requestedTxsInflightSize + === + fold (availableTxIds `Map.restrictKeys` requestedTxsInflight)) + + where + availableTxIdsSet :: Set txid + availableTxIdsSet = Map.keysSet availableTxIds + + unacknowledgedTxIdsSet :: Set txid + unacknowledgedTxIdsSet = Set.fromList (toList unacknowledgedTxIds) + + bufferedTxsSet = Map.keysSet bufferedTxs :: Set txid + liveSet = Map.keysSet referenceCounts :: Set txid + txStates = Map.elems peerTxStates :: [PeerTxState txid tx] + +-- +-- Generate `InboudState` +-- + +-- | PeerTxState generator. +-- +-- `mkArbPeerTxState` is the smart constructor. +-- +data ArbPeerTxState txid tx = + ArbPeerTxState { arbPeerTxState :: PeerTxState txid tx, + arbInflightSet :: Set tx, + -- ^ in-flight txs + arbBufferedMap :: Map txid (Maybe tx) + } + +data TxStatus = Available | Inflight | Unknown + +instance Arbitrary TxStatus where + arbitrary = oneof [ pure Available + , pure Inflight + , pure Unknown + ] + +data TxMask tx = TxAvailable tx TxStatus + -- ^ available txid with its size, the Bool indicates if it's + -- in-flight or not + | TxBuffered tx + +fixupTxMask :: txid -> TxMask (Tx txid) -> TxMask (Tx txid) +fixupTxMask txid (TxAvailable tx status) = TxAvailable tx { getTxId = txid } status +fixupTxMask txid (TxBuffered tx) = TxBuffered tx { getTxId = txid } + + +instance Arbitrary tx => Arbitrary (TxMask tx) where + arbitrary = oneof [ TxAvailable + <$> arbitrary + <*> arbitrary + , TxBuffered <$> arbitrary + ] + + -- TODO: implement shrinker; this can be done by writing an inverse of + -- `mkArbPeerTxState` and shrinking the unacknowledged txs & mask map. + + +-- | Smart constructor for `ArbPeerTxState`. +-- +mkArbPeerTxState :: Ord txid + => Fun txid Bool + -> Int -- ^ txids in-flight + -> [txid] + -> Map txid (TxMask (Tx txid)) + -> ArbPeerTxState txid (Tx txid) +mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMaskMap = + ArbPeerTxState + PeerTxState { unacknowledgedTxIds = StrictSeq.fromList unacked, + availableTxIds, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize, + unknownTxs } + (Set.fromList $ Map.elems inflightMap) + bufferedMap + where + mempoolHasTx = apply mempoolHasTxFun + availableTxIds = Map.fromList + [ (txid, getTxSize tx) | (txid, TxAvailable tx _) <- Map.assocs txMaskMap + , not (mempoolHasTx txid) + ] + unknownTxs = Set.fromList + [ txid | (txid, TxAvailable _ Unknown) <- Map.assocs txMaskMap + , not (mempoolHasTx txid) + ] + + requestedTxIdsInflight = fromIntegral txIdsInflight + requestedTxsInflightSize = foldMap getTxSize inflightMap + requestedTxsInflight = Map.keysSet inflightMap + + -- exclude `txid`s which are already in the mempool, we never request such + -- `txid`s + -- + -- TODO: this should be lifted, we might have the same txid in-flight from + -- multiple peers, one will win the race and land in the mempool first + inflightMap = Map.fromList + [ (txid, tx) + | (txid, TxAvailable tx Inflight) <- Map.assocs txMaskMap + , not (mempoolHasTx txid) + ] + + bufferedMap = Map.fromList + [ (txid, Nothing) + | txid <- Map.keys txMaskMap + , mempoolHasTx txid + ] + `Map.union` + Map.fromList + [ (txid, mtx) + | (txid, TxBuffered tx) <- Map.assocs txMaskMap + , let !mtx = if mempoolHasTx txid + then Nothing + else Just $! tx { getTxId = txid } + ] + + +genArbPeerTxState + :: forall txid. + ( Arbitrary txid + , Ord txid + ) + => Fun txid Bool + -> Int -- ^ max txids inflight + -> Gen (ArbPeerTxState txid (Tx txid)) +genArbPeerTxState mempoolHasTxFun maxTxIdsInflight = do + -- unacknowledged sequence + unacked <- arbitrary + -- generate `Map txid (TxMask tx)` + txIdsInflight <- choose (0, maxTxIdsInflight) + txMap <- Map.fromList + <$> traverse (\txid -> (\a -> (txid, fixupTxMask txid a)) <$> arbitrary) + (nub unacked) + return $ mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMap + + +genSharedTxState + :: forall txid. + ( Arbitrary txid + , Ord txid + , Function txid + , CoArbitrary txid + ) + => Int -- ^ max txids inflight + -> Gen ( Fun txid Bool + , (PeerAddr, PeerTxState txid (Tx txid)) + , SharedTxState PeerAddr txid (Tx txid) + , Map PeerAddr (ArbPeerTxState txid (Tx txid)) + ) +genSharedTxState maxTxIdsInflight = do + _mempoolHasTxFun@(Fun (_, _, x) _) <- arbitrary :: Gen (Fun Bool Bool) + let mempoolHasTxFun = Fun (function (const False), False, x) (const False) + pss <- listOf1 (genArbPeerTxState mempoolHasTxFun maxTxIdsInflight) + + let pss' :: [(PeerAddr, ArbPeerTxState txid (Tx txid))] + pss' = [0..] `zip` pss + + peer <- choose (0, length pss - 1) + + let st :: SharedTxState PeerAddr txid (Tx txid) + st = fixupSharedTxState + (apply mempoolHasTxFun) + SharedTxState { + peerTxStates = Map.fromList + [ (peeraddr, arbPeerTxState) + | (peeraddr, ArbPeerTxState { arbPeerTxState }) + <- pss' + ], + inflightTxs = foldl' (Map.unionWith (+)) Map.empty + [ Map.fromSet (const 1) (Set.map getTxId arbInflightSet) + | ArbPeerTxState { arbInflightSet } + <- pss + ], + inflightTxsSize = 0, -- It is set by fixupSharedTxState + bufferedTxs = fold + [ arbBufferedMap + | ArbPeerTxState { arbBufferedMap } + <- pss + ], + referenceCounts = Map.empty + } + + return ( mempoolHasTxFun + , (peer, peerTxStates st Map.! peer) + , st + , Map.fromList pss' + ) + + +-- | Make sure `SharedTxState` is well formed. +-- +fixupSharedTxState + :: Ord txid + => (txid -> Bool) -- ^ mempoolHasTx + -> SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx +fixupSharedTxState _mempoolHasTx st@SharedTxState { peerTxStates } = + st { peerTxStates = peerTxStates', + inflightTxs = inflightTxs', + inflightTxsSize = foldMap requestedTxsInflightSize peerTxStates', + bufferedTxs = bufferedTxs', + referenceCounts = referenceCounts' + } + where + peerTxStates' = + Map.map (\ps@PeerTxState { availableTxIds, + requestedTxsInflight } -> + + let -- requested txs must not be buffered + requestedTxsInflight' = requestedTxsInflight + Set.\\ Map.keysSet bufferedTxs' + requestedTxsInflightSize' = fold $ availableTxIds + `Map.restrictKeys` + requestedTxsInflight' + + in ps { requestedTxsInflight = requestedTxsInflight', + requestedTxsInflightSize = requestedTxsInflightSize' } + ) + peerTxStates + + inflightTxs' = foldr (\PeerTxState { requestedTxsInflight } m -> + Map.unionWith (+) + (Map.fromSet (const 1) requestedTxsInflight) + m + ) + Map.empty + peerTxStates' + + bufferedTxs' = + bufferedTxs st + `Map.restrictKeys` + foldr (\PeerTxState {unacknowledgedTxIds = unacked } r -> + r <> Set.fromList (toList unacked)) + Set.empty (Map.elems peerTxStates) + + + referenceCounts' = + foldl' + (\m PeerTxState { unacknowledgedTxIds } -> + foldl' + (flip $ + Map.alter (\case + Nothing -> Just $! 1 + Just cnt -> Just $! succ cnt) + ) + m + unacknowledgedTxIds + ) + Map.empty + (Map.elems peerTxStates) + + +shrinkSharedTxState :: ( Arbitrary txid + , Ord txid + , Function txid + , Ord peeraddr + ) + => (txid -> Bool) + -> SharedTxState peeraddr txid (Tx txid) + -> [SharedTxState peeraddr txid (Tx txid)] +shrinkSharedTxState mempoolHasTx st@SharedTxState { peerTxStates, + inflightTxs, + bufferedTxs } = + [ st' + | peerTxStates' <- Map.fromList <$> shrinkList (\_ -> []) (Map.toList peerTxStates) + , not (Map.null peerTxStates') + , let st' = fixupSharedTxState mempoolHasTx st { peerTxStates = peerTxStates' } + , st' /= st + ] + ++ + [ fixupSharedTxState mempoolHasTx st { inflightTxs = inflightTxs' } + | inflightTxs' <- Map.fromList <$> shrinkList (\_ -> []) (Map.toList inflightTxs) + ] + ++ + [ st + | bufferedTxs' <- Map.fromList + <$> shrinkList (\_ -> []) (Map.assocs bufferedTxs) + , let minBuffered = + foldMap + (\PeerTxState { + unacknowledgedTxIds, + availableTxIds, + unknownTxs + } + -> + Set.fromList (toList unacknowledgedTxIds) + Set.\\ Map.keysSet availableTxIds + Set.\\ unknownTxs + ) + peerTxStates + bufferedTxs'' = bufferedTxs' + `Map.union` + (bufferedTxs `Map.restrictKeys` minBuffered) + st' = fixupSharedTxState mempoolHasTx st { bufferedTxs = bufferedTxs'' } + , st' /= st + ] + +-- +-- Arbitrary `SharaedTxState` instance +-- + +data ArbSharedTxState = + ArbSharedTxState + (Fun TxId Bool) + (SharedTxState PeerAddr TxId (Tx TxId)) + deriving Show + +instance Arbitrary ArbSharedTxState where + arbitrary = do + Small maxTxIdsInflight <- arbitrary + (mempoolHasTx, _, sharedTxState, _) <- genSharedTxState maxTxIdsInflight + return $ ArbSharedTxState mempoolHasTx sharedTxState + + shrink (ArbSharedTxState mempoolHasTx st) = + [ ArbSharedTxState mempoolHasTx st' + | st' <- shrinkSharedTxState (apply mempoolHasTx) st + ] + + +-- | Verify that generated `SharedTxState` has no thunks if it's evaluated to +-- WHNF. +-- +prop_SharedTxState_nothunks :: ArbSharedTxState -> Property +prop_SharedTxState_nothunks (ArbSharedTxState _ !st) = + case unsafeNoThunks st of + Nothing -> property True + Just ctx -> counterexample (show ctx) False + + +prop_SharedTxState_generator + :: ArbSharedTxState + -> Property +prop_SharedTxState_generator (ArbSharedTxState _ st) = sharedTxStateInvariant st + + +prop_SharedTxState_shrinker + :: Fixed ArbSharedTxState + -> Property +prop_SharedTxState_shrinker = + property + . foldMap (\(ArbSharedTxState _ st) -> All $ sharedTxStateInvariant st) + . shrink + . getFixed + + +-- +-- `receivedTxIdsImpl` properties +-- + + +data ArbReceivedTxIds = + ArbReceivedTxIds (Fun TxId Bool) -- ^ mempoolHasTx + [Tx TxId] -- ^ some txs to acknowledge + PeerAddr -- ^ peer address + (PeerTxState TxId (Tx TxId)) + -- ^ peer state + (SharedTxState PeerAddr TxId (Tx TxId)) + -- ^ initial state + deriving Show + +instance Arbitrary ArbReceivedTxIds where + arbitrary = do + Small maxTxIdsInflight <- arbitrary + (mempoolHasTxFun, (peeraddr, ps), st, psMap) <- genSharedTxState maxTxIdsInflight + txsToAck <- sublistOf (Set.toList $ arbInflightSet (psMap Map.! peeraddr)) + pure $ ArbReceivedTxIds + mempoolHasTxFun + txsToAck + peeraddr + ps + st + + shrink (ArbReceivedTxIds mempoolHasTxFun txs peeraddr ps st) = + [ ArbReceivedTxIds mempoolHasTxFun txs' peeraddr ps st + | txs' <- shrink txs + ] + ++ + [ ArbReceivedTxIds + mempoolHasTxFun' txs peeraddr ps + (fixupSharedTxState (apply mempoolHasTxFun') st) + | mempoolHasTxFun' <- shrink mempoolHasTxFun + ] + + +prop_receivedTxIds_generator + :: ArbReceivedTxIds + -> Property +prop_receivedTxIds_generator (ArbReceivedTxIds _ someTxsToAck _peeraddr _ps st) = + label ("numToAck " ++ labelInt 100 10 (length someTxsToAck)) + . counterexample (show st) + $ sharedTxStateInvariant st + + +-- | This property verifies that `acknowledgeTxIds` acknowledges a prefix of +-- unacknowledged txs, and that the `numTxIdsToAck` as well as `RefCoundDiff` +-- are correct. +-- +-- It doesn't validate the returned `PeerTxState` holds it's properties as this +-- needs to be done in the context of updated `SharedTxState`. This is verified +-- by `prop_receivedTxIdsImpl`, `prop_collectTxsImpl` and +-- `prop_makeDecisions_acknowledged`. +-- +prop_acknowledgeTxIds :: ArbReceivedTxIds + -> Property +prop_acknowledgeTxIds (ArbReceivedTxIds _mempoolHasTxFun _txs _peeraddr ps st) = + case TXS.acknowledgeTxIds st ps of + (numTxIdsToAck, txs, TXS.RefCountDiff { TXS.txIdsToAck }, ps') -> + counterexample "number of tx ids to ack must agree with RefCountDiff" + ( fromIntegral numTxIdsToAck + === + getSum (foldMap Sum txIdsToAck) + ) + + .&&. counterexample "acknowledged txs must form a prefix" + let unacked = toList (unacknowledgedTxIds ps) + unacked' = toList (unacknowledgedTxIds ps') + in case unacked `stripSuffix` unacked' of + Nothing -> counterexample "acknowledged txs are not a prefix" False + Just txIdsToAck' -> + txIdsToAck + === + Map.fromListWith (+) ((,1) <$> txIdsToAck') + + .&&. counterexample "acknowledged txs" (counterexample ("numTxIdsToAck = " ++ show numTxIdsToAck) + let acked :: [TxId] + acked = [ txid + | txid <- take (fromIntegral numTxIdsToAck) (toList $ unacknowledgedTxIds ps) + , Just _ <- maybeToList $ txid `Map.lookup` bufferedTxs st + ] + in getTxId `map` txs === acked) + where + stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] + stripSuffix as suffix = + reverse <$> reverse suffix `stripPrefix` reverse as + + +-- | Verify that `hasTxIdsToAcknowledge` and `acknowledgeTxIds` are compatible. +-- +prop_hasTxIdsToAcknowledge + :: ArbReceivedTxIds + -> Property +prop_hasTxIdsToAcknowledge (ArbReceivedTxIds _mempoolHasTxFun _txs _peeraddr ps st) = + case ( TXS.hasTxIdsToAcknowledge st ps + , TXS.acknowledgeTxIds st ps + ) of + (canAck, (numTxIdsToAck, _, _, _)) -> + canAck === (numTxIdsToAck > 0) + + +-- | Verify 'inboundStateInvariant' when acknowledging a sequence of txs. +-- +prop_receivedTxIdsImpl + :: ArbReceivedTxIds + -> Property +prop_receivedTxIdsImpl (ArbReceivedTxIds mempoolHasTxFun txs peeraddr ps st) = + -- InboundState invariant + counterexample + ( "Unacknowledged in mempool: " ++ + show (apply mempoolHasTxFun <$> toList (unacknowledgedTxIds ps)) ++ "\n" + ++ "InboundState invariant violation:\n" ++ + show st' + ) + (sharedTxStateInvariant st') + + -- unacknowledged txs are well formed + .&&. counterexample "unacknowledged txids are not well formed" + ( let unacked = toList $ unacknowledgedTxIds ps <> txidSeq + unacked' = toList $ unacknowledgedTxIds ps' + in counterexample ("old & received: " ++ show unacked ++ "\n" ++ + "new: " ++ show unacked') $ + unacked' `isSuffixOf` unacked + ) + + .&&. -- `receivedTxIdsImpl` doesn't acknowledge any `txids` + counterexample "acknowledged property violation" + ( let unacked = toList $ unacknowledgedTxIds ps + unacked' = toList $ unacknowledgedTxIds ps' + in unacked `isPrefixOf` unacked' + ) + where + st' = TXS.receivedTxIdsImpl (apply mempoolHasTxFun) + peeraddr 0 txidSeq txidMap st + ps' = peerTxStates st' Map.! peeraddr + + txidSeq = StrictSeq.fromList (getTxId <$> txs) + txidMap = Map.fromList [ (getTxId tx, getTxSize tx) | tx <- txs ] + + +-- | Verify that `SharedTxState` returned by `receivedTxIdsImpl` if evaluated +-- to WHNF it doesn't contain any thunks. +-- +prop_receivedTxIdsImpl_nothunks + :: ArbReceivedTxIds + -> Property +prop_receivedTxIdsImpl_nothunks (ArbReceivedTxIds mempoolHasTxFun txs peeraddr _ st) = + case TXS.receivedTxIdsImpl (apply mempoolHasTxFun) + peeraddr 0 txidSeq txidMap st of + !st' -> case unsafeNoThunks st' of + Nothing -> property True + Just ctx -> counterexample (show ctx) False + where + txidSeq = StrictSeq.fromList (getTxId <$> txs) + txidMap = Map.fromList [ (getTxId tx, getTxSize tx) | tx <- txs ] + + +-- +-- `collectTxs` properties +-- + + +data ArbCollectTxs = + ArbCollectTxs (Fun TxId Bool) -- ^ mempoolHasTx + (Set TxId) -- ^ requested txid's + (Map TxId (Tx TxId)) -- ^ received txs + PeerAddr -- ^ peeraddr + (PeerTxState TxId (Tx TxId)) + (SharedTxState PeerAddr TxId (Tx TxId)) + -- ^ 'InboundState' + deriving Show + + +instance Arbitrary ArbCollectTxs where + arbitrary = do + Small maxTxIdsInflight <- arbitrary + ( mempoolHasTxFun + , (peeraddr, ps@PeerTxState { availableTxIds, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize }) + , st + , _ + ) + <- genSharedTxState maxTxIdsInflight + requestedTxIds <- take (fromIntegral requestedTxIdsInflight) + <$> sublistOf (toList requestedTxsInflight) + + -- Limit the requested `txid`s to satisfy `requestedTxsInflightSize`. + let requestedTxIds' = fmap fst + . takeWhile (\(_,s) -> s <= requestedTxsInflightSize) + $ zip requestedTxIds + (scanl1 (<>) [availableTxIds Map.! txid | txid <- requestedTxIds ]) + + receivedTx <- sublistOf requestedTxIds' + >>= traverse (\txid -> do + valid <- frequency [(4, pure True), (1, pure False)] + pure $ Tx { getTxId = txid, + getTxSize = availableTxIds Map.! txid, + getTxValid = valid }) + + pure $ assert (foldMap getTxSize receivedTx <= requestedTxsInflightSize) + $ ArbCollectTxs mempoolHasTxFun + (Set.fromList requestedTxIds') + (Map.fromList [ (getTxId tx, tx) | tx <- receivedTx ]) + peeraddr + ps + st + + shrink (ArbCollectTxs mempoolHasTx requestedTxs receivedTxs peeraddr ps st) = + [ ArbCollectTxs mempoolHasTx + requestedTxs' + (receivedTxs `Map.restrictKeys` requestedTxs') + peeraddr ps st + | requestedTxs' <- Set.fromList <$> shrinkList (\_ -> []) (Set.toList requestedTxs) + ] + ++ + [ ArbCollectTxs mempoolHasTx + requestedTxs + (receivedTxs `Map.restrictKeys` receivedTxIds) + peeraddr ps st + | receivedTxIds <- Set.fromList <$> shrinkList (\_ -> []) (Map.keys receivedTxs) + ] + ++ + [ ArbCollectTxs mempoolHasTx + (requestedTxs + `Set.intersection` unacked + `Set.intersection` inflightTxSet) + (receivedTxs + `Map.restrictKeys` unacked + `Map.restrictKeys` inflightTxSet) + peeraddr ps + st' + | let unacked = Set.fromList + . toList + . unacknowledgedTxIds + $ ps + , st'@SharedTxState { inflightTxs } <- shrinkSharedTxState (apply mempoolHasTx) st + , let inflightTxSet = Map.keysSet inflightTxs + , peeraddr `Map.member` peerTxStates st' + , st' /= st + ] + + +prop_collectTxs_generator + :: ArbCollectTxs + -> Property +prop_collectTxs_generator (ArbCollectTxs _ requestedTxIds receivedTxs peeraddr + ps@PeerTxState { availableTxIds, + requestedTxsInflightSize } + st) = + counterexample "size of requested txs must not be larger than requestedTxsInflightSize" + (requestedSize <= requestedTxsInflightSize) + .&&. counterexample "inflightTxsSize must be greater than requestedSize" + (inflightTxsSize st >= requestedSize) + .&&. counterexample ("receivedTxs must be a subset of requestedTxIds " + ++ show (Map.keysSet receivedTxs Set.\\ requestedTxIds)) + (Map.keysSet receivedTxs `Set.isSubsetOf` requestedTxIds) + .&&. counterexample "peerTxState" + (Map.lookup peeraddr (peerTxStates st) === Just ps) + where + requestedSize = fold (availableTxIds `Map.restrictKeys` requestedTxIds) + + +prop_collectTxs_shrinker + :: Fixed ArbCollectTxs + -- ^ disabled shrinking + -> Property +prop_collectTxs_shrinker (Fixed txs) = + property $ foldMap (\a@(ArbCollectTxs _ _ _ _ _ st) -> + All . counterexample (show st) $ + f a =/= f txs + .&&. sharedTxStateInvariant st + ) (shrink txs) + where + f (ArbCollectTxs _ reqSet recvMap peeraddr ps st) = (reqSet, recvMap, peeraddr, ps, st) + + +-- | Verify `collectTxsImpl` properties: +-- +-- * verify `SharedTxState` invariant; +-- * unacknowledged txids after `collectTxsImpl` must be a suffix of the +-- original ones; +-- * progress property: we acknowledge as many `txid`s as possible +-- +prop_collectTxsImpl + :: ArbCollectTxs + -> Property +prop_collectTxsImpl (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived peeraddr ps st) = + + label ("number of txids inflight " ++ labelInt 25 5 (Map.size $ inflightTxs st)) $ + label ("number of txids requested " ++ labelInt 25 5 (Set.size txidsRequested)) $ + label ("number of txids received " ++ labelInt 10 2 (Map.size txsReceived)) $ + + -- InboundState invariant + counterexample + ( "InboundState invariant violation:\n" ++ show st' ++ "\n" + ++ show ps' + ) + (sharedTxStateInvariant st') + + .&&. + -- `collectTxsImpl` doesn't modify unacknowledged TxId's + counterexample "acknowledged property violation" + ( let unacked = toList $ unacknowledgedTxIds ps + unacked' = toList $ unacknowledgedTxIds ps' + in unacked === unacked' + ) + where + st' = TXS.collectTxsImpl peeraddr txidsRequested txsReceived st + ps' = peerTxStates st' Map.! peeraddr + + +-- | Verify that `SharedTxState` returned by `collectTxsImpl` if evaluated to +-- WHNF, it doesn't contain any thunks. +-- +prop_collectTxsImpl_nothunks + :: ArbCollectTxs + -> Property +prop_collectTxsImpl_nothunks (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived peeraddr _ st) = + case unsafeNoThunks $! st' of + Nothing -> property True + Just ctx -> counterexample (show ctx) False + where + st' = TXS.collectTxsImpl peeraddr txidsRequested txsReceived st + + +-- +-- 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/scripts/ci/check-stylish-ignore b/scripts/ci/check-stylish-ignore index 10f9da46dea..ed2a98be460 100644 --- a/scripts/ci/check-stylish-ignore +++ b/scripts/ci/check-stylish-ignore @@ -2,6 +2,7 @@ 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/TxSubmission/Inbound/State.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 From d394d3c5a9cbca0f0d9058368aa46d3ee5cf07ad Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 8 Dec 2023 13:36:39 +0100 Subject: [PATCH 02/54] tx-submission: decision logic --- ouroboros-network/ouroboros-network.cabal | 2 + .../Network/TxSubmission/Inbound/Decision.hs | 487 +++++++++++++++ .../Network/TxSubmission/Inbound/Policy.hs | 32 + .../Network/TxSubmission/Inbound/State.hs | 39 ++ .../Test/Ouroboros/Network/TxSubmission.hs | 570 +++++++++++++++++- 5 files changed, 1129 insertions(+), 1 deletion(-) create mode 100644 ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs create mode 100644 ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 616b82b484a..e82bb0919f3 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -97,6 +97,8 @@ library Ouroboros.Network.PeerSelection.Types Ouroboros.Network.PeerSharing Ouroboros.Network.TxSubmission.Inbound + Ouroboros.Network.TxSubmission.Inbound.Decision + Ouroboros.Network.TxSubmission.Inbound.Policy Ouroboros.Network.TxSubmission.Inbound.State Ouroboros.Network.TxSubmission.Mempool.Reader Ouroboros.Network.TxSubmission.Outbound diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs new file mode 100644 index 00000000000..2bd5fc6dc75 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs @@ -0,0 +1,487 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Ouroboros.Network.TxSubmission.Inbound.Decision + ( TxDecision (..) + -- * Internal API exposed for testing + , makeDecisions + , filterActivePeers + , SharedDecisionContext (..) + , pickTxsToDownload + ) where + +import Control.Arrow ((>>>)) +import Control.Exception (assert) + +import Data.Bifunctor (second) +import Data.List (mapAccumR, sortOn) +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import Data.Set qualified as Set + +import Data.Sequence.Strict qualified as StrictSeq +import Ouroboros.Network.DeltaQ (PeerGSV (..), gsvRequestResponseDuration) +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound.Policy +import Ouroboros.Network.TxSubmission.Inbound.State + + +-- | Decision made by the decision logic. Each peer will receive a 'Decision'. +-- +-- /note:/ it is rather non-standard to represent a choice between requesting +-- `txid`s and `tx`'s as a product rather than a sum type. The client will +-- need to download `tx`s first and then send a request for more txids (and +-- acknowledge some `txid`s). Due to pipelining each client will request +-- decision from the decision logic quite often (every two pipelined requests), +-- but with this design a decision once taken will make the peer non-active +-- (e.g. it won't be returned by `filterActivePeers`) for longer, and thus the +-- expensive `makeDecision` computation will not need to take that peer into +-- account. +-- +data TxDecision txid tx = TxDecision { + txdTxIdsToAcknowledge :: !NumTxIdsToAck, + -- ^ txid's to acknowledge + + txdTxIdsToRequest :: !NumTxIdsToReq, + -- ^ number of txid's to request + + txdPipelineTxIds :: !Bool, + -- ^ the tx-submission protocol only allows to pipeline `txid`'s requests + -- if we have non-acknowledged `txid`s. + + txdTxsToRequest :: !(Set txid), + -- ^ txid's to download. + + txdTxsToMempool :: ![tx] + -- ^ list of `tx`s to submit to the mempool. + } + deriving (Show, Eq) + +-- | A non-commutative semigroup instance. +-- +-- /note:/ this instance must be consistent with `pickTxsToDownload` and how +-- `PeerTxState` is updated. It is designed to work with `TMergeVar`s. +-- +instance Ord txid => Semigroup (TxDecision txid tx) where + TxDecision { txdTxIdsToAcknowledge, + txdTxIdsToRequest, + txdPipelineTxIds = _ignored, + txdTxsToRequest, + txdTxsToMempool } + <> + TxDecision { txdTxIdsToAcknowledge = txdTxIdsToAcknowledge', + txdTxIdsToRequest = txdTxIdsToRequest', + txdPipelineTxIds = txdPipelineTxIds', + txdTxsToRequest = txdTxsToRequest', + txdTxsToMempool = txdTxsToMempool' } + = + TxDecision { txdTxIdsToAcknowledge = txdTxIdsToAcknowledge + txdTxIdsToAcknowledge', + txdTxIdsToRequest = txdTxIdsToRequest + txdTxIdsToRequest', + txdPipelineTxIds = txdPipelineTxIds', + txdTxsToRequest = txdTxsToRequest <> txdTxsToRequest', + txdTxsToMempool = txdTxsToMempool ++ txdTxsToMempool' + } + + +data SharedDecisionContext peeraddr txid tx = SharedDecisionContext { + -- TODO: check how to access it. + sdcPeerGSV :: !(Map peeraddr PeerGSV), + + sdcSharedTxState :: !(SharedTxState peeraddr txid tx) + } + deriving Show + +-- +-- Decision Logic +-- + +-- | Make download decisions. +-- +makeDecisions + :: forall peeraddr txid tx. + ( Ord peeraddr + , Ord txid + ) + => TxDecisionPolicy + -- ^ decision policy + -> SharedDecisionContext peeraddr txid tx + -- ^ decision context + -> Map peeraddr (PeerTxState txid tx) + -- ^ list of available peers. + -- + -- This is a subset of `peerTxStates` of peers which either: + -- * can be used to download a `tx`, + -- * can acknowledge some `txid`s. + -- + -> ( SharedTxState peeraddr txid tx + , Map peeraddr (TxDecision txid tx) + ) +makeDecisions policy SharedDecisionContext { + sdcPeerGSV = peerGSV, + sdcSharedTxState = st + } + = fn + . pickTxsToDownload policy st + . orderByDeltaQ peerGSV + where + fn :: forall a. + (a, [(peeraddr, TxDecision txid tx)]) + -> (a, Map peeraddr (TxDecision txid tx)) + fn (a, as) = (a, Map.fromList as) + + +-- | Order peers by `DeltaQ`. +-- +orderByDeltaQ :: forall peeraddr txid tx. + Ord peeraddr + => Map peeraddr PeerGSV + -> Map peeraddr (PeerTxState txid tx) + -> [(peeraddr, PeerTxState txid tx)] +orderByDeltaQ dq = + sortOn (\(peeraddr, _) -> + gsvRequestResponseDuration + (dq Map.! peeraddr) reqSize respSize) + . Map.toList + where + -- according to calculations in `txSubmissionProtocolLimits`: sizes of + -- `MsgRequestTx` with a single `txid` and `MsgReplyTxs` with a single + -- `tx`. + reqSize :: SizeInBytes + reqSize = 36 -- 32 + 4 (MsgRequestTxs overhead) + + respSize :: SizeInBytes + respSize = 65540 + + +-- | Internal state of `pickTxsToDownload` computation. +-- +data St peeraddr txid tx = + St { stInflightSize :: !SizeInBytes, + -- ^ size of all `tx`s in-flight. + + stInflight :: !(Map txid Int), + -- ^ `txid`s in-flight. + + stAcknowledged :: !(Map txid Int) + -- ^ acknowledged `txid` with multiplicities. It is used to update + -- `referenceCounts`. + } + + +-- | Distribute `tx`'s to download among available peers. Peers are considered +-- in the given order. +-- +-- * pick txs from the set of available tx's (in `txid` order, note these sets +-- might be different for different peers). +-- * pick txs until the peers in-flight limit (we can go over the limit by one tx) +-- (`txsSizeInflightPerPeer` limit) +-- * pick txs until the overall in-flight limit (we can go over the limit by one tx) +-- (`maxTxsSizeInflight` limit) +-- * each tx can be downloaded simultaneously from at most +-- `txInflightMultiplicity` peers. +-- +pickTxsToDownload + :: forall peeraddr txid tx. + ( Ord peeraddr + , Ord txid + ) + => TxDecisionPolicy + -- ^ decision policy + -> SharedTxState peeraddr txid tx + -- ^ shared state + + -> [(peeraddr, PeerTxState txid tx)] + -> ( SharedTxState peeraddr txid tx + , [(peeraddr, TxDecision txid tx)] + ) + +pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, + maxTxsSizeInflight, + txInflightMultiplicity } + sharedState@SharedTxState { peerTxStates, + inflightTxs, + inflightTxsSize, + bufferedTxs, + referenceCounts } = + -- outer fold: fold `[(peeraddr, PeerTxState txid tx)]` + mapAccumR + accumFn + -- initial state + St { stInflight = inflightTxs, + stInflightSize = inflightTxsSize, + stAcknowledged = Map.empty } + + >>> + gn + where + accumFn :: St peeraddr txid tx + -> (peeraddr, PeerTxState txid tx) + -> ( St peeraddr txid tx + , ( (peeraddr, PeerTxState txid tx) + , TxDecision txid tx + ) + ) + accumFn + st@St { stInflight, + stInflightSize, + stAcknowledged } + ( peeraddr + , peerTxState@PeerTxState { availableTxIds, + unknownTxs, + requestedTxsInflight, + requestedTxsInflightSize + } + ) + = + let sizeInflightAll :: SizeInBytes + sizeInflightOther :: SizeInBytes + + sizeInflightAll = stInflightSize + sizeInflightOther = sizeInflightAll - requestedTxsInflightSize + + in if sizeInflightAll >= maxTxsSizeInflight + then let (numTxIdsToAck, txsToMempool, RefCountDiff { txIdsToAck }, peerTxState') = + acknowledgeTxIds sharedState peerTxState + (numTxIdsToReq, peerTxState'') = numTxIdsToRequest policy peerTxState' + + stAcknowledged' = Map.unionWith (+) stAcknowledged txIdsToAck + in + ( st { stAcknowledged = stAcknowledged' } + , ( (peeraddr, peerTxState'') + , TxDecision { txdTxIdsToAcknowledge = numTxIdsToAck, + txdTxIdsToRequest = numTxIdsToReq, + txdPipelineTxIds = not + . StrictSeq.null + . unacknowledgedTxIds + $ peerTxState', + txdTxsToRequest = Set.empty, + txdTxsToMempool = txsToMempool + } + ) + ) + else + let requestedTxsInflightSize' :: SizeInBytes + txsToRequest :: Set txid + + (requestedTxsInflightSize', txsToRequest) = + -- inner fold: fold available `txid`s + -- + -- Note: although `Map.foldrWithKey` could be used here, it + -- does not allow to short circuit the fold, unlike + -- `foldWithState`. + foldWithState + (\(txid, (txSize, inflightMultiplicity)) sizeInflight -> + if -- note that we pick `txid`'s as long the `s` is + -- smaller or equal to `txsSizeInflightPerPeer`. + sizeInflight <= txsSizeInflightPerPeer + -- overall `tx`'s in-flight must be smaller than + -- `maxTxsSizeInflight` + && sizeInflight + sizeInflightOther <= maxTxsSizeInflight + -- the transaction must not be downloaded from more + -- than `txInflightMultiplicity` peers simultaneously + && inflightMultiplicity < txInflightMultiplicity + -- TODO: we must validate that `txSize` is smaller than + -- maximum txs size + then Just (sizeInflight + txSize, txid) + else Nothing + ) + (Map.assocs $ + -- merge `availableTxIds` with `stInflight`, so we don't + -- need to lookup into `stInflight` on every `txid` which + -- is in `availableTxIds`. + Map.merge (Map.mapMaybeMissing \_txid -> Just . (,0)) + Map.dropMissing + (Map.zipWithMatched \_txid -> (,)) + + availableTxIds + stInflight + -- remove `tx`s which were already downloaded by some + -- other peer or are in-flight or unknown by this peer. + `Map.withoutKeys` + (Map.keysSet bufferedTxs <> requestedTxsInflight <> unknownTxs) + + ) + requestedTxsInflightSize + -- pick from `txid`'s which are available from that given + -- peer. Since we are folding a dictionary each `txid` + -- will be selected only once from a given peer (at least + -- in each round). + + peerTxState' = peerTxState { + requestedTxsInflightSize = requestedTxsInflightSize', + requestedTxsInflight = requestedTxsInflight + <> txsToRequest + } + + (numTxIdsToAck, txsToMempool, RefCountDiff { txIdsToAck }, peerTxState'') = + acknowledgeTxIds 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 + + (numTxIdsToReq, peerTxState''') = numTxIdsToRequest policy peerTxState'' + + + in ( St { stInflight = stInflight', + stInflightSize = sizeInflightOther + requestedTxsInflightSize', + stAcknowledged = stAcknowledged' } + , ( (peeraddr, peerTxState''') + , TxDecision { txdTxIdsToAcknowledge = numTxIdsToAck, + txdPipelineTxIds = not + . StrictSeq.null + . unacknowledgedTxIds + $ peerTxState''', + txdTxIdsToRequest = numTxIdsToReq, + txdTxsToRequest = txsToRequest, + txdTxsToMempool = txsToMempool + } + ) + ) + + gn :: ( St peeraddr txid tx + , [((peeraddr, PeerTxState txid tx), TxDecision txid tx)] + ) + -> ( SharedTxState peeraddr txid tx + , [(peeraddr, TxDecision txid tx)] + ) + gn + ( St { stInflight, + stInflightSize, + stAcknowledged } + , as + ) + = + let peerTxStates' = Map.fromList ((\(a,_) -> a) <$> as) + <> peerTxStates + + referenceCounts' = + Map.merge (Map.mapMaybeMissing \_ x -> Just x) + (Map.mapMaybeMissing \_ _ -> assert False Nothing) + (Map.zipWithMaybeMatched \_ x y -> if x > y then Just $! x - y + else Nothing) + referenceCounts + stAcknowledged + + liveSet = Map.keysSet referenceCounts' + + bufferedTxs' = bufferedTxs + `Map.restrictKeys` + liveSet + + in ( sharedState { + peerTxStates = peerTxStates', + inflightTxs = stInflight, + inflightTxsSize = stInflightSize, + bufferedTxs = bufferedTxs', + referenceCounts = referenceCounts' } + , -- exclude empty results + mapMaybe (\((a, _), b) -> case b of + TxDecision { txdTxIdsToAcknowledge = 0, + txdTxIdsToRequest = 0, + txdTxsToRequest, + txdTxsToMempool } + | null txdTxsToRequest + , null txdTxsToMempool + -> Nothing + _ -> Just (a, b) + ) + as + ) + + + +-- | Filter peers which can either download a `tx` or acknowledge `txid`s. +-- +filterActivePeers + :: forall peeraddr txid tx. + Ord txid + => TxDecisionPolicy + -> SharedTxState peeraddr txid tx + -> Map peeraddr (PeerTxState txid tx) +filterActivePeers + TxDecisionPolicy { maxUnacknowledgedTxIds, + txsSizeInflightPerPeer, + maxTxsSizeInflight, + txInflightMultiplicity } + st@SharedTxState { peerTxStates, + bufferedTxs, + inflightTxs, + inflightTxsSize } + | overLimit + = Map.filter fn peerTxStates + | otherwise + = Map.filter gn peerTxStates + where + overLimit = inflightTxsSize > maxTxsSizeInflight + unrequestable = Map.keysSet (Map.filter (>= txInflightMultiplicity) inflightTxs) + <> Map.keysSet bufferedTxs + + fn :: PeerTxState txid tx -> Bool + fn ps@PeerTxState { unacknowledgedTxIds, + requestedTxIdsInflight } = + hasTxIdsToAcknowledge st ps + || requestedTxIdsInflight + numOfUnacked < maxUnacknowledgedTxIds + where + numOfUnacked = fromIntegral (StrictSeq.length unacknowledgedTxIds) + + gn :: PeerTxState txid tx -> Bool + gn ps@PeerTxState { unacknowledgedTxIds, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize, + availableTxIds, + unknownTxs } = + hasTxIdsToAcknowledge st ps + || requestedTxIdsInflight + numOfUnacked < maxUnacknowledgedTxIds + || (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 + +-- +-- Auxiliary functions +-- + +-- | A fold with state implemented as a `foldr` to take advantage of fold-build +-- fusion optimisation. +-- +foldWithState + :: forall s a b. + Ord b + => (a -> s -> Maybe (s, b)) + -> [a] -> s -> (s, Set b) +{-# INLINE foldWithState #-} + +foldWithState f = foldr cons nil + where + cons :: a + -> (s -> (s, Set b)) + -> (s -> (s, Set b)) + cons a k = \ !s -> + case f a s of + Nothing -> nil s + Just (!s', !b) -> + case Set.insert b `second` k s' of + r@(!_s, !_bs) -> r + + nil :: s -> (s, Set b) + nil = \ !s -> (s, Set.empty) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs new file mode 100644 index 00000000000..532742dfdf9 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs @@ -0,0 +1,32 @@ +module Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy (..)) where + +import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToReq (..)) +import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) + +-- | Policy for making decisions +-- +data TxDecisionPolicy = TxDecisionPolicy { + maxNumTxIdsToRequest :: !NumTxIdsToReq, + -- ^ a maximal number of txids requested at once. + + maxUnacknowledgedTxIds :: !NumTxIdsToReq, + -- ^ maximal number of unacknowledgedTxIds. Measured in `NumTxIdsToReq` + -- since we enforce this policy by requesting not more txids than what + -- this limit allows. + + -- + -- Configuration of tx decision logic. + -- + + txsSizeInflightPerPeer :: !SizeInBytes, + -- ^ a limit of tx size in-flight from a single peer. + -- It can be exceed by max tx size. + + maxTxsSizeInflight :: !SizeInBytes, + -- ^ a limit of tx size in-flight from all peers. + -- It can be exceed by max tx size. + + txInflightMultiplicity :: !Int + -- ^ from how many peers download the `txid` simultaneously + } + deriving Show diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs index 8537748109e..32c9d9ec200 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs @@ -10,6 +10,7 @@ module Ouroboros.Network.TxSubmission.Inbound.State ( -- * Core API SharedTxState (..) , PeerTxState (..) + , numTxIdsToRequest , SharedTxStateVar , newSharedTxStateVar , receivedTxIds @@ -47,6 +48,7 @@ import GHC.Stack (HasCallStack) import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..), NumTxIdsToReq (..)) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) +import Ouroboros.Network.TxSubmission.Inbound.Policy import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..)) @@ -95,6 +97,43 @@ instance ( NoThunks txid ) => NoThunks (PeerTxState txid tx) +-- | Compute number of `txids` to request respecting `TxDecisionPolicy`; update +-- `PeerTxState`. +-- +numTxIdsToRequest :: TxDecisionPolicy + -> PeerTxState txid tx + -> (NumTxIdsToReq, PeerTxState txid tx) +numTxIdsToRequest + TxDecisionPolicy { maxNumTxIdsToRequest, + maxUnacknowledgedTxIds } + ps@PeerTxState { unacknowledgedTxIds, + requestedTxIdsInflight } + = + ( txIdsToRequest + , ps { requestedTxIdsInflight = requestedTxIdsInflight + + txIdsToRequest } + ) + where + -- we are forcing two invariants here: + -- * there are at most `maxUnacknowledgedTxIds` (what we request is added to + -- `unacknowledgedTxIds`) + -- * there are at most `maxNumTxIdsToRequest` txid requests at a time per + -- peer + -- + -- TODO: both conditions provide an upper bound for overall requests for + -- `txid`s to all inbound peers. + txIdsToRequest, unacked, unackedAndRequested :: NumTxIdsToReq + + txIdsToRequest = + assert (unackedAndRequested <= maxUnacknowledgedTxIds) $ + assert (requestedTxIdsInflight <= maxNumTxIdsToRequest) $ + (maxUnacknowledgedTxIds - unackedAndRequested) + `min` (maxNumTxIdsToRequest - requestedTxIdsInflight) + + unackedAndRequested = unacked + requestedTxIdsInflight + unacked = fromIntegral $ StrictSeq.length unacknowledgedTxIds + + -- | Shared state of all `TxSubmission` clients. -- -- New `txid` enters `unacknowledgedTxIds` it is also added to `availableTxIds` diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs index bf374344a2b..a0278729b63 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs @@ -39,7 +39,9 @@ import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy qualified as BSL import Data.Foldable as Foldable (find, fold, foldl', toList) import Data.Function (on) -import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, nubBy, stripPrefix) +import Data.List (intercalate, isPrefixOf, isSuffixOf, mapAccumR, nub, nubBy, + stripPrefix) +import Data.Map.Merge.Strict qualified as Map import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, isJust, maybeToList) @@ -63,6 +65,9 @@ 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.Inbound.Decision +import Ouroboros.Network.TxSubmission.Inbound.Decision qualified as TXS +import Ouroboros.Network.TxSubmission.Inbound.Policy import Ouroboros.Network.TxSubmission.Inbound.State (PeerTxState (..), SharedTxState (..)) import Ouroboros.Network.TxSubmission.Inbound.State qualified as TXS @@ -70,6 +75,7 @@ import Ouroboros.Network.TxSubmission.Mempool.Reader import Ouroboros.Network.TxSubmission.Outbound import Ouroboros.Network.Util.ShowProxy +import Test.Ouroboros.Network.BlockFetch (PeerGSVT (..)) import Test.Ouroboros.Network.Utils import Test.QuickCheck @@ -77,6 +83,7 @@ import Test.QuickCheck.Function (apply) import Test.QuickCheck.Monoids (All (..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) +import Text.Pretty.Simple import Text.Printf @@ -105,11 +112,24 @@ tests = testGroup "Ouroboros.Network.TxSubmission" , testProperty "hasTxIdsToAcknowledge" prop_hasTxIdsToAcknowledge , 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 + ] ] @@ -1228,6 +1248,554 @@ prop_collectTxsImpl_nothunks (ArbCollectTxs _mempoolHasTxFun txidsRequested txsR st' = TXS.collectTxsImpl peeraddr txidsRequested txsReceived st +newtype ArbTxDecisionPolicy = ArbTxDecisionPolicy TxDecisionPolicy + deriving Show + +instance Arbitrary ArbTxDecisionPolicy where + arbitrary = + ArbTxDecisionPolicy . fixupTxDecisionPolicy + <$> ( TxDecisionPolicy + <$> (getSmall <$> arbitrary) + <*> (getSmall <$> arbitrary) + <*> (SizeInBytes . getPositive <$> arbitrary) + <*> (SizeInBytes . getPositive <$> arbitrary) + <*> (getPositive <$> arbitrary)) + + shrink (ArbTxDecisionPolicy a@TxDecisionPolicy { + maxNumTxIdsToRequest, + txsSizeInflightPerPeer, + maxTxsSizeInflight, + txInflightMultiplicity }) = + [ ArbTxDecisionPolicy a { maxNumTxIdsToRequest = NumTxIdsToReq x } + | x <- shrink (getNumTxIdsToReq maxNumTxIdsToRequest) + ] + ++ + [ ArbTxDecisionPolicy . fixupTxDecisionPolicy + $ a { txsSizeInflightPerPeer = SizeInBytes s } + | s <- shrink (getSizeInBytes txsSizeInflightPerPeer) + ] + ++ + [ ArbTxDecisionPolicy . fixupTxDecisionPolicy + $ a { maxTxsSizeInflight = SizeInBytes s } + | s <- shrink (getSizeInBytes maxTxsSizeInflight) + ] + ++ + [ ArbTxDecisionPolicy . fixupTxDecisionPolicy + $ a { txInflightMultiplicity = x } + | Positive x <- shrink (Positive 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 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'' + -- -- Auxiliary functions -- From beb5f9babbaa3fc37aaf8421463a187cf6f27610 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 23 Feb 2024 15:15:07 +0100 Subject: [PATCH 03/54] tx-submission: generalised CollectPipelined Allow monadic action when trying to pipeline more messages, while collecting responses. --- .../Ouroboros/Network/Protocol/TxSubmission2/Server.hs | 10 +++++----- .../Ouroboros/Network/Protocol/TxSubmission2/Direct.hs | 3 ++- .../Network/Protocol/TxSubmission2/Examples.hs | 2 +- .../src/Ouroboros/Network/TxSubmission/Inbound.hs | 2 +- .../testlib/Test/Ouroboros/Network/TxSubmission.hs | 10 +++++++--- 5 files changed, 16 insertions(+), 11 deletions(-) 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/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/src/Ouroboros/Network/TxSubmission/Inbound.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs index 8970edb2ea5..9c9628c0686 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs @@ -262,7 +262,7 @@ txSubmissionInbound tracer (NumTxIdsToAck maxUnacked) mpReader mpWriter _version -- traceWith tracer (TraceTxInboundCanRequestMoreTxs (natToInt n)) pure $ CollectPipelined - (Just (continueWithState (serverReqTxs (Succ n')) st)) + (Just (pure $ continueWithState (serverReqTxs (Succ n')) st)) (collectAndContinueWithState (handleReply n') st) else do diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs index a0278729b63..0c0a476bdd4 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs @@ -18,6 +18,7 @@ import Prelude hiding (seq) import NoThunks.Class +import Control.Concurrent.Class.MonadMVar (MonadMVar) import Control.Concurrent.Class.MonadSTM import Control.Exception (SomeException (..), assert) import Control.Monad.Class.MonadAsync @@ -263,6 +264,7 @@ txSubmissionSimulation , MonadFork m , MonadLabelledSTM m , MonadMask m + , MonadMVar m , MonadSay m , MonadST m , MonadTimer m @@ -273,13 +275,14 @@ txSubmissionSimulation , txid ~ Int ) - => NumTxIdsToAck + => Tracer m (String, TraceSendRecv (TxSubmission2 txid (Tx txid))) + -> NumTxIdsToAck -> [Tx txid] -> ControlMessageSTM m -> Maybe DiffTime -> Maybe DiffTime -> m ([Tx txid], [Tx txid]) -txSubmissionSimulation maxUnacked outboundTxs +txSubmissionSimulation tracer maxUnacked outboundTxs controlMessageSTM inboundDelay outboundDelay = do @@ -289,7 +292,7 @@ txSubmissionSimulation maxUnacked outboundTxs (fromIntegral maxUnacked) outboundAsync <- async $ runPeerWithLimits - (("OUTBOUND",) `contramap` verboseTracer) + (("OUTBOUND",) `contramap` tracer) txSubmissionCodec2 (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) timeLimitsTxSubmission2 @@ -356,6 +359,7 @@ prop_txSubmission (Positive maxUnacked) (NonEmpty outboundTxs) delay = * realToFrac (length outboundTxs `div` 4)) atomically (writeTVar controlMessageVar Terminate) txSubmissionSimulation + verboseTracer (NumTxIdsToAck maxUnacked) outboundTxs (readTVar controlMessageVar) mbDelayTime mbDelayTime From db24009ad51e1946ca646708b91f8ae95730de09 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 13 Mar 2024 14:35:16 +0100 Subject: [PATCH 04/54] tx-submission: registry --- ouroboros-network/ouroboros-network.cabal | 4 +- .../Network/TxSubmission/Inbound/Registry.hs | 243 ++++++++++++++++++ .../Test/Ouroboros/Network/TxSubmission.hs | 70 +++++ 3 files changed, 316 insertions(+), 1 deletion(-) create mode 100644 ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index e82bb0919f3..9a3459d4122 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -100,6 +100,7 @@ library Ouroboros.Network.TxSubmission.Inbound.Decision Ouroboros.Network.TxSubmission.Inbound.Policy Ouroboros.Network.TxSubmission.Inbound.State + Ouroboros.Network.TxSubmission.Inbound.Registry Ouroboros.Network.TxSubmission.Mempool.Reader Ouroboros.Network.TxSubmission.Outbound @@ -172,7 +173,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, diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs new file mode 100644 index 00000000000..72eb7ebb7c1 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Network.TxSubmission.Inbound.Registry + ( SharedTxStateVar + , newSharedTxStateVar + , PeerTxAPI (..) + , decisionLogicThread + , withPeer + ) where + +import Control.Concurrent.Class.MonadMVar.Strict +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTimer.SI + +import Data.Foldable (foldl', traverse_) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Void (Void) + +import Ouroboros.Network.DeltaQ (PeerGSV (..)) +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound.Decision +import Ouroboros.Network.TxSubmission.Inbound.Policy +import Ouroboros.Network.TxSubmission.Inbound.State +import Ouroboros.Network.TxSubmission.Mempool.Reader + +-- | Communication channels between `TxSubmission` client mini-protocol and +-- decision logic. +-- +newtype TxChannels m peeraddr txid tx = TxChannels { + txChannelMap :: Map peeraddr (StrictMVar m (TxDecision txid tx)) + } + +type TxChannelsVar m peeraddr txid tx = StrictMVar m (TxChannels m peeraddr txid tx) + +-- | API to access `PeerTxState` inside `PeerTxStateVar`. +-- +data PeerTxAPI m txid tx = PeerTxAPI { + readTxDecision :: m (TxDecision txid tx), + -- ^ a blocking action which reads `TxDecision` + + handleReceivedTxIds :: NumTxIdsToReq + -> StrictSeq txid + -- ^ received txids + -> Map txid SizeInBytes + -- ^ received sizes of advertised tx's + -> m (), + -- ^ handle received txids + + handleReceivedTxs :: Set txid + -- ^ requested txids + -> Map txid tx + -- ^ received txs + -> m () + -- ^ handle received txs + } + + +-- | 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 peeraddr txid tx idx m a. + ( MonadMask m + , MonadMVar m + , MonadSTM m + , Ord txid + , Ord peeraddr + , Show peeraddr + ) + => TxChannelsVar m peeraddr txid tx + -> SharedTxStateVar m peeraddr txid tx + -> TxSubmissionMempoolReader txid tx idx m + -> peeraddr + -- ^ new peer + -> (PeerTxAPI m txid tx -> m a) + -- ^ callback which gives access to `PeerTxStateAPI` + -> m a +withPeer channelsVar + sharedStateVar + TxSubmissionMempoolReader { mempoolGetSnapshot } + peeraddr io = + bracket + (do -- create a communication channel + !peerTxAPI <- + modifyMVar channelsVar + \ TxChannels { txChannelMap } -> do + chann <- newEmptyMVar + let (chann', txChannelMap') = + Map.alterF (\mbChann -> + let !chann'' = fromMaybe chann mbChann + in (chann'', Just chann'')) + peeraddr + txChannelMap + return + ( TxChannels { txChannelMap = txChannelMap' } + , PeerTxAPI { readTxDecision = takeMVar chann', + handleReceivedTxIds, + handleReceivedTxs } + ) + + atomically $ modifyTVar sharedStateVar registerPeer + return peerTxAPI + ) + -- the handler is a short blocking operation, thus we need to use + -- `uninterruptibleMask_` + (\_ -> uninterruptibleMask_ do + atomically $ modifyTVar sharedStateVar unregisterPeer + modifyMVar_ channelsVar + \ TxChannels { txChannelMap } -> + return TxChannels { txChannelMap = Map.delete peeraddr txChannelMap } + ) + io + where + registerPeer :: SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + registerPeer st@SharedTxState { peerTxStates } = + st { peerTxStates = + Map.insert + peeraddr + PeerTxState { + availableTxIds = Map.empty, + requestedTxIdsInflight = 0, + requestedTxsInflightSize = 0, + requestedTxsInflight = Set.empty, + unacknowledgedTxIds = StrictSeq.empty, + unknownTxs = Set.empty } + peerTxStates + } + + -- TODO: this function needs to be tested! + unregisterPeer :: SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + unregisterPeer st@SharedTxState { peerTxStates, + bufferedTxs, + referenceCounts } = + st { peerTxStates = peerTxStates', + bufferedTxs = bufferedTxs', + referenceCounts = referenceCounts' } + where + (PeerTxState { unacknowledgedTxIds }, peerTxStates') = + Map.alterF + (\case + Nothing -> error ("TxSubmission.withPeer: invariant violation for peer " ++ show peeraddr) + Just a -> (a, Nothing)) + peeraddr + peerTxStates + + referenceCounts' = + foldl' (flip $ Map.update + \cnt -> if cnt > 1 + then Just $! pred cnt + else Nothing) + referenceCounts + unacknowledgedTxIds + + liveSet = Map.keysSet referenceCounts' + + bufferedTxs' = bufferedTxs + `Map.restrictKeys` + liveSet + + -- + -- PeerTxAPI + -- + + handleReceivedTxIds :: NumTxIdsToReq + -> StrictSeq txid + -> Map txid SizeInBytes + -> m () + handleReceivedTxIds numTxIdsToReq txidsSeq txidsMap = do + -- TODO: hide this inside `receivedTxIds` so it's run in the same STM + -- transaction. + mempoolSnapshot <- atomically mempoolGetSnapshot + receivedTxIds sharedStateVar + mempoolSnapshot + peeraddr + numTxIdsToReq + txidsSeq + txidsMap + + + handleReceivedTxs :: Set txid + -- ^ requested txids + -> Map txid tx + -- ^ received txs + -> m () + handleReceivedTxs txids txs = + collectTxs sharedStateVar peeraddr txids txs + + +decisionLogicThread + :: forall m peeraddr txid tx. + ( MonadDelay m + , MonadMVar m + , MonadSTM m + , Ord peeraddr + , Ord txid + ) + => TxDecisionPolicy + -> StrictTVar m (Map peeraddr PeerGSV) + -> TxChannelsVar m peeraddr txid tx + -> SharedTxStateVar m peeraddr txid tx + -> m Void +decisionLogicThread policy gsvVar txChannelsVar sharedStateVar = 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 <- atomically do + sharedCtx <- + SharedDecisionContext + <$> readTVar gsvVar + <*> 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 + TxChannels { txChannelMap } <- readMVar txChannelsVar + traverse_ + (\(mvar, d) -> modifyMVar_ mvar (\d' -> pure (d' <> d))) + (Map.intersectionWith (,) + txChannelMap + decisions) + go diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs index 0c0a476bdd4..178d7959f50 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs @@ -131,6 +131,11 @@ tests = testGroup "Ouroboros.Network.TxSubmission" , testProperty "acknowledged" prop_makeDecisions_acknowledged , testProperty "exhaustive" prop_makeDecisions_exhaustive ] + , testGroup "Registry" + [ testGroup "filterActivePeers" + [ testProperty "not limiting decisions" prop_filterActivePeers_not_limitting_decisions + ] + ] ] @@ -1800,6 +1805,71 @@ prop_makeDecisions_exhaustive . counterexample ("state'': " ++ show sharedTxState'') $ null decisions'' + +-- | `filterActivePeers` should not change decisions made by `makeDecisions` +-- +-- +-- This test checks the following properties: +-- +-- In what follows, the set of active peers is defined as the keys of the map +-- returned by `filterActivePeers`. +-- +-- 1. The set of active peers is a superset of peers for which a decision was +-- made; +-- 2. The set of active peer which can acknowledge txids is a subset of peers +-- for which a decision was made; +-- 3. Decisions made from the results of `filterActivePeers` is the same as from +-- the original set. +-- +-- Ad 2. a stronger property is not possible. There can be a peer for which +-- a decision was not taken but which is an active peer. +-- +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 ("found non-active peers for which decision can be made: " + ++ show (decisionPeers Set.\\ activePeers) + ) + (decisionPeers `Set.isSubsetOf` activePeers) + .&&. + counterexample ("found an active peer which can acknowledge txids " + ++ "for which decision was not made: " + ++ show (activePeersAck Set.\\ decisionPeers)) + (activePeersAck `Set.isSubsetOf` decisionPeers) + .&&. + counterexample "decisions from active peers are not equal to decisions from all peers" + (decisions === decisionsOfActivePeers) + where + activePeersMap = TXS.filterActivePeers policy st + activePeers = Map.keysSet activePeersMap + -- peers which are active & can acknowledge txids + activePeersAck = activePeers + `Set.intersection` + Map.keysSet (Map.filter (TXS.hasTxIdsToAcknowledge st) (peerTxStates st)) + (_, 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 -- From 74d15acefb6d326ffdd3bef168b28db9d00ad4b8 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 15 Jul 2024 09:50:07 +0200 Subject: [PATCH 05/54] tx-submission: inbound peer using tx-submission decision logic --- ouroboros-network/ouroboros-network.cabal | 1 + .../Ouroboros/Network/TxSubmission/Inbound.hs | 13 +- .../Network/TxSubmission/Inbound/Server.hs | 185 ++++++++++++++++++ 3 files changed, 198 insertions(+), 1 deletion(-) create mode 100644 ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 9a3459d4122..862d7cd4bd8 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -97,6 +97,7 @@ library Ouroboros.Network.PeerSelection.Types Ouroboros.Network.PeerSharing Ouroboros.Network.TxSubmission.Inbound + Ouroboros.Network.TxSubmission.Inbound.Server Ouroboros.Network.TxSubmission.Inbound.Decision Ouroboros.Network.TxSubmission.Inbound.Policy Ouroboros.Network.TxSubmission.Inbound.State diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs index 9c9628c0686..73b95b29a0b 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs @@ -9,6 +9,8 @@ {-# OPTIONS_GHC -Wno-partial-fields #-} +-- | Legacy `tx-submission` inbound peer. +-- module Ouroboros.Network.TxSubmission.Inbound ( txSubmissionInbound , TxSubmissionMempoolWriter (..) @@ -45,6 +47,7 @@ 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.Decision (TxDecision) import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..), TxSubmissionMempoolReader (..)) @@ -85,9 +88,17 @@ data TraceTxSubmissionInbound txid tx = -- | Just processed transaction pass/fail breakdown. | TraceTxSubmissionProcessed ProcessedTxCount -- | Server received 'MsgDone' - | TraceTxInboundTerminated | TraceTxInboundCanRequestMoreTxs Int | TraceTxInboundCannotRequestMoreTxs Int + + -- + -- messages emitted by the new implementation of the server in + -- "Ouroboros.Network.TxSubmission.Inbound.Server"; some of them are also + -- used in this module. + -- + + | TraceTxInboundTerminated + | TraceTxInboundDecision (TxDecision txid tx) deriving (Eq, Show) data TxSubmissionProtocolError = diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs new file mode 100644 index 00000000000..8c585184080 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Network.TxSubmission.Inbound.Server where + +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set qualified as Set + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Exception (assert) +import Control.Monad.Class.MonadThrow +import Control.Tracer (Tracer, traceWith) + +import Network.TypedProtocol + +import Control.Monad (unless) +import Ouroboros.Network.Protocol.TxSubmission2.Server +import Ouroboros.Network.TxSubmission.Inbound (TraceTxSubmissionInbound (..), + TxSubmissionMempoolWriter (..), TxSubmissionProtocolError (..)) +import Ouroboros.Network.TxSubmission.Inbound.Decision (TxDecision (..)) +import Ouroboros.Network.TxSubmission.Inbound.Registry (PeerTxAPI (..)) + + +-- | A tx-submission outbound side (server, sic!). +-- +-- The server blocks on receiving `TxDecision` from the decision logic. If +-- there are tx's to download it pipelines two requests: first for tx's second +-- for txid's. If there are no tx's to download, it either sends a blocking or +-- non-blocking request for txid's. +-- +txSubmissionInboundV2 + :: forall txid tx idx m. + ( MonadSTM m + , MonadThrow m + , Ord txid + ) + => Tracer m (TraceTxSubmissionInbound txid tx) + -> TxSubmissionMempoolWriter txid tx idx m + -> PeerTxAPI m txid tx + -> TxSubmissionServerPipelined txid tx m () +txSubmissionInboundV2 + tracer + TxSubmissionMempoolWriter { + txId, + mempoolAddTxs + } + PeerTxAPI { + readTxDecision, + handleReceivedTxIds, + handleReceivedTxs + } + = + TxSubmissionServerPipelined serverIdle + where + serverIdle + :: m (ServerStIdle Z txid tx m ()) + serverIdle = do + -- Block on next decision. + txd@TxDecision { txdTxsToRequest = txsToReq, txdTxsToMempool = txs } + <- readTxDecision + traceWith tracer (TraceTxInboundDecision txd) + txidsAccepted <- mempoolAddTxs txs + let !collected = length txidsAccepted + traceWith tracer $ + TraceTxSubmissionCollected collected + -- TODO: + -- We can update the state so that other `tx-submission` servers will + -- not try to add these txs to the mempool. + if Set.null txsToReq + then serverReqTxIds Zero txd + else serverReqTxs txd + + + -- Pipelined request of txs + serverReqTxs :: TxDecision txid tx + -> m (ServerStIdle Z txid tx m ()) + serverReqTxs txd@TxDecision { txdTxsToRequest = txsToReq } = + pure $ SendMsgRequestTxsPipelined (Set.toList txsToReq) + (serverReqTxIds (Succ Zero) txd) + + + serverReqTxIds :: forall (n :: N). + Nat n + -> TxDecision txid tx + -> m (ServerStIdle n txid tx m ()) + serverReqTxIds + n TxDecision { txdTxIdsToAcknowledge = 0, + txdTxIdsToRequest = 0 } + = + case n of + Zero -> serverIdle + Succ _ -> handleReplies n + + serverReqTxIds + -- if there are no unacknowledged txids, the protocol requires sending + -- a blocking `MsgRequestTxIds` request. This is important, as otherwise + -- the client side wouldn't have a chance to terminate the + -- mini-protocol. + Zero TxDecision { txdTxIdsToAcknowledge = txIdsToAck, + txdPipelineTxIds = False, + txdTxIdsToRequest = txIdsToReq + } + = + pure $ SendMsgRequestTxIdsBlocking + txIdsToAck txIdsToReq + -- Our result if the client terminates the protocol + (traceWith tracer TraceTxInboundTerminated) + (\txids -> do + let txids' = NonEmpty.toList txids + txidsSeq = StrictSeq.fromList $ fst <$> txids' + txidsMap = Map.fromList txids' + unless (StrictSeq.length txidsSeq <= fromIntegral txIdsToReq) $ + throwIO ProtocolErrorTxIdsNotRequested + handleReceivedTxIds txIdsToReq txidsSeq txidsMap + serverIdle + ) + + serverReqTxIds + n@Zero TxDecision { txdTxIdsToAcknowledge = txIdsToAck, + txdPipelineTxIds = True, + txdTxIdsToRequest = txIdsToReq + } + = + pure $ SendMsgRequestTxIdsPipelined + txIdsToAck txIdsToReq + (handleReplies (Succ n)) + + serverReqTxIds + n@Succ{} TxDecision { txdTxIdsToAcknowledge = txIdsToAck, + txdPipelineTxIds, + txdTxIdsToRequest = txIdsToReq + } + = + -- it is impossible that we have had `tx`'s to request (Succ{} - is an + -- evidence for that), but no unacknowledged `txid`s. + assert txdPipelineTxIds $ + pure $ SendMsgRequestTxIdsPipelined + txIdsToAck txIdsToReq + (handleReplies (Succ n)) + + + handleReplies :: forall (n :: N). + Nat (S n) + -> m (ServerStIdle (S n) txid tx m ()) + handleReplies (Succ n'@Succ{}) = + pure $ CollectPipelined + Nothing + (handleReply (handleReplies n')) + + handleReplies (Succ Zero) = + pure $ CollectPipelined + Nothing + (handleReply serverIdle) + + handleReply :: forall (n :: N). + m (ServerStIdle n txid tx m ()) + -- continuation + -> Collect txid tx + -> m (ServerStIdle n txid tx m ()) + handleReply k = \case + CollectTxIds txIdsToReq txids -> do + let txidsSeq = StrictSeq.fromList $ fst <$> txids + txidsMap = Map.fromList txids + unless (StrictSeq.length txidsSeq <= fromIntegral txIdsToReq) $ + throwIO ProtocolErrorTxIdsNotRequested + handleReceivedTxIds txIdsToReq txidsSeq txidsMap + k + CollectTxs txids txs -> do + let requested = Set.fromList txids + received = Map.fromList [ (txId tx, tx) | tx <- txs ] + + unless (Map.keysSet received `Set.isSubsetOf` requested) $ + throwIO ProtocolErrorTxNotRequested + -- TODO: all sizes of txs which were announced earlier with + -- `MsgReplyTxIds` must be verified. + + handleReceivedTxs requested received + k From da7f535b248f117d227990af34cf4cd3d4742231 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 22 Jul 2024 18:41:17 +0200 Subject: [PATCH 06/54] ouroboros-network: tx-submission module structure Export everything from the `Ouroboros.Network.TxSubmission.Inbound` module. --- ouroboros-network/ouroboros-network.cabal | 5 +- .../Ouroboros/Network/TxSubmission/Inbound.hs | 77 ++++--------------- .../Network/TxSubmission/Inbound/Registry.hs | 5 ++ .../Network/TxSubmission/Inbound/Server.hs | 3 +- .../Network/TxSubmission/Inbound/Types.hs | 75 ++++++++++++++++++ .../Test/Ouroboros/Network/TxSubmission.hs | 2 - 6 files changed, 99 insertions(+), 68 deletions(-) create mode 100644 ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 862d7cd4bd8..720ca27b760 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -97,11 +97,12 @@ library Ouroboros.Network.PeerSelection.Types Ouroboros.Network.PeerSharing Ouroboros.Network.TxSubmission.Inbound - Ouroboros.Network.TxSubmission.Inbound.Server Ouroboros.Network.TxSubmission.Inbound.Decision Ouroboros.Network.TxSubmission.Inbound.Policy - Ouroboros.Network.TxSubmission.Inbound.State Ouroboros.Network.TxSubmission.Inbound.Registry + Ouroboros.Network.TxSubmission.Inbound.Server + Ouroboros.Network.TxSubmission.Inbound.State + Ouroboros.Network.TxSubmission.Inbound.Types Ouroboros.Network.TxSubmission.Mempool.Reader Ouroboros.Network.TxSubmission.Outbound diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs index 73b95b29a0b..2bfbb27ed12 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs @@ -12,10 +12,14 @@ -- | Legacy `tx-submission` inbound peer. -- module Ouroboros.Network.TxSubmission.Inbound - ( txSubmissionInbound - , TxSubmissionMempoolWriter (..) - , TraceTxSubmissionInbound (..) - , TxSubmissionProtocolError (..) + ( -- * New Tx-Submission server + module Server + , module Types + , module Decision + , module Registry + , module Policy + -- * Legacy Tx-Submission server + , txSubmissionInbound , ProcessedTxCount (..) ) where @@ -47,70 +51,19 @@ 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.Decision (TxDecision) +import Ouroboros.Network.TxSubmission.Inbound.Types 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. +-- re-exports -- -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' - | TraceTxInboundCanRequestMoreTxs Int - | TraceTxInboundCannotRequestMoreTxs Int - - -- - -- messages emitted by the new implementation of the server in - -- "Ouroboros.Network.TxSubmission.Inbound.Server"; some of them are also - -- used in this module. - -- - - | TraceTxInboundTerminated - | TraceTxInboundDecision (TxDecision txid tx) - deriving (Eq, Show) - -data TxSubmissionProtocolError = - ProtocolErrorTxNotRequested - | ProtocolErrorTxIdsNotRequested - deriving Show - -instance Exception TxSubmissionProtocolError where - displayException ProtocolErrorTxNotRequested = - "The peer replied with a transaction we did not ask for." - displayException ProtocolErrorTxIdsNotRequested = - "The peer replied with more txids than we asked for." +import Ouroboros.Network.TxSubmission.Inbound.Decision as Decision +import Ouroboros.Network.TxSubmission.Inbound.Policy as Policy +import Ouroboros.Network.TxSubmission.Inbound.Registry as Registry +import Ouroboros.Network.TxSubmission.Inbound.Server as Server +import Ouroboros.Network.TxSubmission.Inbound.Types as Types -- | Information maintained internally in the 'txSubmissionInbound' server diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs index 72eb7ebb7c1..013d4a96341 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -7,6 +7,8 @@ module Ouroboros.Network.TxSubmission.Inbound.Registry ( SharedTxStateVar , newSharedTxStateVar + , TxChannelsVar + , newTxChannelsVar , PeerTxAPI (..) , decisionLogicThread , withPeer @@ -43,6 +45,9 @@ newtype TxChannels m peeraddr txid tx = TxChannels { type TxChannelsVar m peeraddr txid tx = StrictMVar m (TxChannels m peeraddr txid tx) +newTxChannelsVar :: MonadMVar m => m (TxChannelsVar m peeraddr txid tx) +newTxChannelsVar = newMVar (TxChannels Map.empty) + -- | API to access `PeerTxState` inside `PeerTxStateVar`. -- data PeerTxAPI m txid tx = PeerTxAPI { diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs index 8c585184080..332abe5bb3c 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs @@ -22,10 +22,9 @@ import Network.TypedProtocol import Control.Monad (unless) import Ouroboros.Network.Protocol.TxSubmission2.Server -import Ouroboros.Network.TxSubmission.Inbound (TraceTxSubmissionInbound (..), - TxSubmissionMempoolWriter (..), TxSubmissionProtocolError (..)) import Ouroboros.Network.TxSubmission.Inbound.Decision (TxDecision (..)) import Ouroboros.Network.TxSubmission.Inbound.Registry (PeerTxAPI (..)) +import Ouroboros.Network.TxSubmission.Inbound.Types -- | A tx-submission outbound side (server, sic!). diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs new file mode 100644 index 00000000000..b42aa68d3ca --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs @@ -0,0 +1,75 @@ +module Ouroboros.Network.TxSubmission.Inbound.Types + ( ProcessedTxCount (..) + , TxSubmissionMempoolWriter (..) + , TraceTxSubmissionInbound (..) + , TxSubmissionProtocolError (..) + ) where + +import Control.Exception (Exception (..)) + +import Ouroboros.Network.TxSubmission.Inbound.Decision (TxDecision (..)) + + +data ProcessedTxCount = ProcessedTxCount { + -- | Just accepted this many transactions. + ptxcAccepted :: Int + -- | Just rejected this many transactions. + , ptxcRejected :: Int + } + deriving (Eq, Show) + + +-- | The consensus layer functionality that the inbound side of the tx +-- submission logic requires. +-- +-- This is provided to the tx submission logic by the consensus layer. +-- +data TxSubmissionMempoolWriter txid tx idx m = + TxSubmissionMempoolWriter { + + -- | Compute the transaction id from a transaction. + -- + -- This is used in the protocol handler to verify a full transaction + -- matches a previously given transaction id. + -- + txId :: tx -> txid, + + -- | Supply a batch of transactions to the mempool. They are either + -- accepted or rejected individually, but in the order supplied. + -- + -- The 'txid's of all transactions that were added successfully are + -- returned. + mempoolAddTxs :: [tx] -> m [txid] + } + + +data TraceTxSubmissionInbound txid tx = + -- | Number of transactions just about to be inserted. + TraceTxSubmissionCollected Int + -- | Just processed transaction pass/fail breakdown. + | TraceTxSubmissionProcessed ProcessedTxCount + -- | Server received 'MsgDone' + | TraceTxInboundCanRequestMoreTxs Int + | TraceTxInboundCannotRequestMoreTxs Int + + -- + -- messages emitted by the new implementation of the server in + -- "Ouroboros.Network.TxSubmission.Inbound.Server"; some of them are also + -- used in this module. + -- + + | TraceTxInboundTerminated + | TraceTxInboundDecision (TxDecision txid tx) + deriving (Eq, Show) + + +data TxSubmissionProtocolError = + ProtocolErrorTxNotRequested + | ProtocolErrorTxIdsNotRequested + deriving Show + +instance Exception TxSubmissionProtocolError where + displayException ProtocolErrorTxNotRequested = + "The peer replied with a transaction we did not ask for." + displayException ProtocolErrorTxIdsNotRequested = + "The peer replied with more txids than we asked for." diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs index 178d7959f50..26c78cfa969 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs @@ -66,9 +66,7 @@ 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.Inbound.Decision import Ouroboros.Network.TxSubmission.Inbound.Decision qualified as TXS -import Ouroboros.Network.TxSubmission.Inbound.Policy import Ouroboros.Network.TxSubmission.Inbound.State (PeerTxState (..), SharedTxState (..)) import Ouroboros.Network.TxSubmission.Inbound.State qualified as TXS From 0602061e132cb856c4704c65f03f4ac445a0dc84 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 30 Jul 2024 09:36:11 +0200 Subject: [PATCH 07/54] tx-submission: debug tracer for SharedTxState --- .../Network/TxSubmission/Inbound/Registry.hs | 22 +++++++----- .../Network/TxSubmission/Inbound/State.hs | 34 ++++++++++++++----- 2 files changed, 39 insertions(+), 17 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs index 013d4a96341..94822139e0b 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -18,6 +18,7 @@ import Control.Concurrent.Class.MonadMVar.Strict import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTimer.SI +import Control.Tracer (Tracer (..), traceWith) import Data.Foldable (foldl', traverse_) import Data.Map.Strict (Map) @@ -84,7 +85,8 @@ withPeer , Ord peeraddr , Show peeraddr ) - => TxChannelsVar m peeraddr txid tx + => Tracer m (DebugSharedTxState peeraddr txid tx) + -> TxChannelsVar m peeraddr txid tx -> SharedTxStateVar m peeraddr txid tx -> TxSubmissionMempoolReader txid tx idx m -> peeraddr @@ -92,7 +94,8 @@ withPeer -> (PeerTxAPI m txid tx -> m a) -- ^ callback which gives access to `PeerTxStateAPI` -> m a -withPeer channelsVar +withPeer tracer + channelsVar sharedStateVar TxSubmissionMempoolReader { mempoolGetSnapshot } peeraddr io = @@ -188,7 +191,8 @@ withPeer channelsVar -- TODO: hide this inside `receivedTxIds` so it's run in the same STM -- transaction. mempoolSnapshot <- atomically mempoolGetSnapshot - receivedTxIds sharedStateVar + receivedTxIds tracer + sharedStateVar mempoolSnapshot peeraddr numTxIdsToReq @@ -202,7 +206,7 @@ withPeer channelsVar -- ^ received txs -> m () handleReceivedTxs txids txs = - collectTxs sharedStateVar peeraddr txids txs + collectTxs tracer sharedStateVar peeraddr txids txs decisionLogicThread @@ -213,12 +217,13 @@ decisionLogicThread , Ord peeraddr , Ord txid ) - => TxDecisionPolicy + => Tracer m (DebugSharedTxState peeraddr txid tx) + -> TxDecisionPolicy -> StrictTVar m (Map peeraddr PeerGSV) -> TxChannelsVar m peeraddr txid tx -> SharedTxStateVar m peeraddr txid tx -> m Void -decisionLogicThread policy gsvVar txChannelsVar sharedStateVar = go +decisionLogicThread tracer policy gsvVar txChannelsVar sharedStateVar = go where go :: m Void go = do @@ -226,7 +231,7 @@ decisionLogicThread policy gsvVar txChannelsVar sharedStateVar = go -- if there are too many inbound connections. threadDelay 0.005 -- 5ms - decisions <- atomically do + (decisions, st) <- atomically do sharedCtx <- SharedDecisionContext <$> readTVar gsvVar @@ -238,7 +243,8 @@ decisionLogicThread policy gsvVar txChannelsVar sharedStateVar = go let (sharedState, decisions) = makeDecisions policy sharedCtx activePeers writeTVar sharedStateVar sharedState - return decisions + return (decisions, sharedState) + traceWith tracer (DebugSharedTxState st) TxChannels { txChannelMap } <- readMVar txChannelsVar traverse_ (\(mvar, d) -> modifyMVar_ mvar (\d' -> pure (d' <> d))) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs index 32c9d9ec200..738bffef3ff 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs @@ -17,6 +17,8 @@ module Ouroboros.Network.TxSubmission.Inbound.State , collectTxs , acknowledgeTxIds , hasTxIdsToAcknowledge + -- * Debug output + , DebugSharedTxState (..) -- * Internals, only exported for testing purposes: , RefCountDiff (..) , updateRefCounts @@ -26,6 +28,7 @@ module Ouroboros.Network.TxSubmission.Inbound.State import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) +import Control.Tracer (Tracer, traceWith) import Data.Foldable (fold, #if !MIN_VERSION_base(4,20,0) @@ -539,7 +542,8 @@ newSharedTxStateVar = newTVarIO SharedTxState { peerTxStates = Map.empty, receivedTxIds :: forall m peeraddr idx tx txid. (MonadSTM m, Ord txid, Ord peeraddr) - => SharedTxStateVar m peeraddr txid tx + => Tracer m (DebugSharedTxState peeraddr txid tx) + -> SharedTxStateVar m peeraddr txid tx -> MempoolSnapshot txid tx idx -> peeraddr -> NumTxIdsToReq @@ -550,9 +554,10 @@ receivedTxIds -> Map txid SizeInBytes -- ^ received `txid`s with sizes -> m () -receivedTxIds sharedVar MempoolSnapshot{mempoolHasTx} peeraddr reqNo txidsSeq txidsMap = - atomically $ - modifyTVar sharedVar (receivedTxIdsImpl mempoolHasTx peeraddr reqNo txidsSeq txidsMap) +receivedTxIds tracer sharedVar MempoolSnapshot{mempoolHasTx} peeraddr reqNo txidsSeq txidsMap = do + st <- atomically $ + stateTVar sharedVar ((\a -> (a,a)) . receivedTxIdsImpl mempoolHasTx peeraddr reqNo txidsSeq txidsMap) + traceWith tracer (DebugSharedTxState st) -- | Include received `tx`s in `SharedTxState`. Return number of `txids` @@ -561,14 +566,25 @@ receivedTxIds sharedVar MempoolSnapshot{mempoolHasTx} peeraddr reqNo txidsSeq tx collectTxs :: forall m peeraddr tx txid. (MonadSTM m, Ord txid, Ord peeraddr) - => SharedTxStateVar m peeraddr txid tx + => Tracer m (DebugSharedTxState peeraddr txid tx) + -> SharedTxStateVar m peeraddr txid tx -> peeraddr -> Set txid -- ^ set of requested txids -> Map txid tx -- ^ received txs -> m () -- ^ number of txids to be acknowledged and txs to be added to the -- mempool -collectTxs sharedVar peeraddr txidsRequested txsMap = - atomically $ - modifyTVar sharedVar - (collectTxsImpl peeraddr txidsRequested txsMap) +collectTxs tracer sharedVar peeraddr txidsRequested txsMap = do + st <- atomically $ + stateTVar sharedVar + ((\a -> (a,a)) . collectTxsImpl peeraddr txidsRequested txsMap) + traceWith tracer (DebugSharedTxState st) + +-- +-- +-- + +-- | Debug tracer. +-- +newtype DebugSharedTxState peeraddr txid tx = DebugSharedTxState (SharedTxState peeraddr txid tx) + deriving Show From fb43b0ddaede7c709874d85d7bce73034520d2c8 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Mon, 22 Jul 2024 10:53:07 +0100 Subject: [PATCH 08/54] tx-submission: refactored TxSubmission files and added V2 sim - Factored out common type definitions, their generators and properties to a Common.hs file. - Added a TxSubmissionV2 module with the boilerplate to run the new, more accurate submission that uses the V2 version of TxSubmission protocol --- ouroboros-network/ouroboros-network.cabal | 4 + .../Network/TxSubmission/Inbound/Registry.hs | 7 +- .../Test/Ouroboros/Network/TxSubmission.hs | 1885 +---------------- .../Ouroboros/Network/TxSubmission/Common.hs | 1740 +++++++++++++++ .../Network/TxSubmission/TxSubmissionV1.hs | 192 ++ .../Network/TxSubmission/TxSubmissionV2.hs | 258 +++ 6 files changed, 2204 insertions(+), 1882 deletions(-) create mode 100644 ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs create mode 100644 ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV1.hs create mode 100644 ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 720ca27b760..9bce76351d2 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -358,6 +358,7 @@ library testlib random, serialise, si-timers, + strict-mvar, strict-stm, tasty, tasty-hunit, @@ -398,6 +399,9 @@ library testlib Test.Ouroboros.Network.PeerSelection.PeerMetric Test.Ouroboros.Network.PeerSelection.RootPeersDNS Test.Ouroboros.Network.TxSubmission + Test.Ouroboros.Network.TxSubmission.Common + Test.Ouroboros.Network.TxSubmission.TxSubmissionV1 + Test.Ouroboros.Network.TxSubmission.TxSubmissionV2 Test.Ouroboros.Network.Version -- Simulation tests, and IO tests which don't require native system calls. diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs index 94822139e0b..040d605499d 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -5,9 +5,10 @@ {-# LANGUAGE ScopedTypeVariables #-} module Ouroboros.Network.TxSubmission.Inbound.Registry - ( SharedTxStateVar - , newSharedTxStateVar + ( TxChannels (..) , TxChannelsVar + , SharedTxStateVar + , newSharedTxStateVar , newTxChannelsVar , PeerTxAPI (..) , decisionLogicThread @@ -77,7 +78,7 @@ data PeerTxAPI m txid tx = PeerTxAPI { -- `PeerTxStateAPI` is only safe inside the `withPeer` scope. -- withPeer - :: forall peeraddr txid tx idx m a. + :: forall tx peeraddr txid idx m a. ( MonadMask m , MonadMVar m , MonadSTM m diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs index 26c78cfa969..a09c6742e9f 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs @@ -1,1887 +1,14 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - module Test.Ouroboros.Network.TxSubmission (tests) where -import Prelude hiding (seq) - -import NoThunks.Class - -import Control.Concurrent.Class.MonadMVar (MonadMVar) -import Control.Concurrent.Class.MonadSTM -import Control.Exception (SomeException (..), assert) -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadFork -import Control.Monad.Class.MonadSay -import Control.Monad.Class.MonadST -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer.SI -import Control.Monad.IOSim hiding (SimResult) -import Control.Tracer (Tracer (..), 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, fold, foldl', toList) -import Data.Function (on) -import Data.List (intercalate, isPrefixOf, isSuffixOf, mapAccumR, nub, nubBy, - stripPrefix) -import Data.Map.Merge.Strict qualified as Map -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe, isJust, maybeToList) -import Data.Monoid (Sum (..)) -import Data.Sequence (Seq) -import Data.Sequence qualified as Seq -import Data.Sequence.Strict qualified as StrictSeq -import Data.Set (Set) -import Data.Set qualified as Set -import 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.Inbound.Decision qualified as TXS -import Ouroboros.Network.TxSubmission.Inbound.State (PeerTxState (..), - SharedTxState (..)) -import Ouroboros.Network.TxSubmission.Inbound.State qualified as TXS -import Ouroboros.Network.TxSubmission.Mempool.Reader -import Ouroboros.Network.TxSubmission.Outbound -import Ouroboros.Network.Util.ShowProxy +import Test.Ouroboros.Network.TxSubmission.Common qualified as Common +import Test.Ouroboros.Network.TxSubmission.TxSubmissionV1 qualified as V1 +import Test.Ouroboros.Network.TxSubmission.TxSubmissionV2 qualified as V2 -import Test.Ouroboros.Network.BlockFetch (PeerGSVT (..)) -import Test.Ouroboros.Network.Utils - -import Test.QuickCheck -import Test.QuickCheck.Function (apply) -import Test.QuickCheck.Monoids (All (..)) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (testProperty) -import Text.Pretty.Simple -import Text.Printf - tests :: TestTree tests = testGroup "Ouroboros.Network.TxSubmission" - [ testProperty "txSubmission" prop_txSubmission - , testProperty "x" prop_x - , 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 "hasTxIdsToAcknowledge" prop_hasTxIdsToAcknowledge - , 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 - ] - ] + [ Common.tests + , V1.tests + , V2.tests ] - - -data Tx txid = Tx { - getTxId :: !txid, - getTxSize :: !SizeInBytes, - -- | If false this means that when this tx will be submitted to a remote - -- mempool it will not be valid. The outbound mempool might contain - -- invalid tx's in this sense. - getTxValid :: !Bool - } - deriving (Eq, Ord, Show, Generic) - -instance NoThunks txid => NoThunks (Tx txid) -instance ShowProxy txid => ShowProxy (Tx txid) where - showProxy _ = "Tx " ++ showProxy (Proxy :: Proxy txid) - -instance Arbitrary txid => Arbitrary (Tx txid) where - arbitrary = - Tx <$> arbitrary - <*> chooseEnum (0, maxTxSize) - -- note: - -- generating small tx sizes avoids overflow error when semigroup - -- instance of `SizeInBytes` is used (summing up all inflight tx - -- sizes). - <*> frequency [ (3, pure True) - , (1, pure False) - ] - - --- maximal tx size -maxTxSize :: SizeInBytes -maxTxSize = 65536 - -type TxId = Int - -newtype Mempool m txid = Mempool (TVar m (Seq (Tx txid))) - - -emptyMempool :: MonadSTM m => m (Mempool m txid) -emptyMempool = Mempool <$> newTVarIO Seq.empty - -newMempool :: MonadSTM m - => [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 - , MonadMVar m - , MonadSay m - , MonadST m - , MonadTimer m - , MonadThrow (STM m) - , Ord 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) <- createConnectedBufferedChannels - (fromIntegral maxUnacked) - 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 - 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 - 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 - -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 - - --- --- InboundState properties --- - -type PeerAddr = Int - --- | 'InboundState` invariant. --- -sharedTxStateInvariant - :: forall peeraddr txid tx. - ( Ord txid - , Show txid - ) - => SharedTxState peeraddr txid tx - -> Property -sharedTxStateInvariant SharedTxState { - peerTxStates, - inflightTxs, - inflightTxsSize, - bufferedTxs, - referenceCounts - } = - - -- -- `inflightTxs` and `bufferedTxs` are disjoint - -- counterexample "inflightTxs not disjoint with bufferedTxs" - -- (null (inflightTxsSet `Set.intersection` bufferedTxsSet)) - - -- the set of buffered txids is equal to sum of the sets of - -- unacknowledged txids. - counterexample "bufferedTxs txid not a subset of unacknoledged txids" - (bufferedTxsSet - `Set.isSubsetOf` - foldr (\PeerTxState { unacknowledgedTxIds } r -> - r <> Set.fromList (toList unacknowledgedTxIds)) - Set.empty txStates) - - .&&. counterexample "referenceCounts invariant violation" - ( referenceCounts - === - foldl' - (\m PeerTxState { unacknowledgedTxIds = unacked } -> - foldl' - (flip $ - Map.alter (\case - Nothing -> Just $! 1 - Just cnt -> Just $! succ cnt) - ) - m - unacked - ) - Map.empty txStates - ) - - .&&. counterexample ("bufferedTxs contain tx which should be gc-ed: " - ++ show (Map.keysSet bufferedTxs `Set.difference` liveSet)) - (Map.keysSet bufferedTxs `Set.isSubsetOf` liveSet) - - .&&. counterexample "inflightTxs must be a sum of requestedTxInflight sets" - (inflightTxs - === - foldr (\PeerTxState { requestedTxsInflight } m -> - Map.unionWith (+) (Map.fromSet (\_ -> 1) requestedTxsInflight) m) - Map.empty - peerTxStates) - - -- PeerTxState invariants - .&&. counterexample "PeerTxState invariant violation" - (foldMap (\ps -> All - . counterexample (show ps) - . peerTxStateInvariant - $ ps - ) - peerTxStates) - - .&&. counterexample "inflightTxsSize invariant violation" - (inflightTxsSize === foldMap requestedTxsInflightSize peerTxStates) - - - - where - peerTxStateInvariant :: PeerTxState txid tx -> Property - peerTxStateInvariant PeerTxState { availableTxIds, - unacknowledgedTxIds, - unknownTxs, - requestedTxIdsInflight, - requestedTxsInflight, - requestedTxsInflightSize } = - - - counterexample ("unknownTxs is not a subset of unacknowledgedTxIds: " - ++ show (unknownTxs Set.\\ unacknowledgedTxIdsSet)) - (unknownTxs `Set.isSubsetOf` unacknowledgedTxIdsSet) - - .&&. counterexample ("availableTxs is not a subset of unacknowledgedTxIds: " - ++ show (availableTxIdsSet Set.\\ unacknowledgedTxIdsSet)) - (availableTxIdsSet `Set.isSubsetOf` unacknowledgedTxIdsSet) - - .&&. counterexample ("unacknowledged tx must be either available, unknown or buffered: " - ++ show (unacknowledgedTxIdsSet - Set.\\ availableTxIdsSet - Set.\\ unknownTxs - Set.\\ bufferedTxsSet)) - (unacknowledgedTxIdsSet - Set.\\ availableTxIdsSet - Set.\\ unknownTxs - `Set.isSubsetOf` - bufferedTxsSet - ) - - .&&. counterexample "requestedTxIdsInflight invariant violation" - (requestedTxIdsInflight >= 0) - - -- a requested tx is either available or buffered - .&&. counterexample ("requestedTxsInflight invariant violation: " - ++ show (requestedTxsInflight - Set.\\ availableTxIdsSet - Set.\\ bufferedTxsSet)) - (requestedTxsInflight Set.\\ availableTxIdsSet `Set.isSubsetOf` bufferedTxsSet) - - .&&. counterexample "requestedTxsInfightSize" - (requestedTxsInflightSize - === - fold (availableTxIds `Map.restrictKeys` requestedTxsInflight)) - - where - availableTxIdsSet :: Set txid - availableTxIdsSet = Map.keysSet availableTxIds - - unacknowledgedTxIdsSet :: Set txid - unacknowledgedTxIdsSet = Set.fromList (toList unacknowledgedTxIds) - - bufferedTxsSet = Map.keysSet bufferedTxs :: Set txid - liveSet = Map.keysSet referenceCounts :: Set txid - txStates = Map.elems peerTxStates :: [PeerTxState txid tx] - --- --- Generate `InboudState` --- - --- | PeerTxState generator. --- --- `mkArbPeerTxState` is the smart constructor. --- -data ArbPeerTxState txid tx = - ArbPeerTxState { arbPeerTxState :: PeerTxState txid tx, - arbInflightSet :: Set tx, - -- ^ in-flight txs - arbBufferedMap :: Map txid (Maybe tx) - } - -data TxStatus = Available | Inflight | Unknown - -instance Arbitrary TxStatus where - arbitrary = oneof [ pure Available - , pure Inflight - , pure Unknown - ] - -data TxMask tx = TxAvailable tx TxStatus - -- ^ available txid with its size, the Bool indicates if it's - -- in-flight or not - | TxBuffered tx - -fixupTxMask :: txid -> TxMask (Tx txid) -> TxMask (Tx txid) -fixupTxMask txid (TxAvailable tx status) = TxAvailable tx { getTxId = txid } status -fixupTxMask txid (TxBuffered tx) = TxBuffered tx { getTxId = txid } - - -instance Arbitrary tx => Arbitrary (TxMask tx) where - arbitrary = oneof [ TxAvailable - <$> arbitrary - <*> arbitrary - , TxBuffered <$> arbitrary - ] - - -- TODO: implement shrinker; this can be done by writing an inverse of - -- `mkArbPeerTxState` and shrinking the unacknowledged txs & mask map. - - --- | Smart constructor for `ArbPeerTxState`. --- -mkArbPeerTxState :: Ord txid - => Fun txid Bool - -> Int -- ^ txids in-flight - -> [txid] - -> Map txid (TxMask (Tx txid)) - -> ArbPeerTxState txid (Tx txid) -mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMaskMap = - ArbPeerTxState - PeerTxState { unacknowledgedTxIds = StrictSeq.fromList unacked, - availableTxIds, - requestedTxIdsInflight, - requestedTxsInflight, - requestedTxsInflightSize, - unknownTxs } - (Set.fromList $ Map.elems inflightMap) - bufferedMap - where - mempoolHasTx = apply mempoolHasTxFun - availableTxIds = Map.fromList - [ (txid, getTxSize tx) | (txid, TxAvailable tx _) <- Map.assocs txMaskMap - , not (mempoolHasTx txid) - ] - unknownTxs = Set.fromList - [ txid | (txid, TxAvailable _ Unknown) <- Map.assocs txMaskMap - , not (mempoolHasTx txid) - ] - - requestedTxIdsInflight = fromIntegral txIdsInflight - requestedTxsInflightSize = foldMap getTxSize inflightMap - requestedTxsInflight = Map.keysSet inflightMap - - -- exclude `txid`s which are already in the mempool, we never request such - -- `txid`s - -- - -- TODO: this should be lifted, we might have the same txid in-flight from - -- multiple peers, one will win the race and land in the mempool first - inflightMap = Map.fromList - [ (txid, tx) - | (txid, TxAvailable tx Inflight) <- Map.assocs txMaskMap - , not (mempoolHasTx txid) - ] - - bufferedMap = Map.fromList - [ (txid, Nothing) - | txid <- Map.keys txMaskMap - , mempoolHasTx txid - ] - `Map.union` - Map.fromList - [ (txid, mtx) - | (txid, TxBuffered tx) <- Map.assocs txMaskMap - , let !mtx = if mempoolHasTx txid - then Nothing - else Just $! tx { getTxId = txid } - ] - - -genArbPeerTxState - :: forall txid. - ( Arbitrary txid - , Ord txid - ) - => Fun txid Bool - -> Int -- ^ max txids inflight - -> Gen (ArbPeerTxState txid (Tx txid)) -genArbPeerTxState mempoolHasTxFun maxTxIdsInflight = do - -- unacknowledged sequence - unacked <- arbitrary - -- generate `Map txid (TxMask tx)` - txIdsInflight <- choose (0, maxTxIdsInflight) - txMap <- Map.fromList - <$> traverse (\txid -> (\a -> (txid, fixupTxMask txid a)) <$> arbitrary) - (nub unacked) - return $ mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMap - - -genSharedTxState - :: forall txid. - ( Arbitrary txid - , Ord txid - , Function txid - , CoArbitrary txid - ) - => Int -- ^ max txids inflight - -> Gen ( Fun txid Bool - , (PeerAddr, PeerTxState txid (Tx txid)) - , SharedTxState PeerAddr txid (Tx txid) - , Map PeerAddr (ArbPeerTxState txid (Tx txid)) - ) -genSharedTxState maxTxIdsInflight = do - _mempoolHasTxFun@(Fun (_, _, x) _) <- arbitrary :: Gen (Fun Bool Bool) - let mempoolHasTxFun = Fun (function (const False), False, x) (const False) - pss <- listOf1 (genArbPeerTxState mempoolHasTxFun maxTxIdsInflight) - - let pss' :: [(PeerAddr, ArbPeerTxState txid (Tx txid))] - pss' = [0..] `zip` pss - - peer <- choose (0, length pss - 1) - - let st :: SharedTxState PeerAddr txid (Tx txid) - st = fixupSharedTxState - (apply mempoolHasTxFun) - SharedTxState { - peerTxStates = Map.fromList - [ (peeraddr, arbPeerTxState) - | (peeraddr, ArbPeerTxState { arbPeerTxState }) - <- pss' - ], - inflightTxs = foldl' (Map.unionWith (+)) Map.empty - [ Map.fromSet (const 1) (Set.map getTxId arbInflightSet) - | ArbPeerTxState { arbInflightSet } - <- pss - ], - inflightTxsSize = 0, -- It is set by fixupSharedTxState - bufferedTxs = fold - [ arbBufferedMap - | ArbPeerTxState { arbBufferedMap } - <- pss - ], - referenceCounts = Map.empty - } - - return ( mempoolHasTxFun - , (peer, peerTxStates st Map.! peer) - , st - , Map.fromList pss' - ) - - --- | Make sure `SharedTxState` is well formed. --- -fixupSharedTxState - :: Ord txid - => (txid -> Bool) -- ^ mempoolHasTx - -> SharedTxState peeraddr txid tx - -> SharedTxState peeraddr txid tx -fixupSharedTxState _mempoolHasTx st@SharedTxState { peerTxStates } = - st { peerTxStates = peerTxStates', - inflightTxs = inflightTxs', - inflightTxsSize = foldMap requestedTxsInflightSize peerTxStates', - bufferedTxs = bufferedTxs', - referenceCounts = referenceCounts' - } - where - peerTxStates' = - Map.map (\ps@PeerTxState { availableTxIds, - requestedTxsInflight } -> - - let -- requested txs must not be buffered - requestedTxsInflight' = requestedTxsInflight - Set.\\ Map.keysSet bufferedTxs' - requestedTxsInflightSize' = fold $ availableTxIds - `Map.restrictKeys` - requestedTxsInflight' - - in ps { requestedTxsInflight = requestedTxsInflight', - requestedTxsInflightSize = requestedTxsInflightSize' } - ) - peerTxStates - - inflightTxs' = foldr (\PeerTxState { requestedTxsInflight } m -> - Map.unionWith (+) - (Map.fromSet (const 1) requestedTxsInflight) - m - ) - Map.empty - peerTxStates' - - bufferedTxs' = - bufferedTxs st - `Map.restrictKeys` - foldr (\PeerTxState {unacknowledgedTxIds = unacked } r -> - r <> Set.fromList (toList unacked)) - Set.empty (Map.elems peerTxStates) - - - referenceCounts' = - foldl' - (\m PeerTxState { unacknowledgedTxIds } -> - foldl' - (flip $ - Map.alter (\case - Nothing -> Just $! 1 - Just cnt -> Just $! succ cnt) - ) - m - unacknowledgedTxIds - ) - Map.empty - (Map.elems peerTxStates) - - -shrinkSharedTxState :: ( Arbitrary txid - , Ord txid - , Function txid - , Ord peeraddr - ) - => (txid -> Bool) - -> SharedTxState peeraddr txid (Tx txid) - -> [SharedTxState peeraddr txid (Tx txid)] -shrinkSharedTxState mempoolHasTx st@SharedTxState { peerTxStates, - inflightTxs, - bufferedTxs } = - [ st' - | peerTxStates' <- Map.fromList <$> shrinkList (\_ -> []) (Map.toList peerTxStates) - , not (Map.null peerTxStates') - , let st' = fixupSharedTxState mempoolHasTx st { peerTxStates = peerTxStates' } - , st' /= st - ] - ++ - [ fixupSharedTxState mempoolHasTx st { inflightTxs = inflightTxs' } - | inflightTxs' <- Map.fromList <$> shrinkList (\_ -> []) (Map.toList inflightTxs) - ] - ++ - [ st - | bufferedTxs' <- Map.fromList - <$> shrinkList (\_ -> []) (Map.assocs bufferedTxs) - , let minBuffered = - foldMap - (\PeerTxState { - unacknowledgedTxIds, - availableTxIds, - unknownTxs - } - -> - Set.fromList (toList unacknowledgedTxIds) - Set.\\ Map.keysSet availableTxIds - Set.\\ unknownTxs - ) - peerTxStates - bufferedTxs'' = bufferedTxs' - `Map.union` - (bufferedTxs `Map.restrictKeys` minBuffered) - st' = fixupSharedTxState mempoolHasTx st { bufferedTxs = bufferedTxs'' } - , st' /= st - ] - --- --- Arbitrary `SharaedTxState` instance --- - -data ArbSharedTxState = - ArbSharedTxState - (Fun TxId Bool) - (SharedTxState PeerAddr TxId (Tx TxId)) - deriving Show - -instance Arbitrary ArbSharedTxState where - arbitrary = do - Small maxTxIdsInflight <- arbitrary - (mempoolHasTx, _, sharedTxState, _) <- genSharedTxState maxTxIdsInflight - return $ ArbSharedTxState mempoolHasTx sharedTxState - - shrink (ArbSharedTxState mempoolHasTx st) = - [ ArbSharedTxState mempoolHasTx st' - | st' <- shrinkSharedTxState (apply mempoolHasTx) st - ] - - --- | Verify that generated `SharedTxState` has no thunks if it's evaluated to --- WHNF. --- -prop_SharedTxState_nothunks :: ArbSharedTxState -> Property -prop_SharedTxState_nothunks (ArbSharedTxState _ !st) = - case unsafeNoThunks st of - Nothing -> property True - Just ctx -> counterexample (show ctx) False - - -prop_SharedTxState_generator - :: ArbSharedTxState - -> Property -prop_SharedTxState_generator (ArbSharedTxState _ st) = sharedTxStateInvariant st - - -prop_SharedTxState_shrinker - :: Fixed ArbSharedTxState - -> Property -prop_SharedTxState_shrinker = - property - . foldMap (\(ArbSharedTxState _ st) -> All $ sharedTxStateInvariant st) - . shrink - . getFixed - - --- --- `receivedTxIdsImpl` properties --- - - -data ArbReceivedTxIds = - ArbReceivedTxIds (Fun TxId Bool) -- ^ mempoolHasTx - [Tx TxId] -- ^ some txs to acknowledge - PeerAddr -- ^ peer address - (PeerTxState TxId (Tx TxId)) - -- ^ peer state - (SharedTxState PeerAddr TxId (Tx TxId)) - -- ^ initial state - deriving Show - -instance Arbitrary ArbReceivedTxIds where - arbitrary = do - Small maxTxIdsInflight <- arbitrary - (mempoolHasTxFun, (peeraddr, ps), st, psMap) <- genSharedTxState maxTxIdsInflight - txsToAck <- sublistOf (Set.toList $ arbInflightSet (psMap Map.! peeraddr)) - pure $ ArbReceivedTxIds - mempoolHasTxFun - txsToAck - peeraddr - ps - st - - shrink (ArbReceivedTxIds mempoolHasTxFun txs peeraddr ps st) = - [ ArbReceivedTxIds mempoolHasTxFun txs' peeraddr ps st - | txs' <- shrink txs - ] - ++ - [ ArbReceivedTxIds - mempoolHasTxFun' txs peeraddr ps - (fixupSharedTxState (apply mempoolHasTxFun') st) - | mempoolHasTxFun' <- shrink mempoolHasTxFun - ] - - -prop_receivedTxIds_generator - :: ArbReceivedTxIds - -> Property -prop_receivedTxIds_generator (ArbReceivedTxIds _ someTxsToAck _peeraddr _ps st) = - label ("numToAck " ++ labelInt 100 10 (length someTxsToAck)) - . counterexample (show st) - $ sharedTxStateInvariant st - - --- | This property verifies that `acknowledgeTxIds` acknowledges a prefix of --- unacknowledged txs, and that the `numTxIdsToAck` as well as `RefCoundDiff` --- are correct. --- --- It doesn't validate the returned `PeerTxState` holds it's properties as this --- needs to be done in the context of updated `SharedTxState`. This is verified --- by `prop_receivedTxIdsImpl`, `prop_collectTxsImpl` and --- `prop_makeDecisions_acknowledged`. --- -prop_acknowledgeTxIds :: ArbReceivedTxIds - -> Property -prop_acknowledgeTxIds (ArbReceivedTxIds _mempoolHasTxFun _txs _peeraddr ps st) = - case TXS.acknowledgeTxIds st ps of - (numTxIdsToAck, txs, TXS.RefCountDiff { TXS.txIdsToAck }, ps') -> - counterexample "number of tx ids to ack must agree with RefCountDiff" - ( fromIntegral numTxIdsToAck - === - getSum (foldMap Sum txIdsToAck) - ) - - .&&. counterexample "acknowledged txs must form a prefix" - let unacked = toList (unacknowledgedTxIds ps) - unacked' = toList (unacknowledgedTxIds ps') - in case unacked `stripSuffix` unacked' of - Nothing -> counterexample "acknowledged txs are not a prefix" False - Just txIdsToAck' -> - txIdsToAck - === - Map.fromListWith (+) ((,1) <$> txIdsToAck') - - .&&. counterexample "acknowledged txs" (counterexample ("numTxIdsToAck = " ++ show numTxIdsToAck) - let acked :: [TxId] - acked = [ txid - | txid <- take (fromIntegral numTxIdsToAck) (toList $ unacknowledgedTxIds ps) - , Just _ <- maybeToList $ txid `Map.lookup` bufferedTxs st - ] - in getTxId `map` txs === acked) - where - stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] - stripSuffix as suffix = - reverse <$> reverse suffix `stripPrefix` reverse as - - --- | Verify that `hasTxIdsToAcknowledge` and `acknowledgeTxIds` are compatible. --- -prop_hasTxIdsToAcknowledge - :: ArbReceivedTxIds - -> Property -prop_hasTxIdsToAcknowledge (ArbReceivedTxIds _mempoolHasTxFun _txs _peeraddr ps st) = - case ( TXS.hasTxIdsToAcknowledge st ps - , TXS.acknowledgeTxIds st ps - ) of - (canAck, (numTxIdsToAck, _, _, _)) -> - canAck === (numTxIdsToAck > 0) - - --- | Verify 'inboundStateInvariant' when acknowledging a sequence of txs. --- -prop_receivedTxIdsImpl - :: ArbReceivedTxIds - -> Property -prop_receivedTxIdsImpl (ArbReceivedTxIds mempoolHasTxFun txs peeraddr ps st) = - -- InboundState invariant - counterexample - ( "Unacknowledged in mempool: " ++ - show (apply mempoolHasTxFun <$> toList (unacknowledgedTxIds ps)) ++ "\n" - ++ "InboundState invariant violation:\n" ++ - show st' - ) - (sharedTxStateInvariant st') - - -- unacknowledged txs are well formed - .&&. counterexample "unacknowledged txids are not well formed" - ( let unacked = toList $ unacknowledgedTxIds ps <> txidSeq - unacked' = toList $ unacknowledgedTxIds ps' - in counterexample ("old & received: " ++ show unacked ++ "\n" ++ - "new: " ++ show unacked') $ - unacked' `isSuffixOf` unacked - ) - - .&&. -- `receivedTxIdsImpl` doesn't acknowledge any `txids` - counterexample "acknowledged property violation" - ( let unacked = toList $ unacknowledgedTxIds ps - unacked' = toList $ unacknowledgedTxIds ps' - in unacked `isPrefixOf` unacked' - ) - where - st' = TXS.receivedTxIdsImpl (apply mempoolHasTxFun) - peeraddr 0 txidSeq txidMap st - ps' = peerTxStates st' Map.! peeraddr - - txidSeq = StrictSeq.fromList (getTxId <$> txs) - txidMap = Map.fromList [ (getTxId tx, getTxSize tx) | tx <- txs ] - - --- | Verify that `SharedTxState` returned by `receivedTxIdsImpl` if evaluated --- to WHNF it doesn't contain any thunks. --- -prop_receivedTxIdsImpl_nothunks - :: ArbReceivedTxIds - -> Property -prop_receivedTxIdsImpl_nothunks (ArbReceivedTxIds mempoolHasTxFun txs peeraddr _ st) = - case TXS.receivedTxIdsImpl (apply mempoolHasTxFun) - peeraddr 0 txidSeq txidMap st of - !st' -> case unsafeNoThunks st' of - Nothing -> property True - Just ctx -> counterexample (show ctx) False - where - txidSeq = StrictSeq.fromList (getTxId <$> txs) - txidMap = Map.fromList [ (getTxId tx, getTxSize tx) | tx <- txs ] - - --- --- `collectTxs` properties --- - - -data ArbCollectTxs = - ArbCollectTxs (Fun TxId Bool) -- ^ mempoolHasTx - (Set TxId) -- ^ requested txid's - (Map TxId (Tx TxId)) -- ^ received txs - PeerAddr -- ^ peeraddr - (PeerTxState TxId (Tx TxId)) - (SharedTxState PeerAddr TxId (Tx TxId)) - -- ^ 'InboundState' - deriving Show - - -instance Arbitrary ArbCollectTxs where - arbitrary = do - Small maxTxIdsInflight <- arbitrary - ( mempoolHasTxFun - , (peeraddr, ps@PeerTxState { availableTxIds, - requestedTxIdsInflight, - requestedTxsInflight, - requestedTxsInflightSize }) - , st - , _ - ) - <- genSharedTxState maxTxIdsInflight - requestedTxIds <- take (fromIntegral requestedTxIdsInflight) - <$> sublistOf (toList requestedTxsInflight) - - -- Limit the requested `txid`s to satisfy `requestedTxsInflightSize`. - let requestedTxIds' = fmap fst - . takeWhile (\(_,s) -> s <= requestedTxsInflightSize) - $ zip requestedTxIds - (scanl1 (<>) [availableTxIds Map.! txid | txid <- requestedTxIds ]) - - receivedTx <- sublistOf requestedTxIds' - >>= traverse (\txid -> do - valid <- frequency [(4, pure True), (1, pure False)] - pure $ Tx { getTxId = txid, - getTxSize = availableTxIds Map.! txid, - getTxValid = valid }) - - pure $ assert (foldMap getTxSize receivedTx <= requestedTxsInflightSize) - $ ArbCollectTxs mempoolHasTxFun - (Set.fromList requestedTxIds') - (Map.fromList [ (getTxId tx, tx) | tx <- receivedTx ]) - peeraddr - ps - st - - shrink (ArbCollectTxs mempoolHasTx requestedTxs receivedTxs peeraddr ps st) = - [ ArbCollectTxs mempoolHasTx - requestedTxs' - (receivedTxs `Map.restrictKeys` requestedTxs') - peeraddr ps st - | requestedTxs' <- Set.fromList <$> shrinkList (\_ -> []) (Set.toList requestedTxs) - ] - ++ - [ ArbCollectTxs mempoolHasTx - requestedTxs - (receivedTxs `Map.restrictKeys` receivedTxIds) - peeraddr ps st - | receivedTxIds <- Set.fromList <$> shrinkList (\_ -> []) (Map.keys receivedTxs) - ] - ++ - [ ArbCollectTxs mempoolHasTx - (requestedTxs - `Set.intersection` unacked - `Set.intersection` inflightTxSet) - (receivedTxs - `Map.restrictKeys` unacked - `Map.restrictKeys` inflightTxSet) - peeraddr ps - st' - | let unacked = Set.fromList - . toList - . unacknowledgedTxIds - $ ps - , st'@SharedTxState { inflightTxs } <- shrinkSharedTxState (apply mempoolHasTx) st - , let inflightTxSet = Map.keysSet inflightTxs - , peeraddr `Map.member` peerTxStates st' - , st' /= st - ] - - -prop_collectTxs_generator - :: ArbCollectTxs - -> Property -prop_collectTxs_generator (ArbCollectTxs _ requestedTxIds receivedTxs peeraddr - ps@PeerTxState { availableTxIds, - requestedTxsInflightSize } - st) = - counterexample "size of requested txs must not be larger than requestedTxsInflightSize" - (requestedSize <= requestedTxsInflightSize) - .&&. counterexample "inflightTxsSize must be greater than requestedSize" - (inflightTxsSize st >= requestedSize) - .&&. counterexample ("receivedTxs must be a subset of requestedTxIds " - ++ show (Map.keysSet receivedTxs Set.\\ requestedTxIds)) - (Map.keysSet receivedTxs `Set.isSubsetOf` requestedTxIds) - .&&. counterexample "peerTxState" - (Map.lookup peeraddr (peerTxStates st) === Just ps) - where - requestedSize = fold (availableTxIds `Map.restrictKeys` requestedTxIds) - - -prop_collectTxs_shrinker - :: Fixed ArbCollectTxs - -- ^ disabled shrinking - -> Property -prop_collectTxs_shrinker (Fixed txs) = - property $ foldMap (\a@(ArbCollectTxs _ _ _ _ _ st) -> - All . counterexample (show st) $ - f a =/= f txs - .&&. sharedTxStateInvariant st - ) (shrink txs) - where - f (ArbCollectTxs _ reqSet recvMap peeraddr ps st) = (reqSet, recvMap, peeraddr, ps, st) - - --- | Verify `collectTxsImpl` properties: --- --- * verify `SharedTxState` invariant; --- * unacknowledged txids after `collectTxsImpl` must be a suffix of the --- original ones; --- * progress property: we acknowledge as many `txid`s as possible --- -prop_collectTxsImpl - :: ArbCollectTxs - -> Property -prop_collectTxsImpl (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived peeraddr ps st) = - - label ("number of txids inflight " ++ labelInt 25 5 (Map.size $ inflightTxs st)) $ - label ("number of txids requested " ++ labelInt 25 5 (Set.size txidsRequested)) $ - label ("number of txids received " ++ labelInt 10 2 (Map.size txsReceived)) $ - - -- InboundState invariant - counterexample - ( "InboundState invariant violation:\n" ++ show st' ++ "\n" - ++ show ps' - ) - (sharedTxStateInvariant st') - - .&&. - -- `collectTxsImpl` doesn't modify unacknowledged TxId's - counterexample "acknowledged property violation" - ( let unacked = toList $ unacknowledgedTxIds ps - unacked' = toList $ unacknowledgedTxIds ps' - in unacked === unacked' - ) - where - st' = TXS.collectTxsImpl peeraddr txidsRequested txsReceived st - ps' = peerTxStates st' Map.! peeraddr - - --- | Verify that `SharedTxState` returned by `collectTxsImpl` if evaluated to --- WHNF, it doesn't contain any thunks. --- -prop_collectTxsImpl_nothunks - :: ArbCollectTxs - -> Property -prop_collectTxsImpl_nothunks (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived peeraddr _ st) = - case unsafeNoThunks $! st' of - Nothing -> property True - Just ctx -> counterexample (show ctx) False - where - st' = TXS.collectTxsImpl peeraddr txidsRequested txsReceived st - - -newtype ArbTxDecisionPolicy = ArbTxDecisionPolicy TxDecisionPolicy - deriving Show - -instance Arbitrary ArbTxDecisionPolicy where - arbitrary = - ArbTxDecisionPolicy . fixupTxDecisionPolicy - <$> ( TxDecisionPolicy - <$> (getSmall <$> arbitrary) - <*> (getSmall <$> arbitrary) - <*> (SizeInBytes . getPositive <$> arbitrary) - <*> (SizeInBytes . getPositive <$> arbitrary) - <*> (getPositive <$> arbitrary)) - - shrink (ArbTxDecisionPolicy a@TxDecisionPolicy { - maxNumTxIdsToRequest, - txsSizeInflightPerPeer, - maxTxsSizeInflight, - txInflightMultiplicity }) = - [ ArbTxDecisionPolicy a { maxNumTxIdsToRequest = NumTxIdsToReq x } - | x <- shrink (getNumTxIdsToReq maxNumTxIdsToRequest) - ] - ++ - [ ArbTxDecisionPolicy . fixupTxDecisionPolicy - $ a { txsSizeInflightPerPeer = SizeInBytes s } - | s <- shrink (getSizeInBytes txsSizeInflightPerPeer) - ] - ++ - [ ArbTxDecisionPolicy . fixupTxDecisionPolicy - $ a { maxTxsSizeInflight = SizeInBytes s } - | s <- shrink (getSizeInBytes maxTxsSizeInflight) - ] - ++ - [ ArbTxDecisionPolicy . fixupTxDecisionPolicy - $ a { txInflightMultiplicity = x } - | Positive x <- shrink (Positive 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 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'' - - --- | `filterActivePeers` should not change decisions made by `makeDecisions` --- --- --- This test checks the following properties: --- --- In what follows, the set of active peers is defined as the keys of the map --- returned by `filterActivePeers`. --- --- 1. The set of active peers is a superset of peers for which a decision was --- made; --- 2. The set of active peer which can acknowledge txids is a subset of peers --- for which a decision was made; --- 3. Decisions made from the results of `filterActivePeers` is the same as from --- the original set. --- --- Ad 2. a stronger property is not possible. There can be a peer for which --- a decision was not taken but which is an active peer. --- -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 ("found non-active peers for which decision can be made: " - ++ show (decisionPeers Set.\\ activePeers) - ) - (decisionPeers `Set.isSubsetOf` activePeers) - .&&. - counterexample ("found an active peer which can acknowledge txids " - ++ "for which decision was not made: " - ++ show (activePeersAck Set.\\ decisionPeers)) - (activePeersAck `Set.isSubsetOf` decisionPeers) - .&&. - counterexample "decisions from active peers are not equal to decisions from all peers" - (decisions === decisionsOfActivePeers) - where - activePeersMap = TXS.filterActivePeers policy st - activePeers = Map.keysSet activePeersMap - -- peers which are active & can acknowledge txids - activePeersAck = activePeers - `Set.intersection` - Map.keysSet (Map.filter (TXS.hasTxIdsToAcknowledge st) (peerTxStates st)) - (_, 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/Common.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs new file mode 100644 index 00000000000..dc7d99b6cdf --- /dev/null +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs @@ -0,0 +1,1740 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Ouroboros.Network.TxSubmission.Common where + +import Prelude hiding (seq) + +import NoThunks.Class + +import Control.Concurrent.Class.MonadSTM +import Control.Exception (SomeException (..), assert) +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadSay +import Control.Monad.Class.MonadST +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI +import Control.Monad.IOSim hiding (SimResult) +import Control.Tracer (Tracer (..), showTracing, traceWith) + +import Codec.CBOR.Decoding qualified as CBOR +import Codec.CBOR.Encoding qualified as CBOR +import Codec.CBOR.Read qualified as CBOR + +import Data.ByteString.Lazy (ByteString) +import Data.Foldable as Foldable (find, fold, foldl', toList) +import Data.Function (on) +import Data.List (intercalate, isPrefixOf, isSuffixOf, mapAccumR, nub, nubBy, + stripPrefix) +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, isJust, maybeToList) +import Data.Monoid (Sum (..)) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Generics (Generic) + +import Network.TypedProtocol.Codec + +import Ouroboros.Network.Protocol.TxSubmission2.Codec +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound +import Ouroboros.Network.TxSubmission.Inbound.Decision qualified as TXS +import Ouroboros.Network.TxSubmission.Inbound.State (PeerTxState (..), + SharedTxState (..)) +import Ouroboros.Network.TxSubmission.Inbound.State qualified as TXS +import Ouroboros.Network.TxSubmission.Mempool.Reader +import Ouroboros.Network.Util.ShowProxy + +import Test.Ouroboros.Network.BlockFetch (PeerGSVT (..)) + +import Test.QuickCheck +import Test.QuickCheck.Function (apply) +import Test.QuickCheck.Monoids (All (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Text.Pretty.Simple +import Text.Printf + + +tests :: TestTree +tests = testGroup "Ouroboros.Network.TxSubmission.Common" + [ testGroup "State" + [ testGroup "Arbitrary" + [ testGroup "ArbSharedTxState" + [ testProperty "generator" prop_SharedTxState_generator + , testProperty "shrinker" $ withMaxSuccess 10 + prop_SharedTxState_shrinker + , testProperty "nothunks" prop_SharedTxState_nothunks + ] + , testGroup "ArbReceivedTxIds" + [ testProperty "generator" prop_receivedTxIds_generator + ] + , testGroup "ArbCollectTxs" + [ testProperty "generator" prop_collectTxs_generator + , testProperty "shrinker" $ withMaxSuccess 10 + prop_collectTxs_shrinker + ] + ] + , testProperty "acknowledgeTxIds" prop_acknowledgeTxIds + , testProperty "hasTxIdsToAcknowledge" prop_hasTxIdsToAcknowledge + , 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 + ] + ] + ] + +data Tx txid = Tx { + getTxId :: !txid, + getTxSize :: !SizeInBytes, + -- | If false this means that when this tx will be submitted to a remote + -- mempool it will not be valid. The outbound mempool might contain + -- invalid tx's in this sense. + getTxValid :: !Bool + } + deriving (Eq, Ord, Show, Generic) + +instance NoThunks txid => NoThunks (Tx txid) +instance ShowProxy txid => ShowProxy (Tx txid) where + showProxy _ = "Tx " ++ showProxy (Proxy :: Proxy txid) + +instance Arbitrary txid => Arbitrary (Tx txid) where + arbitrary = + Tx <$> arbitrary + <*> chooseEnum (0, maxTxSize) + -- note: + -- generating small tx sizes avoids overflow error when semigroup + -- instance of `SizeInBytes` is used (summing up all inflight tx + -- sizes). + <*> frequency [ (3, pure True) + , (1, pure False) + ] + +-- maximal tx size +maxTxSize :: SizeInBytes +maxTxSize = 65536 + +type TxId = Int + +newtype Mempool m txid = Mempool (TVar m (Seq (Tx txid))) + + +emptyMempool :: MonadSTM m => m (Mempool m txid) +emptyMempool = Mempool <$> newTVarIO Seq.empty + +newMempool :: ( MonadSTM m + , Eq txid + ) + => [Tx txid] + -> m (Mempool m txid) +newMempool = fmap Mempool + . newTVarIO + . Seq.fromList + +readMempool :: MonadSTM m => Mempool m txid -> m [Tx txid] +readMempool (Mempool mempool) = toList <$> readTVarIO mempool + + +getMempoolReader :: forall txid m. + ( MonadSTM m + , Eq txid + , Show txid + ) + => Mempool m txid + -> TxSubmissionMempoolReader txid (Tx txid) Int m +getMempoolReader (Mempool mempool) = + TxSubmissionMempoolReader { mempoolGetSnapshot, mempoolZeroIdx = 0 } + where + mempoolGetSnapshot :: STM m (MempoolSnapshot txid (Tx txid) Int) + mempoolGetSnapshot = getSnapshot <$> readTVar mempool + + getSnapshot :: Seq (Tx txid) + -> MempoolSnapshot txid (Tx txid) Int + getSnapshot seq = + MempoolSnapshot { + mempoolTxIdsAfter = + \idx -> zipWith f [idx + 1 ..] (toList $ Seq.drop idx seq), + -- why do I need to use `pred`? + mempoolLookupTx = flip Seq.lookup seq . pred, + mempoolHasTx = \txid -> isJust $ find (\tx -> getTxId tx == txid) seq + } + + f :: Int -> Tx txid -> (txid, Int, SizeInBytes) + f idx Tx {getTxId, getTxSize} = (getTxId, idx, getTxSize) + + +getMempoolWriter :: forall txid m. + ( MonadSTM m + , Ord txid + , Eq txid + ) + => Mempool m txid + -> TxSubmissionMempoolWriter txid (Tx txid) Int m +getMempoolWriter (Mempool mempool) = + TxSubmissionMempoolWriter { + txId = getTxId, + + mempoolAddTxs = \txs -> do + atomically $ do + mempoolTxs <- readTVar mempool + let currentIds = Set.fromList (map getTxId (toList mempoolTxs)) + validTxs = nubBy (on (==) getTxId) + $ filter + (\Tx { getTxId, getTxValid } -> + getTxValid + && getTxId `Set.notMember` currentIds) + txs + mempoolTxs' = Foldable.foldl' (Seq.|>) mempoolTxs validTxs + writeTVar mempool mempoolTxs' + return (map getTxId validTxs) + } + + +txSubmissionCodec2 :: MonadST m + => Codec (TxSubmission2 Int (Tx Int)) + CBOR.DeserialiseFailure m ByteString +txSubmissionCodec2 = + codecTxSubmission2 CBOR.encodeInt CBOR.decodeInt + encodeTx decodeTx + where + encodeTx Tx {getTxId, getTxSize, getTxValid} = + CBOR.encodeListLen 3 + <> CBOR.encodeInt getTxId + <> CBOR.encodeWord32 (getSizeInBytes getTxSize) + <> CBOR.encodeBool getTxValid + + decodeTx = do + _ <- CBOR.decodeListLen + Tx <$> CBOR.decodeInt + <*> (SizeInBytes <$> CBOR.decodeWord32) + <*> CBOR.decodeBool + + +newtype LargeNonEmptyList a = LargeNonEmpty { getLargeNonEmpty :: [a] } + deriving Show + +instance Arbitrary a => Arbitrary (LargeNonEmptyList a) where + arbitrary = + LargeNonEmpty <$> suchThat (resize 500 (listOf arbitrary)) ((>25) . length) + + +-- TODO: Belongs in iosim. +data SimResult a = SimReturn a [String] + | SimException SomeException [String] + | SimDeadLock [String] + +-- Traverses a list of trace events and returns the result along with all log messages. +-- Incase of a pure exception, ie an assert, all tracers evaluated so far are returned. +evaluateTrace :: SimTrace a -> IO (SimResult a) +evaluateTrace = go [] + where + go as tr = do + r <- try (evaluate tr) + case r of + Right (SimTrace _ _ _ (EventSay s) tr') -> go (s : as) tr' + Right (SimTrace _ _ _ _ tr' ) -> go as tr' + Right (SimPORTrace _ _ _ _ (EventSay s) tr') -> go (s : as) tr' + Right (SimPORTrace _ _ _ _ _ tr' ) -> go as tr' + Right (TraceMainReturn _ _ a _) -> pure $ SimReturn a (reverse as) + Right (TraceMainException _ _ e _) -> pure $ SimException e (reverse as) + Right (TraceDeadlock _ _) -> pure $ SimDeadLock (reverse as) + Right TraceLoop -> error "IOSimPOR step time limit exceeded" + Right (TraceInternalError e) -> error ("IOSim: " ++ e) + Left (SomeException e) -> pure $ SimException (SomeException e) (reverse as) + +data WithThreadAndTime a = WithThreadAndTime { + wtatOccuredAt :: !Time + , wtatWithinThread :: !String + , wtatEvent :: !a + } + +instance (Show a) => Show (WithThreadAndTime a) where + show WithThreadAndTime {wtatOccuredAt, wtatWithinThread, wtatEvent} = + printf "%s: %s: %s" (show wtatOccuredAt) (show wtatWithinThread) (show wtatEvent) + +verboseTracer :: forall a m. + ( MonadAsync m + , MonadDelay m + , MonadSay m + , MonadMonotonicTime m + , Show a + ) + => Tracer m a +verboseTracer = threadAndTimeTracer $ showTracing $ Tracer say + +threadAndTimeTracer :: forall a m. + ( MonadAsync m + , MonadDelay m + , MonadMonotonicTime m + ) + => Tracer m (WithThreadAndTime a) -> Tracer m a +threadAndTimeTracer tr = Tracer $ \s -> do + !now <- getMonotonicTime + !tid <- myThreadId + traceWith tr $ WithThreadAndTime now (show tid) s + + +-- +-- InboundState properties +-- + +type PeerAddr = Int + +-- | 'InboundState` invariant. +-- +sharedTxStateInvariant + :: forall peeraddr txid tx. + ( Ord txid + , Show txid + ) + => SharedTxState peeraddr txid tx + -> Property +sharedTxStateInvariant SharedTxState { + peerTxStates, + inflightTxs, + inflightTxsSize, + bufferedTxs, + referenceCounts + } = + + -- -- `inflightTxs` and `bufferedTxs` are disjoint + -- counterexample "inflightTxs not disjoint with bufferedTxs" + -- (null (inflightTxsSet `Set.intersection` bufferedTxsSet)) + + -- the set of buffered txids is equal to sum of the sets of + -- unacknowledged txids. + counterexample "bufferedTxs txid not a subset of unacknoledged txids" + (bufferedTxsSet + `Set.isSubsetOf` + foldr (\PeerTxState { unacknowledgedTxIds } r -> + r <> Set.fromList (toList unacknowledgedTxIds)) + Set.empty txStates) + + .&&. counterexample "referenceCounts invariant violation" + ( referenceCounts + === + foldl' + (\m PeerTxState { unacknowledgedTxIds = unacked } -> + foldl' + (flip $ + Map.alter (\case + Nothing -> Just $! 1 + Just cnt -> Just $! succ cnt) + ) + m + unacked + ) + Map.empty txStates + ) + + .&&. counterexample ("bufferedTxs contain tx which should be gc-ed: " + ++ show (Map.keysSet bufferedTxs `Set.difference` liveSet)) + (Map.keysSet bufferedTxs `Set.isSubsetOf` liveSet) + + .&&. counterexample "inflightTxs must be a sum of requestedTxInflight sets" + (inflightTxs + === + foldr (\PeerTxState { requestedTxsInflight } m -> + Map.unionWith (+) (Map.fromSet (\_ -> 1) requestedTxsInflight) m) + Map.empty + peerTxStates) + + -- PeerTxState invariants + .&&. counterexample "PeerTxState invariant violation" + (foldMap (\ps -> All + . counterexample (show ps) + . peerTxStateInvariant + $ ps + ) + peerTxStates) + + .&&. counterexample "inflightTxsSize invariant violation" + (inflightTxsSize === foldMap requestedTxsInflightSize peerTxStates) + + + + where + peerTxStateInvariant :: PeerTxState txid tx -> Property + peerTxStateInvariant PeerTxState { availableTxIds, + unacknowledgedTxIds, + unknownTxs, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize } = + + + counterexample ("unknownTxs is not a subset of unacknowledgedTxIds: " + ++ show (unknownTxs Set.\\ unacknowledgedTxIdsSet)) + (unknownTxs `Set.isSubsetOf` unacknowledgedTxIdsSet) + + .&&. counterexample ("availableTxs is not a subset of unacknowledgedTxIds: " + ++ show (availableTxIdsSet Set.\\ unacknowledgedTxIdsSet)) + (availableTxIdsSet `Set.isSubsetOf` unacknowledgedTxIdsSet) + + .&&. counterexample ("unacknowledged tx must be either available, unknown or buffered: " + ++ show (unacknowledgedTxIdsSet + Set.\\ availableTxIdsSet + Set.\\ unknownTxs + Set.\\ bufferedTxsSet)) + (unacknowledgedTxIdsSet + Set.\\ availableTxIdsSet + Set.\\ unknownTxs + `Set.isSubsetOf` + bufferedTxsSet + ) + + .&&. counterexample "requestedTxIdsInflight invariant violation" + (requestedTxIdsInflight >= 0) + + -- a requested tx is either available or buffered + .&&. counterexample ("requestedTxsInflight invariant violation: " + ++ show (requestedTxsInflight + Set.\\ availableTxIdsSet + Set.\\ bufferedTxsSet)) + (requestedTxsInflight Set.\\ availableTxIdsSet `Set.isSubsetOf` bufferedTxsSet) + + .&&. counterexample "requestedTxsInfightSize" + (requestedTxsInflightSize + === + fold (availableTxIds `Map.restrictKeys` requestedTxsInflight)) + + where + availableTxIdsSet :: Set txid + availableTxIdsSet = Map.keysSet availableTxIds + + unacknowledgedTxIdsSet :: Set txid + unacknowledgedTxIdsSet = Set.fromList (toList unacknowledgedTxIds) + + bufferedTxsSet = Map.keysSet bufferedTxs :: Set txid + liveSet = Map.keysSet referenceCounts :: Set txid + txStates = Map.elems peerTxStates :: [PeerTxState txid tx] + +-- +-- Generate `InboundState` +-- + +-- | PeerTxState generator. +-- +-- `mkArbPeerTxState` is the smart constructor. +-- +data ArbPeerTxState txid tx = + ArbPeerTxState { arbPeerTxState :: PeerTxState txid tx, + arbInflightSet :: Set tx, + -- ^ in-flight txs + arbBufferedMap :: Map txid (Maybe tx) + } + +data TxStatus = Available | Inflight | Unknown + +instance Arbitrary TxStatus where + arbitrary = oneof [ pure Available + , pure Inflight + , pure Unknown + ] + +data TxMask tx = TxAvailable tx TxStatus + -- ^ available txid with its size, the Bool indicates if it's + -- in-flight or not + | TxBuffered tx + +fixupTxMask :: txid -> TxMask (Tx txid) -> TxMask (Tx txid) +fixupTxMask txid (TxAvailable tx status) = TxAvailable tx { getTxId = txid } status +fixupTxMask txid (TxBuffered tx) = TxBuffered tx { getTxId = txid } + + +instance Arbitrary tx => Arbitrary (TxMask tx) where + arbitrary = oneof [ TxAvailable + <$> arbitrary + <*> arbitrary + , TxBuffered <$> arbitrary + ] + + -- TODO: implement shrinker; this can be done by writing an inverse of + -- `mkArbPeerTxState` and shrinking the unacknowledged txs & mask map. + + +-- | Smart constructor for `ArbPeerTxState`. +-- +mkArbPeerTxState :: Ord txid + => Fun txid Bool + -> Int -- ^ txids in-flight + -> [txid] + -> Map txid (TxMask (Tx txid)) + -> ArbPeerTxState txid (Tx txid) +mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMaskMap = + ArbPeerTxState + PeerTxState { unacknowledgedTxIds = StrictSeq.fromList unacked, + availableTxIds, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize, + unknownTxs } + (Set.fromList $ Map.elems inflightMap) + bufferedMap + where + mempoolHasTx = apply mempoolHasTxFun + availableTxIds = Map.fromList + [ (txid, getTxSize tx) | (txid, TxAvailable tx _) <- Map.assocs txMaskMap + , not (mempoolHasTx txid) + ] + unknownTxs = Set.fromList + [ txid | (txid, TxAvailable _ Unknown) <- Map.assocs txMaskMap + , not (mempoolHasTx txid) + ] + + requestedTxIdsInflight = fromIntegral txIdsInflight + requestedTxsInflightSize = foldMap getTxSize inflightMap + requestedTxsInflight = Map.keysSet inflightMap + + -- exclude `txid`s which are already in the mempool, we never request such + -- `txid`s + -- + -- TODO: this should be lifted, we might have the same txid in-flight from + -- multiple peers, one will win the race and land in the mempool first + inflightMap = Map.fromList + [ (txid, tx) + | (txid, TxAvailable tx Inflight) <- Map.assocs txMaskMap + , not (mempoolHasTx txid) + ] + + bufferedMap = Map.fromList + [ (txid, Nothing) + | txid <- Map.keys txMaskMap + , mempoolHasTx txid + ] + `Map.union` + Map.fromList + [ (txid, mtx) + | (txid, TxBuffered tx) <- Map.assocs txMaskMap + , let !mtx = if mempoolHasTx txid + then Nothing + else Just $! tx { getTxId = txid } + ] + + +genArbPeerTxState + :: forall txid. + ( Arbitrary txid + , Ord txid + ) + => Fun txid Bool + -> Int -- ^ max txids inflight + -> Gen (ArbPeerTxState txid (Tx txid)) +genArbPeerTxState mempoolHasTxFun maxTxIdsInflight = do + -- unacknowledged sequence + unacked <- arbitrary + -- generate `Map txid (TxMask tx)` + txIdsInflight <- choose (0, maxTxIdsInflight) + txMap <- Map.fromList + <$> traverse (\txid -> (\a -> (txid, fixupTxMask txid a)) <$> arbitrary) + (nub unacked) + return $ mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMap + + +genSharedTxState + :: forall txid. + ( Arbitrary txid + , Ord txid + , Function txid + , CoArbitrary txid + ) + => Int -- ^ max txids inflight + -> Gen ( Fun txid Bool + , (PeerAddr, PeerTxState txid (Tx txid)) + , SharedTxState PeerAddr txid (Tx txid) + , Map PeerAddr (ArbPeerTxState txid (Tx txid)) + ) +genSharedTxState maxTxIdsInflight = do + _mempoolHasTxFun@(Fun (_, _, x) _) <- arbitrary :: Gen (Fun Bool Bool) + let mempoolHasTxFun = Fun (function (const False), False, x) (const False) + pss <- listOf1 (genArbPeerTxState mempoolHasTxFun maxTxIdsInflight) + + let pss' :: [(PeerAddr, ArbPeerTxState txid (Tx txid))] + pss' = [0..] `zip` pss + + peer <- choose (0, length pss - 1) + + let st :: SharedTxState PeerAddr txid (Tx txid) + st = fixupSharedTxState + (apply mempoolHasTxFun) + SharedTxState { + peerTxStates = Map.fromList + [ (peeraddr, arbPeerTxState) + | (peeraddr, ArbPeerTxState { arbPeerTxState }) + <- pss' + ], + inflightTxs = foldl' (Map.unionWith (+)) Map.empty + [ Map.fromSet (const 1) (Set.map getTxId arbInflightSet) + | ArbPeerTxState { arbInflightSet } + <- pss + ], + inflightTxsSize = 0, -- It is set by fixupSharedTxState + bufferedTxs = fold + [ arbBufferedMap + | ArbPeerTxState { arbBufferedMap } + <- pss + ], + referenceCounts = Map.empty + } + + return ( mempoolHasTxFun + , (peer, peerTxStates st Map.! peer) + , st + , Map.fromList pss' + ) + + +-- | Make sure `SharedTxState` is well formed. +-- +fixupSharedTxState + :: Ord txid + => (txid -> Bool) -- ^ mempoolHasTx + -> SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx +fixupSharedTxState _mempoolHasTx st@SharedTxState { peerTxStates } = + st { peerTxStates = peerTxStates', + inflightTxs = inflightTxs', + inflightTxsSize = foldMap requestedTxsInflightSize peerTxStates', + bufferedTxs = bufferedTxs', + referenceCounts = referenceCounts' + } + where + peerTxStates' = + Map.map (\ps@PeerTxState { availableTxIds, + requestedTxsInflight } -> + + let -- requested txs must not be buffered + requestedTxsInflight' = requestedTxsInflight + Set.\\ Map.keysSet bufferedTxs' + requestedTxsInflightSize' = fold $ availableTxIds + `Map.restrictKeys` + requestedTxsInflight' + + in ps { requestedTxsInflight = requestedTxsInflight', + requestedTxsInflightSize = requestedTxsInflightSize' } + ) + peerTxStates + + inflightTxs' = foldr (\PeerTxState { requestedTxsInflight } m -> + Map.unionWith (+) + (Map.fromSet (const 1) requestedTxsInflight) + m + ) + Map.empty + peerTxStates' + + bufferedTxs' = + bufferedTxs st + `Map.restrictKeys` + foldr (\PeerTxState {unacknowledgedTxIds = unacked } r -> + r <> Set.fromList (toList unacked)) + Set.empty (Map.elems peerTxStates) + + + referenceCounts' = + foldl' + (\m PeerTxState { unacknowledgedTxIds } -> + foldl' + (flip $ + Map.alter (\case + Nothing -> Just $! 1 + Just cnt -> Just $! succ cnt) + ) + m + unacknowledgedTxIds + ) + Map.empty + (Map.elems peerTxStates) + + +shrinkSharedTxState :: ( Arbitrary txid + , Ord txid + , Function txid + , Ord peeraddr + ) + => (txid -> Bool) + -> SharedTxState peeraddr txid (Tx txid) + -> [SharedTxState peeraddr txid (Tx txid)] +shrinkSharedTxState mempoolHasTx st@SharedTxState { peerTxStates, + inflightTxs, + bufferedTxs } = + [ st' + | peerTxStates' <- Map.fromList <$> shrinkList (\_ -> []) (Map.toList peerTxStates) + , not (Map.null peerTxStates') + , let st' = fixupSharedTxState mempoolHasTx st { peerTxStates = peerTxStates' } + , st' /= st + ] + ++ + [ fixupSharedTxState mempoolHasTx st { inflightTxs = inflightTxs' } + | inflightTxs' <- Map.fromList <$> shrinkList (\_ -> []) (Map.toList inflightTxs) + ] + ++ + [ st + | bufferedTxs' <- Map.fromList + <$> shrinkList (\_ -> []) (Map.assocs bufferedTxs) + , let minBuffered = + foldMap + (\PeerTxState { + unacknowledgedTxIds, + availableTxIds, + unknownTxs + } + -> + Set.fromList (toList unacknowledgedTxIds) + Set.\\ Map.keysSet availableTxIds + Set.\\ unknownTxs + ) + peerTxStates + bufferedTxs'' = bufferedTxs' + `Map.union` + (bufferedTxs `Map.restrictKeys` minBuffered) + st' = fixupSharedTxState mempoolHasTx st { bufferedTxs = bufferedTxs'' } + , st' /= st + ] + +-- +-- Arbitrary `SharaedTxState` instance +-- + +data ArbSharedTxState = + ArbSharedTxState + (Fun TxId Bool) + (SharedTxState PeerAddr TxId (Tx TxId)) + deriving Show + +instance Arbitrary ArbSharedTxState where + arbitrary = do + Small maxTxIdsInflight <- arbitrary + (mempoolHasTx, _, sharedTxState, _) <- genSharedTxState maxTxIdsInflight + return $ ArbSharedTxState mempoolHasTx sharedTxState + + shrink (ArbSharedTxState mempoolHasTx st) = + [ ArbSharedTxState mempoolHasTx st' + | st' <- shrinkSharedTxState (apply mempoolHasTx) st + ] + + +-- | Verify that generated `SharedTxState` has no thunks if it's evaluated to +-- WHNF. +-- +prop_SharedTxState_nothunks :: ArbSharedTxState -> Property +prop_SharedTxState_nothunks (ArbSharedTxState _ !st) = + case unsafeNoThunks st of + Nothing -> property True + Just ctx -> counterexample (show ctx) False + + +prop_SharedTxState_generator + :: ArbSharedTxState + -> Property +prop_SharedTxState_generator (ArbSharedTxState _ st) = sharedTxStateInvariant st + + +prop_SharedTxState_shrinker + :: Fixed ArbSharedTxState + -> Property +prop_SharedTxState_shrinker = + property + . foldMap (\(ArbSharedTxState _ st) -> All $ sharedTxStateInvariant st) + . shrink + . getFixed + + +-- +-- `receivedTxIdsImpl` properties +-- + + +data ArbReceivedTxIds = + ArbReceivedTxIds (Fun TxId Bool) -- ^ mempoolHasTx + [Tx TxId] -- ^ some txs to acknowledge + PeerAddr -- ^ peer address + (PeerTxState TxId (Tx TxId)) + -- ^ peer state + (SharedTxState PeerAddr TxId (Tx TxId)) + -- ^ initial state + deriving Show + +instance Arbitrary ArbReceivedTxIds where + arbitrary = do + Small maxTxIdsInflight <- arbitrary + (mempoolHasTxFun, (peeraddr, ps), st, psMap) <- genSharedTxState maxTxIdsInflight + txsToAck <- sublistOf (Set.toList $ arbInflightSet (psMap Map.! peeraddr)) + pure $ ArbReceivedTxIds + mempoolHasTxFun + txsToAck + peeraddr + ps + st + + shrink (ArbReceivedTxIds mempoolHasTxFun txs peeraddr ps st) = + [ ArbReceivedTxIds mempoolHasTxFun txs' peeraddr ps st + | txs' <- shrink txs + ] + ++ + [ ArbReceivedTxIds + mempoolHasTxFun' txs peeraddr ps + (fixupSharedTxState (apply mempoolHasTxFun') st) + | mempoolHasTxFun' <- shrink mempoolHasTxFun + ] + + +prop_receivedTxIds_generator + :: ArbReceivedTxIds + -> Property +prop_receivedTxIds_generator (ArbReceivedTxIds _ someTxsToAck _peeraddr _ps st) = + label ("numToAck " ++ labelInt 100 10 (length someTxsToAck)) + . counterexample (show st) + $ sharedTxStateInvariant st + + +-- | This property verifies that `acknowledgeTxIds` acknowledges a prefix of +-- unacknowledged txs, and that the `numTxIdsToAck` as well as `RefCoundDiff` +-- are correct. +-- +-- It doesn't validate the returned `PeerTxState` holds it's properties as this +-- needs to be done in the context of updated `SharedTxState`. This is verified +-- by `prop_receivedTxIdsImpl`, `prop_collectTxsImpl` and +-- `prop_makeDecisions_acknowledged`. +-- +prop_acknowledgeTxIds :: ArbReceivedTxIds + -> Property +prop_acknowledgeTxIds (ArbReceivedTxIds _mempoolHasTxFun _txs _peeraddr ps st) = + case TXS.acknowledgeTxIds st ps of + (numTxIdsToAck, txs, TXS.RefCountDiff { TXS.txIdsToAck }, ps') -> + counterexample "number of tx ids to ack must agree with RefCountDiff" + ( fromIntegral numTxIdsToAck + === + getSum (foldMap Sum txIdsToAck) + ) + + .&&. counterexample "acknowledged txs must form a prefix" + let unacked = toList (unacknowledgedTxIds ps) + unacked' = toList (unacknowledgedTxIds ps') + in case unacked `stripSuffix` unacked' of + Nothing -> counterexample "acknowledged txs are not a prefix" False + Just txIdsToAck' -> + txIdsToAck + === + Map.fromListWith (+) ((,1) <$> txIdsToAck') + + .&&. counterexample "acknowledged txs" (counterexample ("numTxIdsToAck = " ++ show numTxIdsToAck) + let acked :: [TxId] + acked = [ txid + | txid <- take (fromIntegral numTxIdsToAck) (toList $ unacknowledgedTxIds ps) + , Just _ <- maybeToList $ txid `Map.lookup` bufferedTxs st + ] + in getTxId `map` txs === acked) + where + stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] + stripSuffix as suffix = + reverse <$> reverse suffix `stripPrefix` reverse as + + +-- | Verify that `hasTxIdsToAcknowledge` and `acknowledgeTxIds` are compatible. +-- +prop_hasTxIdsToAcknowledge + :: ArbReceivedTxIds + -> Property +prop_hasTxIdsToAcknowledge (ArbReceivedTxIds _mempoolHasTxFun _txs _peeraddr ps st) = + case ( TXS.hasTxIdsToAcknowledge st ps + , TXS.acknowledgeTxIds st ps + ) of + (canAck, (numTxIdsToAck, _, _, _)) -> + canAck === (numTxIdsToAck > 0) + + +-- | Verify 'inboundStateInvariant' when acknowledging a sequence of txs. +-- +prop_receivedTxIdsImpl + :: ArbReceivedTxIds + -> Property +prop_receivedTxIdsImpl (ArbReceivedTxIds mempoolHasTxFun txs peeraddr ps st) = + -- InboundState invariant + counterexample + ( "Unacknowledged in mempool: " ++ + show (apply mempoolHasTxFun <$> toList (unacknowledgedTxIds ps)) ++ "\n" + ++ "InboundState invariant violation:\n" ++ + show st' + ) + (sharedTxStateInvariant st') + + -- unacknowledged txs are well formed + .&&. counterexample "unacknowledged txids are not well formed" + ( let unacked = toList $ unacknowledgedTxIds ps <> txidSeq + unacked' = toList $ unacknowledgedTxIds ps' + in counterexample ("old & received: " ++ show unacked ++ "\n" ++ + "new: " ++ show unacked') $ + unacked' `isSuffixOf` unacked + ) + + .&&. -- `receivedTxIdsImpl` doesn't acknowledge any `txids` + counterexample "acknowledged property violation" + ( let unacked = toList $ unacknowledgedTxIds ps + unacked' = toList $ unacknowledgedTxIds ps' + in unacked `isPrefixOf` unacked' + ) + where + st' = TXS.receivedTxIdsImpl (apply mempoolHasTxFun) + peeraddr 0 txidSeq txidMap st + ps' = peerTxStates st' Map.! peeraddr + + txidSeq = StrictSeq.fromList (getTxId <$> txs) + txidMap = Map.fromList [ (getTxId tx, getTxSize tx) | tx <- txs ] + + +-- | Verify that `SharedTxState` returned by `receivedTxIdsImpl` if evaluated +-- to WHNF it doesn't contain any thunks. +-- +prop_receivedTxIdsImpl_nothunks + :: ArbReceivedTxIds + -> Property +prop_receivedTxIdsImpl_nothunks (ArbReceivedTxIds mempoolHasTxFun txs peeraddr _ st) = + case TXS.receivedTxIdsImpl (apply mempoolHasTxFun) + peeraddr 0 txidSeq txidMap st of + !st' -> case unsafeNoThunks st' of + Nothing -> property True + Just ctx -> counterexample (show ctx) False + where + txidSeq = StrictSeq.fromList (getTxId <$> txs) + txidMap = Map.fromList [ (getTxId tx, getTxSize tx) | tx <- txs ] + + +-- +-- `collectTxs` properties +-- + + +data ArbCollectTxs = + ArbCollectTxs (Fun TxId Bool) -- ^ mempoolHasTx + (Set TxId) -- ^ requested txid's + (Map TxId (Tx TxId)) -- ^ received txs + PeerAddr -- ^ peeraddr + (PeerTxState TxId (Tx TxId)) + (SharedTxState PeerAddr TxId (Tx TxId)) + -- ^ 'InboundState' + deriving Show + + +instance Arbitrary ArbCollectTxs where + arbitrary = do + Small maxTxIdsInflight <- arbitrary + ( mempoolHasTxFun + , (peeraddr, ps@PeerTxState { availableTxIds, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize }) + , st + , _ + ) + <- genSharedTxState maxTxIdsInflight + requestedTxIds <- take (fromIntegral requestedTxIdsInflight) + <$> sublistOf (toList requestedTxsInflight) + + -- Limit the requested `txid`s to satisfy `requestedTxsInflightSize`. + let requestedTxIds' = fmap fst + . takeWhile (\(_,s) -> s <= requestedTxsInflightSize) + $ zip requestedTxIds + (scanl1 (<>) [availableTxIds Map.! txid | txid <- requestedTxIds ]) + + receivedTx <- sublistOf requestedTxIds' + >>= traverse (\txid -> do + valid <- frequency [(4, pure True), (1, pure False)] + pure $ Tx { getTxId = txid, + getTxSize = availableTxIds Map.! txid, + getTxValid = valid }) + + pure $ assert (foldMap getTxSize receivedTx <= requestedTxsInflightSize) + $ ArbCollectTxs mempoolHasTxFun + (Set.fromList requestedTxIds') + (Map.fromList [ (getTxId tx, tx) | tx <- receivedTx ]) + peeraddr + ps + st + + shrink (ArbCollectTxs mempoolHasTx requestedTxs receivedTxs peeraddr ps st) = + [ ArbCollectTxs mempoolHasTx + requestedTxs' + (receivedTxs `Map.restrictKeys` requestedTxs') + peeraddr ps st + | requestedTxs' <- Set.fromList <$> shrinkList (\_ -> []) (Set.toList requestedTxs) + ] + ++ + [ ArbCollectTxs mempoolHasTx + requestedTxs + (receivedTxs `Map.restrictKeys` receivedTxIds) + peeraddr ps st + | receivedTxIds <- Set.fromList <$> shrinkList (\_ -> []) (Map.keys receivedTxs) + ] + ++ + [ ArbCollectTxs mempoolHasTx + (requestedTxs + `Set.intersection` unacked + `Set.intersection` inflightTxSet) + (receivedTxs + `Map.restrictKeys` unacked + `Map.restrictKeys` inflightTxSet) + peeraddr ps + st' + | let unacked = Set.fromList + . toList + . unacknowledgedTxIds + $ ps + , st'@SharedTxState { inflightTxs } <- shrinkSharedTxState (apply mempoolHasTx) st + , let inflightTxSet = Map.keysSet inflightTxs + , peeraddr `Map.member` peerTxStates st' + , st' /= st + ] + + +prop_collectTxs_generator + :: ArbCollectTxs + -> Property +prop_collectTxs_generator (ArbCollectTxs _ requestedTxIds receivedTxs peeraddr + ps@PeerTxState { availableTxIds, + requestedTxsInflightSize } + st) = + counterexample "size of requested txs must not be larger than requestedTxsInflightSize" + (requestedSize <= requestedTxsInflightSize) + .&&. counterexample "inflightTxsSize must be greater than requestedSize" + (inflightTxsSize st >= requestedSize) + .&&. counterexample ("receivedTxs must be a subset of requestedTxIds " + ++ show (Map.keysSet receivedTxs Set.\\ requestedTxIds)) + (Map.keysSet receivedTxs `Set.isSubsetOf` requestedTxIds) + .&&. counterexample "peerTxState" + (Map.lookup peeraddr (peerTxStates st) === Just ps) + where + requestedSize = fold (availableTxIds `Map.restrictKeys` requestedTxIds) + + +prop_collectTxs_shrinker + :: Fixed ArbCollectTxs + -- ^ disabled shrinking + -> Property +prop_collectTxs_shrinker (Fixed txs) = + property $ foldMap (\a@(ArbCollectTxs _ _ _ _ _ st) -> + All . counterexample (show st) $ + f a =/= f txs + .&&. sharedTxStateInvariant st + ) (shrink txs) + where + f (ArbCollectTxs _ reqSet recvMap peeraddr ps st) = (reqSet, recvMap, peeraddr, ps, st) + + +-- | Verify `collectTxsImpl` properties: +-- +-- * verify `SharedTxState` invariant; +-- * unacknowledged txids after `collectTxsImpl` must be a suffix of the +-- original ones; +-- * progress property: we acknowledge as many `txid`s as possible +-- +prop_collectTxsImpl + :: ArbCollectTxs + -> Property +prop_collectTxsImpl (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived peeraddr ps st) = + + label ("number of txids inflight " ++ labelInt 25 5 (Map.size $ inflightTxs st)) $ + label ("number of txids requested " ++ labelInt 25 5 (Set.size txidsRequested)) $ + label ("number of txids received " ++ labelInt 10 2 (Map.size txsReceived)) $ + + -- InboundState invariant + counterexample + ( "InboundState invariant violation:\n" ++ show st' ++ "\n" + ++ show ps' + ) + (sharedTxStateInvariant st') + + .&&. + -- `collectTxsImpl` doesn't modify unacknowledged TxId's + counterexample "acknowledged property violation" + ( let unacked = toList $ unacknowledgedTxIds ps + unacked' = toList $ unacknowledgedTxIds ps' + in unacked === unacked' + ) + where + st' = TXS.collectTxsImpl peeraddr txidsRequested txsReceived st + ps' = peerTxStates st' Map.! peeraddr + + +-- | Verify that `SharedTxState` returned by `collectTxsImpl` if evaluated to +-- WHNF, it doesn't contain any thunks. +-- +prop_collectTxsImpl_nothunks + :: ArbCollectTxs + -> Property +prop_collectTxsImpl_nothunks (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived peeraddr _ st) = + case unsafeNoThunks $! st' of + Nothing -> property True + Just ctx -> counterexample (show ctx) False + where + st' = TXS.collectTxsImpl peeraddr txidsRequested txsReceived st + + +newtype ArbTxDecisionPolicy = ArbTxDecisionPolicy TxDecisionPolicy + deriving Show + +instance Arbitrary ArbTxDecisionPolicy where + arbitrary = + ArbTxDecisionPolicy . fixupTxDecisionPolicy + <$> ( TxDecisionPolicy + <$> (getSmall <$> arbitrary) + <*> (getSmall <$> arbitrary) + <*> (SizeInBytes . getPositive <$> arbitrary) + <*> (SizeInBytes . getPositive <$> arbitrary) + <*> (getPositive <$> arbitrary)) + + shrink (ArbTxDecisionPolicy a@TxDecisionPolicy { + maxNumTxIdsToRequest, + txsSizeInflightPerPeer, + maxTxsSizeInflight, + txInflightMultiplicity }) = + [ ArbTxDecisionPolicy a { maxNumTxIdsToRequest = NumTxIdsToReq x } + | x <- shrink (getNumTxIdsToReq maxNumTxIdsToRequest) + ] + ++ + [ ArbTxDecisionPolicy . fixupTxDecisionPolicy + $ a { txsSizeInflightPerPeer = SizeInBytes s } + | s <- shrink (getSizeInBytes txsSizeInflightPerPeer) + ] + ++ + [ ArbTxDecisionPolicy . fixupTxDecisionPolicy + $ a { maxTxsSizeInflight = SizeInBytes s } + | s <- shrink (getSizeInBytes maxTxsSizeInflight) + ] + ++ + [ ArbTxDecisionPolicy . fixupTxDecisionPolicy + $ a { txInflightMultiplicity = x } + | Positive x <- shrink (Positive 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 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'' + + +-- | `filterActivePeers` should not change decisions made by `makeDecisions` +-- +-- +-- This test checks the following properties: +-- +-- In what follows, the set of active peers is defined as the keys of the map +-- returned by `filterActivePeers`. +-- +-- 1. The set of active peers is a superset of peers for which a decision was +-- made; +-- 2. The set of active peer which can acknowledge txids is a subset of peers +-- for which a decision was made; +-- 3. Decisions made from the results of `filterActivePeers` is the same as from +-- the original set. +-- +-- Ad 2. a stronger property is not possible. There can be a peer for which +-- a decision was not taken but which is an active peer. +-- +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 ("found non-active peers for which decision can be made: " + ++ show (decisionPeers Set.\\ activePeers) + ) + (decisionPeers `Set.isSubsetOf` activePeers) + .&&. + counterexample ("found an active peer which can acknowledge txids " + ++ "for which decision was not made: " + ++ show (activePeersAck Set.\\ decisionPeers)) + (activePeersAck `Set.isSubsetOf` decisionPeers) + .&&. + counterexample "decisions from active peers are not equal to decisions from all peers" + (decisions === decisionsOfActivePeers) + where + activePeersMap = TXS.filterActivePeers policy st + activePeers = Map.keysSet activePeersMap + -- peers which are active & can acknowledge txids + activePeersAck = activePeers + `Set.intersection` + Map.keysSet (Map.filter (TXS.hasTxIdsToAcknowledge st) (peerTxStates st)) + (_, 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/TxSubmissionV1.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV1.hs new file mode 100644 index 00000000000..4c6f0dc3447 --- /dev/null +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV1.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.TxSubmissionV1 (tests) where + +import Prelude hiding (seq) + +import NoThunks.Class + +import Control.Concurrent.Class.MonadMVar (MonadMVar) +import Control.Concurrent.Class.MonadSTM +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadSay +import Control.Monad.Class.MonadST +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI +import Control.Monad.IOSim hiding (SimResult) +import Control.Tracer (Tracer (..), contramap, nullTracer) + +import Data.ByteString.Lazy qualified as BSL +import Data.Function (on) +import Data.List (intercalate, nubBy) +import Data.Maybe (fromMaybe) +import Data.Word (Word16) + +import Ouroboros.Network.Channel +import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM) +import Ouroboros.Network.Driver +import Ouroboros.Network.NodeToNode (NodeToNodeVersion (..)) +import Ouroboros.Network.Protocol.TxSubmission2.Client +import Ouroboros.Network.Protocol.TxSubmission2.Codec +import Ouroboros.Network.Protocol.TxSubmission2.Server +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound +import Ouroboros.Network.TxSubmission.Outbound +import Ouroboros.Network.Util.ShowProxy + + +import Test.QuickCheck +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Test.Ouroboros.Network.TxSubmission.Common hiding (tests) +import Test.Ouroboros.Network.Utils + + +tests :: TestTree +tests = testGroup "Ouroboros.Network.TxSubmission.TxSubmissionV1" + [ testProperty "txSubmission" prop_txSubmission + ] + +txSubmissionSimulation + :: forall m txid. + ( MonadAsync m + , MonadDelay m + , MonadFork m + , MonadMask m + , MonadMVar m + , MonadSay m + , MonadST m + , MonadSTM m + , MonadTimer m + , MonadThrow m + , MonadThrow (STM m) + , MonadMonotonicTime m + , Ord txid + , Eq txid + , ShowProxy txid + , NoThunks (Tx txid) + + , txid ~ Int + ) + => Tracer m (String, TraceSendRecv (TxSubmission2 txid (Tx txid))) + -> NumTxIdsToAck + -> [Tx txid] + -> ControlMessageSTM m + -> Maybe DiffTime + -> Maybe DiffTime + -> m ([Tx txid], [Tx txid]) +txSubmissionSimulation tracer maxUnacked outboundTxs + controlMessageSTM + inboundDelay outboundDelay = do + + inboundMempool <- emptyMempool + outboundMempool <- newMempool outboundTxs + (outboundChannel, inboundChannel) <- createConnectedChannels + outboundAsync <- + async $ runPeerWithLimits + (("OUTBOUND",) `contramap` tracer) + txSubmissionCodec2 + (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) + timeLimitsTxSubmission2 + (maybe id delayChannel outboundDelay outboundChannel) + (txSubmissionClientPeer (outboundPeer outboundMempool)) + + inboundAsync <- + async $ runPipelinedPeerWithLimits + (("INBOUND",) `contramap` verboseTracer) + txSubmissionCodec2 + (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) + timeLimitsTxSubmission2 + (maybe id delayChannel inboundDelay inboundChannel) + (txSubmissionServerPeerPipelined (inboundPeer inboundMempool)) + + _ <- waitAnyCancel [ outboundAsync, inboundAsync ] + + inmp <- readMempool inboundMempool + outmp <- readMempool outboundMempool + return (inmp, outmp) + where + + outboundPeer :: Mempool m txid -> TxSubmissionClient txid (Tx txid) m () + outboundPeer outboundMempool = + txSubmissionOutbound + nullTracer + maxUnacked + (getMempoolReader outboundMempool) + (maxBound :: NodeToNodeVersion) + controlMessageSTM + + inboundPeer :: Mempool m txid -> TxSubmissionServerPipelined txid (Tx txid) m () + inboundPeer inboundMempool = + txSubmissionInbound + nullTracer + 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/TxSubmissionV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs new file mode 100644 index 00000000000..5acdfe41f1b --- /dev/null +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Ouroboros.Network.TxSubmission.TxSubmissionV2 (tests) where + +import Prelude hiding (seq) + +import NoThunks.Class + +import Control.Concurrent.Class.MonadMVar (MonadMVar) +import Control.Concurrent.Class.MonadMVar.Strict qualified as Strict +import Control.Concurrent.Class.MonadSTM +import Control.Concurrent.Class.MonadSTM.Strict (StrictTVar) +import Control.Concurrent.Class.MonadSTM.Strict qualified as 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, nullTracer) + + +import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lazy qualified as BSL +import Data.Function (on) +import Data.List (intercalate, nubBy) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Void (Void) +import Data.Word (Word16) + +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.Snocket (TestAddress (..)) +import Ouroboros.Network.TxSubmission.Inbound.Policy +import Ouroboros.Network.TxSubmission.Inbound.Registry +import Ouroboros.Network.TxSubmission.Inbound.Server (txSubmissionInboundV2) +import Ouroboros.Network.TxSubmission.Inbound.State +import Ouroboros.Network.TxSubmission.Outbound +import Ouroboros.Network.Util.ShowProxy + +import Test.Ouroboros.Network.TxSubmission.Common hiding (tests) +import Test.Ouroboros.Network.Utils + +import Test.QuickCheck +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + + +tests :: TestTree +tests = testGroup "Ouroboros.Network.TxSubmission.TxSubmissionV2" + [ 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))) + -> Tracer m (DebugSharedTxState (TestAddress Int) txid (Tx txid)) + -> NumTxIdsToAck + -> [Tx txid] + -> ControlMessageSTM m + -> Maybe DiffTime + -> Maybe DiffTime + -> m ([Tx txid], [Tx txid]) +txSubmissionSimulation tracer tracerDST maxUnacked outboundTxs + controlMessageSTM + inboundDelay outboundDelay = do + + inboundMempool <- emptyMempool + outboundMempool <- newMempool outboundTxs + (outboundChannel, inboundChannel) <- createConnectedChannels + + txChannelsMVar <- Strict.newMVar (TxChannels Map.empty) + sharedTxStateVar <- newSharedTxStateVar + gsvVar <- Strict.newTVarIO Map.empty + + asyncs <- runTxSubmission [(TestAddress 0, outboundChannel, inboundChannel)] + txChannelsMVar + sharedTxStateVar + (outboundMempool, inboundMempool) + gsvVar + undefined + (pure . snd) + + _ <- waitAnyCancel asyncs + + inmp <- readMempool inboundMempool + outmp <- readMempool outboundMempool + return (inmp, outmp) + where + + runTxSubmission :: [(TestAddress Int, Channel m ByteString, Channel m ByteString)] + -> TxChannelsVar m (TestAddress Int) txid (Tx txid) + -> SharedTxStateVar m (TestAddress Int) txid (Tx txid) + -> (Mempool m txid, Mempool m txid) + -> StrictTVar m (Map (TestAddress Int) PeerGSV) + -> TxDecisionPolicy + -> ((Async m Void, [Async m ((), Maybe ByteString)]) -> m b) + -> m b + runTxSubmission addrs txChannelsVar sharedTxStateVar + (outboundMempool, inboundMempool) gsvVar txDecisionPolicy k = + withAsync (decisionLogicThread tracerDST txDecisionPolicy gsvVar txChannelsVar sharedTxStateVar) $ \a -> do + -- Construct txSubmission outbound client + let clients = + (\(addr, outboundChannel, _) -> + ( addr + , outboundChannel + , txSubmissionOutbound nullTracer + maxUnacked + (getMempoolReader outboundMempool) + (maxBound :: NodeToNodeVersion) + controlMessageSTM + )) <$> addrs + + -- Construct txSubmission inbound server + servers <- forM addrs + (\(addr, _, inboundChannel) -> + withPeer + tracerDST + txChannelsVar + sharedTxStateVar + (getMempoolReader inboundMempool) + addr $ \api -> + pure $ + ( addr + , inboundChannel + , txSubmissionInboundV2 nullTracer + (getMempoolWriter inboundMempool) + api + ) + ) + + -- Construct txSubmission outbound client miniprotocol peer runner + let runPeerClients = + (\(_, channel, client) -> + runPeerWithLimits + (("OUTBOUND",) `contramap` tracer) + txSubmissionCodec2 + (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) + timeLimitsTxSubmission2 + (maybe id delayChannel outboundDelay channel) + (txSubmissionClientPeer client)) + <$> clients + -- Construct txSubmission inbound server miniprotocol peer runner + runPeerServers = + (\(addr, channel, server) -> + runPipelinedPeerWithLimits + (("INBOUND " ++ show addr,) `contramap` verboseTracer) + txSubmissionCodec2 + (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) + timeLimitsTxSubmission2 + (maybe id delayChannel inboundDelay channel) + (txSubmissionServerPeerPipelined server)) + <$> servers + + -- Run clients and servers + withAsyncAll (runPeerClients ++ runPeerServers) (\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) + + +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 + 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 From 191abcbe3dcddc0c0adfdc829e5d39dd9f55b937 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Tue, 10 Sep 2024 14:48:49 +0100 Subject: [PATCH 09/54] tx-submission: fixed ArbTxDecisionPolicy generator Refactored SimResult name to not clash with IOSim's. --- .../src/Ouroboros/Network/SizeInBytes.hs | 1 + .../Ouroboros/Network/TxSubmission/Common.hs | 25 +++++++++++-------- 2 files changed, 15 insertions(+), 11 deletions(-) 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/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs index dc7d99b6cdf..440e676f524 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs @@ -257,13 +257,13 @@ instance Arbitrary a => Arbitrary (LargeNonEmptyList a) where -- TODO: Belongs in iosim. -data SimResult a = SimReturn a [String] - | SimException SomeException [String] - | SimDeadLock [String] +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 (SimResult a) +evaluateTrace :: SimTrace a -> IO (SimResults a) evaluateTrace = go [] where go as tr = do @@ -300,6 +300,9 @@ verboseTracer :: forall a m. => 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 @@ -1115,11 +1118,11 @@ instance Arbitrary ArbTxDecisionPolicy where arbitrary = ArbTxDecisionPolicy . fixupTxDecisionPolicy <$> ( TxDecisionPolicy - <$> (getSmall <$> arbitrary) - <*> (getSmall <$> arbitrary) + <$> (getSmall . getPositive <$> arbitrary) + <*> (getSmall . getPositive <$> arbitrary) <*> (SizeInBytes . getPositive <$> arbitrary) <*> (SizeInBytes . getPositive <$> arbitrary) - <*> (getPositive <$> arbitrary)) + <*> (getSmall . getPositive <$> arbitrary)) shrink (ArbTxDecisionPolicy a@TxDecisionPolicy { maxNumTxIdsToRequest, @@ -1127,22 +1130,22 @@ instance Arbitrary ArbTxDecisionPolicy where maxTxsSizeInflight, txInflightMultiplicity }) = [ ArbTxDecisionPolicy a { maxNumTxIdsToRequest = NumTxIdsToReq x } - | x <- shrink (getNumTxIdsToReq maxNumTxIdsToRequest) + | (Positive (Small x)) <- shrink (Positive (Small (getNumTxIdsToReq maxNumTxIdsToRequest))) ] ++ [ ArbTxDecisionPolicy . fixupTxDecisionPolicy $ a { txsSizeInflightPerPeer = SizeInBytes s } - | s <- shrink (getSizeInBytes txsSizeInflightPerPeer) + | Positive s <- shrink (Positive (getSizeInBytes txsSizeInflightPerPeer)) ] ++ [ ArbTxDecisionPolicy . fixupTxDecisionPolicy $ a { maxTxsSizeInflight = SizeInBytes s } - | s <- shrink (getSizeInBytes maxTxsSizeInflight) + | Positive s <- shrink (Positive (getSizeInBytes maxTxsSizeInflight)) ] ++ [ ArbTxDecisionPolicy . fixupTxDecisionPolicy $ a { txInflightMultiplicity = x } - | Positive x <- shrink (Positive txInflightMultiplicity) + | Positive (Small x) <- shrink (Positive (Small txInflightMultiplicity)) ] From 2d65c411c509acaa77dbb39d46be874e392df46e Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Wed, 11 Sep 2024 10:14:10 +0100 Subject: [PATCH 10/54] tx-submission: added txSubmissionV2 simulation - Updated txSubmissionV2 test - Fixed TODO about passing an STM action inside receivedTxIds - Fixed usage of partial function `(!)` - Fixed wrong usage of MVars in decisionLogicThread that lead to deadlock. --- .../Network/TxSubmission/Inbound/Decision.hs | 21 +- .../Network/TxSubmission/Inbound/Registry.hs | 35 +- .../Network/TxSubmission/Inbound/State.hs | 13 +- .../Network/TxSubmission/TxSubmissionV2.hs | 379 +++++++++++------- 4 files changed, 278 insertions(+), 170 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs index 2bd5fc6dc75..97d8472d040 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs @@ -8,6 +8,7 @@ module Ouroboros.Network.TxSubmission.Inbound.Decision ( TxDecision (..) + , emptyTxDecision -- * Internal API exposed for testing , makeDecisions , filterActivePeers @@ -28,7 +29,8 @@ import Data.Set (Set) import Data.Set qualified as Set import Data.Sequence.Strict qualified as StrictSeq -import Ouroboros.Network.DeltaQ (PeerGSV (..), gsvRequestResponseDuration) +import Ouroboros.Network.DeltaQ (PeerGSV (..), defaultGSV, + gsvRequestResponseDuration) import Ouroboros.Network.Protocol.TxSubmission2.Type import Ouroboros.Network.TxSubmission.Inbound.Policy import Ouroboros.Network.TxSubmission.Inbound.State @@ -90,6 +92,14 @@ instance Ord txid => Semigroup (TxDecision txid tx) where txdTxsToMempool = txdTxsToMempool ++ txdTxsToMempool' } +emptyTxDecision :: TxDecision txid tx +emptyTxDecision = TxDecision { + txdTxIdsToAcknowledge = 0, + txdTxIdsToRequest = 0, + txdPipelineTxIds = False, + txdTxsToRequest = Set.empty, + txdTxsToMempool = [] + } data SharedDecisionContext peeraddr txid tx = SharedDecisionContext { -- TODO: check how to access it. @@ -148,7 +158,10 @@ orderByDeltaQ :: forall peeraddr txid tx. orderByDeltaQ dq = sortOn (\(peeraddr, _) -> gsvRequestResponseDuration - (dq Map.! peeraddr) reqSize respSize) + (Map.findWithDefault defaultGSV peeraddr dq) + reqSize + respSize + ) . Map.toList where -- according to calculations in `txSubmissionProtocolLimits`: sizes of @@ -361,8 +374,8 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, ) gn ( St { stInflight, - stInflightSize, - stAcknowledged } + stInflightSize, + stAcknowledged } , as ) = diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs index 040d605499d..b93881a7289 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -19,7 +19,6 @@ import Control.Concurrent.Class.MonadMVar.Strict import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTimer.SI -import Control.Tracer (Tracer (..), traceWith) import Data.Foldable (foldl', traverse_) import Data.Map.Strict (Map) @@ -31,6 +30,7 @@ import Data.Set (Set) import Data.Set qualified as Set import Data.Void (Void) +import Control.Tracer (Tracer, traceWith) import Ouroboros.Network.DeltaQ (PeerGSV (..)) import Ouroboros.Network.Protocol.TxSubmission2.Type import Ouroboros.Network.TxSubmission.Inbound.Decision @@ -73,6 +73,10 @@ data PeerTxAPI m txid tx = PeerTxAPI { } +data TraceDecision peeraddr txid tx = + TraceDecisions (Map peeraddr (TxDecision txid tx)) + deriving (Eq, Show) + -- | A bracket function which registers / de-registers a new peer in -- `SharedTxStateVar` and `PeerTxStateVar`s, which exposes `PeerTxStateAPI`. -- `PeerTxStateAPI` is only safe inside the `withPeer` scope. @@ -188,13 +192,10 @@ withPeer tracer -> StrictSeq txid -> Map txid SizeInBytes -> m () - handleReceivedTxIds numTxIdsToReq txidsSeq txidsMap = do - -- TODO: hide this inside `receivedTxIds` so it's run in the same STM - -- transaction. - mempoolSnapshot <- atomically mempoolGetSnapshot + handleReceivedTxIds numTxIdsToReq txidsSeq txidsMap = receivedTxIds tracer sharedStateVar - mempoolSnapshot + mempoolGetSnapshot peeraddr numTxIdsToReq txidsSeq @@ -215,16 +216,17 @@ decisionLogicThread ( MonadDelay m , MonadMVar m , MonadSTM m + , MonadMask m , Ord peeraddr , Ord txid ) => Tracer m (DebugSharedTxState peeraddr txid tx) -> TxDecisionPolicy - -> StrictTVar m (Map peeraddr PeerGSV) + -> STM m (Map peeraddr PeerGSV) -> TxChannelsVar m peeraddr txid tx -> SharedTxStateVar m peeraddr txid tx -> m Void -decisionLogicThread tracer policy gsvVar txChannelsVar sharedStateVar = go +decisionLogicThread tracer policy readGSVVar txChannelsVar sharedStateVar = go where go :: m Void go = do @@ -235,7 +237,7 @@ decisionLogicThread tracer policy gsvVar txChannelsVar sharedStateVar = go (decisions, st) <- atomically do sharedCtx <- SharedDecisionContext - <$> readTVar gsvVar + <$> readGSVVar <*> readTVar sharedStateVar let activePeers = filterActivePeers policy (sdcSharedTxState sharedCtx) @@ -245,11 +247,22 @@ decisionLogicThread tracer policy gsvVar txChannelsVar sharedStateVar = go let (sharedState, decisions) = makeDecisions policy sharedCtx activePeers writeTVar sharedStateVar sharedState return (decisions, sharedState) - traceWith tracer (DebugSharedTxState st) + traceWith tracer (DebugSharedTxState "decisionLogicThread" st) TxChannels { txChannelMap } <- readMVar txChannelsVar traverse_ - (\(mvar, d) -> modifyMVar_ mvar (\d' -> pure (d' <> d))) + (\(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/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs index 738bffef3ff..cdf64f6acb9 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs @@ -544,7 +544,7 @@ receivedTxIds (MonadSTM m, Ord txid, Ord peeraddr) => Tracer m (DebugSharedTxState peeraddr txid tx) -> SharedTxStateVar m peeraddr txid tx - -> MempoolSnapshot txid tx idx + -> STM m (MempoolSnapshot txid tx idx) -> peeraddr -> NumTxIdsToReq -- ^ number of requests to subtract from @@ -554,10 +554,11 @@ receivedTxIds -> Map txid SizeInBytes -- ^ received `txid`s with sizes -> m () -receivedTxIds tracer sharedVar MempoolSnapshot{mempoolHasTx} peeraddr reqNo txidsSeq txidsMap = do - st <- atomically $ +receivedTxIds tracer sharedVar getMempoolSnapshot peeraddr reqNo txidsSeq txidsMap = do + st <- atomically $ do + MempoolSnapshot{mempoolHasTx} <- getMempoolSnapshot stateTVar sharedVar ((\a -> (a,a)) . receivedTxIdsImpl mempoolHasTx peeraddr reqNo txidsSeq txidsMap) - traceWith tracer (DebugSharedTxState st) + traceWith tracer (DebugSharedTxState "receivedTxIds" st) -- | Include received `tx`s in `SharedTxState`. Return number of `txids` @@ -578,7 +579,7 @@ collectTxs tracer sharedVar peeraddr txidsRequested txsMap = do st <- atomically $ stateTVar sharedVar ((\a -> (a,a)) . collectTxsImpl peeraddr txidsRequested txsMap) - traceWith tracer (DebugSharedTxState st) + traceWith tracer (DebugSharedTxState "collectTxs" st) -- -- @@ -586,5 +587,5 @@ collectTxs tracer sharedVar peeraddr txidsRequested txsMap = do -- | Debug tracer. -- -newtype DebugSharedTxState peeraddr txid tx = DebugSharedTxState (SharedTxState peeraddr txid tx) +data DebugSharedTxState peeraddr txid tx = DebugSharedTxState String (SharedTxState peeraddr txid tx) deriving Show diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs index 5acdfe41f1b..8a0df2b825c 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} @@ -28,18 +29,18 @@ 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 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.List (intercalate, nubBy) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Void (Void) -import Data.Word (Word16) import Ouroboros.Network.Channel import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM) @@ -50,7 +51,6 @@ 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.Snocket (TestAddress (..)) import Ouroboros.Network.TxSubmission.Inbound.Policy import Ouroboros.Network.TxSubmission.Inbound.Registry import Ouroboros.Network.TxSubmission.Inbound.Server (txSubmissionInboundV2) @@ -59,7 +59,7 @@ import Ouroboros.Network.TxSubmission.Outbound import Ouroboros.Network.Util.ShowProxy import Test.Ouroboros.Network.TxSubmission.Common hiding (tests) -import Test.Ouroboros.Network.Utils +import Test.Ouroboros.Network.Utils hiding (debugTracer) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) @@ -71,8 +71,44 @@ tests = testGroup "Ouroboros.Network.TxSubmission.TxSubmissionV2" [ testProperty "txSubmission" prop_txSubmission ] -txSubmissionSimulation - :: forall m txid. +data TxSubmissionV2State = + TxSubmissionV2State { + peerMap :: Map Int ( [Tx Int] + , Maybe (Positive SmallDelay) + , Maybe (Positive SmallDelay) + -- ^ The delay must be smaller (<) than 5s, so that overall + -- delay is less than 10s, otherwise 'smallDelay' in + -- 'timeLimitsTxSubmission2' will kick in. + ) + , decisionPolicy :: TxDecisionPolicy + } deriving (Show) + +instance Arbitrary TxSubmissionV2State where + arbitrary = do + ArbTxDecisionPolicy decisionPolicy <- arbitrary + peersN <- choose (1, 10) + txsN <- choose (1, 10) + txs <- divvy txsN . nubBy (on (==) getTxId) <$> vectorOf (peersN * txsN) arbitrary + peers <- vectorOf peersN arbitrary + peersState <- map (\(a, (b, c)) -> (a, b, c)) + . zip txs + <$> vectorOf peersN arbitrary + return (TxSubmissionV2State (Map.fromList (zip peers peersState)) decisionPolicy) + shrink TxSubmissionV2State { peerMap, decisionPolicy } = + TxSubmissionV2State <$> shrinkMap1 peerMap + <*> [ policy + | ArbTxDecisionPolicy policy <- shrink (ArbTxDecisionPolicy decisionPolicy) + ] + where + shrinkMap1 :: (Ord k, Arbitrary k, Arbitrary v) => Map k v -> [Map k v] + shrinkMap1 m + | Map.size m <= 1 = [m] + | otherwise = [Map.delete k m | k <- Map.keys m] ++ singletonMaps + where + singletonMaps = [Map.singleton k v | (k, v) <- Map.toList m] + +runTxSubmissionV2 + :: forall m peeraddr txid. ( MonadAsync m , MonadDelay m , MonadFork m @@ -89,110 +125,105 @@ txSubmissionSimulation , Eq txid , ShowProxy txid , NoThunks (Tx txid) + , Show peeraddr + , Ord peeraddr , txid ~ Int ) => Tracer m (String, TraceSendRecv (TxSubmission2 txid (Tx txid))) - -> Tracer m (DebugSharedTxState (TestAddress Int) txid (Tx txid)) - -> NumTxIdsToAck - -> [Tx txid] - -> ControlMessageSTM m - -> Maybe DiffTime - -> Maybe DiffTime - -> m ([Tx txid], [Tx txid]) -txSubmissionSimulation tracer tracerDST maxUnacked outboundTxs - controlMessageSTM - inboundDelay outboundDelay = do - - inboundMempool <- emptyMempool - outboundMempool <- newMempool outboundTxs - (outboundChannel, inboundChannel) <- createConnectedChannels + -> Tracer m (DebugSharedTxState peeraddr txid (Tx txid)) + -> Map peeraddr ( [Tx txid] + , ControlMessageSTM m + , Maybe DiffTime + , Maybe DiffTime + ) + -> TxDecisionPolicy + -> m ([Tx txid], [[Tx txid]]) +runTxSubmissionV2 tracer tracerDST state txDecisionPolicy = do + + state' <- traverse (\(b, c, d, e) -> do + mempool <- newMempool b + (outChannel, inChannel) <- createConnectedChannels + return (mempool, c, d, e, outChannel, inChannel) + ) state + + inboundMempool <- emptyMempool txChannelsMVar <- Strict.newMVar (TxChannels Map.empty) sharedTxStateVar <- newSharedTxStateVar gsvVar <- Strict.newTVarIO Map.empty - asyncs <- runTxSubmission [(TestAddress 0, outboundChannel, inboundChannel)] - txChannelsMVar - sharedTxStateVar - (outboundMempool, inboundMempool) - gsvVar - undefined - (pure . snd) + runTxSubmission state' + txChannelsMVar + sharedTxStateVar + inboundMempool + gsvVar + (\(a, as) -> do + _ <- waitAnyCancel as + cancel a - _ <- waitAnyCancel asyncs + inmp <- readMempool inboundMempool + outmp <- forM (Map.elems state') + (\(outMempool, _, _, _, _, _) -> readMempool outMempool) + return (inmp, outmp) + ) - inmp <- readMempool inboundMempool - outmp <- readMempool outboundMempool - return (inmp, outmp) where - - runTxSubmission :: [(TestAddress Int, Channel m ByteString, Channel m ByteString)] - -> TxChannelsVar m (TestAddress Int) txid (Tx txid) - -> SharedTxStateVar m (TestAddress Int) txid (Tx txid) - -> (Mempool m txid, Mempool m txid) - -> StrictTVar m (Map (TestAddress Int) PeerGSV) - -> TxDecisionPolicy + runTxSubmission :: Map peeraddr ( Mempool m txid -- ^ Outbound mempool + , ControlMessageSTM m + , Maybe DiffTime -- ^ Outbound delay + , Maybe DiffTime -- ^ Inbound delay + , Channel m ByteString -- ^ Outbound channel + , Channel m ByteString -- ^ Inbound channel + ) + -> TxChannelsVar m peeraddr txid (Tx txid) + -> SharedTxStateVar m peeraddr txid (Tx txid) + -> Mempool m txid -- ^ Inbound mempool + -> StrictTVar m (Map peeraddr PeerGSV) -> ((Async m Void, [Async m ((), Maybe ByteString)]) -> m b) -> m b - runTxSubmission addrs txChannelsVar sharedTxStateVar - (outboundMempool, inboundMempool) gsvVar txDecisionPolicy k = - withAsync (decisionLogicThread tracerDST txDecisionPolicy gsvVar txChannelsVar sharedTxStateVar) $ \a -> do - -- Construct txSubmission outbound client - let clients = - (\(addr, outboundChannel, _) -> - ( addr - , outboundChannel - , txSubmissionOutbound nullTracer - maxUnacked - (getMempoolReader outboundMempool) - (maxBound :: NodeToNodeVersion) - controlMessageSTM - )) <$> addrs - - -- Construct txSubmission inbound server - servers <- forM addrs - (\(addr, _, inboundChannel) -> - withPeer - tracerDST - txChannelsVar - sharedTxStateVar - (getMempoolReader inboundMempool) - addr $ \api -> - pure $ - ( addr - , inboundChannel - , txSubmissionInboundV2 nullTracer - (getMempoolWriter inboundMempool) - api - ) - ) - - -- Construct txSubmission outbound client miniprotocol peer runner - let runPeerClients = - (\(_, channel, client) -> - runPeerWithLimits - (("OUTBOUND",) `contramap` tracer) - txSubmissionCodec2 - (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) - timeLimitsTxSubmission2 - (maybe id delayChannel outboundDelay channel) - (txSubmissionClientPeer client)) - <$> clients - -- Construct txSubmission inbound server miniprotocol peer runner - runPeerServers = - (\(addr, channel, server) -> - runPipelinedPeerWithLimits - (("INBOUND " ++ show addr,) `contramap` verboseTracer) - txSubmissionCodec2 - (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) - timeLimitsTxSubmission2 - (maybe id delayChannel inboundDelay channel) - (txSubmissionServerPeerPipelined server)) - <$> servers + runTxSubmission st txChannelsVar sharedTxStateVar + inboundMempool gsvVar k = + withAsync (decisionLogicThread tracerDST txDecisionPolicy (Strict.readTVar gsvVar) txChannelsVar sharedTxStateVar) $ \a -> do + -- Construct txSubmission outbound client + let clients = (\(addr, (mempool, ctrlMsgSTM, outDelay, _, outChannel, _)) -> do + let client = txSubmissionOutbound verboseTracer + (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 tracerDST + txChannelsVar + sharedTxStateVar + (getMempoolReader inboundMempool) + addr $ \api -> do + let server = txSubmissionInboundV2 verboseTracer + (getMempoolWriter inboundMempool) + api + runPipelinedPeerWithLimits + (("INBOUND " ++ show addr,) `contramap` verboseTracer) + txSubmissionCodec2 + (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) + timeLimitsTxSubmission2 + (maybe id delayChannel inDelay inChannel) + (txSubmissionServerPeerPipelined server) + ) <$> Map.assocs st -- Run clients and servers - withAsyncAll (runPeerClients ++ runPeerServers) (\asyncs -> k (a, asyncs)) + withAsyncAll (clients ++ servers) (\asyncs -> k (a, asyncs)) withAsyncAll :: MonadAsync m => [m a] -> ([Async m a] -> m b) -> m b withAsyncAll xs0 action = go [] xs0 @@ -200,59 +231,109 @@ txSubmissionSimulation tracer tracerDST maxUnacked outboundTxs go as [] = action (reverse as) go as (x:xs) = withAsync x (\a -> go (a:as) xs) +txSubmissionV2Simulation :: forall s . TxSubmissionV2State -> IOSim s ([Tx Int], [[Tx Int]]) +txSubmissionV2Simulation (TxSubmissionV2State state txDecisionPolicy) = do + state' <- traverse (\(txs, mbOutDelay, mbInDelay) -> do + let mbOutDelayTime = getSmallDelay . getPositive <$> mbOutDelay + mbInDelayTime = getSmallDelay . getPositive <$> mbInDelay + controlMessageVar <- newTVarIO Continue + return ( txs + , controlMessageVar + , mbOutDelayTime + , mbInDelayTime + ) + ) + state + + state'' <- traverse (\(txs, var, mbOutDelay, mbInDelay) -> do + return ( txs + , readTVar var + , mbOutDelay + , mbInDelay + ) + ) + state' + + let simDelayTime = Map.foldl' (\m (txs, _, mbInDelay, mbOutDelay) -> + max m ( fromMaybe 1 (max <$> mbInDelay <*> mbOutDelay) + * realToFrac (length txs `div` 4) + ) + ) + 0 + $ state'' + controlMessageVars = (\(_, x, _, _) -> x) + <$> Map.elems state' + + _ <- async do + threadDelay (simDelayTime + 1000) + atomically (traverse_ (`writeTVar` Terminate) controlMessageVars) + + let tracer = verboseTracer <> debugTracer + tracer' = verboseTracer <> debugTracer + runTxSubmissionV2 tracer tracer' state'' txDecisionPolicy + +-- | Tests overall tx submission semantics. The properties checked in this +-- property test are the same as for tx submission v1. We need this to know we +-- didn't regress. +-- +prop_txSubmission :: TxSubmissionV2State -> Property +prop_txSubmission st = + ioProperty $ do + tr' <- evaluateTrace (runSimTrace (txSubmissionV2Simulation st)) + 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, outmps) _trace -> do + r <- mapM (\outmp -> do + 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 $ counterexample ("(True, True) " ++ show outmp) + $ checkMempools 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 $ counterexample ("(True, False) " ++ show outmp) + $ checkMempools 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 $ counterexample ("(False, True) " ++ 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. + return $ property True) + outmps + return $ counterexample (intercalate "\n" _trace) + $ conjoin r + +checkMempools :: (Eq a, Show a) => [a] -> [a] -> Property +checkMempools [] [] = property True +checkMempools _ [] = property True +checkMempools [] _ = property False +checkMempools inp@(i : is) outp@(o : os) = + if o == i then counterexample (show inp ++ " " ++ show outp) + $ checkMempools is os + else counterexample (show inp ++ " " ++ show outp) + $ checkMempools is outp -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 - 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 +-- | 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) From 9ba4a81afb3a655aeaa69d59db68c6dec8450886 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 17 Sep 2024 10:20:17 +0200 Subject: [PATCH 11/54] tx-submission: rop V2 in internal APIs --- .../Network/TxSubmission/TxSubmissionV2.hs | 90 +++++++++---------- 1 file changed, 45 insertions(+), 45 deletions(-) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs index 8a0df2b825c..78593ba9a93 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs @@ -71,8 +71,8 @@ tests = testGroup "Ouroboros.Network.TxSubmission.TxSubmissionV2" [ testProperty "txSubmission" prop_txSubmission ] -data TxSubmissionV2State = - TxSubmissionV2State { +data TxSubmissionState = + TxSubmissionState { peerMap :: Map Int ( [Tx Int] , Maybe (Positive SmallDelay) , Maybe (Positive SmallDelay) @@ -83,7 +83,7 @@ data TxSubmissionV2State = , decisionPolicy :: TxDecisionPolicy } deriving (Show) -instance Arbitrary TxSubmissionV2State where +instance Arbitrary TxSubmissionState where arbitrary = do ArbTxDecisionPolicy decisionPolicy <- arbitrary peersN <- choose (1, 10) @@ -93,12 +93,12 @@ instance Arbitrary TxSubmissionV2State where peersState <- map (\(a, (b, c)) -> (a, b, c)) . zip txs <$> vectorOf peersN arbitrary - return (TxSubmissionV2State (Map.fromList (zip peers peersState)) decisionPolicy) - shrink TxSubmissionV2State { peerMap, decisionPolicy } = - TxSubmissionV2State <$> shrinkMap1 peerMap - <*> [ policy - | ArbTxDecisionPolicy policy <- shrink (ArbTxDecisionPolicy decisionPolicy) - ] + return (TxSubmissionState (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 @@ -107,7 +107,7 @@ instance Arbitrary TxSubmissionV2State where where singletonMaps = [Map.singleton k v | (k, v) <- Map.toList m] -runTxSubmissionV2 +runTxSubmission :: forall m peeraddr txid. ( MonadAsync m , MonadDelay m @@ -139,7 +139,7 @@ runTxSubmissionV2 ) -> TxDecisionPolicy -> m ([Tx txid], [[Tx txid]]) -runTxSubmissionV2 tracer tracerDST state txDecisionPolicy = do +runTxSubmission tracer tracerDST state txDecisionPolicy = do state' <- traverse (\(b, c, d, e) -> do mempool <- newMempool b @@ -153,37 +153,37 @@ runTxSubmissionV2 tracer tracerDST state txDecisionPolicy = do sharedTxStateVar <- newSharedTxStateVar gsvVar <- Strict.newTVarIO Map.empty - runTxSubmission state' - txChannelsMVar - sharedTxStateVar - inboundMempool - gsvVar - (\(a, as) -> do - _ <- waitAnyCancel as - cancel a - - inmp <- readMempool inboundMempool - outmp <- forM (Map.elems state') - (\(outMempool, _, _, _, _, _) -> readMempool outMempool) - return (inmp, outmp) - ) + run state' + txChannelsMVar + sharedTxStateVar + inboundMempool + gsvVar + (\(a, as) -> do + _ <- waitAnyCancel as + cancel a + + inmp <- readMempool inboundMempool + outmp <- forM (Map.elems state') + (\(outMempool, _, _, _, _, _) -> readMempool outMempool) + return (inmp, outmp) + ) where - runTxSubmission :: Map peeraddr ( Mempool m txid -- ^ Outbound mempool - , ControlMessageSTM m - , Maybe DiffTime -- ^ Outbound delay - , Maybe DiffTime -- ^ Inbound delay - , Channel m ByteString -- ^ Outbound channel - , Channel m ByteString -- ^ Inbound channel - ) - -> TxChannelsVar m peeraddr txid (Tx txid) - -> SharedTxStateVar m peeraddr txid (Tx txid) - -> Mempool m txid -- ^ Inbound mempool - -> StrictTVar m (Map peeraddr PeerGSV) - -> ((Async m Void, [Async m ((), Maybe ByteString)]) -> m b) - -> m b - runTxSubmission st txChannelsVar sharedTxStateVar - inboundMempool gsvVar k = + 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) + -> 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 sharedTxStateVar + inboundMempool gsvVar k = withAsync (decisionLogicThread tracerDST txDecisionPolicy (Strict.readTVar gsvVar) txChannelsVar sharedTxStateVar) $ \a -> do -- Construct txSubmission outbound client let clients = (\(addr, (mempool, ctrlMsgSTM, outDelay, _, outChannel, _)) -> do @@ -231,8 +231,8 @@ runTxSubmissionV2 tracer tracerDST state txDecisionPolicy = do go as [] = action (reverse as) go as (x:xs) = withAsync x (\a -> go (a:as) xs) -txSubmissionV2Simulation :: forall s . TxSubmissionV2State -> IOSim s ([Tx Int], [[Tx Int]]) -txSubmissionV2Simulation (TxSubmissionV2State state txDecisionPolicy) = do +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 @@ -270,16 +270,16 @@ txSubmissionV2Simulation (TxSubmissionV2State state txDecisionPolicy) = do let tracer = verboseTracer <> debugTracer tracer' = verboseTracer <> debugTracer - runTxSubmissionV2 tracer tracer' state'' txDecisionPolicy + 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 :: TxSubmissionV2State -> Property +prop_txSubmission :: TxSubmissionState -> Property prop_txSubmission st = ioProperty $ do - tr' <- evaluateTrace (runSimTrace (txSubmissionV2Simulation st)) + tr' <- evaluateTrace (runSimTrace (txSubmissionSimulation st)) case tr' of SimException e trace -> do return $ counterexample (intercalate "\n" $ show e : trace) False From bad9fb08723044d488736a4d769aa9fe19b4d51e Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Wed, 11 Sep 2024 11:20:13 +0100 Subject: [PATCH 12/54] tx-submission: fixed a race condition There was a race condition between the `decisionLogicThread` producing a `TxDecision` and an inbound server picking up the most up to date `TxDecision`. This would lead to the inbound side issuing a blocking request when the client was awaiting for a non-blocking request. This blocking request isn't wrong considering the issued decision; it is a legit decision that's made which leads to the inbound server issuing a blocking request but because we have received a txid in the meantime and didn't manage to read it soon enough we didn't create a more important decision. The fix involved being aware of how many requests for txs we have in flight and not generate "low priority" policies. `hasTxIdsToAcknowledge` is not used anywhere in the code so it is removed. `filterActivePeers` is improved by making its decision logic more closed to `pickTxsToDownload`. `filterActivePeers` test is fixed, since it doesn't hold under the new logic: `filterActivePeers` will not compute a decision for peers which have `requestedTxIdsInflight` and `makeDecisions` computes non-empty decisions for peers with no `requestedTxIdsInflight`. So: 1. "The set of active peers is a superset of peers for which a decision was made" this is not true since it is possible that a non active peer has a legitimate decision, but due to our race-condition protection condition we just don't generate it. 2. "The set of active peer which can acknowledge txids is a subset of peers for which a decision was made" this is removed since hasTxIdsToAcknowledge function is removed 3. "Decisions made from the results of `filterActivePeers` is the same as from the original set" this isn't true because of what I said above So I refactored the test to check that the number of filtered decisions is a subset of the total number of decisions, which I believe to be a more accurate test for the current logic --- .../Network/TxSubmission/Inbound/Decision.hs | 164 ++++++++++++------ .../Network/TxSubmission/Inbound/Policy.hs | 15 +- .../Network/TxSubmission/Inbound/Server.hs | 5 +- .../Network/TxSubmission/Inbound/State.hs | 73 ++++---- .../Network/TxSubmission/Inbound/Types.hs | 1 + .../Network/TxSubmission/Outbound.hs | 16 +- .../Ouroboros/Network/TxSubmission/Common.hs | 141 +++++++++------ 7 files changed, 269 insertions(+), 146 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs index 97d8472d040..62a9a9cec5f 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs @@ -261,25 +261,32 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, sizeInflightOther = sizeInflightAll - requestedTxsInflightSize in if sizeInflightAll >= maxTxsSizeInflight - then let (numTxIdsToAck, txsToMempool, RefCountDiff { txIdsToAck }, peerTxState') = - acknowledgeTxIds sharedState peerTxState - (numTxIdsToReq, peerTxState'') = numTxIdsToRequest policy peerTxState' + then let (numTxIdsToAck, numTxIdsToReq, txsToMempool, RefCountDiff { txIdsToAck }, peerTxState') = + acknowledgeTxIds policy sharedState peerTxState stAcknowledged' = Map.unionWith (+) stAcknowledged txIdsToAck in - ( st { stAcknowledged = stAcknowledged' } - , ( (peeraddr, peerTxState'') - , TxDecision { txdTxIdsToAcknowledge = numTxIdsToAck, - txdTxIdsToRequest = numTxIdsToReq, - txdPipelineTxIds = not - . StrictSeq.null - . unacknowledgedTxIds - $ peerTxState', - txdTxsToRequest = Set.empty, - txdTxsToMempool = txsToMempool - } - ) - ) + if requestedTxIdsInflight peerTxState' > 0 + then + ( st { stAcknowledged = stAcknowledged' } + , ( (peeraddr, peerTxState') + , TxDecision { txdTxIdsToAcknowledge = numTxIdsToAck, + txdTxIdsToRequest = numTxIdsToReq, + txdPipelineTxIds = not + . StrictSeq.null + . unacknowledgedTxIds + $ peerTxState', + txdTxsToRequest = Set.empty, + txdTxsToMempool = txsToMempool + } + ) + ) + else + ( st + , ( (peeraddr, peerTxState') + , emptyTxDecision + ) + ) else let requestedTxsInflightSize' :: SizeInBytes txsToRequest :: Set txid @@ -334,8 +341,8 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, <> txsToRequest } - (numTxIdsToAck, txsToMempool, RefCountDiff { txIdsToAck }, peerTxState'') = - acknowledgeTxIds sharedState peerTxState' + (numTxIdsToAck, numTxIdsToReq, txsToMempool, RefCountDiff { txIdsToAck }, peerTxState'') = + acknowledgeTxIds policy sharedState peerTxState' stAcknowledged' = Map.unionWith (+) stAcknowledged txIdsToAck @@ -346,25 +353,32 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, stInflight' :: Map txid Int stInflight' = Map.unionWith (+) stInflightDelta stInflight - - (numTxIdsToReq, peerTxState''') = numTxIdsToRequest policy peerTxState'' - - - in ( St { stInflight = stInflight', - stInflightSize = sizeInflightOther + requestedTxsInflightSize', - stAcknowledged = stAcknowledged' } - , ( (peeraddr, peerTxState''') - , TxDecision { txdTxIdsToAcknowledge = numTxIdsToAck, - txdPipelineTxIds = not - . StrictSeq.null - . unacknowledgedTxIds - $ peerTxState''', - txdTxIdsToRequest = numTxIdsToReq, - txdTxsToRequest = txsToRequest, - txdTxsToMempool = txsToMempool - } - ) - ) + in + if requestedTxIdsInflight peerTxState'' > 0 + then + ( St { stInflight = stInflight', + stInflightSize = sizeInflightOther + requestedTxsInflightSize', + stAcknowledged = stAcknowledged' } + , ( (peeraddr, peerTxState'') + , TxDecision { txdTxIdsToAcknowledge = numTxIdsToAck, + txdPipelineTxIds = not + . StrictSeq.null + . unacknowledgedTxIds + $ peerTxState'', + txdTxIdsToRequest = numTxIdsToReq, + txdTxsToRequest = txsToRequest, + txdTxsToMempool = txsToMempool + } + ) + ) + else + ( st { stInflight = stInflight', + stInflightSize = sizeInflightOther + requestedTxsInflightSize' + } + , ( (peeraddr, peerTxState'') + , emptyTxDecision { txdTxsToRequest = txsToRequest } + ) + ) gn :: ( St peeraddr txid tx , [((peeraddr, PeerTxState txid tx), TxDecision txid tx)] @@ -430,11 +444,13 @@ filterActivePeers TxDecisionPolicy { maxUnacknowledgedTxIds, txsSizeInflightPerPeer, maxTxsSizeInflight, - txInflightMultiplicity } - st@SharedTxState { peerTxStates, - bufferedTxs, - inflightTxs, - inflightTxsSize } + txInflightMultiplicity, + maxNumTxIdsToRequest + } + SharedTxState { peerTxStates, + bufferedTxs, + inflightTxs, + inflightTxsSize } | overLimit = Map.filter fn peerTxStates | otherwise @@ -445,22 +461,44 @@ filterActivePeers <> Map.keysSet bufferedTxs fn :: PeerTxState txid tx -> Bool - fn ps@PeerTxState { unacknowledgedTxIds, - requestedTxIdsInflight } = - hasTxIdsToAcknowledge st ps - || requestedTxIdsInflight + numOfUnacked < maxUnacknowledgedTxIds + fn PeerTxState { unacknowledgedTxIds, + requestedTxIdsInflight, + unknownTxs + } = + -- hasTxIdsToAcknowledge st ps || + requestedTxIdsInflight == 0 -- document why it's not <= maxTxIdsInFlightPerPeer + && requestedTxIdsInflight + numOfUnacked <= maxUnacknowledgedTxIds + && txIdsToRequest > 0 where - numOfUnacked = fromIntegral (StrictSeq.length unacknowledgedTxIds) + -- Split `unacknowledgedTxIds'` into the longest prefix of `txid`s which + -- can be acknowledged and the unacknowledged `txid`s. + (acknowledgedTxIds, _) = + StrictSeq.spanl (\txid -> txid `Map.member` bufferedTxs + || txid `Set.member` unknownTxs + ) + unacknowledgedTxIds + numOfUnacked = fromIntegral (StrictSeq.length unacknowledgedTxIds) + numOfAcked = StrictSeq.length acknowledgedTxIds + unackedAndRequested = numOfUnacked + requestedTxIdsInflight + txIdsToRequest = + assert (unackedAndRequested <= maxUnacknowledgedTxIds) $ + assert (requestedTxIdsInflight <= maxNumTxIdsToRequest) $ + (maxUnacknowledgedTxIds - unackedAndRequested + fromIntegral numOfAcked) + `min` + (maxNumTxIdsToRequest - requestedTxIdsInflight) gn :: PeerTxState txid tx -> Bool - gn ps@PeerTxState { unacknowledgedTxIds, - requestedTxIdsInflight, - requestedTxsInflight, - requestedTxsInflightSize, - availableTxIds, - unknownTxs } = - hasTxIdsToAcknowledge st ps - || requestedTxIdsInflight + numOfUnacked < maxUnacknowledgedTxIds + gn PeerTxState { unacknowledgedTxIds, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize, + availableTxIds, + unknownTxs } = + -- hasTxIdsToAcknowledge st ps || + ( requestedTxIdsInflight == 0 + && requestedTxIdsInflight + numOfUnacked <= maxUnacknowledgedTxIds + && txIdsToRequest > 0 + ) || (underSizeLimit && not (Map.null downloadable)) where numOfUnacked = fromIntegral (StrictSeq.length unacknowledgedTxIds) @@ -470,6 +508,22 @@ filterActivePeers `Map.withoutKeys` unknownTxs `Map.withoutKeys` unrequestable + -- Split `unacknowledgedTxIds'` into the longest prefix of `txid`s which + -- can be acknowledged and the unacknowledged `txid`s. + (acknowledgedTxIds, _) = + StrictSeq.spanl (\txid -> txid `Map.member` bufferedTxs + || txid `Set.member` unknownTxs + ) + unacknowledgedTxIds + numOfAcked = StrictSeq.length acknowledgedTxIds + unackedAndRequested = numOfUnacked + requestedTxIdsInflight + txIdsToRequest = + assert (unackedAndRequested <= maxUnacknowledgedTxIds) $ + assert (requestedTxIdsInflight <= maxNumTxIdsToRequest) $ + (maxUnacknowledgedTxIds - unackedAndRequested + fromIntegral numOfAcked) + `min` + (maxNumTxIdsToRequest - requestedTxIdsInflight) + -- -- Auxiliary functions -- diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs index 532742dfdf9..7f6fb1569e0 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs @@ -1,4 +1,7 @@ -module Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy (..)) where +module Ouroboros.Network.TxSubmission.Inbound.Policy + ( TxDecisionPolicy (..) + , defaultTxDecisionPolicy + ) where import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToReq (..)) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) @@ -30,3 +33,13 @@ data TxDecisionPolicy = TxDecisionPolicy { -- ^ from how many peers download the `txid` simultaneously } deriving Show + +defaultTxDecisionPolicy :: TxDecisionPolicy +defaultTxDecisionPolicy = + TxDecisionPolicy { + maxNumTxIdsToRequest = 1, + maxUnacknowledgedTxIds = 2, + txsSizeInflightPerPeer = 2, + maxTxsSizeInflight = maxBound, + txInflightMultiplicity = 2 + } diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs index 332abe5bb3c..273509a41fb 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs @@ -66,6 +66,8 @@ txSubmissionInboundV2 <- readTxDecision traceWith tracer (TraceTxInboundDecision txd) txidsAccepted <- mempoolAddTxs txs + traceWith tracer $ + TraceTxInboundAddedToMempool txidsAccepted let !collected = length txidsAccepted traceWith tracer $ TraceTxSubmissionCollected collected @@ -90,8 +92,7 @@ txSubmissionInboundV2 -> TxDecision txid tx -> m (ServerStIdle n txid tx m ()) serverReqTxIds - n TxDecision { txdTxIdsToAcknowledge = 0, - txdTxIdsToRequest = 0 } + n TxDecision { txdTxIdsToRequest = 0 } = case n of Zero -> serverIdle diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs index cdf64f6acb9..b2eb8b5d04b 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs @@ -16,7 +16,6 @@ module Ouroboros.Network.TxSubmission.Inbound.State , receivedTxIds , collectTxs , acknowledgeTxIds - , hasTxIdsToAcknowledge -- * Debug output , DebugSharedTxState (..) -- * Internals, only exported for testing purposes: @@ -224,48 +223,47 @@ instance ( NoThunks peeraddr -- Pure public API -- --- | Check if a peer can acknowledge at least one `txid`. --- -hasTxIdsToAcknowledge - :: forall peeraddr txid tx. - Ord txid - => SharedTxState peeraddr txid tx - -> PeerTxState txid tx - -> Bool -hasTxIdsToAcknowledge - SharedTxState { bufferedTxs } - PeerTxState { unacknowledgedTxIds, unknownTxs } - = - -- We just need to look at the front of the unacknowledged `txid`s. - case unacknowledgedTxIds of - txid StrictSeq.:<| _ -> txid `Map.member` bufferedTxs - || txid `Set.member` unknownTxs - _ -> False - - acknowledgeTxIds :: forall peeraddr tx txid. Ord txid - => SharedTxState peeraddr txid tx + => TxDecisionPolicy + -> SharedTxState peeraddr txid tx -> PeerTxState txid tx - -> (NumTxIdsToAck, [tx], RefCountDiff txid, PeerTxState txid tx) + -> (NumTxIdsToAck, NumTxIdsToReq, [tx], RefCountDiff txid, PeerTxState txid tx) -- ^ number of txid to acknowledge, txids to acknowledge with multiplicities, -- updated PeerTxState. {-# INLINE acknowledgeTxIds #-} acknowledgeTxIds + TxDecisionPolicy { maxNumTxIdsToRequest, + maxUnacknowledgedTxIds } SharedTxState { bufferedTxs } ps@PeerTxState { availableTxIds, unacknowledgedTxIds, - unknownTxs } + unknownTxs, + requestedTxIdsInflight } = - ( fromIntegral $ StrictSeq.length acknowledgedTxIds - , txsToMempool - , refCountDiff - , ps { unacknowledgedTxIds = unacknowledgedTxIds', - availableTxIds = availableTxIds', - unknownTxs = unknownTxs' } - ) + -- We can only acknowledge txids when we can request new ones, since + -- a `MsgRequestTxIds` for 0 txids is a protocol error. + if txIdsToRequest > 0 + then + ( txIdsToAcknowledge + , txIdsToRequest + , txsToMempool + , refCountDiff + , ps { unacknowledgedTxIds = unacknowledgedTxIds', + availableTxIds = availableTxIds', + unknownTxs = unknownTxs', + requestedTxIdsInflight = requestedTxIdsInflight + + txIdsToRequest } + ) + else + ( 0 + , 0 + , [] + , RefCountDiff Map.empty + , ps + ) where -- Split `unacknowledgedTxIds'` into the longest prefix of `txid`s which -- can be acknowledged and the unacknowledged `txid`s. @@ -302,6 +300,21 @@ acknowledgeTxIds 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. diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs index b42aa68d3ca..74224b535d3 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs @@ -51,6 +51,7 @@ data TraceTxSubmissionInbound txid tx = -- | Server received 'MsgDone' | TraceTxInboundCanRequestMoreTxs Int | TraceTxInboundCannotRequestMoreTxs Int + | TraceTxInboundAddedToMempool [txid] -- -- messages emitted by the new implementation of the server in 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/TxSubmission/Common.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs index 440e676f524..85d2bbd7faf 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs @@ -94,7 +94,6 @@ tests = testGroup "Ouroboros.Network.TxSubmission.Common" ] ] , testProperty "acknowledgeTxIds" prop_acknowledgeTxIds - , testProperty "hasTxIdsToAcknowledge" prop_hasTxIdsToAcknowledge , testProperty "receivedTxIdsImpl" prop_receivedTxIdsImpl , testProperty "collectTxsImpl" prop_collectTxsImpl , testProperty "numTxIdsToRequest" prop_numTxIdsToRequest @@ -838,11 +837,11 @@ prop_receivedTxIds_generator (ArbReceivedTxIds _ someTxsToAck _peeraddr _ps st) -- by `prop_receivedTxIdsImpl`, `prop_collectTxsImpl` and -- `prop_makeDecisions_acknowledged`. -- -prop_acknowledgeTxIds :: ArbReceivedTxIds +prop_acknowledgeTxIds :: ArbDecisionContextWithReceivedTxIds -> Property -prop_acknowledgeTxIds (ArbReceivedTxIds _mempoolHasTxFun _txs _peeraddr ps st) = - case TXS.acknowledgeTxIds st ps of - (numTxIdsToAck, txs, TXS.RefCountDiff { TXS.txIdsToAck }, ps') -> +prop_acknowledgeTxIds (ArbDecisionContextWithReceivedTxIds policy SharedDecisionContext { sdcSharedTxState = st } ps _ _ _) = + case TXS.acknowledgeTxIds policy st ps of + (numTxIdsToAck, txIdsToRequest, txs, TXS.RefCountDiff { TXS.txIdsToAck }, ps') | txIdsToRequest > 0 -> counterexample "number of tx ids to ack must agree with RefCountDiff" ( fromIntegral numTxIdsToAck === @@ -866,25 +865,13 @@ prop_acknowledgeTxIds (ArbReceivedTxIds _mempoolHasTxFun _txs _peeraddr ps st) = , Just _ <- maybeToList $ txid `Map.lookup` bufferedTxs st ] in getTxId `map` txs === acked) + _otherwise -> property True where stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] stripSuffix as suffix = reverse <$> reverse suffix `stripPrefix` reverse as --- | Verify that `hasTxIdsToAcknowledge` and `acknowledgeTxIds` are compatible. --- -prop_hasTxIdsToAcknowledge - :: ArbReceivedTxIds - -> Property -prop_hasTxIdsToAcknowledge (ArbReceivedTxIds _mempoolHasTxFun _txs _peeraddr ps st) = - case ( TXS.hasTxIdsToAcknowledge st ps - , TXS.acknowledgeTxIds st ps - ) of - (canAck, (numTxIdsToAck, _, _, _)) -> - canAck === (numTxIdsToAck > 0) - - -- | Verify 'inboundStateInvariant' when acknowledging a sequence of txs. -- prop_receivedTxIdsImpl @@ -1609,8 +1596,8 @@ prop_makeDecisions_acknowledged ackFromState :: Map PeerAddr NumTxIdsToAck ackFromState = - Map.map (\ps -> case TXS.acknowledgeTxIds sharedTxState ps of - (a, _, _, _) -> a) + Map.map (\ps -> case TXS.acknowledgeTxIds policy sharedTxState ps of + (a, _, _, _, _) -> a) . peerTxStates $ sharedTxState @@ -1659,25 +1646,89 @@ prop_makeDecisions_exhaustive . counterexample ("state'': " ++ show sharedTxState'') $ null decisions'' +data ArbDecisionContextWithReceivedTxIds = ArbDecisionContextWithReceivedTxIds { + adcrDecisionPolicy :: TxDecisionPolicy, + adcrSharedContext :: SharedDecisionContext PeerAddr TxId (Tx TxId), + adcrPeerTxState :: PeerTxState TxId (Tx TxId), + adcrMempoolHasTx :: Fun TxId Bool, + adcrTxsToAck :: [Tx TxId], + -- txids to acknowledge + adcrPeerAddr :: PeerAddr + -- the peer which owns the acknowledged txids + } + deriving Show + + +instance Arbitrary ArbDecisionContextWithReceivedTxIds where + arbitrary = do + ArbTxDecisionPolicy policy <- arbitrary + ArbReceivedTxIds mempoolHasTx + txIdsToAck + peeraddr + ps + st + <- arbitrary + + let st' = fixupSharedTxStateForPolicy + (apply mempoolHasTx) + policy st + ps' = fixupPeerTxStateWithPolicy policy ps + txIdsToAck' = take (fromIntegral (TXS.requestedTxIdsInflight $ peerTxStates st' Map.! peeraddr)) txIdsToAck + peers = Map.keys (peerTxStates st') + + gsvs <- zip peers + <$> infiniteListOf (unPeerGSVT <$> arbitrary) + + return ArbDecisionContextWithReceivedTxIds { + adcrDecisionPolicy = policy, + adcrSharedContext = SharedDecisionContext { + sdcPeerGSV = Map.fromList gsvs, + sdcSharedTxState = st' + }, + adcrPeerTxState = ps', + adcrMempoolHasTx = mempoolHasTx, + adcrTxsToAck = txIdsToAck', + adcrPeerAddr = peeraddr + } + + shrink ArbDecisionContextWithReceivedTxIds { + adcrDecisionPolicy = policy, + adcrSharedContext = ctx, + adcrPeerTxState = ps, + adcrMempoolHasTx = mempoolHasTx, + adcrTxsToAck = txIdsToAck, + adcrPeerAddr = peeraddr + } + = + [ ArbDecisionContextWithReceivedTxIds { + adcrDecisionPolicy = policy', + adcrSharedContext = ctx', + adcrPeerTxState = ps, + adcrMempoolHasTx = mempoolHasTx', + adcrTxsToAck = txIdsToAck', + adcrPeerAddr = peeraddr + } + | ArbDecisionContexts { + arbDecisionPolicy = policy', + arbSharedContext = ctx'@SharedDecisionContext { sdcSharedTxState = st' }, + arbMempoolHasTx = mempoolHasTx' + } + <- shrink ArbDecisionContexts { + arbDecisionPolicy = policy, + arbSharedContext = ctx, + arbMempoolHasTx = mempoolHasTx + } + , peeraddr `Map.member` peerTxStates st' + , let txIdsToAck' = take ( fromIntegral + . TXS.requestedTxIdsInflight + $ peerTxStates st' Map.! peeraddr + ) + txIdsToAck + ] + -- | `filterActivePeers` should not change decisions made by `makeDecisions` -- --- --- This test checks the following properties: --- --- In what follows, the set of active peers is defined as the keys of the map --- returned by `filterActivePeers`. --- --- 1. The set of active peers is a superset of peers for which a decision was --- made; --- 2. The set of active peer which can acknowledge txids is a subset of peers --- for which a decision was made; --- 3. Decisions made from the results of `filterActivePeers` is the same as from --- the original set. --- --- Ad 2. a stronger property is not possible. There can be a peer for which --- a decision was not taken but which is an active peer. --- prop_filterActivePeers_not_limitting_decisions :: ArbDecisionContexts TxId -> Property @@ -1694,25 +1745,13 @@ prop_filterActivePeers_not_limitting_decisions ,"active decisions: " ++ show decisionsOfActivePeers ," " ++ show activePeers]) $ - counterexample ("found non-active peers for which decision can be made: " - ++ show (decisionPeers Set.\\ activePeers) + counterexample ("active peers does not restrict the total number of valid decisions available" + ++ show (decisionsOfActivePeers Map.\\ decisions) ) - (decisionPeers `Set.isSubsetOf` activePeers) - .&&. - counterexample ("found an active peer which can acknowledge txids " - ++ "for which decision was not made: " - ++ show (activePeersAck Set.\\ decisionPeers)) - (activePeersAck `Set.isSubsetOf` decisionPeers) - .&&. - counterexample "decisions from active peers are not equal to decisions from all peers" - (decisions === decisionsOfActivePeers) + (Map.keysSet decisionsOfActivePeers `Set.isSubsetOf` Map.keysSet decisions) where activePeersMap = TXS.filterActivePeers policy st activePeers = Map.keysSet activePeersMap - -- peers which are active & can acknowledge txids - activePeersAck = activePeers - `Set.intersection` - Map.keysSet (Map.filter (TXS.hasTxIdsToAcknowledge st) (peerTxStates st)) (_, decisionsOfActivePeers) = TXS.makeDecisions policy sharedCtx activePeersMap From 6ffe01fa8b3fc9880cd0961257a0b6eb8ffa1cb2 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 17 Sep 2024 17:24:23 +0200 Subject: [PATCH 13/54] tx-submission: defaultTxDecisionPolicy Add `max_TX_SIZE` which is shared between * `defaultTxDecisionPolicy`, and * `txSubmissionProtocolLimits` --- .../src/Ouroboros/Network/NodeToNode.hs | 9 ++++--- .../Network/TxSubmission/Inbound/Decision.hs | 7 ++++- .../Network/TxSubmission/Inbound/Policy.hs | 27 +++++++++++++++---- 3 files changed, 34 insertions(+), 9 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index bb6001cc1fd..852ebd2f280 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,10 @@ 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.Policy (max_TX_SIZE) import Ouroboros.Network.Util.ShowProxy (ShowProxy, showProxy) @@ -353,12 +356,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 txSubmissionMaxUnacked * (44 + fromIntegral @SizeInBytes @Int max_TX_SIZE) } keepAliveProtocolLimits _ = diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs index 62a9a9cec5f..5b504ec7c9a 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs @@ -92,6 +92,7 @@ instance Ord txid => Semigroup (TxDecision txid tx) where txdTxsToMempool = txdTxsToMempool ++ txdTxsToMempool' } +-- | A no-op decision. emptyTxDecision :: TxDecision txid tx emptyTxDecision = TxDecision { txdTxIdsToAcknowledge = 0, @@ -268,6 +269,7 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, in if requestedTxIdsInflight peerTxState' > 0 then + -- we have txids to request ( st { stAcknowledged = stAcknowledged' } , ( (peeraddr, peerTxState') , TxDecision { txdTxIdsToAcknowledge = numTxIdsToAck, @@ -282,6 +284,8 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, ) ) else + -- there are no `txid`s to request, nor we can request `tx`s due + -- to in-flight size limits ( st , ( (peeraddr, peerTxState') , emptyTxDecision @@ -356,6 +360,7 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, in if requestedTxIdsInflight peerTxState'' > 0 then + -- we can request `txid`s & `tx`s ( St { stInflight = stInflight', stInflightSize = sizeInflightOther + requestedTxsInflightSize', stAcknowledged = stAcknowledged' } @@ -372,6 +377,7 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, ) ) else + -- there are no `txid`s to request, only `tx`s. ( st { stInflight = stInflight', stInflightSize = sizeInflightOther + requestedTxsInflightSize' } @@ -494,7 +500,6 @@ filterActivePeers requestedTxsInflightSize, availableTxIds, unknownTxs } = - -- hasTxIdsToAcknowledge st ps || ( requestedTxIdsInflight == 0 && requestedTxIdsInflight + numOfUnacked <= maxUnacknowledgedTxIds && txIdsToRequest > 0 diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs index 7f6fb1569e0..e625bc42326 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs @@ -1,11 +1,27 @@ +{-# LANGUAGE NumericUnderscores #-} + module Ouroboros.Network.TxSubmission.Inbound.Policy ( TxDecisionPolicy (..) , defaultTxDecisionPolicy + , max_TX_SIZE ) where 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 { @@ -37,9 +53,10 @@ data TxDecisionPolicy = TxDecisionPolicy { defaultTxDecisionPolicy :: TxDecisionPolicy defaultTxDecisionPolicy = TxDecisionPolicy { - maxNumTxIdsToRequest = 1, - maxUnacknowledgedTxIds = 2, - txsSizeInflightPerPeer = 2, - maxTxsSizeInflight = maxBound, - txInflightMultiplicity = 2 + maxNumTxIdsToRequest = 3, + maxUnacknowledgedTxIds = 10, -- must be the same as txSubmissionMaxUnacked + -- TODO: we should take it `MiniProtocolParameters`. + txsSizeInflightPerPeer = max_TX_SIZE * 6, + maxTxsSizeInflight = max_TX_SIZE * 20, + txInflightMultiplicity = 1 } From 935ce0e0e4890f9a2bddf937ded931906db2007d Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Wed, 11 Sep 2024 11:34:14 +0100 Subject: [PATCH 14/54] tx-submission: added test to check tx multiplicities --- .../Network/TxSubmission/TxSubmissionV2.hs | 42 +++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs index 78593ba9a93..119d818eb86 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs @@ -5,6 +5,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -69,6 +70,7 @@ import Test.Tasty.QuickCheck (testProperty) tests :: TestTree tests = testGroup "Ouroboros.Network.TxSubmission.TxSubmissionV2" [ testProperty "txSubmission" prop_txSubmission + , testProperty "txSubmission inflight" prop_txSubmission_inflight ] data TxSubmissionState = @@ -322,6 +324,46 @@ prop_txSubmission st = return $ counterexample (intercalate "\n" _trace) $ conjoin r +-- | 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 + checkMempools :: (Eq a, Show a) => [a] -> [a] -> Property checkMempools [] [] = property True checkMempools _ [] = property True From 4cbcdcc4f39e4cb414162ac7dd79bad13cf9134d Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Wed, 11 Sep 2024 11:35:06 +0100 Subject: [PATCH 15/54] net-sim: integrated txSubmissionV2 in testnet diffusion simulation Added tx submission diffusion test-net test. This test checks that even in the presence of a node that keeps disconnecting, but eventually stays online, we manage to learn about all its transactions. --- .../Ouroboros/Network/TxSubmission/Inbound.hs | 25 +- .../Test/Ouroboros/Network/Diffusion/Node.hs | 38 +- .../Network/Diffusion/Node/Kernel.hs | 50 ++- .../Network/Diffusion/Node/MiniProtocols.hs | 109 ++++- .../Network/Diffusion/Testnet/Cardano.hs | 380 ++++++++++++++++-- .../Diffusion/Testnet/Cardano/Simulation.hs | 151 +++++-- .../Ouroboros/Network/TxSubmission/Common.hs | 4 + 7 files changed, 639 insertions(+), 118 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs index 2bfbb27ed12..e8ff9faaac6 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs @@ -9,17 +9,11 @@ {-# OPTIONS_GHC -Wno-partial-fields #-} --- | Legacy `tx-submission` inbound peer. --- module Ouroboros.Network.TxSubmission.Inbound - ( -- * New Tx-Submission server - module Server - , module Types - , module Decision - , module Registry - , module Policy - -- * Legacy Tx-Submission server - , txSubmissionInbound + ( txSubmissionInbound + , TxSubmissionMempoolWriter (..) + , TraceTxSubmissionInbound (..) + , TxSubmissionProtocolError (..) , ProcessedTxCount (..) ) where @@ -55,17 +49,6 @@ import Ouroboros.Network.TxSubmission.Inbound.Types import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..), TxSubmissionMempoolReader (..)) --- --- re-exports --- - -import Ouroboros.Network.TxSubmission.Inbound.Decision as Decision -import Ouroboros.Network.TxSubmission.Inbound.Policy as Policy -import Ouroboros.Network.TxSubmission.Inbound.Registry as Registry -import Ouroboros.Network.TxSubmission.Inbound.Server as Server -import Ouroboros.Network.TxSubmission.Inbound.Types as Types - - -- | Information maintained internally in the 'txSubmissionInbound' server -- implementation. -- diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs index 4d7154e26b3..258d7337c5f 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -77,6 +77,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 +113,14 @@ import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) import Ouroboros.Network.Snocket (MakeBearer, Snocket, TestAddress (..), invalidFileDescriptor) +import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy) +import Ouroboros.Network.TxSubmission.Inbound.Registry (decisionLogicThread) +import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState) +import Ouroboros.Network.TxSubmission.Inbound.Types (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 +130,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.Common (Tx) data Interfaces extraAPI m = Interfaces @@ -165,6 +172,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 +262,15 @@ 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 (DebugSharedTxState 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 tracerTxSubmissionDebug = + Node.withNodeKernelThread blockGeneratorArgs (aTxs na) $ \ nodeKernel nodeKernelThread -> do dnsTimeoutScriptVar <- newTVarIO (aDNSTimeoutScript na) dnsLookupDelayScriptVar <- newTVarIO (aDNSLookupDelayScript na) @@ -336,6 +347,8 @@ run blockGeneratorArgs limits ni na apps = Node.applications (aDebugTracer na) + tracerTxSubmissionInbound + tracerTxSubmissionDebug nodeKernel Node.cborCodecs limits @@ -350,11 +363,19 @@ run blockGeneratorArgs limits ni na apps) $ \ diffusionThread -> withAsync (blockFetch nodeKernel) $ \blockFetchLogicThread -> - wait diffusionThread - <> wait blockFetchLogicThread - <> wait nodeKernelThread + + withAsync (decisionLogicThread + tracerTxSubmissionDebug + (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 +394,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 +512,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..ff010fa7716 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs @@ -66,6 +66,10 @@ 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 +80,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.Registry (SharedTxStateVar, + TxChannels (..), TxChannelsVar, newSharedTxStateVar) import Test.Ouroboros.Network.Diffusion.Node.ChainDB (ChainDB (..)) import Test.Ouroboros.Network.Diffusion.Node.ChainDB qualified as ChainDB import Test.Ouroboros.Network.Orphans () +import Test.Ouroboros.Network.TxSubmission.Common (Mempool, Tx, newMempool) import Test.QuickCheck (Arbitrary (..), choose, chooseInt, frequency, oneof) @@ -263,7 +268,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 +285,24 @@ data NodeKernel header block s m = NodeKernel { nkPeerSharingAPI :: PeerSharingAPI NtNAddr s m, - nkPublicPeerSelectionVar :: StrictTVar m (PublicPeerSelectionState NtNAddr) + nkPublicPeerSelectionVar :: StrictTVar m (PublicPeerSelectionState NtNAddr), + + nkMempool :: Mempool m txid, + + nkTxChannelsVar :: TxChannelsVar m NtNAddr txid (Tx txid), + + nkSharedTxStateVar :: SharedTxStateVar m NtNAddr txid (Tx txid) } -newNodeKernel :: MonadSTM m - => s -> m (NodeKernel header block s m) -newNodeKernel rng = do +newNodeKernel :: ( MonadSTM m + , Strict.MonadMVar m + , RandomGen s + , Eq txid + ) + => s + -> [Tx txid] + -> m (NodeKernel header block s txid m) +newNodeKernel rng txs = do publicStateVar <- makePublicPeerSelectionStateVar NodeKernel <$> newTVarIO Map.empty @@ -297,11 +314,14 @@ newNodeKernel rng = do ps_POLICY_PEER_SHARE_STICKY_TIME ps_POLICY_PEER_SHARE_MAX_PEERS <*> pure publicStateVar + <*> newMempool txs + <*> Strict.newMVar (TxChannels Map.empty) + <*> newSharedTxStateVar -- | Register a new upstream chain-sync client. -- registerClientChains :: MonadSTM m - => NodeKernel header block s m + => NodeKernel header block s txid m -> NtNAddr -> m (StrictTVar m (Chain header)) registerClientChains NodeKernel { nkClientChains } peerAddr = atomically $ do @@ -313,7 +333,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,29 +385,33 @@ 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 , MonadThrow m , MonadThrow (STM m) + , Strict.MonadMVar m , HasFullHeader block , RandomGen seed + , Eq txid ) => BlockGeneratorArgs block seed - -> (NodeKernel header block seed m -> Async m Void -> m a) + -> [Tx txid] + -> (NodeKernel header block seed txid m -> Async m Void -> m a) -- ^ The continuation which has a handle to the chain selection \/ block -- production thread. The thread might throw an exception. -> m a withNodeKernelThread BlockGeneratorArgs { bgaSlotDuration, bgaBlockGenerator, bgaSeed } + txs k = do - kernel <- newNodeKernel psSeed + kernel <- newNodeKernel psSeed txs withSlotTime bgaSlotDuration $ \waitForSlot -> withAsync (blockProducerThread kernel waitForSlot) (k kernel) where (bpSeed, psSeed) = split bgaSeed - blockProducerThread :: NodeKernel header block seed m + blockProducerThread :: NodeKernel header block seed txid m -> (SlotNo -> STM m SlotNo) -> m Void blockProducerThread NodeKernel { nkChainProducerState, nkChainDB } diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs index d15a7d3eb5d..f998308f0e4 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -82,10 +82,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 +94,25 @@ 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.Policy (TxDecisionPolicy (..)) +import Ouroboros.Network.TxSubmission.Inbound.Registry (SharedTxStateVar, + TxChannelsVar, withPeer) +import Ouroboros.Network.TxSubmission.Inbound.Server (txSubmissionInboundV2) +import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState) +import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxSubmissionInbound) +import Ouroboros.Network.TxSubmission.Outbound (txSubmissionOutbound) import Ouroboros.Network.Util.ShowProxy import Ouroboros.Network.Diffusion.Policies (simplePeerSelectionPolicy) import Test.Ouroboros.Network.Diffusion.Node.Kernel +import Test.Ouroboros.Network.TxSubmission.Common (Mempool, Tx, + getMempoolReader, getMempoolWriter, txSubmissionCodec2) -- | Protocol codecs. @@ -114,6 +128,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 +143,7 @@ cborCodecs = Codecs , keepAliveCodec = codecKeepAlive_v2 , pingPongCodec = codecPingPong , peerSharingCodec = codecPeerSharing encodeNtNAddr decodeNtNAddr + , txSubmissionCodec = txSubmissionCodec2 } @@ -180,6 +197,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 +235,7 @@ data AppArgs header block m = AppArgs :: PSTypes.PeerSharing , aaPeerMetrics :: PeerMetrics m NtNAddr + , aaTxDecisionPolicy :: TxDecisionPolicy } @@ -235,7 +261,9 @@ applications :: forall block header s m. , RandomGen s ) => Tracer m String - -> NodeKernel header block s m + -> Tracer m (TraceTxSubmissionInbound Int (Tx Int)) + -> Tracer m (DebugSharedTxState NtNAddr Int (Tx Int)) + -> NodeKernel header block s Int m -> Codecs NtNAddr header block m -> LimitsAndTimeouts header block -> AppArgs header block m @@ -243,10 +271,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 +288,7 @@ applications debugTracer nodeKernel , aaChainSyncEarlyExit , aaOwnPeerSharing , aaPeerMetrics + , aaTxDecisionPolicy } toHeader = Diffusion.Applications @@ -332,6 +362,18 @@ applications debugTracer nodeKernel blockFetchInitiator blockFetchResponder } + + , MiniProtocol { + miniProtocolNum = txSubmissionMiniProtocolNum, + miniProtocolStart = StartOnDemand, + miniProtocolLimits = txSubmissionLimits limits, + miniProtocolRun = + InitiatorAndResponderProtocol + (txSubmissionInitiator aaTxDecisionPolicy (nkMempool nodeKernel)) + (txSubmissionResponder (nkMempool nodeKernel) + (nkTxChannelsVar nodeKernel) + (nkSharedTxStateVar nodeKernel)) + } ] , withWarm = WithWarm [ MiniProtocol @@ -620,6 +662,61 @@ applications debugTracer nodeKernel $ peerSharingServerPeer $ peerSharingServer psAPI + txSubmissionInitiator + :: TxDecisionPolicy + -> Mempool m Int + -> MiniProtocolCb (ExpandedInitiatorContext NtNAddr m) ByteString m () + txSubmissionInitiator txDecisionPolicy mempool = + MiniProtocolCb $ + \ ExpandedInitiatorContext { + eicConnectionId = connId, + eicControlMessage = controlMessageSTM + } + channel + -> do + let client = txSubmissionOutbound + ((show . (connId,)) `contramap` debugTracer) + (NumTxIdsToAck $ getNumTxIdsToReq + $ maxUnacknowledgedTxIds + $ txDecisionPolicy) + (getMempoolReader mempool) + maxBound + controlMessageSTM + labelThisThread "TxSubmissionClient" + runPeerWithLimits + ((show . (connId,)) `contramap` debugTracer) + txSubmissionCodec + (txSubmissionSizeLimits limits) + (txSubmissionTimeLimits limits) + channel + (txSubmissionClientPeer client) + + txSubmissionResponder + :: Mempool m Int + -> TxChannelsVar m NtNAddr Int (Tx Int) + -> SharedTxStateVar m NtNAddr Int (Tx Int) + -> MiniProtocolCb (ResponderContext NtNAddr) ByteString m () + txSubmissionResponder mempool txChannelsVar sharedTxStateVar = + MiniProtocolCb $ + \ ResponderContext { rcConnectionId = connId@ConnectionId { remoteAddress = them }} channel + -> do + withPeer txSubmissionInboundDebug + txChannelsVar + sharedTxStateVar + (getMempoolReader mempool) + them $ \api -> do + let server = txSubmissionInboundV2 + txSubmissionInboundTracer + (getMempoolWriter mempool) + api + labelThisThread "TxSubmissionServer" + runPipelinedPeerWithLimits + ((show . (connId,)) `contramap` debugTracer) + txSubmissionCodec + (txSubmissionSizeLimits limits) + (txSubmissionTimeLimits limits) + channel + (txSubmissionServerPeerPipelined server) -- -- Orphaned Instances diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs index 2f7835b68af..a8e0f2a2616 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -24,16 +24,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 (foldl', 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 +52,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 +84,15 @@ 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.Policy (defaultTxDecisionPolicy, + txInflightMultiplicity) +import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState (..), + inflightTxs) +import Ouroboros.Network.TxSubmission.Inbound.Types + (TraceTxSubmissionInbound (..)) +import Ouroboros.Network.TxSubmission.Outbound (TxSubmissionProtocolError (..)) + +import Simulation.Network.Snocket (BearerInfo (..), noAttenuation) import Test.Ouroboros.Network.ConnectionManager.Timeouts import Test.Ouroboros.Network.ConnectionManager.Utils @@ -93,11 +105,11 @@ 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.Common (ArbTxDecisionPolicy (..), + Tx (..)) 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 @@ -157,6 +169,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 +255,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 +370,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 +412,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 +454,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 +590,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 +618,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 +654,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 +717,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 +745,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 +780,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 +818,253 @@ 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 + -> TurbulentCommands + -> (NonEmptyList (Tx Int), NonEmptyList (Tx Int)) + -> Property +unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) + (TurbulentCommands commands) + (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) + , (RelayAccessAddress "0.0.0.2" 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 + , commands) + ] + in checkAllTransactions (runSimTrace + (diffusionSimulation noAttenuation + diffScript + iosimTracer) + ) + 500000 -- ^ Running for 500k might not be enough. + where + -- We need to make sure the transactions are unique, this simplifies + -- things. + uniqueTxsA = map (\(t, i) -> t { getTxId = (foldl' (+) 0 $ map ord "0.0.0.0") + i }) + (zip txsA [0 :: Int ..]) + uniqueTxsB = map (\(t, i) -> t { getTxId = (foldl' (+) 0 $ map ord "0.0.0.1") + i }) + (zip txsB [100 :: Int ..]) + + -- This checks the property that after running the simulation for a while + -- both nodes manage to get all valid transactions. + -- + checkAllTransactions :: SimTrace Void + -> Int + -> Property + checkAllTransactions ioSimTrace traceNumber = + let events = fmap (\(WithTime t (WithName name b)) -> WithName name (WithTime t b)) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.take traceNumber + $ ioSimTrace + + -- Build the accepted (sorted) txids map for each peer + -- + sortedAcceptedTxidsMap :: Map NtNAddr [Int] + sortedAcceptedTxidsMap = + foldr (\l r -> + foldl' (\rr (WithName n (WithTime _ x)) -> + case x of + -- When we add txids to the mempool, we collect them + -- into the map + DiffusionTxSubmissionInbound (TraceTxInboundAddedToMempool txids) -> + Map.alter (maybe (Just []) (Just . sort . (txids ++))) n rr + -- When the node is shutdown we have to reset the accepted + -- txids list + DiffusionDiffusionSimulationTrace TrKillingNode -> + Map.alter (Just . const []) n rr + _ -> rr) r l + ) Map.empty + . Trace.toList + . splitWithNameTrace + $ events + + -- Construct the list of valid (sorted) txs from peer A and peer B. + -- This is essentially our goal lists + -- + (validSortedTxidsA, validSortedTxidsB) = + let f = sort + . map (\Tx {getTxId} -> getTxId) + . filter (\Tx {getTxValid} -> getTxValid) + in bimap f f (uniqueTxsA, uniqueTxsB) + + in counterexample (intercalate "\n" $ map show $ Trace.toList $ events) + $ counterexample ("unique txs: " ++ show uniqueTxsA ++ " " ++ show uniqueTxsB) + $ counterexample ("accepted txids map: " ++ show sortedAcceptedTxidsMap) + $ counterexample ("valid transactions that should be accepted: " + ++ show validSortedTxidsA ++ " " ++ show validSortedTxidsB) + + -- Success criteria, after running for 500k events, we check the map + -- for the two nodes involved in the simulation and verify that indeed + -- each peer managed to learn about the other peer' transactions. + -- + $ case ( Map.lookup (TestAddress (IPAddr (read "0.0.0.0") 0)) sortedAcceptedTxidsMap + , Map.lookup (TestAddress (IPAddr (read "0.0.0.1") 0)) sortedAcceptedTxidsMap + ) of + (Just acceptedTxidsA, Just acceptedTxidsB) -> + acceptedTxidsA === validSortedTxidsB + .&&. acceptedTxidsB === validSortedTxidsA + _ -> counterexample "Didn't find any entry in the map!" + $ False + +-- | This test checks the ratio of the inflight txs against the allowed by the +-- TxDecisionPolicy. +-- +prop_check_inflight_ratio :: AbsBearerInfo + -> DiffusionScript + -> Property +prop_check_inflight_ratio bi ds@(DiffusionScript simArgs _ _) = + let sim :: forall s . IOSim s Void + sim = diffusionSimulation (toBearerInfo bi) + ds + iosimTracer + + events :: Events DiffusionTestTrace + events = Signal.eventsFromList + . Trace.toList + . fmap ( (\(WithTime t (WithName _ b)) -> (t, b)) + ) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.take 500000 + $ runSimTrace + $ sim + + inflightTxsMap = + foldr' + (\(_, m) r -> Map.unionWith (max) m r + ) + Map.empty + $ Signal.eventsToList + $ Signal.selectEvents + (\case + DiffusionTxSubmissionDebug (DebugSharedTxState _ d) -> Just (inflightTxs d) + _ -> Nothing + ) + $ events + + txDecisionPolicy = saTxDecisionPolicy simArgs + + in tabulate "Max observeed ratio of inflight multiplicity by the max stipulated by the policy" + (map (\m -> "has " ++ show m ++ " in flight - ratio: " + ++ show @(Ratio Int) (fromIntegral m / fromIntegral (txInflightMultiplicity txDecisionPolicy)) + ) + (Map.elems inflightTxsMap)) + $ True + -- | This test coverage of InboundGovernor transitions. -- prop_inbound_governor_transitions_coverage :: AbsBearerInfo @@ -1112,7 +1390,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 +1414,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 +1448,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 +2034,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 +2099,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 +2162,7 @@ prop_connect_failure (AbsIOError ioerr) = script = DiffusionScript - (SimArgs 1 20) + (SimArgs 1 20 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [ (NodeArgs { naSeed = 0, @@ -1908,7 +2189,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 +2219,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] ) @@ -2007,7 +2290,7 @@ prop_accept_failure (AbsIOError ioerr) = script = DiffusionScript - (SimArgs 1 20) + (SimArgs 1 20 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [ (NodeArgs { naSeed = 0, @@ -2034,7 +2317,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 +2347,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 +3343,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 +3370,8 @@ async_demotion_network_script = naChainSyncEarlyExit = False, naPeerSharing = PeerSharingDisabled, - naFetchModeScript = singletonScript FetchModeDeadline + naFetchModeScript = singletonScript (PraosFetchMode FetchModeDeadline), + naTxs = [] } @@ -3645,7 +3932,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 +3960,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 +4003,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 +4037,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 +4067,8 @@ prop_unit_reconnect = (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [ JoinNetwork 0 ]) , (NodeArgs @@ -3806,7 +4096,8 @@ prop_unit_reconnect = (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [ JoinNetwork 10 ]) ] @@ -4221,12 +4512,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 +5001,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 +5029,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 +5064,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] ) 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..0bcd0b58f31 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 @@ -22,6 +22,7 @@ module Test.Ouroboros.Network.Diffusion.Testnet.Cardano.Simulation , prop_diffusionScript_fixupCommands , prop_diffusionScript_commandScript_valid , fixupCommands + , TurbulentCommands (..) , diffusionSimulation , Command (..) -- * Tracing @@ -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.Policy (TxDecisionPolicy) +import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState) +import Ouroboros.Network.TxSubmission.Inbound.Types (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) 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.Common (ArbTxDecisionPolicy (..), + Tx (..)) import Test.Ouroboros.Network.Utils import Test.QuickCheck @@ -152,17 +164,20 @@ import Test.QuickCheck -- data SimArgs = SimArgs - { saSlot :: DiffTime + { saSlot :: DiffTime -- ^ 'randomBlockGenerationArgs' slot duration argument - , saQuota :: Int + , saQuota :: Int -- ^ 'randomBlockGenerationArgs' quota value + , saTxDecisionPolicy :: TxDecisionPolicy + -- ^ Decision policy for tx submission protocol } instance Show SimArgs where - show SimArgs { saSlot, saQuota } = + show SimArgs { saSlot, saQuota, saTxDecisionPolicy } = unwords [ "SimArgs" , show saSlot , show saQuota + , "(" ++ show saTxDecisionPolicy ++ ")" ] data ServiceDomainName = @@ -218,7 +233,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 +242,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 +261,7 @@ instance Show NodeArgs where , "(" ++ show naChainSyncExitOnBlockNo ++ ")" , show naChainSyncEarlyExit , show naFetchModeScript + , show naTxs ] data Command = JoinNetwork DiffTime @@ -306,6 +324,48 @@ fixupCommands (jn@(JoinNetwork _):t) = jn : go jn t _ -> cmd : go cmd cmds fixupCommands (_:t) = fixupCommands t +-- | Turbulent commands have some turbulence by connecting and disconnecting +-- the node, but eventually keeping the node online. +-- +newtype TurbulentCommands = TurbulentCommands [Command] + deriving (Eq, Show) + +instance Arbitrary TurbulentCommands where + arbitrary = do + turbulenceNumber <- choose (2, 7) + -- Make sure turbulenceNumber is an even number + -- This simplifies making sure we keep the node online. + let turbulenceNumber' = + if odd turbulenceNumber + then turbulenceNumber + 1 + else turbulenceNumber + delays <- vectorOf turbulenceNumber' delay + let commands = zipWith (\f d -> f d) (cycle [JoinNetwork, Kill]) delays + ++ [JoinNetwork 0] + return (TurbulentCommands commands) + where + delay = frequency [ (3, genDelayWithPrecision 65) + , (1, (/ 10) <$> genDelayWithPrecision 60) + ] + shrink (TurbulentCommands xs) = + [ TurbulentCommands xs' | xs' <- shrinkList shrinkCommand xs, invariant xs' ] ++ + [ TurbulentCommands (take n xs) | n <- [0, length xs - 3], n `mod` 3 == 0, invariant (take n xs) ] + + where + shrinkDelay = map fromRational . shrink . toRational + + shrinkCommand :: Command -> [Command] + shrinkCommand (JoinNetwork d) = JoinNetwork <$> shrinkDelay d + shrinkCommand (Kill d) = Kill <$> shrinkDelay d + shrinkCommand (Reconfigure d lrp) = Reconfigure <$> shrinkDelay d + <*> pure lrp + + invariant :: [Command] -> Bool + invariant [JoinNetwork _] = True + invariant [JoinNetwork _, Kill _, JoinNetwork _] = True + invariant (JoinNetwork _ : Kill _ : JoinNetwork _ : rest) = invariant rest + invariant _ = False + -- | Simulation arguments. -- -- Slot length needs to be greater than 0 else we get a livelock on the IOSim. @@ -313,13 +373,16 @@ fixupCommands (_:t) = fixupCommands t -- Quota values matches mainnet, so a slot length of 1s and 1 / 20 chance that -- someone gets to make a block. -- -mainnetSimArgs :: Int -> SimArgs -mainnetSimArgs numberOfNodes = +mainnetSimArgs :: Int + -> TxDecisionPolicy + -> SimArgs +mainnetSimArgs numberOfNodes txDecisionPolicy = SimArgs { saSlot = secondsToDiffTime 1, saQuota = if numberOfNodes > 0 then 20 `div` numberOfNodes - else 100 + else 100, + saTxDecisionPolicy = txDecisionPolicy } @@ -363,8 +426,9 @@ genNodeArgs :: [TestnetRelayInfo] -> Int -> [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig PeerTrustable))] -> TestnetRelayInfo + -> [Tx Int] -> Gen NodeArgs -genNodeArgs relays minConnected localRootPeers self = flip suchThat hasUpstream $ do +genNodeArgs 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. -- @@ -428,7 +492,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 <- @@ -456,6 +520,7 @@ genNodeArgs relays minConnected localRootPeers self = flip suchThat hasUpstream , naChainSyncEarlyExit = chainSyncEarlyExit , naPeerSharing = peerSharing , naFetchModeScript = fetchModeScript + , naTxs = txs } where makeRelayAccessPoint (relay, _, _, _) = relay @@ -612,18 +677,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 (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 :: (TestnetRelayInfo, [Tx Int]) -> Gen (NodeArgs, [Command]) + go (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 relays' minConnected localRts relay txs commands <- genCommands localRts return (nodeArgs, commands) @@ -909,6 +990,8 @@ data DiffusionTestTrace = | DiffusionServerTrace (Server.Trace NtNAddr) | DiffusionFetchTrace (TraceFetchClientState BlockHeader) | DiffusionChurnModeTrace TracerChurnMode + | DiffusionTxSubmissionInbound (TraceTxSubmissionInbound Int (Tx Int)) + | DiffusionTxSubmissionDebug (DebugSharedTxState NtNAddr Int (Tx Int)) | DiffusionDebugTrace String | DiffusionDNSTrace DNSTrace deriving (Show) @@ -1042,6 +1125,7 @@ diffusionSimulation runNode SimArgs { saSlot = bgaSlotDuration , saQuota = quota + , saTxDecisionPolicy = txDecisionPolicy } NodeArgs { naSeed = seed @@ -1057,6 +1141,7 @@ diffusionSimulation , naChainSyncExitOnBlockNo = chainSyncExitOnBlockNo , naChainSyncEarlyExit = chainSyncEarlyExit , naPeerSharing = peerSharing + , naTxs = txs } ntnSnocket ntcSnocket @@ -1072,7 +1157,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 +1186,14 @@ diffusionSimulation limitsAndTimeouts = Node.LimitsAndTimeouts { Node.chainSyncLimits = defaultMiniProtocolsLimit - , Node.chainSyncSizeLimits = byteLimitsChainSync (const 0) + , Node.chainSyncSizeLimits = byteLimitsChainSync (fromIntegral . BL.length) , Node.chainSyncTimeLimits = 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 +1208,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 @@ -1208,6 +1295,8 @@ diffusionSimulation , Node.aDebugTracer = (\s -> WithTime (Time (-1)) (WithName addr (DiffusionDebugTrace s))) `contramap` nodeTracer , Node.aExtraChurnArgs = cardanoChurnArgs + , Node.aTxDecisionPolicy = txDecisionPolicy + , Node.aTxs = txs } tracers = mkTracers addr @@ -1239,6 +1328,14 @@ diffusionSimulation . tracerWithName addr . tracerWithTime $ nodeTracer) + ( contramap DiffusionTxSubmissionInbound + . tracerWithName addr + . tracerWithTime + $ nodeTracer) + ( contramap DiffusionTxSubmissionDebug + . tracerWithName addr + . tracerWithTime + $ nodeTracer) `catch` \e -> traceWith (diffSimTracer addr) (TrErrored e) >> throwIO e diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs index 85d2bbd7faf..b5fbbaedd73 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs @@ -56,7 +56,10 @@ import Network.TypedProtocol.Codec import Ouroboros.Network.Protocol.TxSubmission2.Codec import Ouroboros.Network.Protocol.TxSubmission2.Type import Ouroboros.Network.TxSubmission.Inbound +import Ouroboros.Network.TxSubmission.Inbound.Decision + (SharedDecisionContext (..), TxDecision (..)) import Ouroboros.Network.TxSubmission.Inbound.Decision qualified as TXS +import Ouroboros.Network.TxSubmission.Inbound.Policy import Ouroboros.Network.TxSubmission.Inbound.State (PeerTxState (..), SharedTxState (..)) import Ouroboros.Network.TxSubmission.Inbound.State qualified as TXS @@ -1646,6 +1649,7 @@ prop_makeDecisions_exhaustive . counterexample ("state'': " ++ show sharedTxState'') $ null decisions'' + data ArbDecisionContextWithReceivedTxIds = ArbDecisionContextWithReceivedTxIds { adcrDecisionPolicy :: TxDecisionPolicy, adcrSharedContext :: SharedDecisionContext PeerAddr TxId (Tx TxId), From dc4da5658cb88ca915ddcddacdb07d8629e6749a Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 16 Sep 2024 07:36:50 +0200 Subject: [PATCH 16/54] tx-submission: added DebugTxLogic tracer Module structure needs to be reorganised to have just one debug tracer. --- .../Network/TxSubmission/Inbound/Registry.hs | 21 +++++++++++++++---- .../Test/Ouroboros/Network/Diffusion/Node.hs | 9 +++++--- .../Diffusion/Testnet/Cardano/Simulation.hs | 6 ++++++ .../Network/TxSubmission/TxSubmissionV2.hs | 17 ++++++++------- 4 files changed, 39 insertions(+), 14 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs index b93881a7289..0d2d2f17954 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -12,11 +12,13 @@ module Ouroboros.Network.TxSubmission.Inbound.Registry , newTxChannelsVar , PeerTxAPI (..) , decisionLogicThread + , DebugTxLogic (..) , withPeer ) where import Control.Concurrent.Class.MonadMVar.Strict import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTimer.SI @@ -211,22 +213,32 @@ withPeer tracer collectTxs tracer sharedStateVar peeraddr txids txs +-- | TODO: reorganise modules so there's just one `Debug` tracer. +data DebugTxLogic peeraddr txid tx = + DebugTxLogicSharedTxState (SharedTxState peeraddr txid tx) + | DebugTxLogicDecisions (Map peeraddr (TxDecision txid tx)) + deriving Show + + decisionLogicThread :: forall m peeraddr txid tx. ( MonadDelay m , MonadMVar m , MonadSTM m - , MonadMask m + , MonadMask m + , MonadFork m , Ord peeraddr , Ord txid ) - => Tracer m (DebugSharedTxState peeraddr txid tx) + => Tracer m (DebugTxLogic peeraddr txid tx) -> TxDecisionPolicy -> STM m (Map peeraddr PeerGSV) -> TxChannelsVar m peeraddr txid tx -> SharedTxStateVar m peeraddr txid tx -> m Void -decisionLogicThread tracer policy readGSVVar txChannelsVar sharedStateVar = go +decisionLogicThread tracer policy readGSVVar txChannelsVar sharedStateVar = do + labelThisThread "tx-decision" + go where go :: m Void go = do @@ -247,7 +259,8 @@ decisionLogicThread tracer policy readGSVVar txChannelsVar sharedStateVar = go let (sharedState, decisions) = makeDecisions policy sharedCtx activePeers writeTVar sharedStateVar sharedState return (decisions, sharedState) - traceWith tracer (DebugSharedTxState "decisionLogicThread" st) + traceWith tracer (DebugTxLogicSharedTxState st) + traceWith tracer (DebugTxLogicDecisions decisions) TxChannels { txChannelMap } <- readMVar txChannelsVar traverse_ (\(mvar, d) -> modifyMVarWithDefault_ mvar d (\d' -> pure (d' <> d))) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs index 258d7337c5f..7e088011e75 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -114,7 +114,8 @@ import Ouroboros.Network.Snocket (MakeBearer, Snocket, TestAddress (..), invalidFileDescriptor) import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy) -import Ouroboros.Network.TxSubmission.Inbound.Registry (decisionLogicThread) +import Ouroboros.Network.TxSubmission.Inbound.Registry (DebugTxLogic, + decisionLogicThread) import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState) import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxSubmissionInbound) @@ -264,12 +265,14 @@ run :: forall extraState extraDebugState extraAPI -> Tracer m (TraceLabelPeer NtNAddr (TraceFetchClientState BlockHeader)) -> Tracer m (TraceTxSubmissionInbound Int (Tx Int)) -> Tracer m (DebugSharedTxState NtNAddr Int (Tx Int)) + -> Tracer m (DebugTxLogic NtNAddr Int (Tx Int)) -> m Void run blockGeneratorArgs limits ni na emptyExtraState emptyExtraCounters extraPeersAPI psArgs psToExtraCounters toExtraPeers requestPublicRootPeers peerChurnGovernor - tracers tracerBlockFetch tracerTxSubmissionInbound tracerTxSubmissionDebug = + tracers tracerBlockFetch tracerTxSubmissionInbound tracerTxSubmissionDebug + tracerTxLogic = Node.withNodeKernelThread blockGeneratorArgs (aTxs na) $ \ nodeKernel nodeKernelThread -> do dnsTimeoutScriptVar <- newTVarIO (aDNSTimeoutScript na) @@ -365,7 +368,7 @@ run blockGeneratorArgs limits ni na withAsync (blockFetch nodeKernel) $ \blockFetchLogicThread -> withAsync (decisionLogicThread - tracerTxSubmissionDebug + tracerTxLogic (aTxDecisionPolicy na) (readPeerGSVs (nkFetchClientRegistry nodeKernel)) (nkTxChannelsVar nodeKernel) 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 0bcd0b58f31..b2f4288ab04 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 @@ -132,6 +132,7 @@ import Ouroboros.Network.Protocol.TxSubmission2.Codec (byteLimitsTxSubmission2, import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Snocket (Snocket, TestAddress (..)) import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy) +import Ouroboros.Network.TxSubmission.Inbound.Registry (DebugTxLogic) import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState) import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxSubmissionInbound) @@ -992,6 +993,7 @@ data DiffusionTestTrace = | DiffusionChurnModeTrace TracerChurnMode | DiffusionTxSubmissionInbound (TraceTxSubmissionInbound Int (Tx Int)) | DiffusionTxSubmissionDebug (DebugSharedTxState NtNAddr Int (Tx Int)) + | DiffusionTxLogicDebug (DebugTxLogic NtNAddr Int (Tx Int)) | DiffusionDebugTrace String | DiffusionDNSTrace DNSTrace deriving (Show) @@ -1336,6 +1338,10 @@ diffusionSimulation . tracerWithName addr . tracerWithTime $ nodeTracer) + ( contramap DiffusionTxLogicDebug + . tracerWithName addr + . tracerWithTime + $ nodeTracer) `catch` \e -> traceWith (diffSimTracer addr) (TrErrored e) >> throwIO e diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs index 119d818eb86..58c49a51754 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs @@ -95,7 +95,9 @@ instance Arbitrary TxSubmissionState where peersState <- map (\(a, (b, c)) -> (a, b, c)) . zip txs <$> vectorOf peersN arbitrary - return (TxSubmissionState (Map.fromList (zip peers peersState)) decisionPolicy) + return TxSubmissionState { peerMap = Map.fromList (zip peers peersState), + decisionPolicy + } shrink TxSubmissionState { peerMap, decisionPolicy } = TxSubmissionState <$> shrinkMap1 peerMap <*> [ policy @@ -134,6 +136,7 @@ runTxSubmission ) => Tracer m (String, TraceSendRecv (TxSubmission2 txid (Tx txid))) -> Tracer m (DebugSharedTxState peeraddr txid (Tx txid)) + -> Tracer m (DebugTxLogic peeraddr txid (Tx txid)) -> Map peeraddr ( [Tx txid] , ControlMessageSTM m , Maybe DiffTime @@ -141,7 +144,7 @@ runTxSubmission ) -> TxDecisionPolicy -> m ([Tx txid], [[Tx txid]]) -runTxSubmission tracer tracerDST state txDecisionPolicy = do +runTxSubmission tracer tracerDST tracerTxLogic state txDecisionPolicy = do state' <- traverse (\(b, c, d, e) -> do mempool <- newMempool b @@ -186,10 +189,10 @@ runTxSubmission tracer tracerDST state txDecisionPolicy = do -> m b run st txChannelsVar sharedTxStateVar inboundMempool gsvVar k = - withAsync (decisionLogicThread tracerDST txDecisionPolicy (Strict.readTVar gsvVar) txChannelsVar sharedTxStateVar) $ \a -> do + withAsync (decisionLogicThread tracerTxLogic txDecisionPolicy (Strict.readTVar gsvVar) txChannelsVar sharedTxStateVar) $ \a -> do -- Construct txSubmission outbound client let clients = (\(addr, (mempool, ctrlMsgSTM, outDelay, _, outChannel, _)) -> do - let client = txSubmissionOutbound verboseTracer + let client = txSubmissionOutbound (Tracer $ say . show) (NumTxIdsToAck $ getNumTxIdsToReq $ maxUnacknowledgedTxIds $ txDecisionPolicy) @@ -270,9 +273,9 @@ txSubmissionSimulation (TxSubmissionState state txDecisionPolicy) = do threadDelay (simDelayTime + 1000) atomically (traverse_ (`writeTVar` Terminate) controlMessageVars) - let tracer = verboseTracer <> debugTracer - tracer' = verboseTracer <> debugTracer - runTxSubmission tracer tracer' state'' txDecisionPolicy + let tracer :: forall a. Show a => Tracer (IOSim s) a + tracer = verboseTracer <> debugTracer + runTxSubmission tracer tracer tracer state'' txDecisionPolicy -- | Tests overall tx submission semantics. The properties checked in this -- property test are the same as for tx submission v1. We need this to know we From 4f09cf06fffb481c0f9a56215bde817907be8b2e Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 16 Sep 2024 07:40:24 +0200 Subject: [PATCH 17/54] tx-submission: label TVars in tests --- .../Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs index 58c49a51754..5a4740d089c 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs @@ -120,7 +120,7 @@ runTxSubmission , MonadMVar m , MonadSay m , MonadST m - , MonadSTM m + , MonadLabelledSTM m , MonadTimer m , MonadThrow m , MonadThrow (STM m) @@ -156,7 +156,9 @@ runTxSubmission tracer tracerDST tracerTxLogic state txDecisionPolicy = do txChannelsMVar <- Strict.newMVar (TxChannels Map.empty) sharedTxStateVar <- newSharedTxStateVar + Strict.labelTVarIO sharedTxStateVar "shared-tx-state" gsvVar <- Strict.newTVarIO Map.empty + Strict.labelTVarIO gsvVar "gsv" run state' txChannelsMVar From 7e24e8ca358108884b659e2c10cb006fb4398dfd Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 16 Sep 2024 07:41:12 +0200 Subject: [PATCH 18/54] tx-submission: use strict STM in tests --- .../Network/TxSubmission/TxSubmissionV2.hs | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs index 5a4740d089c..8142739c36d 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs @@ -16,11 +16,8 @@ import Prelude hiding (seq) import NoThunks.Class -import Control.Concurrent.Class.MonadMVar (MonadMVar) -import Control.Concurrent.Class.MonadMVar.Strict qualified as Strict -import Control.Concurrent.Class.MonadSTM -import Control.Concurrent.Class.MonadSTM.Strict (StrictTVar) -import Control.Concurrent.Class.MonadSTM.Strict qualified as Strict +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 @@ -154,11 +151,11 @@ runTxSubmission tracer tracerDST tracerTxLogic state txDecisionPolicy = do inboundMempool <- emptyMempool - txChannelsMVar <- Strict.newMVar (TxChannels Map.empty) + txChannelsMVar <- newMVar (TxChannels Map.empty) sharedTxStateVar <- newSharedTxStateVar - Strict.labelTVarIO sharedTxStateVar "shared-tx-state" - gsvVar <- Strict.newTVarIO Map.empty - Strict.labelTVarIO gsvVar "gsv" + labelTVarIO sharedTxStateVar "shared-tx-state" + gsvVar <- newTVarIO Map.empty + labelTVarIO gsvVar "gsv" run state' txChannelsMVar @@ -191,7 +188,7 @@ runTxSubmission tracer tracerDST tracerTxLogic state txDecisionPolicy = do -> m b run st txChannelsVar sharedTxStateVar inboundMempool gsvVar k = - withAsync (decisionLogicThread tracerTxLogic txDecisionPolicy (Strict.readTVar gsvVar) txChannelsVar sharedTxStateVar) $ \a -> do + 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) From 53c45184b65d2d03bbbca4ff391e07c9a37e55d9 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 17 Sep 2024 18:20:49 +0200 Subject: [PATCH 19/54] tx-submission: refactored test Use `IOSim` API. `evaluateTrace` from `Test.Ouroboros.Network.LedgerPeers` has the annoying property that once the trace was evaluated in won't show the trace again, which makes it hard to work with `cabal repl`. Refactored `checkMempools` to improve readablity. Should be squashed onto `c9d45673ca New txSubmissionV2 simulation` --- .../Network/TxSubmission/TxSubmissionV2.hs | 126 ++++++++++-------- 1 file changed, 73 insertions(+), 53 deletions(-) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs index 8142739c36d..d5f72f773cf 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs @@ -34,7 +34,7 @@ import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy qualified as BSL import Data.Foldable (traverse_) import Data.Function (on) -import Data.List (intercalate, nubBy) +import Data.List (nubBy) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) @@ -282,49 +282,58 @@ txSubmissionSimulation (TxSubmissionState state txDecisionPolicy) = do -- prop_txSubmission :: TxSubmissionState -> Property prop_txSubmission st = - ioProperty $ do - tr' <- evaluateTrace (runSimTrace (txSubmissionSimulation st)) - 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, outmps) _trace -> do - r <- mapM (\outmp -> do - 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 $ counterexample ("(True, True) " ++ show outmp) - $ checkMempools 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 $ counterexample ("(True, False) " ++ show outmp) - $ checkMempools 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 $ counterexample ("(False, True) " ++ 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. - return $ property True) - outmps - return $ counterexample (intercalate "\n" _trace) - $ conjoin r + 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. @@ -366,15 +375,26 @@ prop_txSubmission_inflight st@(TxSubmissionState state _) = inmp in resultRepeatedValidTxs === maxRepeatedValidTxs -checkMempools :: (Eq a, Show a) => [a] -> [a] -> Property -checkMempools [] [] = property True -checkMempools _ [] = property True -checkMempools [] _ = property False -checkMempools inp@(i : is) outp@(o : os) = - if o == i then counterexample (show inp ++ " " ++ show outp) - $ checkMempools is os - else counterexample (show inp ++ " " ++ show outp) - $ checkMempools is outp + +-- | 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. -- From a14a00aad7476bc47362dbc314b07b74a4a01e23 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 17 Sep 2024 19:45:47 +0200 Subject: [PATCH 20/54] tx-submission: put common types in one place This allows us to have just one tracer for tx-submission decision logic. --- ouroboros-network/ouroboros-network.cabal | 7 +- .../Ouroboros/Network/TxSubmission/Inbound.hs | 4 +- .../Network/TxSubmission/Inbound/Decision.hs | 79 +----- .../Network/TxSubmission/Inbound/Registry.hs | 21 +- .../Network/TxSubmission/Inbound/Server.hs | 1 - .../Network/TxSubmission/Inbound/State.hs | 152 +---------- .../Network/TxSubmission/Inbound/Types.hs | 247 ++++++++++++++++- .../Test/Ouroboros/Network/Diffusion/Node.hs | 16 +- .../Network/Diffusion/Node/Kernel.hs | 3 +- .../Network/Diffusion/Node/MiniProtocols.hs | 10 +- .../Network/Diffusion/Testnet/Cardano.hs | 16 +- .../Diffusion/Testnet/Cardano/Simulation.hs | 18 +- .../Test/Ouroboros/Network/TxSubmission.hs | 12 +- .../{TxSubmissionV1.hs => AppV1.hs} | 7 +- .../{TxSubmissionV2.hs => AppV2.hs} | 18 +- .../TxSubmission/{Common.hs => TxLogic.hs} | 233 +--------------- .../Ouroboros/Network/TxSubmission/Types.hs | 248 ++++++++++++++++++ 17 files changed, 565 insertions(+), 527 deletions(-) rename ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/{TxSubmissionV1.hs => AppV1.hs} (97%) rename ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/{TxSubmissionV2.hs => AppV2.hs} (96%) rename ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/{Common.hs => TxLogic.hs} (87%) create mode 100644 ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 9bce76351d2..679b44417c8 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -399,9 +399,10 @@ library testlib Test.Ouroboros.Network.PeerSelection.PeerMetric Test.Ouroboros.Network.PeerSelection.RootPeersDNS Test.Ouroboros.Network.TxSubmission - Test.Ouroboros.Network.TxSubmission.Common - Test.Ouroboros.Network.TxSubmission.TxSubmissionV1 - Test.Ouroboros.Network.TxSubmission.TxSubmissionV2 + 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/TxSubmission/Inbound.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs index e8ff9faaac6..cbae83a1e36 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs @@ -45,7 +45,9 @@ 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.Types +import Ouroboros.Network.TxSubmission.Inbound.Types (ProcessedTxCount (..), + TraceTxSubmissionInbound (..), TxSubmissionMempoolWriter (..), + TxSubmissionProtocolError (..)) import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..), TxSubmissionMempoolReader (..)) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs index 5b504ec7c9a..a6d0ccdeb82 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs @@ -34,86 +34,9 @@ import Ouroboros.Network.DeltaQ (PeerGSV (..), defaultGSV, import Ouroboros.Network.Protocol.TxSubmission2.Type import Ouroboros.Network.TxSubmission.Inbound.Policy import Ouroboros.Network.TxSubmission.Inbound.State +import Ouroboros.Network.TxSubmission.Inbound.Types --- | Decision made by the decision logic. Each peer will receive a 'Decision'. --- --- /note:/ it is rather non-standard to represent a choice between requesting --- `txid`s and `tx`'s as a product rather than a sum type. The client will --- need to download `tx`s first and then send a request for more txids (and --- acknowledge some `txid`s). Due to pipelining each client will request --- decision from the decision logic quite often (every two pipelined requests), --- but with this design a decision once taken will make the peer non-active --- (e.g. it won't be returned by `filterActivePeers`) for longer, and thus the --- expensive `makeDecision` computation will not need to take that peer into --- account. --- -data TxDecision txid tx = TxDecision { - txdTxIdsToAcknowledge :: !NumTxIdsToAck, - -- ^ txid's to acknowledge - - txdTxIdsToRequest :: !NumTxIdsToReq, - -- ^ number of txid's to request - - txdPipelineTxIds :: !Bool, - -- ^ the tx-submission protocol only allows to pipeline `txid`'s requests - -- if we have non-acknowledged `txid`s. - - txdTxsToRequest :: !(Set txid), - -- ^ txid's to download. - - txdTxsToMempool :: ![tx] - -- ^ list of `tx`s to submit to the mempool. - } - deriving (Show, Eq) - --- | A non-commutative semigroup instance. --- --- /note:/ this instance must be consistent with `pickTxsToDownload` and how --- `PeerTxState` is updated. It is designed to work with `TMergeVar`s. --- -instance Ord txid => Semigroup (TxDecision txid tx) where - TxDecision { txdTxIdsToAcknowledge, - txdTxIdsToRequest, - txdPipelineTxIds = _ignored, - txdTxsToRequest, - txdTxsToMempool } - <> - TxDecision { txdTxIdsToAcknowledge = txdTxIdsToAcknowledge', - txdTxIdsToRequest = txdTxIdsToRequest', - txdPipelineTxIds = txdPipelineTxIds', - txdTxsToRequest = txdTxsToRequest', - txdTxsToMempool = txdTxsToMempool' } - = - TxDecision { txdTxIdsToAcknowledge = txdTxIdsToAcknowledge + txdTxIdsToAcknowledge', - txdTxIdsToRequest = txdTxIdsToRequest + txdTxIdsToRequest', - txdPipelineTxIds = txdPipelineTxIds', - txdTxsToRequest = txdTxsToRequest <> txdTxsToRequest', - txdTxsToMempool = txdTxsToMempool ++ txdTxsToMempool' - } - --- | A no-op decision. -emptyTxDecision :: TxDecision txid tx -emptyTxDecision = TxDecision { - txdTxIdsToAcknowledge = 0, - txdTxIdsToRequest = 0, - txdPipelineTxIds = False, - txdTxsToRequest = Set.empty, - txdTxsToMempool = [] - } - -data SharedDecisionContext peeraddr txid tx = SharedDecisionContext { - -- TODO: check how to access it. - sdcPeerGSV :: !(Map peeraddr PeerGSV), - - sdcSharedTxState :: !(SharedTxState peeraddr txid tx) - } - deriving Show - --- --- Decision Logic --- - -- | Make download decisions. -- makeDecisions diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs index 0d2d2f17954..395c42a1b02 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -12,7 +12,6 @@ module Ouroboros.Network.TxSubmission.Inbound.Registry , newTxChannelsVar , PeerTxAPI (..) , decisionLogicThread - , DebugTxLogic (..) , withPeer ) where @@ -38,6 +37,7 @@ import Ouroboros.Network.Protocol.TxSubmission2.Type import Ouroboros.Network.TxSubmission.Inbound.Decision import Ouroboros.Network.TxSubmission.Inbound.Policy import Ouroboros.Network.TxSubmission.Inbound.State +import Ouroboros.Network.TxSubmission.Inbound.Types import Ouroboros.Network.TxSubmission.Mempool.Reader -- | Communication channels between `TxSubmission` client mini-protocol and @@ -75,10 +75,6 @@ data PeerTxAPI m txid tx = PeerTxAPI { } -data TraceDecision peeraddr txid tx = - TraceDecisions (Map peeraddr (TxDecision txid tx)) - deriving (Eq, Show) - -- | A bracket function which registers / de-registers a new peer in -- `SharedTxStateVar` and `PeerTxStateVar`s, which exposes `PeerTxStateAPI`. -- `PeerTxStateAPI` is only safe inside the `withPeer` scope. @@ -92,7 +88,7 @@ withPeer , Ord peeraddr , Show peeraddr ) - => Tracer m (DebugSharedTxState peeraddr txid tx) + => Tracer m (TraceTxLogic peeraddr txid tx) -> TxChannelsVar m peeraddr txid tx -> SharedTxStateVar m peeraddr txid tx -> TxSubmissionMempoolReader txid tx idx m @@ -213,13 +209,6 @@ withPeer tracer collectTxs tracer sharedStateVar peeraddr txids txs --- | TODO: reorganise modules so there's just one `Debug` tracer. -data DebugTxLogic peeraddr txid tx = - DebugTxLogicSharedTxState (SharedTxState peeraddr txid tx) - | DebugTxLogicDecisions (Map peeraddr (TxDecision txid tx)) - deriving Show - - decisionLogicThread :: forall m peeraddr txid tx. ( MonadDelay m @@ -230,7 +219,7 @@ decisionLogicThread , Ord peeraddr , Ord txid ) - => Tracer m (DebugTxLogic peeraddr txid tx) + => Tracer m (TraceTxLogic peeraddr txid tx) -> TxDecisionPolicy -> STM m (Map peeraddr PeerGSV) -> TxChannelsVar m peeraddr txid tx @@ -259,8 +248,8 @@ decisionLogicThread tracer policy readGSVVar txChannelsVar sharedStateVar = do let (sharedState, decisions) = makeDecisions policy sharedCtx activePeers writeTVar sharedStateVar sharedState return (decisions, sharedState) - traceWith tracer (DebugTxLogicSharedTxState st) - traceWith tracer (DebugTxLogicDecisions decisions) + traceWith tracer (TraceSharedTxState "decisionLogicThread" st) + traceWith tracer (TraceTxDecisions decisions) TxChannels { txChannelMap } <- readMVar txChannelsVar traverse_ (\(mvar, d) -> modifyMVarWithDefault_ mvar d (\d' -> pure (d' <> d))) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs index 273509a41fb..69c9b7bcfdc 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs @@ -22,7 +22,6 @@ import Network.TypedProtocol import Control.Monad (unless) import Ouroboros.Network.Protocol.TxSubmission2.Server -import Ouroboros.Network.TxSubmission.Inbound.Decision (TxDecision (..)) import Ouroboros.Network.TxSubmission.Inbound.Registry (PeerTxAPI (..)) import Ouroboros.Network.TxSubmission.Inbound.Types diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs index b2eb8b5d04b..a54318c306c 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs @@ -16,8 +16,6 @@ module Ouroboros.Network.TxSubmission.Inbound.State , receivedTxIds , collectTxs , acknowledgeTxIds - -- * Debug output - , DebugSharedTxState (..) -- * Internals, only exported for testing purposes: , RefCountDiff (..) , updateRefCounts @@ -42,63 +40,16 @@ import Data.Sequence.Strict (StrictSeq) import Data.Sequence.Strict qualified as StrictSeq import Data.Set (Set) import Data.Set qualified as Set -import GHC.Generics (Generic) - -import NoThunks.Class (NoThunks (..)) import GHC.Stack (HasCallStack) import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..), NumTxIdsToReq (..)) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) import Ouroboros.Network.TxSubmission.Inbound.Policy +import Ouroboros.Network.TxSubmission.Inbound.Types import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..)) -data PeerTxState txid tx = PeerTxState { - -- | Those transactions (by their identifier) that the client has told - -- us about, and which we have not yet acknowledged. This is kept in - -- the order in which the client gave them to us. This is the same order - -- in which we submit them to the mempool (or for this example, the final - -- result order). It is also the order we acknowledge in. - -- - unacknowledgedTxIds :: !(StrictSeq txid), - - -- | Set of known transaction ids which can be requested from this peer. - -- - availableTxIds :: !(Map txid SizeInBytes), - - -- | The number of transaction identifiers that we have requested but - -- which have not yet been replied to. We need to track this it keep - -- our requests within the limit on the number of unacknowledged txids. - -- - requestedTxIdsInflight :: !NumTxIdsToReq, - - -- | The size in bytes of transactions that we have requested but which - -- have not yet been replied to. We need to track this it keep our - -- requests within the limit on the number of unacknowledged txids. - -- - requestedTxsInflightSize :: !SizeInBytes, - - -- | The set of requested `txid`s. - -- - requestedTxsInflight :: !(Set txid), - - -- | A subset of `unacknowledgedTxIds` which were unknown to the peer. - -- We need to track these `txid`s since they need to be acknowledged. - -- - -- We track these `txid` per peer, rather than in `bufferedTxs` map, - -- since that could potentially lead to corrupting the node, not being - -- able to download a `tx` which is needed & available from other nodes. - -- - unknownTxs :: !(Set txid) - } - deriving (Eq, Show, Generic) - -instance ( NoThunks txid - , NoThunks tx - ) => NoThunks (PeerTxState txid tx) - - -- | Compute number of `txids` to request respecting `TxDecisionPolicy`; update -- `PeerTxState`. -- @@ -135,90 +86,6 @@ numTxIdsToRequest unackedAndRequested = unacked + requestedTxIdsInflight unacked = fromIntegral $ StrictSeq.length unacknowledgedTxIds - --- | Shared state of all `TxSubmission` clients. --- --- New `txid` enters `unacknowledgedTxIds` it is also added to `availableTxIds` --- and `referenceCounts` (see `acknowledgeTxIdsImpl`). --- --- When a `txid` id is selected to be downloaded, it's added to --- `requestedTxsInflightSize` (see --- `Ouroboros.Network.TxSubmission.Inbound.Decision.pickTxsToDownload`). --- --- When the request arrives, the `txid` is removed from `inflightTxs`. It --- might be added to `unknownTxs` if the server didn't have that `txid`, or --- it's added to `bufferedTxs` (see `collectTxsImpl`). --- --- Whenever we choose `txid` to acknowledge (either in `acknowledtxsIdsImpl`, --- `collectTxsImpl` or --- `Ouroboros.Network.TxSubmission.Inbound.Decision.pickTxsToDownload`, we also --- recalculate `referenceCounts` and only keep live `txid`s in other maps (e.g. --- `availableTxIds`, `bufferedTxs`, `unknownTxs`). --- -data SharedTxState peeraddr txid tx = SharedTxState { - - -- | Map of peer states. - -- - -- /Invariant:/ for peeraddr's which are registered using `withPeer`, - -- there's always an entry in this map even if the set of `txid`s is - -- empty. - -- - peerTxStates :: !(Map peeraddr (PeerTxState txid tx)), - - -- | Set of transactions which are in-flight (have already been - -- requested) together with multiplicities (from how many peers it is - -- currently in-flight) - -- - -- This set can intersect with `availableTxIds`. - -- - inflightTxs :: !(Map txid Int), - - -- | Overall size of all `tx`s in-flight. - -- - inflightTxsSize :: !SizeInBytes, - - -- | Map of `tx` which: - -- - -- * were downloaded, - -- * are already in the mempool (`Nothing` is inserted in that case), - -- - -- We only keep live `txid`, e.g. ones which `txid` is unacknowledged by - -- at least one peer. - -- - -- /Note:/ `txid`s which `tx` were unknown by a peer are tracked - -- separately in `unknownTxs`. - -- - -- /Note:/ previous implementation also needed to explicitly tracked - -- `txid`s which were already acknowledged, but are still unacknowledged. - -- In this implementation, this is done due to reference counting. - -- - -- This map is useful to acknowledge `txid`s, it's basically taking the - -- longest prefix which contains entries in `bufferedTxs` or `unknownTxs`. - -- - bufferedTxs :: !(Map txid (Maybe tx)), - - -- | We track reference counts of all unacknowledged txids. Once the - -- count reaches 0, a tx is removed from `bufferedTxs`. - -- - -- The `bufferedTx` map contains a subset of `txid` which - -- `referenceCounts` contains. - -- - -- /Invariants:/ - -- - -- * the txid count is equal to multiplicity of txid in all - -- `unacknowledgedTxIds` sequences; - -- * @Map.keysSet bufferedTxs `Set.isSubsetOf` Map.keysSet referenceCounts@; - -- * all counts are positive integers. - -- - referenceCounts :: !(Map txid Int) - } - deriving (Eq, Show, Generic) - -instance ( NoThunks peeraddr - , NoThunks tx - , NoThunks txid - ) => NoThunks (SharedTxState peeraddr txid tx) - -- -- Pure public API -- @@ -555,7 +422,7 @@ newSharedTxStateVar = newTVarIO SharedTxState { peerTxStates = Map.empty, receivedTxIds :: forall m peeraddr idx tx txid. (MonadSTM m, Ord txid, Ord peeraddr) - => Tracer m (DebugSharedTxState peeraddr txid tx) + => Tracer m (TraceTxLogic peeraddr txid tx) -> SharedTxStateVar m peeraddr txid tx -> STM m (MempoolSnapshot txid tx idx) -> peeraddr @@ -571,7 +438,7 @@ receivedTxIds tracer sharedVar getMempoolSnapshot peeraddr reqNo txidsSeq txidsM st <- atomically $ do MempoolSnapshot{mempoolHasTx} <- getMempoolSnapshot stateTVar sharedVar ((\a -> (a,a)) . receivedTxIdsImpl mempoolHasTx peeraddr reqNo txidsSeq txidsMap) - traceWith tracer (DebugSharedTxState "receivedTxIds" st) + traceWith tracer (TraceSharedTxState "receivedTxIds" st) -- | Include received `tx`s in `SharedTxState`. Return number of `txids` @@ -580,7 +447,7 @@ receivedTxIds tracer sharedVar getMempoolSnapshot peeraddr reqNo txidsSeq txidsM collectTxs :: forall m peeraddr tx txid. (MonadSTM m, Ord txid, Ord peeraddr) - => Tracer m (DebugSharedTxState peeraddr txid tx) + => Tracer m (TraceTxLogic peeraddr txid tx) -> SharedTxStateVar m peeraddr txid tx -> peeraddr -> Set txid -- ^ set of requested txids @@ -592,13 +459,4 @@ collectTxs tracer sharedVar peeraddr txidsRequested txsMap = do st <- atomically $ stateTVar sharedVar ((\a -> (a,a)) . collectTxsImpl peeraddr txidsRequested txsMap) - traceWith tracer (DebugSharedTxState "collectTxs" st) - --- --- --- - --- | Debug tracer. --- -data DebugSharedTxState peeraddr txid tx = DebugSharedTxState String (SharedTxState peeraddr txid tx) - deriving Show + traceWith tracer (TraceSharedTxState "collectTxs" st) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs index 74224b535d3..996b7aff43e 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs @@ -1,13 +1,256 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} + module Ouroboros.Network.TxSubmission.Inbound.Types - ( ProcessedTxCount (..) + ( -- * PeerTxState + PeerTxState (..) + -- * SharedTxState + , SharedTxState (..) + -- * Decisions + , TxDecision (..) + , emptyTxDecision + , SharedDecisionContext (..) + -- * Various + , ProcessedTxCount (..) + -- * Mempool API , TxSubmissionMempoolWriter (..) + -- * Traces , TraceTxSubmissionInbound (..) + , TraceTxLogic (..) + -- * Protocol Error , TxSubmissionProtocolError (..) ) where import Control.Exception (Exception (..)) +import Data.Map.Strict (Map) +import Data.Sequence.Strict (StrictSeq) +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Generics (Generic) + +import NoThunks.Class (NoThunks (..)) + +import Ouroboros.Network.DeltaQ (PeerGSV (..)) +import Ouroboros.Network.Protocol.TxSubmission2.Type + +-- +-- 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) + } + 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 { -import Ouroboros.Network.TxSubmission.Inbound.Decision (TxDecision (..)) + -- | Map of peer states. + -- + -- /Invariant:/ for peeraddr's which are registered using `withPeer`, + -- there's always an entry in this map even if the set of `txid`s is + -- empty. + -- + peerTxStates :: !(Map peeraddr (PeerTxState txid tx)), + + -- | Set of transactions which are in-flight (have already been + -- requested) together with multiplicities (from how many peers it is + -- currently in-flight) + -- + -- This set can intersect with `availableTxIds`. + -- + inflightTxs :: !(Map txid Int), + + -- | Overall size of all `tx`s in-flight. + -- + inflightTxsSize :: !SizeInBytes, + + -- | Map of `tx` which: + -- + -- * were downloaded, + -- * are already in the mempool (`Nothing` is inserted in that case), + -- + -- We only keep live `txid`, e.g. ones which `txid` is unacknowledged by + -- at least one peer. + -- + -- /Note:/ `txid`s which `tx` were unknown by a peer are tracked + -- separately in `unknownTxs`. + -- + -- /Note:/ previous implementation also needed to explicitly tracked + -- `txid`s which were already acknowledged, but are still unacknowledged. + -- In this implementation, this is done due to reference counting. + -- + -- This map is useful to acknowledge `txid`s, it's basically taking the + -- longest prefix which contains entries in `bufferedTxs` or `unknownTxs`. + -- + bufferedTxs :: !(Map txid (Maybe tx)), + + -- | We track reference counts of all unacknowledged txids. Once the + -- count reaches 0, a tx is removed from `bufferedTxs`. + -- + -- The `bufferedTx` map contains a subset of `txid` which + -- `referenceCounts` contains. + -- + -- /Invariants:/ + -- + -- * the txid count is equal to multiplicity of txid in all + -- `unacknowledgedTxIds` sequences; + -- * @Map.keysSet bufferedTxs `Set.isSubsetOf` Map.keysSet referenceCounts@; + -- * all counts are positive integers. + -- + referenceCounts :: !(Map txid Int) + } + deriving (Eq, Show, Generic) + +instance ( NoThunks peeraddr + , NoThunks tx + , NoThunks txid + ) => NoThunks (SharedTxState peeraddr txid tx) + + +-- +-- Decisions +-- + +-- | Decision made by the decision logic. Each peer will receive a 'Decision'. +-- +-- /note:/ it is rather non-standard to represent a choice between requesting +-- `txid`s and `tx`'s as a product rather than a sum type. The client will +-- need to download `tx`s first and then send a request for more txids (and +-- acknowledge some `txid`s). Due to pipelining each client will request +-- decision from the decision logic quite often (every two pipelined requests), +-- but with this design a decision once taken will make the peer non-active +-- (e.g. it won't be returned by `filterActivePeers`) for longer, and thus the +-- expensive `makeDecision` computation will not need to take that peer into +-- account. +-- +data TxDecision txid tx = TxDecision { + txdTxIdsToAcknowledge :: !NumTxIdsToAck, + -- ^ txid's to acknowledge + + txdTxIdsToRequest :: !NumTxIdsToReq, + -- ^ number of txid's to request + + txdPipelineTxIds :: !Bool, + -- ^ the tx-submission protocol only allows to pipeline `txid`'s requests + -- if we have non-acknowledged `txid`s. + + txdTxsToRequest :: !(Set txid), + -- ^ txid's to download. + + txdTxsToMempool :: ![tx] + -- ^ list of `tx`s to submit to the mempool. + } + deriving (Show, Eq) + +-- | A non-commutative semigroup instance. +-- +-- /note:/ this instance must be consistent with `pickTxsToDownload` and how +-- `PeerTxState` is updated. It is designed to work with `TMergeVar`s. +-- +instance Ord txid => Semigroup (TxDecision txid tx) where + TxDecision { txdTxIdsToAcknowledge, + txdTxIdsToRequest, + txdPipelineTxIds = _ignored, + txdTxsToRequest, + txdTxsToMempool } + <> + TxDecision { txdTxIdsToAcknowledge = txdTxIdsToAcknowledge', + txdTxIdsToRequest = txdTxIdsToRequest', + txdPipelineTxIds = txdPipelineTxIds', + txdTxsToRequest = txdTxsToRequest', + txdTxsToMempool = txdTxsToMempool' } + = + TxDecision { txdTxIdsToAcknowledge = txdTxIdsToAcknowledge + txdTxIdsToAcknowledge', + txdTxIdsToRequest = txdTxIdsToRequest + txdTxIdsToRequest', + txdPipelineTxIds = txdPipelineTxIds', + txdTxsToRequest = txdTxsToRequest <> txdTxsToRequest', + txdTxsToMempool = txdTxsToMempool ++ txdTxsToMempool' + } + +-- | A no-op decision. +emptyTxDecision :: TxDecision txid tx +emptyTxDecision = TxDecision { + txdTxIdsToAcknowledge = 0, + txdTxIdsToRequest = 0, + txdPipelineTxIds = False, + txdTxsToRequest = Set.empty, + txdTxsToMempool = [] + } + +data SharedDecisionContext peeraddr txid tx = SharedDecisionContext { + -- TODO: check how to access it. + sdcPeerGSV :: !(Map peeraddr PeerGSV), + + sdcSharedTxState :: !(SharedTxState peeraddr txid tx) + } + deriving Show + + +-- | TxLogic tracer. +-- +data TraceTxLogic peeraddr txid tx = + TraceSharedTxState String (SharedTxState peeraddr txid tx) + | TraceTxDecisions (Map peeraddr (TxDecision txid tx)) + deriving Show data ProcessedTxCount = ProcessedTxCount { diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs index 7e088011e75..6373b797b4b 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -114,10 +114,9 @@ import Ouroboros.Network.Snocket (MakeBearer, Snocket, TestAddress (..), invalidFileDescriptor) import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy) -import Ouroboros.Network.TxSubmission.Inbound.Registry (DebugTxLogic, - decisionLogicThread) -import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState) -import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxSubmissionInbound) +import Ouroboros.Network.TxSubmission.Inbound.Registry (decisionLogicThread) +import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxLogic, + TraceTxSubmissionInbound) import Simulation.Network.Snocket (AddressType (..), FD) @@ -131,7 +130,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.Common (Tx) +import Test.Ouroboros.Network.TxSubmission.Types (Tx) data Interfaces extraAPI m = Interfaces @@ -264,14 +263,13 @@ run :: forall extraState extraDebugState extraAPI extraPeers extraCounters m -> Tracer m (TraceLabelPeer NtNAddr (TraceFetchClientState BlockHeader)) -> Tracer m (TraceTxSubmissionInbound Int (Tx Int)) - -> Tracer m (DebugSharedTxState NtNAddr Int (Tx Int)) - -> Tracer m (DebugTxLogic NtNAddr Int (Tx Int)) + -> Tracer m (TraceTxLogic NtNAddr Int (Tx Int)) -> m Void run blockGeneratorArgs limits ni na emptyExtraState emptyExtraCounters extraPeersAPI psArgs psToExtraCounters toExtraPeers requestPublicRootPeers peerChurnGovernor - tracers tracerBlockFetch tracerTxSubmissionInbound tracerTxSubmissionDebug + tracers tracerBlockFetch tracerTxSubmissionInbound tracerTxLogic = Node.withNodeKernelThread blockGeneratorArgs (aTxs na) $ \ nodeKernel nodeKernelThread -> do @@ -351,7 +349,7 @@ run blockGeneratorArgs limits ni na apps = Node.applications (aDebugTracer na) tracerTxSubmissionInbound - tracerTxSubmissionDebug + tracerTxLogic nodeKernel Node.cborCodecs limits 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 ff010fa7716..3351caac934 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs @@ -83,10 +83,11 @@ import Ouroboros.Network.Snocket (TestAddress (..)) import Ouroboros.Network.TxSubmission.Inbound.Registry (SharedTxStateVar, TxChannels (..), TxChannelsVar, newSharedTxStateVar) + import Test.Ouroboros.Network.Diffusion.Node.ChainDB (ChainDB (..)) import Test.Ouroboros.Network.Diffusion.Node.ChainDB qualified as ChainDB import Test.Ouroboros.Network.Orphans () -import Test.Ouroboros.Network.TxSubmission.Common (Mempool, Tx, newMempool) +import Test.Ouroboros.Network.TxSubmission.Types (Mempool, Tx, newMempool) import Test.QuickCheck (Arbitrary (..), choose, chooseInt, frequency, oneof) 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 f998308f0e4..3d94ea16bdb 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -104,15 +104,15 @@ import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy (..)) import Ouroboros.Network.TxSubmission.Inbound.Registry (SharedTxStateVar, TxChannelsVar, withPeer) import Ouroboros.Network.TxSubmission.Inbound.Server (txSubmissionInboundV2) -import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState) -import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxSubmissionInbound) +import Ouroboros.Network.TxSubmission.Inbound.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.Common (Mempool, Tx, - getMempoolReader, getMempoolWriter, txSubmissionCodec2) +import Test.Ouroboros.Network.TxSubmission.Types (Mempool, Tx, getMempoolReader, + getMempoolWriter, txSubmissionCodec2) -- | Protocol codecs. @@ -262,7 +262,7 @@ applications :: forall block header s m. ) => Tracer m String -> Tracer m (TraceTxSubmissionInbound Int (Tx Int)) - -> Tracer m (DebugSharedTxState NtNAddr Int (Tx Int)) + -> Tracer m (TraceTxLogic NtNAddr Int (Tx Int)) -> NodeKernel header block s Int m -> Codecs NtNAddr header block m -> LimitsAndTimeouts header block 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 a8e0f2a2616..18350dcede9 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -86,10 +86,9 @@ import Ouroboros.Network.PeerSharing (PeerSharingResult (..)) import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.TxSubmission.Inbound.Policy (defaultTxDecisionPolicy, txInflightMultiplicity) -import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState (..), - inflightTxs) -import Ouroboros.Network.TxSubmission.Inbound.Types - (TraceTxSubmissionInbound (..)) +import Ouroboros.Network.TxSubmission.Inbound.State (inflightTxs) +import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxLogic (..), + TraceTxSubmissionInbound (..)) import Ouroboros.Network.TxSubmission.Outbound (TxSubmissionProtocolError (..)) import Simulation.Network.Snocket (BearerInfo (..), noAttenuation) @@ -105,8 +104,8 @@ 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.Common (ArbTxDecisionPolicy (..), - Tx (..)) +import Test.Ouroboros.Network.TxSubmission.TxLogic (ArbTxDecisionPolicy (..)) +import Test.Ouroboros.Network.TxSubmission.Types (Tx (..)) import Test.Ouroboros.Network.Utils hiding (SmallDelay, debugTracer) @@ -115,6 +114,7 @@ import Test.QuickCheck.Monoids import Test.Tasty import Test.Tasty.QuickCheck (testProperty) + tests :: TestTree tests = testGroup "Ouroboros.Network.Testnet" @@ -1051,8 +1051,8 @@ prop_check_inflight_ratio bi ds@(DiffusionScript simArgs _ _) = $ Signal.eventsToList $ Signal.selectEvents (\case - DiffusionTxSubmissionDebug (DebugSharedTxState _ d) -> Just (inflightTxs d) - _ -> Nothing + DiffusionTxLogic (TraceSharedTxState _ d) -> Just (inflightTxs d) + _ -> Nothing ) $ events 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 b2f4288ab04..3f1ef97132e 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 @@ -132,9 +132,8 @@ import Ouroboros.Network.Protocol.TxSubmission2.Codec (byteLimitsTxSubmission2, import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Snocket (Snocket, TestAddress (..)) import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy) -import Ouroboros.Network.TxSubmission.Inbound.Registry (DebugTxLogic) -import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState) -import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxSubmissionInbound) +import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxLogic, + TraceTxSubmissionInbound) import Ouroboros.Network.Mock.ConcreteBlock (Block (..), BlockHeader (..)) import Simulation.Network.Snocket (BearerInfo (..), FD, SnocketTrace, @@ -153,8 +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.Common (ArbTxDecisionPolicy (..), - Tx (..)) +import Test.Ouroboros.Network.TxSubmission.TxLogic (ArbTxDecisionPolicy (..)) +import Test.Ouroboros.Network.TxSubmission.Types (Tx (..)) import Test.Ouroboros.Network.Utils import Test.QuickCheck @@ -992,8 +991,7 @@ data DiffusionTestTrace = | DiffusionFetchTrace (TraceFetchClientState BlockHeader) | DiffusionChurnModeTrace TracerChurnMode | DiffusionTxSubmissionInbound (TraceTxSubmissionInbound Int (Tx Int)) - | DiffusionTxSubmissionDebug (DebugSharedTxState NtNAddr Int (Tx Int)) - | DiffusionTxLogicDebug (DebugTxLogic NtNAddr Int (Tx Int)) + | DiffusionTxLogic (TraceTxLogic NtNAddr Int (Tx Int)) | DiffusionDebugTrace String | DiffusionDNSTrace DNSTrace deriving (Show) @@ -1334,11 +1332,7 @@ diffusionSimulation . tracerWithName addr . tracerWithTime $ nodeTracer) - ( contramap DiffusionTxSubmissionDebug - . tracerWithName addr - . tracerWithTime - $ nodeTracer) - ( contramap DiffusionTxLogicDebug + ( contramap DiffusionTxLogic . tracerWithName addr . tracerWithTime $ nodeTracer) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs index a09c6742e9f..ef97a176eaf 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission.hs @@ -1,14 +1,14 @@ module Test.Ouroboros.Network.TxSubmission (tests) where -import Test.Ouroboros.Network.TxSubmission.Common qualified as Common -import Test.Ouroboros.Network.TxSubmission.TxSubmissionV1 qualified as V1 -import Test.Ouroboros.Network.TxSubmission.TxSubmissionV2 qualified as V2 +import 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.Tasty (TestTree, testGroup) tests :: TestTree tests = testGroup "Ouroboros.Network.TxSubmission" - [ Common.tests - , V1.tests - , V2.tests + [ TxLogic.tests + , AppV1.tests + , AppV2.tests ] diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV1.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV1.hs similarity index 97% rename from ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV1.hs rename to ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV1.hs index 4c6f0dc3447..abeff672ee6 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV1.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV1.hs @@ -8,7 +8,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} -module Test.Ouroboros.Network.TxSubmission.TxSubmissionV1 (tests) where +module Test.Ouroboros.Network.TxSubmission.AppV1 (tests) where import Prelude hiding (seq) @@ -44,17 +44,16 @@ import Ouroboros.Network.TxSubmission.Inbound 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.Common hiding (tests) +import Test.Ouroboros.Network.TxSubmission.Types import Test.Ouroboros.Network.Utils tests :: TestTree -tests = testGroup "Ouroboros.Network.TxSubmission.TxSubmissionV1" +tests = testGroup "AppV1" [ testProperty "txSubmission" prop_txSubmission ] diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs similarity index 96% rename from ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs rename to ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs index d5f72f773cf..f1a40a326fb 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs @@ -10,7 +10,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} -module Test.Ouroboros.Network.TxSubmission.TxSubmissionV2 (tests) where +module Test.Ouroboros.Network.TxSubmission.AppV2 (tests) where import Prelude hiding (seq) @@ -52,11 +52,12 @@ import Ouroboros.Network.Protocol.TxSubmission2.Type import Ouroboros.Network.TxSubmission.Inbound.Policy import Ouroboros.Network.TxSubmission.Inbound.Registry import Ouroboros.Network.TxSubmission.Inbound.Server (txSubmissionInboundV2) -import Ouroboros.Network.TxSubmission.Inbound.State +import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxLogic) import Ouroboros.Network.TxSubmission.Outbound import Ouroboros.Network.Util.ShowProxy -import Test.Ouroboros.Network.TxSubmission.Common hiding (tests) +import Test.Ouroboros.Network.TxSubmission.TxLogic hiding (tests) +import Test.Ouroboros.Network.TxSubmission.Types import Test.Ouroboros.Network.Utils hiding (debugTracer) import Test.QuickCheck @@ -65,7 +66,7 @@ import Test.Tasty.QuickCheck (testProperty) tests :: TestTree -tests = testGroup "Ouroboros.Network.TxSubmission.TxSubmissionV2" +tests = testGroup "AppV2" [ testProperty "txSubmission" prop_txSubmission , testProperty "txSubmission inflight" prop_txSubmission_inflight ] @@ -132,8 +133,7 @@ runTxSubmission , txid ~ Int ) => Tracer m (String, TraceSendRecv (TxSubmission2 txid (Tx txid))) - -> Tracer m (DebugSharedTxState peeraddr txid (Tx txid)) - -> Tracer m (DebugTxLogic peeraddr txid (Tx txid)) + -> Tracer m (TraceTxLogic peeraddr txid (Tx txid)) -> Map peeraddr ( [Tx txid] , ControlMessageSTM m , Maybe DiffTime @@ -141,7 +141,7 @@ runTxSubmission ) -> TxDecisionPolicy -> m ([Tx txid], [[Tx txid]]) -runTxSubmission tracer tracerDST tracerTxLogic state txDecisionPolicy = do +runTxSubmission tracer tracerTxLogic state txDecisionPolicy = do state' <- traverse (\(b, c, d, e) -> do mempool <- newMempool b @@ -209,7 +209,7 @@ runTxSubmission tracer tracerDST tracerTxLogic state txDecisionPolicy = do -- Construct txSubmission inbound server servers = (\(addr, (_, _, _, inDelay, _, inChannel)) -> - withPeer tracerDST + withPeer tracerTxLogic txChannelsVar sharedTxStateVar (getMempoolReader inboundMempool) @@ -274,7 +274,7 @@ txSubmissionSimulation (TxSubmissionState state txDecisionPolicy) = do let tracer :: forall a. Show a => Tracer (IOSim s) a tracer = verboseTracer <> debugTracer - runTxSubmission tracer tracer tracer state'' txDecisionPolicy + 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 diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs similarity index 87% rename from ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs rename to ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs index b5fbbaedd73..e54cc630951 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Common.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs @@ -12,50 +12,27 @@ {-# OPTIONS_GHC -Wno-orphans #-} -module Test.Ouroboros.Network.TxSubmission.Common where +module Test.Ouroboros.Network.TxSubmission.TxLogic where import Prelude hiding (seq) -import NoThunks.Class +import Control.Exception (assert) -import Control.Concurrent.Class.MonadSTM -import Control.Exception (SomeException (..), assert) -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadFork -import Control.Monad.Class.MonadSay -import Control.Monad.Class.MonadST -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer.SI -import Control.Monad.IOSim hiding (SimResult) -import Control.Tracer (Tracer (..), showTracing, traceWith) - -import Codec.CBOR.Decoding qualified as CBOR -import Codec.CBOR.Encoding qualified as CBOR -import Codec.CBOR.Read qualified as CBOR - -import Data.ByteString.Lazy (ByteString) -import Data.Foldable as Foldable (find, fold, foldl', toList) -import Data.Function (on) -import Data.List (intercalate, isPrefixOf, isSuffixOf, mapAccumR, nub, nubBy, +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, isJust, maybeToList) +import Data.Maybe (fromMaybe, maybeToList) import Data.Monoid (Sum (..)) -import Data.Sequence (Seq) -import Data.Sequence qualified as Seq import Data.Sequence.Strict qualified as StrictSeq import Data.Set (Set) import Data.Set qualified as Set -import GHC.Generics (Generic) -import Network.TypedProtocol.Codec +import NoThunks.Class -import Ouroboros.Network.Protocol.TxSubmission2.Codec import Ouroboros.Network.Protocol.TxSubmission2.Type -import Ouroboros.Network.TxSubmission.Inbound import Ouroboros.Network.TxSubmission.Inbound.Decision (SharedDecisionContext (..), TxDecision (..)) import Ouroboros.Network.TxSubmission.Inbound.Decision qualified as TXS @@ -63,10 +40,9 @@ import Ouroboros.Network.TxSubmission.Inbound.Policy import Ouroboros.Network.TxSubmission.Inbound.State (PeerTxState (..), SharedTxState (..)) import Ouroboros.Network.TxSubmission.Inbound.State qualified as TXS -import Ouroboros.Network.TxSubmission.Mempool.Reader -import Ouroboros.Network.Util.ShowProxy import Test.Ouroboros.Network.BlockFetch (PeerGSVT (..)) +import Test.Ouroboros.Network.TxSubmission.Types import Test.QuickCheck import Test.QuickCheck.Function (apply) @@ -74,11 +50,10 @@ import Test.QuickCheck.Monoids (All (..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Text.Pretty.Simple -import Text.Printf tests :: TestTree -tests = testGroup "Ouroboros.Network.TxSubmission.Common" +tests = testGroup "TxLogic" [ testGroup "State" [ testGroup "Arbitrary" [ testGroup "ArbSharedTxState" @@ -124,198 +99,6 @@ tests = testGroup "Ouroboros.Network.TxSubmission.Common" ] ] -data Tx txid = Tx { - getTxId :: !txid, - getTxSize :: !SizeInBytes, - -- | If false this means that when this tx will be submitted to a remote - -- mempool it will not be valid. The outbound mempool might contain - -- invalid tx's in this sense. - getTxValid :: !Bool - } - deriving (Eq, Ord, Show, Generic) - -instance NoThunks txid => NoThunks (Tx txid) -instance ShowProxy txid => ShowProxy (Tx txid) where - showProxy _ = "Tx " ++ showProxy (Proxy :: Proxy txid) - -instance Arbitrary txid => Arbitrary (Tx txid) where - arbitrary = - Tx <$> arbitrary - <*> chooseEnum (0, maxTxSize) - -- note: - -- generating small tx sizes avoids overflow error when semigroup - -- instance of `SizeInBytes` is used (summing up all inflight tx - -- sizes). - <*> frequency [ (3, pure True) - , (1, pure False) - ] - --- maximal tx size -maxTxSize :: SizeInBytes -maxTxSize = 65536 - -type TxId = Int - -newtype Mempool m txid = Mempool (TVar m (Seq (Tx txid))) - - -emptyMempool :: MonadSTM m => m (Mempool m txid) -emptyMempool = Mempool <$> newTVarIO Seq.empty - -newMempool :: ( MonadSTM m - , Eq txid - ) - => [Tx txid] - -> m (Mempool m txid) -newMempool = fmap Mempool - . newTVarIO - . Seq.fromList - -readMempool :: MonadSTM m => Mempool m txid -> m [Tx txid] -readMempool (Mempool mempool) = toList <$> readTVarIO mempool - - -getMempoolReader :: forall txid m. - ( MonadSTM m - , Eq txid - , Show txid - ) - => Mempool m txid - -> TxSubmissionMempoolReader txid (Tx txid) Int m -getMempoolReader (Mempool mempool) = - TxSubmissionMempoolReader { mempoolGetSnapshot, mempoolZeroIdx = 0 } - where - mempoolGetSnapshot :: STM m (MempoolSnapshot txid (Tx txid) Int) - mempoolGetSnapshot = getSnapshot <$> readTVar mempool - - getSnapshot :: Seq (Tx txid) - -> MempoolSnapshot txid (Tx txid) Int - getSnapshot seq = - MempoolSnapshot { - mempoolTxIdsAfter = - \idx -> zipWith f [idx + 1 ..] (toList $ Seq.drop idx seq), - -- why do I need to use `pred`? - mempoolLookupTx = flip Seq.lookup seq . pred, - mempoolHasTx = \txid -> isJust $ find (\tx -> getTxId tx == txid) seq - } - - f :: Int -> Tx txid -> (txid, Int, SizeInBytes) - f idx Tx {getTxId, getTxSize} = (getTxId, idx, getTxSize) - - -getMempoolWriter :: forall txid m. - ( MonadSTM m - , Ord txid - , Eq txid - ) - => Mempool m txid - -> TxSubmissionMempoolWriter txid (Tx txid) Int m -getMempoolWriter (Mempool mempool) = - TxSubmissionMempoolWriter { - txId = getTxId, - - mempoolAddTxs = \txs -> do - atomically $ do - mempoolTxs <- readTVar mempool - let currentIds = Set.fromList (map getTxId (toList mempoolTxs)) - validTxs = nubBy (on (==) getTxId) - $ filter - (\Tx { getTxId, getTxValid } -> - getTxValid - && getTxId `Set.notMember` currentIds) - txs - mempoolTxs' = Foldable.foldl' (Seq.|>) mempoolTxs validTxs - writeTVar mempool mempoolTxs' - return (map getTxId validTxs) - } - - -txSubmissionCodec2 :: MonadST m - => Codec (TxSubmission2 Int (Tx Int)) - CBOR.DeserialiseFailure m ByteString -txSubmissionCodec2 = - codecTxSubmission2 CBOR.encodeInt CBOR.decodeInt - encodeTx decodeTx - where - encodeTx Tx {getTxId, getTxSize, getTxValid} = - CBOR.encodeListLen 3 - <> CBOR.encodeInt getTxId - <> CBOR.encodeWord32 (getSizeInBytes getTxSize) - <> CBOR.encodeBool getTxValid - - decodeTx = do - _ <- CBOR.decodeListLen - Tx <$> CBOR.decodeInt - <*> (SizeInBytes <$> CBOR.decodeWord32) - <*> CBOR.decodeBool - - -newtype LargeNonEmptyList a = LargeNonEmpty { getLargeNonEmpty :: [a] } - deriving Show - -instance Arbitrary a => Arbitrary (LargeNonEmptyList a) where - arbitrary = - LargeNonEmpty <$> suchThat (resize 500 (listOf arbitrary)) ((>25) . length) - - --- TODO: Belongs in iosim. -data SimResults a = SimReturn a [String] - | SimException SomeException [String] - | SimDeadLock [String] - --- Traverses a list of trace events and returns the result along with all log messages. --- Incase of a pure exception, ie an assert, all tracers evaluated so far are returned. -evaluateTrace :: SimTrace a -> IO (SimResults a) -evaluateTrace = go [] - where - go as tr = do - r <- try (evaluate tr) - case r of - Right (SimTrace _ _ _ (EventSay s) tr') -> go (s : as) tr' - Right (SimTrace _ _ _ _ tr' ) -> go as tr' - Right (SimPORTrace _ _ _ _ (EventSay s) tr') -> go (s : as) tr' - Right (SimPORTrace _ _ _ _ _ tr' ) -> go as tr' - Right (TraceMainReturn _ _ a _) -> pure $ SimReturn a (reverse as) - Right (TraceMainException _ _ e _) -> pure $ SimException e (reverse as) - Right (TraceDeadlock _ _) -> pure $ SimDeadLock (reverse as) - Right TraceLoop -> error "IOSimPOR step time limit exceeded" - Right (TraceInternalError e) -> error ("IOSim: " ++ e) - Left (SomeException e) -> pure $ SimException (SomeException e) (reverse as) - -data WithThreadAndTime a = WithThreadAndTime { - wtatOccuredAt :: !Time - , wtatWithinThread :: !String - , wtatEvent :: !a - } - -instance (Show a) => Show (WithThreadAndTime a) where - show WithThreadAndTime {wtatOccuredAt, wtatWithinThread, wtatEvent} = - printf "%s: %s: %s" (show wtatOccuredAt) (show wtatWithinThread) (show wtatEvent) - -verboseTracer :: forall a m. - ( MonadAsync m - , MonadDelay m - , MonadSay m - , MonadMonotonicTime m - , Show a - ) - => Tracer m a -verboseTracer = threadAndTimeTracer $ showTracing $ Tracer say - -debugTracer :: forall a s. Show a => Tracer (IOSim s) a -debugTracer = threadAndTimeTracer $ showTracing $ Tracer (traceM . show) - -threadAndTimeTracer :: forall a m. - ( MonadAsync m - , MonadDelay m - , MonadMonotonicTime m - ) - => Tracer m (WithThreadAndTime a) -> Tracer m a -threadAndTimeTracer tr = Tracer $ \s -> do - !now <- getMonotonicTime - !tid <- myThreadId - traceWith tr $ WithThreadAndTime now (show tid) s - -- -- InboundState properties 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..36a76dd5006 --- /dev/null +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs @@ -0,0 +1,248 @@ +{-# 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 +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, + -- | If false this means that when this tx will be submitted to a remote + -- mempool it will not be valid. The outbound mempool might contain + -- invalid tx's in this sense. + getTxValid :: !Bool + } + deriving (Eq, Ord, Show, Generic) + +instance NoThunks txid => NoThunks (Tx txid) +instance ShowProxy txid => ShowProxy (Tx txid) where + showProxy _ = "Tx " ++ showProxy (Proxy :: Proxy txid) + +instance Arbitrary txid => Arbitrary (Tx txid) where + arbitrary = + Tx <$> arbitrary + <*> chooseEnum (0, maxTxSize) + -- note: + -- generating small tx sizes avoids overflow error when semigroup + -- instance of `SizeInBytes` is used (summing up all inflight tx + -- sizes). + <*> frequency [ (3, pure True) + , (1, pure False) + ] + +-- maximal tx size +maxTxSize :: SizeInBytes +maxTxSize = 65536 + +type TxId = Int + +newtype Mempool m txid = Mempool (TVar m (Seq (Tx txid))) + + +emptyMempool :: MonadSTM m => m (Mempool m txid) +emptyMempool = Mempool <$> newTVarIO Seq.empty + +newMempool :: ( MonadSTM m + , Eq txid + ) + => [Tx txid] + -> m (Mempool m txid) +newMempool = fmap Mempool + . newTVarIO + . Seq.fromList + +readMempool :: MonadSTM m => Mempool m txid -> m [Tx txid] +readMempool (Mempool mempool) = toList <$> readTVarIO mempool + + +getMempoolReader :: forall txid m. + ( MonadSTM m + , Eq txid + , Show txid + ) + => Mempool m txid + -> TxSubmissionMempoolReader txid (Tx txid) Int m +getMempoolReader (Mempool mempool) = + TxSubmissionMempoolReader { mempoolGetSnapshot, mempoolZeroIdx = 0 } + where + mempoolGetSnapshot :: STM m (MempoolSnapshot txid (Tx txid) Int) + mempoolGetSnapshot = getSnapshot <$> readTVar mempool + + getSnapshot :: Seq (Tx txid) + -> MempoolSnapshot txid (Tx txid) Int + getSnapshot seq = + MempoolSnapshot { + mempoolTxIdsAfter = + \idx -> zipWith f [idx + 1 ..] (toList $ Seq.drop idx seq), + -- why do I need to use `pred`? + mempoolLookupTx = flip Seq.lookup seq . pred, + mempoolHasTx = \txid -> isJust $ find (\tx -> getTxId tx == txid) seq + } + + f :: Int -> Tx txid -> (txid, Int, SizeInBytes) + f idx Tx {getTxId, getTxSize} = (getTxId, idx, getTxSize) + + +getMempoolWriter :: forall txid m. + ( MonadSTM m + , Ord txid + , Eq txid + ) + => Mempool m txid + -> TxSubmissionMempoolWriter txid (Tx txid) Int m +getMempoolWriter (Mempool mempool) = + TxSubmissionMempoolWriter { + txId = getTxId, + + mempoolAddTxs = \txs -> do + atomically $ do + mempoolTxs <- readTVar mempool + let currentIds = Set.fromList (map getTxId (toList mempoolTxs)) + validTxs = nubBy (on (==) getTxId) + $ filter + (\Tx { getTxId, getTxValid } -> + getTxValid + && getTxId `Set.notMember` currentIds) + txs + mempoolTxs' = Foldable.foldl' (Seq.|>) mempoolTxs validTxs + writeTVar mempool mempoolTxs' + return (map getTxId validTxs) + } + + +txSubmissionCodec2 :: MonadST m + => Codec (TxSubmission2 Int (Tx Int)) + CBOR.DeserialiseFailure m ByteString +txSubmissionCodec2 = + codecTxSubmission2 CBOR.encodeInt CBOR.decodeInt + encodeTx decodeTx + where + encodeTx Tx {getTxId, getTxSize, getTxValid} = + CBOR.encodeListLen 3 + <> CBOR.encodeInt getTxId + <> CBOR.encodeWord32 (getSizeInBytes getTxSize) + <> CBOR.encodeBool getTxValid + + decodeTx = do + _ <- CBOR.decodeListLen + Tx <$> CBOR.decodeInt + <*> (SizeInBytes <$> CBOR.decodeWord32) + <*> CBOR.decodeBool + + +newtype LargeNonEmptyList a = LargeNonEmpty { getLargeNonEmpty :: [a] } + deriving Show + +instance Arbitrary a => Arbitrary (LargeNonEmptyList a) where + arbitrary = + LargeNonEmpty <$> suchThat (resize 500 (listOf arbitrary)) ((>25) . length) + + +-- TODO: Belongs in iosim. +data SimResults a = SimReturn a [String] + | SimException SomeException [String] + | SimDeadLock [String] + +-- Traverses a list of trace events and returns the result along with all log messages. +-- Incase of a pure exception, ie an assert, all tracers evaluated so far are returned. +evaluateTrace :: SimTrace a -> IO (SimResults a) +evaluateTrace = go [] + where + go as tr = do + r <- try (evaluate tr) + case r of + Right (SimTrace _ _ _ (EventSay s) tr') -> go (s : as) tr' + Right (SimTrace _ _ _ _ tr' ) -> go as tr' + Right (SimPORTrace _ _ _ _ (EventSay s) tr') -> go (s : as) tr' + Right (SimPORTrace _ _ _ _ _ tr' ) -> go as tr' + Right (TraceMainReturn _ _ a _) -> pure $ SimReturn a (reverse as) + Right (TraceMainException _ _ e _) -> pure $ SimException e (reverse as) + Right (TraceDeadlock _ _) -> pure $ SimDeadLock (reverse as) + Right TraceLoop -> error "IOSimPOR step time limit exceeded" + Right (TraceInternalError e) -> error ("IOSim: " ++ e) + Left (SomeException e) -> pure $ SimException (SomeException e) (reverse as) + + +data WithThreadAndTime a = WithThreadAndTime { + wtatOccuredAt :: !Time + , wtatWithinThread :: !String + , wtatEvent :: !a + } + +instance (Show a) => Show (WithThreadAndTime a) where + show WithThreadAndTime {wtatOccuredAt, wtatWithinThread, wtatEvent} = + printf "%s: %s: %s" (show wtatOccuredAt) (show wtatWithinThread) (show wtatEvent) + +verboseTracer :: forall a m. + ( MonadAsync m + , MonadDelay m + , MonadSay m + , MonadMonotonicTime m + , Show a + ) + => Tracer m a +verboseTracer = threadAndTimeTracer $ showTracing $ Tracer say + +debugTracer :: forall a s. Show a => Tracer (IOSim s) a +debugTracer = threadAndTimeTracer $ showTracing $ Tracer (traceM . show) + +threadAndTimeTracer :: forall a m. + ( MonadAsync m + , MonadDelay m + , MonadMonotonicTime m + ) + => Tracer m (WithThreadAndTime a) -> Tracer m a +threadAndTimeTracer tr = Tracer $ \s -> do + !now <- getMonotonicTime + !tid <- myThreadId + traceWith tr $ WithThreadAndTime now (show tid) s From 1dd9047057778da3b6bfa172f5cb0e5a3200a385 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 18 Sep 2024 13:17:13 +0200 Subject: [PATCH 21/54] tx-submission: compile with ghc < 9.10 --- .../Ouroboros/Network/TxSubmission/Inbound/Registry.hs | 7 ++++++- .../Test/Ouroboros/Network/TxSubmission/TxLogic.hs | 8 +++++++- scripts/ci/check-stylish-ignore | 6 +++++- 3 files changed, 18 insertions(+), 3 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs index 395c42a1b02..336f1667c23 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} @@ -21,7 +22,11 @@ import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTimer.SI -import Data.Foldable (foldl', traverse_) +import Data.Foldable (traverse_ +#if !MIN_VERSION_base(4,20,0) + , foldl' +#endif + ) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs index e54cc630951..d6fc8c33f3b 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -18,7 +19,12 @@ import Prelude hiding (seq) import Control.Exception (assert) -import Data.Foldable as Foldable (fold, foldl', toList) +import Data.Foldable ( + fold, +#if !MIN_VERSION_base(4,20,0) + foldl', +#endif + toList) import Data.List (intercalate, isPrefixOf, isSuffixOf, mapAccumR, nub, stripPrefix) import Data.Map.Merge.Strict qualified as Map diff --git a/scripts/ci/check-stylish-ignore b/scripts/ci/check-stylish-ignore index ed2a98be460..509dba3a0c9 100644 --- a/scripts/ci/check-stylish-ignore +++ b/scripts/ci/check-stylish-ignore @@ -3,8 +3,12 @@ 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/TxSubmission/Inbound/State.hs +ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/TxLogic.hs ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs -ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs +ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs +ouroboros-network/testlib/Test/Ouroboros/Network/Testnet.hs +ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs network-mux/src/Network/Mux/TCPInfo.hs network-mux/src/Network/Mux/Bearer.hs network-mux/src/Network/Mux/Bearer/Pipe.hs From f897d0f5035eb2040ca241e8f8ab28f3267edf93 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Thu, 19 Sep 2024 10:37:48 +0100 Subject: [PATCH 22/54] tx-submission: moved TxDecisionPolicy to MiniProtocolParamenters --- .../src/Ouroboros/Network/NodeToNode.hs | 16 +++++++++------- .../Network/TxSubmission/Inbound/Policy.hs | 1 - 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index 852ebd2f280..437ad682058 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -103,7 +103,8 @@ import Ouroboros.Network.Server.RateLimiting import Ouroboros.Network.SizeInBytes import Ouroboros.Network.Snocket import Ouroboros.Network.Socket -import Ouroboros.Network.TxSubmission.Inbound.Policy (max_TX_SIZE) +import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy (..), + defaultTxDecisionPolicy, max_TX_SIZE) import Ouroboros.Network.Util.ShowProxy (ShowProxy, showProxy) @@ -160,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 @@ -170,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 @@ -298,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 @@ -361,7 +363,7 @@ txSubmissionProtocolLimits MiniProtocolParameters { txSubmissionMaxUnacked } = M -- 10% as a safety margin. -- maximumIngressQueue = addSafetyMargin $ - fromIntegral txSubmissionMaxUnacked * (44 + fromIntegral @SizeInBytes @Int max_TX_SIZE) + fromIntegral maxUnacknowledgedTxIds * (44 + fromIntegral @SizeInBytes @Int max_TX_SIZE) } keepAliveProtocolLimits _ = diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs index e625bc42326..7a2760416a1 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs @@ -55,7 +55,6 @@ defaultTxDecisionPolicy = TxDecisionPolicy { maxNumTxIdsToRequest = 3, maxUnacknowledgedTxIds = 10, -- must be the same as txSubmissionMaxUnacked - -- TODO: we should take it `MiniProtocolParameters`. txsSizeInflightPerPeer = max_TX_SIZE * 6, maxTxsSizeInflight = max_TX_SIZE * 20, txInflightMultiplicity = 1 From 8e31665680a0f9df2c2f14173c80bd61d0f17995 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Thu, 19 Sep 2024 12:04:51 +0100 Subject: [PATCH 23/54] tx-submission: added EnableNewTxSubmissionProtocol flag --- .../src/Ouroboros/Network/Diffusion/Configuration.hs | 5 +++++ .../src/Ouroboros/Network/TxSubmission/Inbound/Server.hs | 5 +++++ 2 files changed, 10 insertions(+) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs index 3b13ff265f1..c98b13d3cad 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 + , defaultEnableNewTxSubmissionProtocol -- re-exports , AcceptedConnectionsLimit (..) , BlockFetchConfiguration (..) @@ -57,6 +58,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.Server + (EnableNewTxSubmissionProtocol (..)) -- |Outbound governor targets -- Targets may vary depending on whether a node is operating in @@ -150,3 +153,5 @@ local_PROTOCOL_IDLE_TIMEOUT = 2 -- 2 seconds local_TIME_WAIT_TIMEOUT :: DiffTime local_TIME_WAIT_TIMEOUT = 0 +defaultEnableNewTxSubmissionProtocol :: EnableNewTxSubmissionProtocol +defaultEnableNewTxSubmissionProtocol = DisableNewTxSubmissionProtocol diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs index 69c9b7bcfdc..da96924467a 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs @@ -25,6 +25,11 @@ import Ouroboros.Network.Protocol.TxSubmission2.Server import Ouroboros.Network.TxSubmission.Inbound.Registry (PeerTxAPI (..)) import Ouroboros.Network.TxSubmission.Inbound.Types +-- | Flag to enable/disable the usage of the new tx submission protocol +-- +data EnableNewTxSubmissionProtocol = + EnableNewTxSubmissionProtocol + | DisableNewTxSubmissionProtocol -- | A tx-submission outbound side (server, sic!). -- From 425c196b12654b1aa9c5ff5d5ed3204deb926ce3 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 23 Sep 2024 11:07:09 +0200 Subject: [PATCH 24/54] tx-submission: verify tx sizes --- .../Network/TxSubmission/Inbound/Registry.hs | 9 +- .../Network/TxSubmission/Inbound/Server.hs | 9 +- .../Network/TxSubmission/Inbound/State.hs | 78 ++++++++++++---- .../Network/TxSubmission/Inbound/Types.hs | 15 ++- .../Network/Diffusion/Node/MiniProtocols.hs | 16 ++-- .../Ouroboros/Network/TxSubmission/AppV2.hs | 1 + .../Ouroboros/Network/TxSubmission/TxLogic.hs | 91 +++++++++++++------ .../Ouroboros/Network/TxSubmission/Types.hs | 29 +++--- 8 files changed, 174 insertions(+), 74 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs index 336f1667c23..a6df364bc21 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -75,7 +75,7 @@ data PeerTxAPI m txid tx = PeerTxAPI { -- ^ requested txids -> Map txid tx -- ^ received txs - -> m () + -> m (Maybe TxSubmissionProtocolError) -- ^ handle received txs } @@ -90,6 +90,7 @@ withPeer , MonadMVar m , MonadSTM m , Ord txid + , Show txid , Ord peeraddr , Show peeraddr ) @@ -97,6 +98,7 @@ withPeer -> TxChannelsVar m peeraddr txid tx -> SharedTxStateVar m peeraddr txid tx -> TxSubmissionMempoolReader txid tx idx m + -> (tx -> SizeInBytes) -> peeraddr -- ^ new peer -> (PeerTxAPI m txid tx -> m a) @@ -106,6 +108,7 @@ withPeer tracer channelsVar sharedStateVar TxSubmissionMempoolReader { mempoolGetSnapshot } + txSize peeraddr io = bracket (do -- create a communication channel @@ -209,9 +212,9 @@ withPeer tracer -- ^ requested txids -> Map txid tx -- ^ received txs - -> m () + -> m (Maybe TxSubmissionProtocolError) handleReceivedTxs txids txs = - collectTxs tracer sharedStateVar peeraddr txids txs + collectTxs tracer txSize sharedStateVar peeraddr txids txs decisionLogicThread diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs index da96924467a..600cf3ec46e 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs @@ -182,8 +182,9 @@ txSubmissionInboundV2 unless (Map.keysSet received `Set.isSubsetOf` requested) $ throwIO ProtocolErrorTxNotRequested - -- TODO: all sizes of txs which were announced earlier with - -- `MsgReplyTxIds` must be verified. - handleReceivedTxs requested received - k + mbe <- handleReceivedTxs requested received + 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/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs index a54318c306c..56590c449c7 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs @@ -32,6 +32,7 @@ import Data.Foldable (fold, foldl', #endif toList) +import Data.Functor (($>)) import Data.Map.Merge.Strict qualified as Map import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map @@ -214,7 +215,8 @@ updateRefCounts referenceCounts (RefCountDiff diff) = receivedTxIdsImpl :: forall peeraddr tx txid. (Ord txid, Ord peeraddr, HasCallStack) - => (txid -> Bool) -- ^ check if txid is in the mempool, ref 'mempoolHasTx' + => (txid -> Bool) -- ^ check if txid is in the mempool, ref + -- 'mempoolHasTx' -> peeraddr -> NumTxIdsToReq -- ^ number of requests to subtract from @@ -302,33 +304,65 @@ receivedTxIdsImpl collectTxsImpl :: forall peeraddr tx txid. - (Ord txid, Ord peeraddr) - => peeraddr + ( Ord peeraddr + , Ord txid + , Show txid + ) + => (tx -> SizeInBytes) -- ^ compute tx size + -> peeraddr -> Set txid -- ^ set of requested txids -> Map txid tx -- ^ received txs -> SharedTxState peeraddr txid tx - -> SharedTxState peeraddr txid tx - -- ^ number of `txid`s to be acknowledged, `tx`s to be added to - -- the mempool and updated state. -collectTxsImpl peeraddr requestedTxIds receivedTxs + -> 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 - (st', peerTxStates') -> - st' { peerTxStates = peerTxStates' } + (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 - -> ( SharedTxState peeraddr txid tx + -> ( Either [(txid, SizeInBytes, SizeInBytes)] + (SharedTxState peeraddr txid tx) , PeerTxState txid tx ) - fn ps = (st'', ps'') + 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 -- add received `tx`s to buffered map @@ -446,17 +480,25 @@ receivedTxIds tracer sharedVar getMempoolSnapshot peeraddr reqNo txidsSeq txidsM -- collectTxs :: forall m peeraddr tx txid. - (MonadSTM m, Ord txid, Ord peeraddr) + (MonadSTM m, Ord txid, Ord peeraddr, + Show 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 () + -> m (Maybe TxSubmissionProtocolError) -- ^ number of txids to be acknowledged and txs to be added to the -- mempool -collectTxs tracer sharedVar peeraddr txidsRequested txsMap = do - st <- atomically $ - stateTVar sharedVar - ((\a -> (a,a)) . collectTxsImpl peeraddr txidsRequested txsMap) - traceWith tracer (TraceSharedTxState "collectTxs" st) +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/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs index 996b7aff43e..bd3427c85c7 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} module Ouroboros.Network.TxSubmission.Inbound.Types ( -- * PeerTxState @@ -310,10 +312,17 @@ data TraceTxSubmissionInbound txid tx = data TxSubmissionProtocolError = ProtocolErrorTxNotRequested | ProtocolErrorTxIdsNotRequested - deriving Show + | forall 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 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 3d94ea16bdb..0d491bfd449 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 #-} @@ -111,8 +112,8 @@ 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) +import Test.Ouroboros.Network.TxSubmission.Types (Mempool, Tx (..), + getMempoolReader, getMempoolWriter, txSubmissionCodec2) -- | Protocol codecs. @@ -598,11 +599,11 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node -- 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 () @@ -704,6 +705,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node txChannelsVar sharedTxStateVar (getMempoolReader mempool) + getTxSize them $ \api -> do let server = txSubmissionInboundV2 txSubmissionInboundTracer diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs index f1a40a326fb..c11adb9d95e 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs @@ -213,6 +213,7 @@ runTxSubmission tracer tracerTxLogic state txDecisionPolicy = do txChannelsVar sharedTxStateVar (getMempoolReader inboundMempool) + getTxSize addr $ \api -> do let server = txSubmissionInboundV2 verboseTracer (getMempoolWriter inboundMempool) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs index d6fc8c33f3b..bfc453de2c9 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs @@ -35,6 +35,7 @@ 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 NoThunks.Class @@ -46,6 +47,7 @@ import Ouroboros.Network.TxSubmission.Inbound.Policy import Ouroboros.Network.TxSubmission.Inbound.State (PeerTxState (..), SharedTxState (..)) import Ouroboros.Network.TxSubmission.Inbound.State qualified as TXS +import Ouroboros.Network.TxSubmission.Inbound.Types qualified as TXS import Test.Ouroboros.Network.BlockFetch (PeerGSVT (..)) import Test.Ouroboros.Network.TxSubmission.Types @@ -306,7 +308,7 @@ mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMaskMap = where mempoolHasTx = apply mempoolHasTxFun availableTxIds = Map.fromList - [ (txid, getTxSize tx) | (txid, TxAvailable tx _) <- Map.assocs txMaskMap + [ (txid, getTxAdvSize tx) | (txid, TxAvailable tx _) <- Map.assocs txMaskMap , not (mempoolHasTx txid) ] unknownTxs = Set.fromList @@ -315,7 +317,7 @@ mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMaskMap = ] requestedTxIdsInflight = fromIntegral txIdsInflight - requestedTxsInflightSize = foldMap getTxSize inflightMap + requestedTxsInflightSize = foldMap getTxAdvSize inflightMap requestedTxsInflight = Map.keysSet inflightMap -- exclude `txid`s which are already in the mempool, we never request such @@ -759,12 +761,20 @@ instance Arbitrary ArbCollectTxs where 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 = availableTxIds Map.! txid, - getTxValid = valid }) + pure $ Tx { getTxId = txid, + getTxSize = size, + -- `availableTxIds` contains advertised sizes + getTxAdvSize = availableTxIds Map.! txid, + getTxValid = valid }) - pure $ assert (foldMap getTxSize receivedTx <= requestedTxsInflightSize) + pure $ assert (foldMap getTxAdvSize receivedTx <= requestedTxsInflightSize) $ ArbCollectTxs mempoolHasTxFun (Set.fromList requestedTxIds') (Map.fromList [ (getTxId tx, tx) | tx <- receivedTx ]) @@ -856,24 +866,49 @@ prop_collectTxsImpl (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived p label ("number of txids inflight " ++ labelInt 25 5 (Map.size $ inflightTxs st)) $ label ("number of txids requested " ++ labelInt 25 5 (Set.size txidsRequested)) $ label ("number of txids received " ++ labelInt 10 2 (Map.size txsReceived)) $ - - -- InboundState invariant - counterexample - ( "InboundState invariant violation:\n" ++ show st' ++ "\n" - ++ show ps' - ) - (sharedTxStateInvariant st') - - .&&. - -- `collectTxsImpl` doesn't modify unacknowledged TxId's - counterexample "acknowledged property violation" - ( let unacked = toList $ unacknowledgedTxIds ps - unacked' = toList $ unacknowledgedTxIds ps' - in unacked === unacked' - ) + 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 - st' = TXS.collectTxsImpl peeraddr txidsRequested txsReceived st - ps' = peerTxStates st' Map.! peeraddr + 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`?" -- | Verify that `SharedTxState` returned by `collectTxsImpl` if evaluated to @@ -883,11 +918,11 @@ prop_collectTxsImpl_nothunks :: ArbCollectTxs -> Property prop_collectTxsImpl_nothunks (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived peeraddr _ st) = - case unsafeNoThunks $! st' of - Nothing -> property True - Just ctx -> counterexample (show ctx) False - where - st' = TXS.collectTxsImpl peeraddr txidsRequested txsReceived st + 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 diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs index 36a76dd5006..6c09b2c10b5 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs @@ -55,12 +55,13 @@ import Text.Printf data Tx txid = Tx { - getTxId :: !txid, - getTxSize :: !SizeInBytes, + 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 + getTxValid :: !Bool } deriving (Eq, Ord, Show, Generic) @@ -69,13 +70,17 @@ instance ShowProxy txid => ShowProxy (Tx txid) where showProxy _ = "Tx " ++ showProxy (Proxy :: Proxy txid) instance Arbitrary txid => Arbitrary (Tx txid) where - arbitrary = + 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 - <*> chooseEnum (0, maxTxSize) - -- note: - -- generating small tx sizes avoids overflow error when semigroup - -- instance of `SizeInBytes` is used (summing up all inflight tx - -- sizes). + <*> pure size + <*> pure advSize <*> frequency [ (3, pure True) , (1, pure False) ] @@ -167,15 +172,17 @@ txSubmissionCodec2 = codecTxSubmission2 CBOR.encodeInt CBOR.decodeInt encodeTx decodeTx where - encodeTx Tx {getTxId, getTxSize, getTxValid} = - CBOR.encodeListLen 3 + 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 From f2173313bc5de84cd0e073ec3c9be7a13086dd3d Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Wed, 25 Sep 2024 11:04:00 +0100 Subject: [PATCH 25/54] tx-submission: deriving Eq and Show for EnableNewTxSubmissionProtocol --- .../src/Ouroboros/Network/TxSubmission/Inbound/Server.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs index 600cf3ec46e..bb8beed8c0d 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs @@ -30,6 +30,7 @@ import Ouroboros.Network.TxSubmission.Inbound.Types data EnableNewTxSubmissionProtocol = EnableNewTxSubmissionProtocol | DisableNewTxSubmissionProtocol + deriving (Eq, Show) -- | A tx-submission outbound side (server, sic!). -- From e34d8984a7512c442e8ca9c84f87dec39a9490d4 Mon Sep 17 00:00:00 2001 From: Karl Knutsson Date: Wed, 2 Oct 2024 13:39:09 +0200 Subject: [PATCH 26/54] tx-submission: TraceTxSubmissionProcessed for the new TX submission Log TraceTxSubmissionProcessed for the new TX submission protocol. Fix count for TraceTxSubmissionCollected, it should be number of TXs "collected", not number of TXs accepted by the mempool. --- .../src/Ouroboros/Network/TxSubmission/Inbound/Server.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs index bb8beed8c0d..5415dc780a7 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs @@ -73,9 +73,16 @@ txSubmissionInboundV2 txidsAccepted <- mempoolAddTxs txs traceWith tracer $ TraceTxInboundAddedToMempool txidsAccepted - let !collected = length txidsAccepted + let !collected = length txs + let !accepted = length txidsAccepted traceWith tracer $ TraceTxSubmissionCollected collected + + traceWith tracer $ TraceTxSubmissionProcessed ProcessedTxCount { + ptxcAccepted = accepted + , ptxcRejected = collected - accepted + } + -- TODO: -- We can update the state so that other `tx-submission` servers will -- not try to add these txs to the mempool. From d4d426888bfc368dd28e87210abc397f12b795e6 Mon Sep 17 00:00:00 2001 From: Karl Knutsson Date: Sat, 5 Oct 2024 07:45:29 +0200 Subject: [PATCH 27/54] tx-submission: added duration to TxInboundAddedToMempool Add the time it took to add TXs to the mempool to the TxInboundAddedToMempool tracer. --- .../Ouroboros/Network/TxSubmission/Inbound/Server.hs | 10 +++++++++- .../Ouroboros/Network/TxSubmission/Inbound/Types.hs | 3 ++- .../Ouroboros/Network/Diffusion/Testnet/Cardano.hs | 2 +- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs index 5415dc780a7..45704c633c3 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs @@ -16,6 +16,7 @@ import Data.Set qualified as Set import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI import Control.Tracer (Tracer, traceWith) import Network.TypedProtocol @@ -43,6 +44,7 @@ txSubmissionInboundV2 :: forall txid tx idx m. ( MonadSTM m , MonadThrow m + , MonadMonotonicTime m , Ord txid ) => Tracer m (TraceTxSubmissionInbound txid tx) @@ -70,9 +72,15 @@ txSubmissionInboundV2 txd@TxDecision { txdTxsToRequest = txsToReq, txdTxsToMempool = txs } <- readTxDecision traceWith tracer (TraceTxInboundDecision txd) + + !start <- getMonotonicTime txidsAccepted <- mempoolAddTxs txs + !end <- getMonotonicTime + let duration = diffTime end start + traceWith tracer $ - TraceTxInboundAddedToMempool txidsAccepted + TraceTxInboundAddedToMempool txidsAccepted duration + let !collected = length txs let !accepted = length txidsAccepted traceWith tracer $ diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs index bd3427c85c7..81c8f9a1030 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs @@ -24,6 +24,7 @@ module Ouroboros.Network.TxSubmission.Inbound.Types ) 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) @@ -296,7 +297,7 @@ data TraceTxSubmissionInbound txid tx = -- | Server received 'MsgDone' | TraceTxInboundCanRequestMoreTxs Int | TraceTxInboundCannotRequestMoreTxs Int - | TraceTxInboundAddedToMempool [txid] + | TraceTxInboundAddedToMempool [txid] DiffTime -- -- messages emitted by the new implementation of the server in 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 18350dcede9..04a2ed1aa8e 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -979,7 +979,7 @@ unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) case x of -- When we add txids to the mempool, we collect them -- into the map - DiffusionTxSubmissionInbound (TraceTxInboundAddedToMempool txids) -> + DiffusionTxSubmissionInbound (TraceTxInboundAddedToMempool txids _) -> Map.alter (maybe (Just []) (Just . sort . (txids ++))) n rr -- When the node is shutdown we have to reset the accepted -- txids list From bd936accd199ee93d59ca3ef920a9f9badee5a11 Mon Sep 17 00:00:00 2001 From: Karl Knutsson Date: Fri, 4 Oct 2024 12:24:59 +0200 Subject: [PATCH 28/54] tx-submission: ranking of peers DeltaQ metrics is only available for our warm and hot peers that also have us as hot. So a fraction of all downstream clients will have a metric. This change the ranking of peers to use simple scoring system. Deliver a new TX before in time before it gets into the block gives you one point. Delivering a TXs thats already in the mempool, is invalid, or fail because it was included in a recent blocks gives you a penalty. Only the peer's that downloaded a TX will attempt to add it to the mempool --- .../Ouroboros/Network/TxSubmission/Inbound.hs | 8 +- .../Network/TxSubmission/Inbound/Decision.hs | 95 +++++++-- .../Network/TxSubmission/Inbound/Policy.hs | 19 +- .../Network/TxSubmission/Inbound/Registry.hs | 194 +++++++++++++++++- .../Network/TxSubmission/Inbound/Server.hs | 74 +++++-- .../Network/TxSubmission/Inbound/State.hs | 107 +++++++--- .../Network/TxSubmission/Inbound/Types.hs | 50 ++++- .../Network/Diffusion/Node/Kernel.hs | 22 +- .../Network/Diffusion/Node/MiniProtocols.hs | 9 +- .../Network/Diffusion/Testnet/Cardano.hs | 2 +- .../Ouroboros/Network/TxSubmission/AppV2.hs | 14 +- .../Ouroboros/Network/TxSubmission/TxLogic.hs | 57 +++-- 12 files changed, 550 insertions(+), 101 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs index cbae83a1e36..33a84921048 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs @@ -36,6 +36,7 @@ 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) @@ -314,13 +315,18 @@ txSubmissionInbound tracer (NumTxIdsToAck maxUnacked) mpReader mpWriter _version traceWith tracer $ TraceTxSubmissionCollected collected + !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 + , ptxcScore = 0 -- This implementatin does not track score } continueWithStateM (serverIdle n) st { diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs index a6d0ccdeb82..0aa2bd06317 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -20,13 +21,15 @@ import Control.Arrow ((>>>)) import Control.Exception (assert) import Data.Bifunctor (second) -import Data.List (mapAccumR, sortOn) +import Data.Hashable +import Data.List (foldl', mapAccumR, sortOn) import Data.Map.Merge.Strict qualified as Map import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe) import Data.Set (Set) import Data.Set qualified as Set +import System.Random (random) import Data.Sequence.Strict qualified as StrictSeq import Ouroboros.Network.DeltaQ (PeerGSV (..), defaultGSV, @@ -43,6 +46,7 @@ makeDecisions :: forall peeraddr txid tx. ( Ord peeraddr , Ord txid + , Hashable peeraddr ) => TxDecisionPolicy -- ^ decision policy @@ -59,12 +63,14 @@ makeDecisions , Map peeraddr (TxDecision txid tx) ) makeDecisions policy SharedDecisionContext { - sdcPeerGSV = peerGSV, + sdcPeerGSV = _peerGSV, sdcSharedTxState = st } - = fn - . pickTxsToDownload policy st - . orderByDeltaQ peerGSV + = 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)]) @@ -72,14 +78,30 @@ makeDecisions policy SharedDecisionContext { 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 = + sortOn (\(peeraddr, ps) -> (score ps, hashWithSalt salt peeraddr)) + . Map.toList + -- | Order peers by `DeltaQ`. -- -orderByDeltaQ :: forall peeraddr txid tx. +_orderByDeltaQ :: forall peeraddr txid tx. Ord peeraddr => Map peeraddr PeerGSV -> Map peeraddr (PeerTxState txid tx) -> [(peeraddr, PeerTxState txid tx)] -orderByDeltaQ dq = +_orderByDeltaQ dq = sortOn (\(peeraddr, _) -> gsvRequestResponseDuration (Map.findWithDefault defaultGSV peeraddr dq) @@ -107,9 +129,13 @@ data St peeraddr txid tx = stInflight :: !(Map txid Int), -- ^ `txid`s in-flight. - stAcknowledged :: !(Map txid Int) + 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. } @@ -147,6 +173,7 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, inflightTxs, inflightTxsSize, bufferedTxs, + limboTxs, referenceCounts } = -- outer fold: fold `[(peeraddr, PeerTxState txid tx)]` mapAccumR @@ -154,7 +181,8 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, -- initial state St { stInflight = inflightTxs, stInflightSize = inflightTxsSize, - stAcknowledged = Map.empty } + stAcknowledged = Map.empty, + stLimboTx = Map.keysSet limboTxs } >>> gn @@ -169,7 +197,8 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, accumFn st@St { stInflight, stInflightSize, - stAcknowledged } + stAcknowledged, + stLimboTx } ( peeraddr , peerTxState@PeerTxState { availableTxIds, unknownTxs, @@ -189,11 +218,13 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, acknowledgeTxIds policy sharedState peerTxState stAcknowledged' = Map.unionWith (+) stAcknowledged txIdsToAck + stLimboTx' = stLimboTx <> (Set.fromList $ map fst txsToMempool) in if requestedTxIdsInflight peerTxState' > 0 then -- we have txids to request - ( st { stAcknowledged = stAcknowledged' } + ( st { stAcknowledged = stAcknowledged' + , stLimboTx = stLimboTx' } , ( (peeraddr, peerTxState') , TxDecision { txdTxIdsToAcknowledge = numTxIdsToAck, txdTxIdsToRequest = numTxIdsToReq, @@ -253,7 +284,8 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, -- 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) + (Map.keysSet bufferedTxs <> requestedTxsInflight <> unknownTxs + <> stLimboTx) ) requestedTxsInflightSize @@ -280,13 +312,16 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, stInflight' :: Map txid Int stInflight' = Map.unionWith (+) stInflightDelta stInflight + + stLimboTx' = stLimboTx <> (Set.fromList $ map fst txsToMempool) in if requestedTxIdsInflight peerTxState'' > 0 then -- we can request `txid`s & `tx`s ( St { stInflight = stInflight', stInflightSize = sizeInflightOther + requestedTxsInflightSize', - stAcknowledged = stAcknowledged' } + stAcknowledged = stAcknowledged', + stLimboTx = stLimboTx' } , ( (peeraddr, peerTxState'') , TxDecision { txdTxIdsToAcknowledge = numTxIdsToAck, txdPipelineTxIds = not @@ -302,7 +337,8 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, else -- there are no `txid`s to request, only `tx`s. ( st { stInflight = stInflight', - stInflightSize = sizeInflightOther + requestedTxsInflightSize' + stInflightSize = sizeInflightOther + requestedTxsInflightSize', + stLimboTx = stLimboTx' } , ( (peeraddr, peerTxState'') , emptyTxDecision { txdTxsToRequest = txsToRequest } @@ -338,13 +374,15 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, bufferedTxs' = bufferedTxs `Map.restrictKeys` liveSet + limboTxs' = foldl' updateLimboTxs limboTxs as in ( sharedState { peerTxStates = peerTxStates', inflightTxs = stInflight, inflightTxsSize = stInflightSize, bufferedTxs = bufferedTxs', - referenceCounts = referenceCounts' } + referenceCounts = referenceCounts', + limboTxs = limboTxs'} , -- exclude empty results mapMaybe (\((a, _), b) -> case b of TxDecision { txdTxIdsToAcknowledge = 0, @@ -359,6 +397,18 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, as ) + where + updateLimboTxs :: Map txid Int + -> ((peeraddr, PeerTxState txid tx), + TxDecision txid tx) + -> Map txid Int + updateLimboTxs m (_,d) = foldl' fn m $ txdTxsToMempool d + 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. @@ -379,7 +429,8 @@ filterActivePeers SharedTxState { peerTxStates, bufferedTxs, inflightTxs, - inflightTxsSize } + inflightTxsSize, + limboTxs } | overLimit = Map.filter fn peerTxStates | otherwise @@ -392,7 +443,9 @@ filterActivePeers fn :: PeerTxState txid tx -> Bool fn PeerTxState { unacknowledgedTxIds, requestedTxIdsInflight, - unknownTxs + unknownTxs, + downloadedTxs, + requestedTxsInflight } = -- hasTxIdsToAcknowledge st ps || requestedTxIdsInflight == 0 -- document why it's not <= maxTxIdsInFlightPerPeer @@ -402,8 +455,10 @@ filterActivePeers -- 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 + 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) @@ -422,6 +477,7 @@ filterActivePeers requestedTxsInflight, requestedTxsInflightSize, availableTxIds, + downloadedTxs, unknownTxs } = ( requestedTxIdsInflight == 0 && requestedTxIdsInflight + numOfUnacked <= maxUnacknowledgedTxIds @@ -435,12 +491,15 @@ filterActivePeers `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 diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs index 7a2760416a1..eea465b7969 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs @@ -6,6 +6,7 @@ module Ouroboros.Network.TxSubmission.Inbound.Policy , max_TX_SIZE ) where +import Control.Monad.Class.MonadTime.SI import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToReq (..)) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) @@ -45,8 +46,19 @@ data TxDecisionPolicy = TxDecisionPolicy { -- ^ a limit of tx size in-flight from all peers. -- It can be exceed by max tx size. - txInflightMultiplicity :: !Int + 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 @@ -57,5 +69,8 @@ defaultTxDecisionPolicy = maxUnacknowledgedTxIds = 10, -- must be the same as txSubmissionMaxUnacked txsSizeInflightPerPeer = max_TX_SIZE * 6, maxTxsSizeInflight = max_TX_SIZE * 20, - txInflightMultiplicity = 1 + txInflightMultiplicity = 2, + bufferedTxsMinLifetime = 2, + scoreRate = 0.1, + scoreMax = 15 * 60 } diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs index a6df364bc21..837fd4dacef 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -8,25 +8,31 @@ module Ouroboros.Network.TxSubmission.Inbound.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.MonadTimer.SI +import Control.Monad.Class.MonadTime.SI import Data.Foldable (traverse_ #if !MIN_VERSION_base(4,20,0) , foldl' #endif ) +import Data.Hashable import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) @@ -57,6 +63,11 @@ type TxChannelsVar m peeraddr txid tx = StrictMVar m (TxChannels m peeraddr txid 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 { @@ -75,8 +86,15 @@ data PeerTxAPI m txid tx = PeerTxAPI { -- ^ requested txids -> Map txid tx -- ^ received txs - -> m (Maybe TxSubmissionProtocolError) + -> m (Maybe TxSubmissionProtocolError), -- ^ handle received txs + + countRejectedTxs :: Time + -> Double + -> m Double, + + withMempoolSem :: m (Either (txid, tx) (txid, tx)) + -> m (Either (txid, tx) (txid, tx)) } @@ -89,6 +107,7 @@ withPeer ( MonadMask m , MonadMVar m , MonadSTM m + , MonadMonotonicTime m , Ord txid , Show txid , Ord peeraddr @@ -96,6 +115,8 @@ withPeer ) => Tracer m (TraceTxLogic peeraddr txid tx) -> TxChannelsVar m peeraddr txid tx + -> TxMempoolSem m + -> TxDecisionPolicy -> SharedTxStateVar m peeraddr txid tx -> TxSubmissionMempoolReader txid tx idx m -> (tx -> SizeInBytes) @@ -106,6 +127,8 @@ withPeer -> m a withPeer tracer channelsVar + (TxMempoolSem mempoolSem) + policy@TxDecisionPolicy { bufferedTxsMinLifetime } sharedStateVar TxSubmissionMempoolReader { mempoolGetSnapshot } txSize @@ -126,7 +149,10 @@ withPeer tracer ( TxChannels { txChannelMap = txChannelMap' } , PeerTxAPI { readTxDecision = takeMVar chann', handleReceivedTxIds, - handleReceivedTxs } + handleReceivedTxs, + countRejectedTxs, + withMempoolSem + } ) atomically $ modifyTVar sharedStateVar registerPeer @@ -154,7 +180,11 @@ withPeer tracer requestedTxsInflightSize = 0, requestedTxsInflight = Set.empty, unacknowledgedTxIds = StrictSeq.empty, - unknownTxs = Set.empty } + unknownTxs = Set.empty, + score = 0, + scoreTs = Time 0, + downloadedTxs = Map.empty, + toMempoolTxs = Map.empty } peerTxStates } @@ -163,12 +193,20 @@ withPeer tracer -> SharedTxState peeraddr txid tx unregisterPeer st@SharedTxState { peerTxStates, bufferedTxs, - referenceCounts } = + referenceCounts, + inflightTxs, + inflightTxsSize, + limboTxs } = st { peerTxStates = peerTxStates', bufferedTxs = bufferedTxs', - referenceCounts = referenceCounts' } + referenceCounts = referenceCounts', + inflightTxs = inflightTxs', + inflightTxsSize = inflightTxsSize', + limboTxs = limboTxs' } where - (PeerTxState { unacknowledgedTxIds }, peerTxStates') = + (PeerTxState { unacknowledgedTxIds, requestedTxsInflight, + requestedTxsInflightSize, toMempoolTxs } + , peerTxStates') = Map.alterF (\case Nothing -> error ("TxSubmission.withPeer: invariant violation for peer " ++ show peeraddr) @@ -190,10 +228,90 @@ withPeer tracer `Map.restrictKeys` liveSet + inflightTxs' = foldl purgeInflightTxs inflightTxs requestedTxsInflight + inflightTxsSize' = inflightTxsSize - requestedTxsInflightSize + + limboTxs' = + 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 -- + withMempoolSem :: m (Either (txid,tx) (txid, tx)) -> m (Either (txid,tx) (txid,tx)) + withMempoolSem a = + bracket_ (atomically $ waitTSem mempoolSem) + (atomically $ signalTSem mempoolSem) + (do + r <- a + now <- getMonotonicTime + atomically $ modifyTVar sharedStateVar (updateBufferedTx now r) + return r + ) + where + updateBufferedTx :: Time + -> Either (txid, tx) (txid, tx) + -> SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + updateBufferedTx _ (Left (txid,_tx)) 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 (Right (txid, tx)) + 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 atf (addTime bufferedTxsMinLifetime now) timedTxs + where + atf :: Maybe [txid] + -> Maybe [txid] + atf Nothing = Just [txid] + atf (Just txids) = Just $! (txid:txids) + + referenceCounts' = Map.alter afn txid referenceCounts + where + afn :: Maybe Int + -> Maybe Int + afn Nothing = Just 1 + afn (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 @@ -216,6 +334,69 @@ withPeer tracer handleReceivedTxs txids txs = collectTxs tracer txSize sharedStateVar peeraddr txids txs + countRejectedTxs :: Time + -> Double + -> m Double + countRejectedTxs now n = atomically $ do + modifyTVar sharedStateVar cntRejects + st <- readTVar sharedStateVar + case Map.lookup peeraddr (peerTxStates st) of + Nothing -> error ("TxSubmission.withPeer: invariant violation for peer " ++ show peeraddr) + Just ps -> return $ score ps + where + cntRejects :: SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + cntRejects st@SharedTxState { peerTxStates } = + let peerTxStates' = Map.update (\ps -> Just $! updateRejects policy now n ps) peeraddr peerTxStates in + st {peerTxStates = peerTxStates'} + +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 = max 0 $ 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. @@ -226,6 +407,7 @@ decisionLogicThread , MonadFork m , Ord peeraddr , Ord txid + , Hashable peeraddr ) => Tracer m (TraceTxLogic peeraddr txid tx) -> TxDecisionPolicy diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs index 45704c633c3..d12c05bcd1e 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs @@ -21,10 +21,11 @@ import Control.Tracer (Tracer, traceWith) import Network.TypedProtocol -import Control.Monad (unless) +import Control.Monad (unless, when) import Ouroboros.Network.Protocol.TxSubmission2.Server import Ouroboros.Network.TxSubmission.Inbound.Registry (PeerTxAPI (..)) import Ouroboros.Network.TxSubmission.Inbound.Types +import Ouroboros.Network.TxSubmission.Mempool.Reader -- | Flag to enable/disable the usage of the new tx submission protocol -- @@ -48,11 +49,15 @@ txSubmissionInboundV2 , Ord txid ) => Tracer m (TraceTxSubmissionInbound txid tx) + -> TxSubmissionMempoolReader txid tx idx m -> TxSubmissionMempoolWriter txid tx idx m -> PeerTxAPI m txid tx -> TxSubmissionServerPipelined txid tx m () txSubmissionInboundV2 tracer + TxSubmissionMempoolReader{ + mempoolGetSnapshot + } TxSubmissionMempoolWriter { txId, mempoolAddTxs @@ -60,7 +65,9 @@ txSubmissionInboundV2 PeerTxAPI { readTxDecision, handleReceivedTxIds, - handleReceivedTxs + handleReceivedTxs, + countRejectedTxs, + withMempoolSem } = TxSubmissionServerPipelined serverIdle @@ -73,23 +80,14 @@ txSubmissionInboundV2 <- readTxDecision traceWith tracer (TraceTxInboundDecision txd) - !start <- getMonotonicTime - txidsAccepted <- mempoolAddTxs txs - !end <- getMonotonicTime - let duration = diffTime end start - - traceWith tracer $ - TraceTxInboundAddedToMempool txidsAccepted duration - let !collected = length txs - let !accepted = length txidsAccepted - traceWith tracer $ - TraceTxSubmissionCollected collected - traceWith tracer $ TraceTxSubmissionProcessed ProcessedTxCount { - ptxcAccepted = accepted - , ptxcRejected = collected - accepted - } + -- Only attempt to add TXs if we have some work to do + when (collected > 0) $ do + mapM_ (withMempoolSem . addTx) txs + + traceWith tracer $ + TraceTxSubmissionCollected collected -- TODO: -- We can update the state so that other `tx-submission` servers will @@ -98,6 +96,48 @@ txSubmissionInboundV2 then serverReqTxIds Zero txd else serverReqTxs txd + addTx :: (txid,tx) -> m (Either (txid, tx) (txid, tx)) + addTx (txid,tx) = 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 tracer $ TraceTxSubmissionProcessed ProcessedTxCount { + ptxcAccepted = 0 + , ptxcRejected = 1 + , ptxcScore = s + } + return $ Left (txid, tx) + else do + !start <- getMonotonicTime + acceptedTxs <- mempoolAddTxs [tx] + !end <- getMonotonicTime + let duration = diffTime end start + + traceWith tracer $ + TraceTxInboundAddedToMempool acceptedTxs duration + if null acceptedTxs + then do + !s <- countRejectedTxs end 1 + traceWith tracer $ TraceTxSubmissionProcessed ProcessedTxCount { + ptxcAccepted = 0 + , ptxcRejected = 1 + , ptxcScore = s + } + return $ Left (txid, tx) + else do + !s <- countRejectedTxs end 0 + traceWith tracer $ TraceTxSubmissionProcessed ProcessedTxCount { + ptxcAccepted = 1 + , ptxcRejected = 0 + , ptxcScore = s + } + return $ Right (txid, tx) -- Pipelined request of txs serverReqTxs :: TxDecision txid tx diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs index 56590c449c7..9c83b7571f8 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs @@ -16,6 +16,7 @@ module Ouroboros.Network.TxSubmission.Inbound.State , receivedTxIds , collectTxs , acknowledgeTxIds + , tickTimedTxs -- * Internals, only exported for testing purposes: , RefCountDiff (..) , updateRefCounts @@ -24,6 +25,7 @@ module Ouroboros.Network.TxSubmission.Inbound.State ) where import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadTime.SI import Control.Exception (assert) import Control.Tracer (Tracer, traceWith) @@ -41,6 +43,7 @@ import Data.Sequence.Strict (StrictSeq) import Data.Sequence.Strict qualified as StrictSeq import Data.Set (Set) import Data.Set qualified as Set +import System.Random (StdGen) import GHC.Stack (HasCallStack) import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..), @@ -97,7 +100,7 @@ acknowledgeTxIds => TxDecisionPolicy -> SharedTxState peeraddr txid tx -> PeerTxState txid tx - -> (NumTxIdsToAck, NumTxIdsToReq, [tx], RefCountDiff txid, PeerTxState txid tx) + -> (NumTxIdsToAck, NumTxIdsToReq, [(txid,tx)], RefCountDiff txid, PeerTxState txid tx) -- ^ number of txid to acknowledge, txids to acknowledge with multiplicities, -- updated PeerTxState. {-# INLINE acknowledgeTxIds #-} @@ -109,7 +112,11 @@ acknowledgeTxIds ps@PeerTxState { availableTxIds, unacknowledgedTxIds, unknownTxs, - requestedTxIdsInflight } + 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. @@ -123,7 +130,10 @@ acknowledgeTxIds availableTxIds = availableTxIds', unknownTxs = unknownTxs', requestedTxIdsInflight = requestedTxIdsInflight - + txIdsToRequest } + + txIdsToRequest, + downloadedTxs = downloadedTxs', + score = score', + toMempoolTxs = toMempoolTxs' } ) else ( 0 @@ -136,16 +146,29 @@ acknowledgeTxIds -- 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 + StrictSeq.spanl (\txid -> (txid `Map.member` bufferedTxs || txid `Set.member` unknownTxs + || txid `Map.member` downloadedTxs) + && txid `Set.notMember` requestedTxsInflight ) unacknowledgedTxIds - txsToMempool :: [tx] - txsToMempool = [ tx - | txid <- toList acknowledgedTxIds - , Just tx <- maybeToList $ txid `Map.lookup` bufferedTxs + 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 _ -> Set.member txid liveSet) downloadedTxs + lateTxs = Map.filterWithKey (\txid _ -> Map.notMember txid txsToMempoolMap) ackedDownloadedTxs + score' = score + (fromIntegral $ Map.size lateTxs) + -- the set of live `txids` liveSet = Set.fromList (toList unacknowledgedTxIds') @@ -204,6 +227,43 @@ updateRefCounts referenceCounts (RefCountDiff diff) = 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') = Map.split now timedTxs + expiredTxs' = -- Map.split doesn't include the `now` entry in any map + case Map.lookup now timedTxs of + (Just txids) -> expiredTxs <> (Map.singleton now txids) + Nothing -> expiredTxs + 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 = 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 @@ -340,7 +400,7 @@ collectTxsImpl txSize peeraddr requestedTxIds receivedTxs ) fn ps = case wrongSizedTxs of - [] -> ( Right st'' + [] -> ( Right st' , ps'' ) _ -> ( Left wrongSizedTxs @@ -365,9 +425,7 @@ collectTxsImpl txSize peeraddr requestedTxIds receivedTxs notReceived = requestedTxIds Set.\\ Map.keysSet receivedTxs - -- add received `tx`s to buffered map - bufferedTxs' = bufferedTxs st - <> Map.map Just receivedTxs + downloadedTxs' = downloadedTxs ps <> receivedTxs -- Add not received txs to `unknownTxs` before acknowledging txids. unknownTxs' = unknownTxs ps <> notReceived @@ -383,8 +441,6 @@ collectTxsImpl txSize peeraddr requestedTxIds receivedTxs assert (requestedTxsInflightSize ps >= requestedSize) $ requestedTxsInflightSize ps - requestedSize - st' = st { bufferedTxs = bufferedTxs' } - -- subtract requested from in-flight inflightTxs'' = Map.merge @@ -395,15 +451,15 @@ collectTxsImpl txSize peeraddr requestedTxIds receivedTxs if z > 0 then Just z else Nothing) - (inflightTxs st') + (inflightTxs st) (Map.fromSet (const 1) requestedTxIds) - inflightTxsSize'' = assert (inflightTxsSize st' >= requestedSize) $ - inflightTxsSize st' - requestedSize + inflightTxsSize'' = assert (inflightTxsSize st >= requestedSize) $ + inflightTxsSize st - requestedSize - st'' = st' { inflightTxs = inflightTxs'', + st' = st { inflightTxs = inflightTxs'', inflightTxsSize = inflightTxsSize'' - } + } -- -- Update PeerTxState @@ -433,7 +489,8 @@ collectTxsImpl txSize peeraddr requestedTxIds receivedTxs ps'' = ps { availableTxIds = availableTxIds'', unknownTxs = unknownTxs'', requestedTxsInflightSize = requestedTxsInflightSize', - requestedTxsInflight = requestedTxsInflight' } + requestedTxsInflight = requestedTxsInflight', + downloadedTxs = downloadedTxs'} -- -- Monadic public API @@ -442,12 +499,16 @@ collectTxsImpl txSize peeraddr requestedTxIds receivedTxs type SharedTxStateVar m peeraddr txid tx = StrictTVar m (SharedTxState peeraddr txid tx) newSharedTxStateVar :: MonadSTM m - => m (SharedTxStateVar m peeraddr txid tx) -newSharedTxStateVar = newTVarIO SharedTxState { peerTxStates = Map.empty, + => 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 } + referenceCounts = Map.empty, + timedTxs = Map.empty, + limboTxs = Map.empty, + peerRng = rng } -- | Acknowledge `txid`s, return the number of `txids` to be acknowledged to the diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs index 81c8f9a1030..bac202d8f52 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} @@ -30,6 +31,7 @@ import Data.Sequence.Strict (StrictSeq) import Data.Set (Set) import Data.Set qualified as Set import GHC.Generics (Generic) +import System.Random (StdGen) import NoThunks.Class (NoThunks (..)) @@ -76,7 +78,25 @@ data PeerTxState txid tx = PeerTxState { -- 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) + 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 hasn't been sent to the mempool yet. + 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. + toMempoolTxs :: !(Map txid tx) + } deriving (Eq, Show, Generic) @@ -128,11 +148,11 @@ data SharedTxState peeraddr txid tx = SharedTxState { -- | Map of `tx` which: -- - -- * were downloaded, + -- * 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. + -- at least one peer or has a `timedTxs` entry. -- -- /Note:/ `txid`s which `tx` were unknown by a peer are tracked -- separately in `unknownTxs`. @@ -146,8 +166,8 @@ data SharedTxState peeraddr txid tx = SharedTxState { -- bufferedTxs :: !(Map txid (Maybe tx)), - -- | We track reference counts of all unacknowledged txids. Once the - -- count reaches 0, a tx is removed from `bufferedTxs`. + -- | 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. @@ -159,13 +179,28 @@ data SharedTxState peeraddr txid tx = SharedTxState { -- * @Map.keysSet bufferedTxs `Set.isSubsetOf` Map.keysSet referenceCounts@; -- * all counts are positive integers. -- - referenceCounts :: !(Map txid Int) + referenceCounts :: !(Map txid Int), + + + -- | A set of timeouts for txids that have been added to bufferedTxs after being + -- inserted into the mempool. + -- Evenry 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 fetchrequests for TXs in this + -- state. + 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) @@ -199,7 +234,7 @@ data TxDecision txid tx = TxDecision { txdTxsToRequest :: !(Set txid), -- ^ txid's to download. - txdTxsToMempool :: ![tx] + txdTxsToMempool :: ![(txid,tx)] -- ^ list of `tx`s to submit to the mempool. } deriving (Show, Eq) @@ -261,6 +296,7 @@ data ProcessedTxCount = ProcessedTxCount { ptxcAccepted :: Int -- | Just rejected this many transactions. , ptxcRejected :: Int + , ptxcScore :: Double } deriving (Eq, Show) 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 3351caac934..d37c21b4e56 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs @@ -52,7 +52,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) @@ -81,9 +81,8 @@ import Ouroboros.Network.PeerSharing (PeerSharingAPI, PeerSharingRegistry (..), import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Snocket (TestAddress (..)) import Ouroboros.Network.TxSubmission.Inbound.Registry (SharedTxStateVar, - TxChannels (..), TxChannelsVar, newSharedTxStateVar) - - + 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 () @@ -292,6 +291,8 @@ data NodeKernel header block s txid m = NodeKernel { nkTxChannelsVar :: TxChannelsVar m NtNAddr txid (Tx txid), + nkTxMempoolSem :: TxMempoolSem m, + nkSharedTxStateVar :: SharedTxStateVar m NtNAddr txid (Tx txid) } @@ -301,9 +302,10 @@ newNodeKernel :: ( MonadSTM m , Eq txid ) => s + -> Int -> [Tx txid] -> m (NodeKernel header block s txid m) -newNodeKernel rng txs = do +newNodeKernel psRng txSeed txs = do publicStateVar <- makePublicPeerSelectionStateVar NodeKernel <$> newTVarIO Map.empty @@ -311,13 +313,14 @@ newNodeKernel rng txs = 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) - <*> newSharedTxStateVar + <*> newTxMempoolSem + <*> newSharedTxStateVar (mkStdGen txSeed) -- | Register a new upstream chain-sync client. -- @@ -406,11 +409,12 @@ withNodeKernelThread withNodeKernelThread BlockGeneratorArgs { bgaSlotDuration, bgaBlockGenerator, bgaSeed } txs k = do - kernel <- newNodeKernel psSeed txs + 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 txid m -> (SlotNo -> STM m SlotNo) 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 0d491bfd449..29640ef7290 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -103,7 +103,7 @@ import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..), import Ouroboros.Network.RethrowPolicy import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy (..)) import Ouroboros.Network.TxSubmission.Inbound.Registry (SharedTxStateVar, - TxChannelsVar, withPeer) + TxChannelsVar, TxMempoolSem, withPeer) import Ouroboros.Network.TxSubmission.Inbound.Server (txSubmissionInboundV2) import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxLogic, TraceTxSubmissionInbound) @@ -373,6 +373,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node (txSubmissionInitiator aaTxDecisionPolicy (nkMempool nodeKernel)) (txSubmissionResponder (nkMempool nodeKernel) (nkTxChannelsVar nodeKernel) + (nkTxMempoolSem nodeKernel) (nkSharedTxStateVar nodeKernel)) } ] @@ -695,20 +696,24 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node 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 sharedTxStateVar = + txSubmissionResponder mempool txChannelsVar txMempoolSem sharedTxStateVar = MiniProtocolCb $ \ ResponderContext { rcConnectionId = connId@ConnectionId { remoteAddress = them }} channel -> do withPeer txSubmissionInboundDebug txChannelsVar + txMempoolSem + aaTxDecisionPolicy sharedTxStateVar (getMempoolReader mempool) getTxSize them $ \api -> do let server = txSubmissionInboundV2 txSubmissionInboundTracer + (getMempoolReader mempool) (getMempoolWriter mempool) api labelThisThread "TxSubmissionServer" 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 04a2ed1aa8e..db0927eec31 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -980,7 +980,7 @@ unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) -- When we add txids to the mempool, we collect them -- into the map DiffusionTxSubmissionInbound (TraceTxInboundAddedToMempool txids _) -> - Map.alter (maybe (Just []) (Just . sort . (txids ++))) n rr + Map.alter (maybe (Just txids) (Just . sort . (txids ++))) n rr -- When the node is shutdown we have to reset the accepted -- txids list DiffusionDiffusionSimulationTrace TrKillingNode -> diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs index c11adb9d95e..a1dcc67599b 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs @@ -34,11 +34,13 @@ 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) @@ -129,6 +131,7 @@ runTxSubmission , NoThunks (Tx txid) , Show peeraddr , Ord peeraddr + , Hashable peeraddr , txid ~ Int ) @@ -150,15 +153,18 @@ runTxSubmission tracer tracerTxLogic state txDecisionPolicy = do ) state inboundMempool <- emptyMempool + let txRng = mkStdGen 42 -- TODO txChannelsMVar <- newMVar (TxChannels Map.empty) - sharedTxStateVar <- newSharedTxStateVar + txMempoolSem <- newTxMempoolSem + sharedTxStateVar <- newSharedTxStateVar txRng labelTVarIO sharedTxStateVar "shared-tx-state" gsvVar <- newTVarIO Map.empty labelTVarIO gsvVar "gsv" run state' txChannelsMVar + txMempoolSem sharedTxStateVar inboundMempool gsvVar @@ -181,12 +187,13 @@ runTxSubmission tracer tracerTxLogic state txDecisionPolicy = do , 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 sharedTxStateVar + run st txChannelsVar txMempoolSem sharedTxStateVar inboundMempool gsvVar k = withAsync (decisionLogicThread tracerTxLogic txDecisionPolicy (readTVar gsvVar) txChannelsVar sharedTxStateVar) $ \a -> do -- Construct txSubmission outbound client @@ -211,11 +218,14 @@ runTxSubmission tracer tracerTxLogic state txDecisionPolicy = do servers = (\(addr, (_, _, _, inDelay, _, inChannel)) -> withPeer tracerTxLogic txChannelsVar + txMempoolSem + txDecisionPolicy sharedTxStateVar (getMempoolReader inboundMempool) getTxSize addr $ \api -> do let server = txSubmissionInboundV2 verboseTracer + (getMempoolReader inboundMempool) (getMempoolWriter inboundMempool) api runPipelinedPeerWithLimits diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs index bfc453de2c9..5330cf3f76b 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs @@ -1,13 +1,16 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} @@ -17,6 +20,7 @@ module Test.Ouroboros.Network.TxSubmission.TxLogic where import Prelude hiding (seq) +import Control.Monad.Class.MonadTime.SI (Time (..)) import Control.Exception (assert) import Data.Foldable ( @@ -30,12 +34,13 @@ import Data.List (intercalate, isPrefixOf, isSuffixOf, mapAccumR, nub, import Data.Map.Merge.Strict qualified as Map import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe, maybeToList) +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 (mkStdGen, StdGen) import NoThunks.Class @@ -120,6 +125,7 @@ sharedTxStateInvariant :: forall peeraddr txid tx. ( Ord txid , Show txid + , Show tx ) => SharedTxState peeraddr txid tx -> Property @@ -209,10 +215,12 @@ sharedTxStateInvariant SharedTxState { ++ show (unacknowledgedTxIdsSet Set.\\ availableTxIdsSet Set.\\ unknownTxs - Set.\\ bufferedTxsSet)) + Set.\\ bufferedTxsSet + Set.\\ downloadedTxsSet)) (unacknowledgedTxIdsSet Set.\\ availableTxIdsSet Set.\\ unknownTxs + Set.\\ downloadedTxsSet `Set.isSubsetOf` bufferedTxsSet ) @@ -239,6 +247,9 @@ sharedTxStateInvariant SharedTxState { 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] @@ -302,7 +313,11 @@ mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMaskMap = requestedTxIdsInflight, requestedTxsInflight, requestedTxsInflightSize, - unknownTxs } + unknownTxs, + score = 0, + scoreTs = Time 0, + downloadedTxs = Map.empty, + toMempoolTxs = Map.empty } (Set.fromList $ Map.elems inflightMap) bufferedMap where @@ -382,6 +397,7 @@ 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 @@ -408,7 +424,10 @@ genSharedTxState maxTxIdsInflight = do | ArbPeerTxState { arbBufferedMap } <- pss ], - referenceCounts = Map.empty + referenceCounts = Map.empty, + timedTxs = Map.empty, + limboTxs = Map.empty, + peerRng = mkStdGen seed } return ( mempoolHasTxFun @@ -635,7 +654,7 @@ prop_acknowledgeTxIds :: ArbDecisionContextWithReceivedTxIds -> Property prop_acknowledgeTxIds (ArbDecisionContextWithReceivedTxIds policy SharedDecisionContext { sdcSharedTxState = st } ps _ _ _) = case TXS.acknowledgeTxIds policy st ps of - (numTxIdsToAck, txIdsToRequest, txs, TXS.RefCountDiff { TXS.txIdsToAck }, ps') | txIdsToRequest > 0 -> + (numTxIdsToAck, txIdsToRequest, txIdsTxs, TXS.RefCountDiff { TXS.txIdsToAck }, ps') | txIdsToRequest > 0 -> counterexample "number of tx ids to ack must agree with RefCountDiff" ( fromIntegral numTxIdsToAck === @@ -653,12 +672,10 @@ prop_acknowledgeTxIds (ArbDecisionContextWithReceivedTxIds policy SharedDecision Map.fromListWith (+) ((,1) <$> txIdsToAck') .&&. counterexample "acknowledged txs" (counterexample ("numTxIdsToAck = " ++ show numTxIdsToAck) - let acked :: [TxId] - acked = [ txid - | txid <- take (fromIntegral numTxIdsToAck) (toList $ unacknowledgedTxIds ps) - , Just _ <- maybeToList $ txid `Map.lookup` bufferedTxs st - ] - in getTxId `map` txs === acked) + 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] @@ -911,6 +928,9 @@ prop_collectTxsImpl (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived p 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. -- @@ -936,7 +956,10 @@ instance Arbitrary ArbTxDecisionPolicy where <*> (getSmall . getPositive <$> arbitrary) <*> (SizeInBytes . getPositive <$> arbitrary) <*> (SizeInBytes . getPositive <$> arbitrary) - <*> (getSmall . getPositive <$> arbitrary)) + <*> (getSmall . getPositive <$> arbitrary) + <*> (realToFrac <$> choose (0 :: Double, 2)) + <*> (choose (0, 1)) + <*> (choose (0, 1800))) shrink (ArbTxDecisionPolicy a@TxDecisionPolicy { maxNumTxIdsToRequest, @@ -1504,6 +1527,10 @@ instance Arbitrary ArbDecisionContextWithReceivedTxIds where txIdsToAck' = take (fromIntegral (TXS.requestedTxIdsInflight $ peerTxStates st' Map.! peeraddr)) txIdsToAck peers = Map.keys (peerTxStates st') + downTxsNum <- choose (0, length txIdsToAck') + let downloadedTxs = foldl' pruneTx Map.empty $ take downTxsNum $ Map.toList (bufferedTxs st') + ps'' = ps' { downloadedTxs = downloadedTxs } + gsvs <- zip peers <$> infiniteListOf (unPeerGSVT <$> arbitrary) @@ -1513,11 +1540,15 @@ instance Arbitrary ArbDecisionContextWithReceivedTxIds where sdcPeerGSV = Map.fromList gsvs, sdcSharedTxState = st' }, - adcrPeerTxState = ps', + 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, From fb9675a5602457f636e7d80f3e41e3ee4b8565ef Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 10 Mar 2025 13:12:20 +0100 Subject: [PATCH 29/54] tx-submission: refactored conutRejectedTxs It is using a single map lookup instead of two. --- .../Network/TxSubmission/Inbound/Registry.hs | 27 ++++++++++--------- 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs index 837fd4dacef..50dac67b9ca 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -92,6 +92,10 @@ data PeerTxAPI m txid tx = PeerTxAPI { countRejectedTxs :: Time -> Double -> m Double, + -- ^ Update `score` & `scoreTs` fields of `PeerTxState`, return the new + -- updated `score`. + -- + -- PRECONDITION: the `Double` argument is non-negative. withMempoolSem :: m (Either (txid, tx) (txid, tx)) -> m (Either (txid, tx) (txid, tx)) @@ -337,18 +341,17 @@ withPeer tracer countRejectedTxs :: Time -> Double -> m Double - countRejectedTxs now n = atomically $ do - modifyTVar sharedStateVar cntRejects - st <- readTVar sharedStateVar - case Map.lookup peeraddr (peerTxStates st) of - Nothing -> error ("TxSubmission.withPeer: invariant violation for peer " ++ show peeraddr) - Just ps -> return $ score ps - where - cntRejects :: SharedTxState peeraddr txid tx - -> SharedTxState peeraddr txid tx - cntRejects st@SharedTxState { peerTxStates } = - let peerTxStates' = Map.update (\ps -> Just $! updateRejects policy now n ps) peeraddr peerTxStates in - st {peerTxStates = peerTxStates'} + 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 From c085912a2505e130264ed3590fc41865bbc0ff8f Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 10 Mar 2025 17:02:48 +0100 Subject: [PATCH 30/54] tx-submission: code style --- .../Network/TxSubmission/Inbound/Decision.hs | 18 ++++----- .../Network/TxSubmission/Inbound/Registry.hs | 39 +++++++++---------- .../Network/TxSubmission/Inbound/Server.hs | 13 ++++--- .../Network/TxSubmission/Inbound/State.hs | 22 +++++------ .../Network/TxSubmission/Inbound/Types.hs | 12 +++--- .../Network/Diffusion/Node/MiniProtocols.hs | 3 +- .../Ouroboros/Network/TxSubmission/AppV2.hs | 8 ++-- 7 files changed, 54 insertions(+), 61 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs index 0aa2bd06317..b3c37b3d47b 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs @@ -313,7 +313,7 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, stInflight' :: Map txid Int stInflight' = Map.unionWith (+) stInflightDelta stInflight - stLimboTx' = stLimboTx <> (Set.fromList $ map fst txsToMempool) + stLimboTx' = stLimboTx <> Set.fromList (map fst txsToMempool) in if requestedTxIdsInflight peerTxState'' > 0 then @@ -374,6 +374,7 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, bufferedTxs' = bufferedTxs `Map.restrictKeys` liveSet + limboTxs' = foldl' updateLimboTxs limboTxs as in ( sharedState { @@ -398,17 +399,17 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, ) where - updateLimboTxs :: Map txid Int - -> ((peeraddr, PeerTxState txid tx), - TxDecision txid tx) + updateLimboTxs :: forall a. + Map txid Int + -> (a, TxDecision txid tx) -> Map txid Int updateLimboTxs m (_,d) = foldl' fn m $ txdTxsToMempool d 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 + 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. @@ -431,12 +432,11 @@ filterActivePeers inflightTxs, inflightTxsSize, limboTxs } - | overLimit + | inflightTxsSize > maxTxsSizeInflight = Map.filter fn peerTxStates | otherwise = Map.filter gn peerTxStates where - overLimit = inflightTxsSize > maxTxsSizeInflight unrequestable = Map.keysSet (Map.filter (>= txInflightMultiplicity) inflightTxs) <> Map.keysSet bufferedTxs @@ -491,7 +491,7 @@ filterActivePeers `Map.withoutKeys` requestedTxsInflight `Map.withoutKeys` unknownTxs `Map.withoutKeys` unrequestable - `Map.withoutKeys` (Map.keysSet limboTxs) + `Map.withoutKeys` Map.keysSet limboTxs -- Split `unacknowledgedTxIds'` into the longest prefix of `txid`s which -- can be acknowledged and the unacknowledged `txid`s. diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs index 50dac67b9ca..c58eceeec2b 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -155,8 +155,7 @@ withPeer tracer handleReceivedTxIds, handleReceivedTxs, countRejectedTxs, - withMempoolSem - } + withMempoolSem } ) atomically $ modifyTVar sharedStateVar registerPeer @@ -208,9 +207,12 @@ withPeer tracer inflightTxsSize = inflightTxsSize', limboTxs = limboTxs' } where - (PeerTxState { unacknowledgedTxIds, requestedTxsInflight, - requestedTxsInflightSize, toMempoolTxs } - , peerTxStates') = + (PeerTxState { unacknowledgedTxIds, + requestedTxsInflight, + requestedTxsInflightSize, + toMempoolTxs } + , peerTxStates') + = Map.alterF (\case Nothing -> error ("TxSubmission.withPeer: invariant violation for peer " ++ show peeraddr) @@ -247,6 +249,7 @@ withPeer tracer where fn (Just n) | n > 1 = Just $! pred n fn _ = Nothing + -- -- PeerTxAPI -- @@ -267,12 +270,11 @@ withPeer tracer -> SharedTxState peeraddr txid tx -> SharedTxState peeraddr txid tx updateBufferedTx _ (Left (txid,_tx)) st@SharedTxState { peerTxStates - , limboTxs } = + , limboTxs } = st { peerTxStates = peerTxStates' , limboTxs = limboTxs' } where - limboTxs' = Map.update (\case - 1 -> Nothing + limboTxs' = Map.update (\case 1 -> Nothing n -> Just $! pred n) txid limboTxs peerTxStates' = Map.update fn peeraddr peerTxStates @@ -292,23 +294,20 @@ withPeer tracer , limboTxs = limboTxs' } where - limboTxs' = Map.update (\case - 1 -> Nothing + limboTxs' = Map.update (\case 1 -> Nothing n -> Just $! pred n) txid limboTxs - timedTxs' = Map.alter atf (addTime bufferedTxsMinLifetime now) timedTxs + timedTxs' = Map.alter fn (addTime bufferedTxsMinLifetime now) timedTxs where - atf :: Maybe [txid] - -> Maybe [txid] - atf Nothing = Just [txid] - atf (Just txids) = Just $! (txid:txids) + fn :: Maybe [txid] -> Maybe [txid] + fn Nothing = Just [txid] + fn (Just txids) = Just $! (txid:txids) - referenceCounts' = Map.alter afn txid referenceCounts + referenceCounts' = Map.alter fn txid referenceCounts where - afn :: Maybe Int - -> Maybe Int - afn Nothing = Just 1 - afn (Just n) = Just $! succ n + fn :: Maybe Int -> Maybe Int + fn Nothing = Just 1 + fn (Just n) = Just $! succ n bufferedTxs' = Map.insert txid (Just tx) bufferedTxs diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs index d12c05bcd1e..0213268fcde 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs @@ -76,15 +76,16 @@ txSubmissionInboundV2 :: m (ServerStIdle Z txid tx m ()) serverIdle = do -- Block on next decision. - txd@TxDecision { txdTxsToRequest = txsToReq, txdTxsToMempool = txs } + txd@TxDecision { txdTxsToRequest = txsToRequest, + txdTxsToMempool = txsToMempool } <- readTxDecision traceWith tracer (TraceTxInboundDecision txd) - let !collected = length txs + let !collected = length txsToMempool -- Only attempt to add TXs if we have some work to do when (collected > 0) $ do - mapM_ (withMempoolSem . addTx) txs + mapM_ (withMempoolSem . addTx) txsToMempool traceWith tracer $ TraceTxSubmissionCollected collected @@ -92,7 +93,7 @@ txSubmissionInboundV2 -- TODO: -- We can update the state so that other `tx-submission` servers will -- not try to add these txs to the mempool. - if Set.null txsToReq + if Set.null txsToRequest then serverReqTxIds Zero txd else serverReqTxs txd @@ -142,8 +143,8 @@ txSubmissionInboundV2 -- Pipelined request of txs serverReqTxs :: TxDecision txid tx -> m (ServerStIdle Z txid tx m ()) - serverReqTxs txd@TxDecision { txdTxsToRequest = txsToReq } = - pure $ SendMsgRequestTxsPipelined (Set.toList txsToReq) + serverReqTxs txd@TxDecision { txdTxsToRequest = txdTxsToRequest } = + pure $ SendMsgRequestTxsPipelined (Set.toList txdTxsToRequest) (serverReqTxIds (Succ Zero) txd) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs index 9c83b7571f8..0521a899bdd 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} @@ -101,8 +100,8 @@ acknowledgeTxIds -> SharedTxState peeraddr txid tx -> PeerTxState txid tx -> (NumTxIdsToAck, NumTxIdsToReq, [(txid,tx)], RefCountDiff txid, PeerTxState txid tx) - -- ^ number of txid to acknowledge, txids to acknowledge with multiplicities, - -- updated PeerTxState. + -- ^ number of txid to acknowledge, requests, txs which we can submit to the + -- mempool, txids to acknowledge with multiplicities, updated PeerTxState. {-# INLINE acknowledgeTxIds #-} acknowledgeTxIds @@ -165,10 +164,9 @@ acknowledgeTxIds toMempoolTxs' = toMempoolTxs <> txsToMempoolMap - (downloadedTxs', ackedDownloadedTxs) = Map.partitionWithKey (\txid _ -> Set.member txid liveSet) downloadedTxs - lateTxs = Map.filterWithKey (\txid _ -> Map.notMember txid txsToMempoolMap) ackedDownloadedTxs - score' = score + (fromIntegral $ Map.size lateTxs) - + (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') @@ -184,7 +182,7 @@ acknowledgeTxIds unknownTxs' = unknownTxs `Set.intersection` liveSet refCountDiff = RefCountDiff - $ foldr (\txid -> Map.alter fn txid) + $ foldr (Map.alter fn) Map.empty acknowledgedTxIds where fn :: Maybe Int -> Maybe Int @@ -238,8 +236,8 @@ tickTimedTxs now st@SharedTxState{ timedTxs let (expiredTxs, timedTxs') = Map.split now timedTxs expiredTxs' = -- Map.split doesn't include the `now` entry in any map case Map.lookup now timedTxs of - (Just txids) -> expiredTxs <> (Map.singleton now txids) - Nothing -> expiredTxs + Just txids -> Map.insert now txids expiredTxs + Nothing -> expiredTxs refDiff = Map.foldl fn Map.empty expiredTxs' referenceCounts' = updateRefCounts referenceCounts (RefCountDiff refDiff) liveSet = Map.keysSet referenceCounts' @@ -458,7 +456,7 @@ collectTxsImpl txSize peeraddr requestedTxIds receivedTxs inflightTxsSize st - requestedSize st' = st { inflightTxs = inflightTxs'', - inflightTxsSize = inflightTxsSize'' + inflightTxsSize = inflightTxsSize'' } -- @@ -490,7 +488,7 @@ collectTxsImpl txSize peeraddr requestedTxIds receivedTxs unknownTxs = unknownTxs'', requestedTxsInflightSize = requestedTxsInflightSize', requestedTxsInflight = requestedTxsInflight', - downloadedTxs = downloadedTxs'} + downloadedTxs = downloadedTxs' } -- -- Monadic public API diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs index bac202d8f52..045bc9364ca 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs @@ -80,7 +80,6 @@ data PeerTxState txid tx = PeerTxState { -- 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. @@ -90,7 +89,7 @@ data PeerTxState txid tx = PeerTxState { scoreTs :: !Time, -- | A set of TXs downloaded from the peer. They are not yet - -- acknowledged and hasn't been sent to the mempool yet. + -- acknowledged and haven't been sent to the mempool yet. downloadedTxs :: !(Map txid tx), -- | A set of TXs on their way to the mempool. @@ -181,15 +180,14 @@ data SharedTxState peeraddr txid tx = SharedTxState { -- referenceCounts :: !(Map txid Int), - -- | A set of timeouts for txids that have been added to bufferedTxs after being -- inserted into the mempool. - -- Evenry txid entry has a reference count in `referenceCounts`. - timedTxs :: (Map Time [txid]), + -- 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 fetchrequests for TXs in this - -- state. + -- way to the mempool. We won't issue further fetch-requests for TXs in + -- this state. limboTxs :: !(Map txid Int), -- | Rng used to randomly order peers 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 29640ef7290..6926ddb8ef3 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -679,8 +679,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node let client = txSubmissionOutbound ((show . (connId,)) `contramap` debugTracer) (NumTxIdsToAck $ getNumTxIdsToReq - $ maxUnacknowledgedTxIds - $ txDecisionPolicy) + $ maxUnacknowledgedTxIds txDecisionPolicy) (getMempoolReader mempool) maxBound controlMessageSTM diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs index a1dcc67599b..870a81b3a36 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs @@ -92,8 +92,7 @@ instance Arbitrary TxSubmissionState where txsN <- choose (1, 10) txs <- divvy txsN . nubBy (on (==) getTxId) <$> vectorOf (peersN * txsN) arbitrary peers <- vectorOf peersN arbitrary - peersState <- map (\(a, (b, c)) -> (a, b, c)) - . zip txs + peersState <- zipWith (curry (\(a, (b, c)) -> (a, b, c))) txs <$> vectorOf peersN arbitrary return TxSubmissionState { peerMap = Map.fromList (zip peers peersState), decisionPolicy @@ -200,8 +199,7 @@ runTxSubmission tracer tracerTxLogic state txDecisionPolicy = do let clients = (\(addr, (mempool, ctrlMsgSTM, outDelay, _, outChannel, _)) -> do let client = txSubmissionOutbound (Tracer $ say . show) (NumTxIdsToAck $ getNumTxIdsToReq - $ maxUnacknowledgedTxIds - $ txDecisionPolicy) + $ maxUnacknowledgedTxIds txDecisionPolicy) (getMempoolReader mempool) (maxBound :: NodeToNodeVersion) ctrlMsgSTM @@ -275,7 +273,7 @@ txSubmissionSimulation (TxSubmissionState state txDecisionPolicy) = do ) ) 0 - $ state'' + state'' controlMessageVars = (\(_, x, _, _) -> x) <$> Map.elems state' From 7f6e240bd19d61719619450e84f9995c188aa496 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 11 Mar 2025 12:01:35 +0100 Subject: [PATCH 31/54] tx-submission: refactored updateRejects MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We don't need to compute `max 0` twice, since the inputs are always non-negative (e.g. `n ≥ 0`) and thus `drained + n ≥ 0`. --- .../Ouroboros/Network/TxSubmission/Inbound/Registry.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs index c58eceeec2b..28ac1e51719 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -352,6 +352,7 @@ withPeer tracer where ps' = updateRejects policy now n ps + updateRejects :: TxDecisionPolicy -> Time -> Double @@ -361,10 +362,12 @@ 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 + !drain = realToFrac duration * scoreRate !drained = max 0 $ score - drain in - pts { score = max 0 $ min scoreMax $ drained + n - , scoreTs = now } + pts { score = min scoreMax $ drained + n + , scoreTs = now + } + drainRejectionThread :: forall m peeraddr txid tx. From 0cfb61ded109a2ce48615f4e40e84cc06ccf738d Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 13 Mar 2025 11:13:06 +0100 Subject: [PATCH 32/54] tx-submission: added TxsToMempool newtype Just to make it more outstanding what the output of `acknowledgeTxIds` is indented for. --- .../Network/TxSubmission/Inbound/Decision.hs | 27 ++++++++++++------- .../Network/TxSubmission/Inbound/Server.hs | 6 ++--- .../Network/TxSubmission/Inbound/State.hs | 11 +++++--- .../Network/TxSubmission/Inbound/Types.hs | 23 ++++++++++------ .../Ouroboros/Network/TxSubmission/TxLogic.hs | 2 +- 5 files changed, 45 insertions(+), 24 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs index b3c37b3d47b..8ee315c24aa 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs @@ -214,11 +214,15 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, sizeInflightOther = sizeInflightAll - requestedTxsInflightSize in if sizeInflightAll >= maxTxsSizeInflight - then let (numTxIdsToAck, numTxIdsToReq, txsToMempool, RefCountDiff { txIdsToAck }, peerTxState') = - acknowledgeTxIds policy sharedState peerTxState + 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 txsToMempool) + stLimboTx' = stLimboTx <> Set.fromList (map fst listOfTxsToMempool) in if requestedTxIdsInflight peerTxState' > 0 then @@ -300,8 +304,12 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, <> txsToRequest } - (numTxIdsToAck, numTxIdsToReq, txsToMempool, RefCountDiff { txIdsToAck }, peerTxState'') = - acknowledgeTxIds policy sharedState peerTxState' + ( numTxIdsToAck + , numTxIdsToReq + , txsToMempool@TxsToMempool { listOfTxsToMempool } + , RefCountDiff { txIdsToAck } + , peerTxState'' + ) = acknowledgeTxIds policy sharedState peerTxState' stAcknowledged' = Map.unionWith (+) stAcknowledged txIdsToAck @@ -313,7 +321,7 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, stInflight' :: Map txid Int stInflight' = Map.unionWith (+) stInflightDelta stInflight - stLimboTx' = stLimboTx <> Set.fromList (map fst txsToMempool) + stLimboTx' = stLimboTx <> Set.fromList (map fst listOfTxsToMempool) in if requestedTxIdsInflight peerTxState'' > 0 then @@ -389,9 +397,9 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, TxDecision { txdTxIdsToAcknowledge = 0, txdTxIdsToRequest = 0, txdTxsToRequest, - txdTxsToMempool } + txdTxsToMempool = TxsToMempool { listOfTxsToMempool } } | null txdTxsToRequest - , null txdTxsToMempool + , null listOfTxsToMempool -> Nothing _ -> Just (a, b) ) @@ -403,7 +411,8 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, Map txid Int -> (a, TxDecision txid tx) -> Map txid Int - updateLimboTxs m (_,d) = foldl' fn m $ txdTxsToMempool d + updateLimboTxs m (_,TxDecision { txdTxsToMempool } ) = + foldl' fn m (listOfTxsToMempool txdTxsToMempool) where fn :: Map txid Int -> (txid,tx) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs index 0213268fcde..bcfbe2417e7 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs @@ -77,15 +77,15 @@ txSubmissionInboundV2 serverIdle = do -- Block on next decision. txd@TxDecision { txdTxsToRequest = txsToRequest, - txdTxsToMempool = txsToMempool } + txdTxsToMempool = TxsToMempool { listOfTxsToMempool } } <- readTxDecision traceWith tracer (TraceTxInboundDecision txd) - let !collected = length txsToMempool + let !collected = length listOfTxsToMempool -- Only attempt to add TXs if we have some work to do when (collected > 0) $ do - mapM_ (withMempoolSem . addTx) txsToMempool + mapM_ (withMempoolSem . addTx) listOfTxsToMempool traceWith tracer $ TraceTxSubmissionCollected collected diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs index 0521a899bdd..3311535708a 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs @@ -99,7 +99,12 @@ acknowledgeTxIds => TxDecisionPolicy -> SharedTxState peeraddr txid tx -> PeerTxState txid tx - -> (NumTxIdsToAck, NumTxIdsToReq, [(txid,tx)], RefCountDiff txid, 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 #-} @@ -123,7 +128,7 @@ acknowledgeTxIds then ( txIdsToAcknowledge , txIdsToRequest - , txsToMempool + , TxsToMempool txsToMempool , refCountDiff , ps { unacknowledgedTxIds = unacknowledgedTxIds', availableTxIds = availableTxIds', @@ -137,7 +142,7 @@ acknowledgeTxIds else ( 0 , 0 - , [] + , TxsToMempool [] , RefCountDiff Map.empty , ps ) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs index 045bc9364ca..7e58ff9329f 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} module Ouroboros.Network.TxSubmission.Inbound.Types ( -- * PeerTxState @@ -10,6 +12,7 @@ module Ouroboros.Network.TxSubmission.Inbound.Types -- * SharedTxState , SharedTxState (..) -- * Decisions + , TxsToMempool (..) , TxDecision (..) , emptyTxDecision , SharedDecisionContext (..) @@ -206,6 +209,10 @@ instance ( NoThunks peeraddr -- 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 @@ -232,7 +239,7 @@ data TxDecision txid tx = TxDecision { txdTxsToRequest :: !(Set txid), -- ^ txid's to download. - txdTxsToMempool :: ![(txid,tx)] + txdTxsToMempool :: !(TxsToMempool txid tx) -- ^ list of `tx`s to submit to the mempool. } deriving (Show, Eq) @@ -259,7 +266,7 @@ instance Ord txid => Semigroup (TxDecision txid tx) where txdTxIdsToRequest = txdTxIdsToRequest + txdTxIdsToRequest', txdPipelineTxIds = txdPipelineTxIds', txdTxsToRequest = txdTxsToRequest <> txdTxsToRequest', - txdTxsToMempool = txdTxsToMempool ++ txdTxsToMempool' + txdTxsToMempool = txdTxsToMempool <> txdTxsToMempool' } -- | A no-op decision. @@ -269,7 +276,7 @@ emptyTxDecision = TxDecision { txdTxIdsToRequest = 0, txdPipelineTxIds = False, txdTxsToRequest = Set.empty, - txdTxsToMempool = [] + txdTxsToMempool = mempty } data SharedDecisionContext peeraddr txid tx = SharedDecisionContext { diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs index 5330cf3f76b..4d6248ed6d4 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs @@ -654,7 +654,7 @@ prop_acknowledgeTxIds :: ArbDecisionContextWithReceivedTxIds -> Property prop_acknowledgeTxIds (ArbDecisionContextWithReceivedTxIds policy SharedDecisionContext { sdcSharedTxState = st } ps _ _ _) = case TXS.acknowledgeTxIds policy st ps of - (numTxIdsToAck, txIdsToRequest, txIdsTxs, TXS.RefCountDiff { TXS.txIdsToAck }, ps') | txIdsToRequest > 0 -> + (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 === From 8c47dc5959db9f5262ae1c88209b6c32009e383f Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 14 Mar 2025 11:31:15 +0100 Subject: [PATCH 33/54] tx-submission: use strict foldl' and Map.foldl' --- .../src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs | 2 +- .../src/Ouroboros/Network/TxSubmission/Inbound/State.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs index 28ac1e51719..4b00625c391 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -234,7 +234,7 @@ withPeer tracer `Map.restrictKeys` liveSet - inflightTxs' = foldl purgeInflightTxs inflightTxs requestedTxsInflight + inflightTxs' = foldl' purgeInflightTxs inflightTxs requestedTxsInflight inflightTxsSize' = inflightTxsSize - requestedTxsInflightSize limboTxs' = diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs index 3311535708a..ae4883afabe 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs @@ -243,7 +243,7 @@ tickTimedTxs now st@SharedTxState{ timedTxs case Map.lookup now timedTxs of Just txids -> Map.insert now txids expiredTxs Nothing -> expiredTxs - refDiff = Map.foldl fn Map.empty expiredTxs' + refDiff = Map.foldl' fn Map.empty expiredTxs' referenceCounts' = updateRefCounts referenceCounts (RefCountDiff refDiff) liveSet = Map.keysSet referenceCounts' bufferedTxs' = bufferedTxs `Map.restrictKeys` liveSet in From 786355f63bb0f5d53b0fd0a6e82d8752c2d9ef19 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 14 Mar 2025 11:54:48 +0100 Subject: [PATCH 34/54] tx-submission: improved haddocks --- .../Network/TxSubmission/Inbound/Registry.hs | 2 ++ .../Network/TxSubmission/Inbound/Types.hs | 21 ++++++++++++++++++- 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs index 4b00625c391..a2c8b1bdef8 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -237,6 +237,8 @@ withPeer tracer inflightTxs' = 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' = foldl' (flip $ Map.update \cnt -> if cnt > 1 diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs index 7e58ff9329f..1de86182499 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs @@ -93,10 +93,21 @@ data PeerTxState txid tx = PeerTxState { -- | 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) } @@ -190,7 +201,15 @@ data SharedTxState peeraddr txid tx = SharedTxState { -- | 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. + -- 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 From c8c766ca66f8147b864d961702cd5c0d9fbff7ed Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 14 Mar 2025 15:36:23 +0100 Subject: [PATCH 35/54] tx-submission: refactored PeerTxAPI Removed `withMempoolSem` and added instead `addTxToMempool`. --- .../Network/TxSubmission/Inbound/Registry.hs | 90 ++++++++++++++----- .../Network/TxSubmission/Inbound/Server.hs | 60 +------------ .../Network/Diffusion/Node/MiniProtocols.hs | 2 +- .../Ouroboros/Network/TxSubmission/AppV2.hs | 2 +- 4 files changed, 71 insertions(+), 83 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs index a2c8b1bdef8..9befe8c9595 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -89,19 +89,14 @@ data PeerTxAPI m txid tx = PeerTxAPI { -> m (Maybe TxSubmissionProtocolError), -- ^ handle received txs - countRejectedTxs :: Time - -> Double - -> m Double, - -- ^ Update `score` & `scoreTs` fields of `PeerTxState`, return the new - -- updated `score`. - -- - -- PRECONDITION: the `Double` argument is non-negative. - - withMempoolSem :: m (Either (txid, tx) (txid, tx)) - -> m (Either (txid, tx) (txid, tx)) + 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. @@ -123,6 +118,7 @@ withPeer -> TxDecisionPolicy -> SharedTxStateVar m peeraddr txid tx -> TxSubmissionMempoolReader txid tx idx m + -> TxSubmissionMempoolWriter txid tx idx m -> (tx -> SizeInBytes) -> peeraddr -- ^ new peer @@ -135,6 +131,7 @@ withPeer tracer policy@TxDecisionPolicy { bufferedTxsMinLifetime } sharedStateVar TxSubmissionMempoolReader { mempoolGetSnapshot } + TxSubmissionMempoolWriter { mempoolAddTxs } txSize peeraddr io = bracket @@ -154,8 +151,7 @@ withPeer tracer , PeerTxAPI { readTxDecision = takeMVar chann', handleReceivedTxIds, handleReceivedTxs, - countRejectedTxs, - withMempoolSem } + submitTxToMempool } ) atomically $ modifyTVar sharedStateVar registerPeer @@ -256,23 +252,65 @@ withPeer tracer -- PeerTxAPI -- - withMempoolSem :: m (Either (txid,tx) (txid, tx)) -> m (Either (txid,tx) (txid,tx)) - withMempoolSem a = + submitTxToMempool :: Tracer m (TraceTxSubmissionInbound txid tx) -> txid -> tx -> m () + submitTxToMempool txTracer txid tx = bracket_ (atomically $ waitTSem mempoolSem) (atomically $ signalTSem mempoolSem) - (do - r <- a - now <- getMonotonicTime - atomically $ modifyTVar sharedStateVar (updateBufferedTx now r) - return r - ) + $ do + res <- addTx + now <- getMonotonicTime + atomically $ modifyTVar sharedStateVar (updateBufferedTx now res) 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 + !start <- getMonotonicTime + acceptedTxs <- mempoolAddTxs [tx] + !end <- getMonotonicTime + let duration = diffTime end start + + traceWith txTracer $ + TraceTxInboundAddedToMempool acceptedTxs duration + 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 - -> Either (txid, tx) (txid, tx) + -> TxMempoolResult -> SharedTxState peeraddr txid tx -> SharedTxState peeraddr txid tx - updateBufferedTx _ (Left (txid,_tx)) st@SharedTxState { peerTxStates - , limboTxs } = + updateBufferedTx _ TxRejected st@SharedTxState { peerTxStates + , limboTxs } = st { peerTxStates = peerTxStates' , limboTxs = limboTxs' } where @@ -283,7 +321,7 @@ withPeer tracer where fn ps = Just $! ps { toMempoolTxs = Map.delete txid (toMempoolTxs ps)} - updateBufferedTx now (Right (txid, tx)) + updateBufferedTx now TxAccepted st@SharedTxState { peerTxStates , bufferedTxs , referenceCounts @@ -339,6 +377,10 @@ withPeer tracer 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 diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs index bcfbe2417e7..e06f1cc9c24 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs @@ -16,7 +16,6 @@ import Data.Set qualified as Set import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI import Control.Tracer (Tracer, traceWith) import Network.TypedProtocol @@ -25,7 +24,6 @@ import Control.Monad (unless, when) import Ouroboros.Network.Protocol.TxSubmission2.Server import Ouroboros.Network.TxSubmission.Inbound.Registry (PeerTxAPI (..)) import Ouroboros.Network.TxSubmission.Inbound.Types -import Ouroboros.Network.TxSubmission.Mempool.Reader -- | Flag to enable/disable the usage of the new tx submission protocol -- @@ -45,29 +43,20 @@ txSubmissionInboundV2 :: forall txid tx idx m. ( MonadSTM m , MonadThrow m - , MonadMonotonicTime m , Ord txid ) => Tracer m (TraceTxSubmissionInbound txid tx) - -> TxSubmissionMempoolReader txid tx idx m -> TxSubmissionMempoolWriter txid tx idx m -> PeerTxAPI m txid tx -> TxSubmissionServerPipelined txid tx m () txSubmissionInboundV2 tracer - TxSubmissionMempoolReader{ - mempoolGetSnapshot - } - TxSubmissionMempoolWriter { - txId, - mempoolAddTxs - } + TxSubmissionMempoolWriter { txId } PeerTxAPI { readTxDecision, handleReceivedTxIds, handleReceivedTxs, - countRejectedTxs, - withMempoolSem + submitTxToMempool } = TxSubmissionServerPipelined serverIdle @@ -85,7 +74,7 @@ txSubmissionInboundV2 -- Only attempt to add TXs if we have some work to do when (collected > 0) $ do - mapM_ (withMempoolSem . addTx) listOfTxsToMempool + mapM_ (uncurry $ submitTxToMempool tracer) listOfTxsToMempool traceWith tracer $ TraceTxSubmissionCollected collected @@ -97,49 +86,6 @@ txSubmissionInboundV2 then serverReqTxIds Zero txd else serverReqTxs txd - addTx :: (txid,tx) -> m (Either (txid, tx) (txid, tx)) - addTx (txid,tx) = 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 tracer $ TraceTxSubmissionProcessed ProcessedTxCount { - ptxcAccepted = 0 - , ptxcRejected = 1 - , ptxcScore = s - } - return $ Left (txid, tx) - else do - !start <- getMonotonicTime - acceptedTxs <- mempoolAddTxs [tx] - !end <- getMonotonicTime - let duration = diffTime end start - - traceWith tracer $ - TraceTxInboundAddedToMempool acceptedTxs duration - if null acceptedTxs - then do - !s <- countRejectedTxs end 1 - traceWith tracer $ TraceTxSubmissionProcessed ProcessedTxCount { - ptxcAccepted = 0 - , ptxcRejected = 1 - , ptxcScore = s - } - return $ Left (txid, tx) - else do - !s <- countRejectedTxs end 0 - traceWith tracer $ TraceTxSubmissionProcessed ProcessedTxCount { - ptxcAccepted = 1 - , ptxcRejected = 0 - , ptxcScore = s - } - return $ Right (txid, tx) - -- Pipelined request of txs serverReqTxs :: TxDecision txid tx -> m (ServerStIdle Z txid tx m ()) 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 6926ddb8ef3..7e44f3975ea 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -708,11 +708,11 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node aaTxDecisionPolicy sharedTxStateVar (getMempoolReader mempool) + (getMempoolWriter mempool) getTxSize them $ \api -> do let server = txSubmissionInboundV2 txSubmissionInboundTracer - (getMempoolReader mempool) (getMempoolWriter mempool) api labelThisThread "TxSubmissionServer" diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs index 870a81b3a36..108ab48f6b8 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs @@ -220,10 +220,10 @@ runTxSubmission tracer tracerTxLogic state txDecisionPolicy = do txDecisionPolicy sharedTxStateVar (getMempoolReader inboundMempool) + (getMempoolWriter inboundMempool) getTxSize addr $ \api -> do let server = txSubmissionInboundV2 verboseTracer - (getMempoolReader inboundMempool) (getMempoolWriter inboundMempool) api runPipelinedPeerWithLimits From b9f806bb53a50467fd164a8b751bd48b9296fb75 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 17 Mar 2025 09:24:35 +0100 Subject: [PATCH 36/54] tx-submission: renamed inbound modules --- ouroboros-network/ouroboros-network.cabal | 14 +++++++------- .../Ouroboros/Network/Diffusion/Configuration.hs | 2 +- .../src/Ouroboros/Network/NodeToNode.hs | 2 +- .../TxSubmission/{Inbound.hs => Inbound/V1.hs} | 4 ++-- .../TxSubmission/Inbound/{Server.hs => V2.hs} | 6 +++--- .../TxSubmission/Inbound/{ => V2}/Decision.hs | 8 ++++---- .../TxSubmission/Inbound/{ => V2}/Policy.hs | 2 +- .../TxSubmission/Inbound/{ => V2}/Registry.hs | 10 +++++----- .../Network/TxSubmission/Inbound/{ => V2}/State.hs | 6 +++--- .../Network/TxSubmission/Inbound/{ => V2}/Types.hs | 13 +++++++------ .../Test/Ouroboros/Network/Diffusion/Node.hs | 6 +++--- .../Ouroboros/Network/Diffusion/Node/Kernel.hs | 2 +- .../Network/Diffusion/Node/MiniProtocols.hs | 8 ++++---- .../Ouroboros/Network/Diffusion/Testnet/Cardano.hs | 8 ++++---- .../Diffusion/Testnet/Cardano/Simulation.hs | 4 ++-- .../Test/Ouroboros/Network/TxSubmission/AppV1.hs | 2 +- .../Test/Ouroboros/Network/TxSubmission/AppV2.hs | 8 ++++---- .../Test/Ouroboros/Network/TxSubmission/TxLogic.hs | 14 ++++++-------- .../Test/Ouroboros/Network/TxSubmission/Types.hs | 2 +- scripts/ci/check-stylish-ignore | 5 ++--- 20 files changed, 62 insertions(+), 64 deletions(-) rename ouroboros-network/src/Ouroboros/Network/TxSubmission/{Inbound.hs => Inbound/V1.hs} (99%) rename ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/{Server.hs => V2.hs} (97%) rename ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/{ => V2}/Decision.hs (98%) rename ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/{ => V2}/Policy.hs (97%) rename ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/{ => V2}/Registry.hs (98%) rename ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/{ => V2}/State.hs (99%) rename ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/{ => V2}/Types.hs (98%) diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 679b44417c8..3402e6af48d 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -96,13 +96,13 @@ library Ouroboros.Network.PeerSelection.State.LocalRootPeers Ouroboros.Network.PeerSelection.Types Ouroboros.Network.PeerSharing - Ouroboros.Network.TxSubmission.Inbound - Ouroboros.Network.TxSubmission.Inbound.Decision - Ouroboros.Network.TxSubmission.Inbound.Policy - Ouroboros.Network.TxSubmission.Inbound.Registry - Ouroboros.Network.TxSubmission.Inbound.Server - Ouroboros.Network.TxSubmission.Inbound.State - Ouroboros.Network.TxSubmission.Inbound.Types + Ouroboros.Network.TxSubmission.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 diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs index c98b13d3cad..9c1a55ac3b7 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs @@ -58,7 +58,7 @@ 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.Server +import Ouroboros.Network.TxSubmission.Inbound.V2 (EnableNewTxSubmissionProtocol (..)) -- |Outbound governor targets diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index 437ad682058..8d26852d8e3 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -103,7 +103,7 @@ import Ouroboros.Network.Server.RateLimiting import Ouroboros.Network.SizeInBytes import Ouroboros.Network.Snocket import Ouroboros.Network.Socket -import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy (..), +import Ouroboros.Network.TxSubmission.Inbound.V2.Policy (TxDecisionPolicy (..), defaultTxDecisionPolicy, max_TX_SIZE) import Ouroboros.Network.Util.ShowProxy (ShowProxy, showProxy) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V1.hs similarity index 99% rename from ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs rename to ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V1.hs index 33a84921048..999dac46b3c 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V1.hs @@ -9,7 +9,7 @@ {-# OPTIONS_GHC -Wno-partial-fields #-} -module Ouroboros.Network.TxSubmission.Inbound +module Ouroboros.Network.TxSubmission.Inbound.V1 ( txSubmissionInbound , TxSubmissionMempoolWriter (..) , TraceTxSubmissionInbound (..) @@ -46,7 +46,7 @@ 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.Types (ProcessedTxCount (..), +import Ouroboros.Network.TxSubmission.Inbound.V2.Types (ProcessedTxCount (..), TraceTxSubmissionInbound (..), TxSubmissionMempoolWriter (..), TxSubmissionProtocolError (..)) import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..), diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs similarity index 97% rename from ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs rename to ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs index e06f1cc9c24..0d508d0d46c 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs @@ -6,7 +6,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} -module Ouroboros.Network.TxSubmission.Inbound.Server where +module Ouroboros.Network.TxSubmission.Inbound.V2 where import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map @@ -22,8 +22,8 @@ import Network.TypedProtocol import Control.Monad (unless, when) import Ouroboros.Network.Protocol.TxSubmission2.Server -import Ouroboros.Network.TxSubmission.Inbound.Registry (PeerTxAPI (..)) -import Ouroboros.Network.TxSubmission.Inbound.Types +import Ouroboros.Network.TxSubmission.Inbound.V2.Registry (PeerTxAPI (..)) +import Ouroboros.Network.TxSubmission.Inbound.V2.Types -- | Flag to enable/disable the usage of the new tx submission protocol -- diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs similarity index 98% rename from ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs rename to ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs index 8ee315c24aa..0231794f351 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -module Ouroboros.Network.TxSubmission.Inbound.Decision +module Ouroboros.Network.TxSubmission.Inbound.V2.Decision ( TxDecision (..) , emptyTxDecision -- * Internal API exposed for testing @@ -35,9 +35,9 @@ import Data.Sequence.Strict qualified as StrictSeq import Ouroboros.Network.DeltaQ (PeerGSV (..), defaultGSV, gsvRequestResponseDuration) import Ouroboros.Network.Protocol.TxSubmission2.Type -import Ouroboros.Network.TxSubmission.Inbound.Policy -import Ouroboros.Network.TxSubmission.Inbound.State -import Ouroboros.Network.TxSubmission.Inbound.Types +import Ouroboros.Network.TxSubmission.Inbound.V2.Policy +import Ouroboros.Network.TxSubmission.Inbound.V2.State +import Ouroboros.Network.TxSubmission.Inbound.V2.Types -- | Make download decisions. diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Policy.hs similarity index 97% rename from ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs rename to ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Policy.hs index eea465b7969..ce6ea378535 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Policy.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NumericUnderscores #-} -module Ouroboros.Network.TxSubmission.Inbound.Policy +module Ouroboros.Network.TxSubmission.Inbound.V2.Policy ( TxDecisionPolicy (..) , defaultTxDecisionPolicy , max_TX_SIZE diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs similarity index 98% rename from ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs rename to ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs index 9befe8c9595..4590c798a50 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs @@ -5,7 +5,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} -module Ouroboros.Network.TxSubmission.Inbound.Registry +module Ouroboros.Network.TxSubmission.Inbound.V2.Registry ( TxChannels (..) , TxChannelsVar , TxMempoolSem @@ -45,10 +45,10 @@ import Data.Void (Void) import Control.Tracer (Tracer, traceWith) import Ouroboros.Network.DeltaQ (PeerGSV (..)) import Ouroboros.Network.Protocol.TxSubmission2.Type -import Ouroboros.Network.TxSubmission.Inbound.Decision -import Ouroboros.Network.TxSubmission.Inbound.Policy -import Ouroboros.Network.TxSubmission.Inbound.State -import Ouroboros.Network.TxSubmission.Inbound.Types +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 diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs similarity index 99% rename from ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs rename to ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs index ae4883afabe..ae2d3386a45 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs @@ -5,7 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -module Ouroboros.Network.TxSubmission.Inbound.State +module Ouroboros.Network.TxSubmission.Inbound.V2.State ( -- * Core API SharedTxState (..) , PeerTxState (..) @@ -48,8 +48,8 @@ import GHC.Stack (HasCallStack) import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..), NumTxIdsToReq (..)) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) -import Ouroboros.Network.TxSubmission.Inbound.Policy -import Ouroboros.Network.TxSubmission.Inbound.Types +import Ouroboros.Network.TxSubmission.Inbound.V2.Policy +import Ouroboros.Network.TxSubmission.Inbound.V2.Types import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..)) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs similarity index 98% rename from ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs rename to ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs index 1de86182499..53929a8b776 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs @@ -6,7 +6,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} -module Ouroboros.Network.TxSubmission.Inbound.Types +module Ouroboros.Network.TxSubmission.Inbound.V2.Types ( -- * PeerTxState PeerTxState (..) -- * SharedTxState @@ -16,14 +16,15 @@ module Ouroboros.Network.TxSubmission.Inbound.Types , TxDecision (..) , emptyTxDecision , SharedDecisionContext (..) - -- * Various + , TraceTxLogic (..) + -- * Types shared with V1 + -- ** Various , ProcessedTxCount (..) - -- * Mempool API + -- ** Mempool API , TxSubmissionMempoolWriter (..) - -- * Traces + -- ** Traces , TraceTxSubmissionInbound (..) - , TraceTxLogic (..) - -- * Protocol Error + -- ** Protocol Error , TxSubmissionProtocolError (..) ) where diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs index 6373b797b4b..af427eea7be 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -113,9 +113,9 @@ import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) import Ouroboros.Network.Snocket (MakeBearer, Snocket, TestAddress (..), invalidFileDescriptor) -import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy) -import Ouroboros.Network.TxSubmission.Inbound.Registry (decisionLogicThread) -import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxLogic, +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) 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 d37c21b4e56..35ca401f414 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs @@ -80,7 +80,7 @@ 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 Ouroboros.Network.TxSubmission.Inbound.Registry (SharedTxStateVar, +import Ouroboros.Network.TxSubmission.Inbound.V2.Registry (SharedTxStateVar, TxChannels (..), TxChannelsVar, TxMempoolSem, newSharedTxStateVar, newTxMempoolSem) import Test.Ouroboros.Network.Diffusion.Node.ChainDB (ChainDB (..)) 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 7e44f3975ea..15789d730c4 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -101,11 +101,11 @@ import Ouroboros.Network.Protocol.TxSubmission2.Server import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..), NumTxIdsToReq (..), TxSubmission2) import Ouroboros.Network.RethrowPolicy -import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy (..)) -import Ouroboros.Network.TxSubmission.Inbound.Registry (SharedTxStateVar, +import Ouroboros.Network.TxSubmission.Inbound.V2 (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.Server (txSubmissionInboundV2) -import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxLogic, +import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TraceTxLogic, TraceTxSubmissionInbound) import Ouroboros.Network.TxSubmission.Outbound (txSubmissionOutbound) import Ouroboros.Network.Util.ShowProxy 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 db0927eec31..b52df8049f2 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -84,10 +84,10 @@ 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.Policy (defaultTxDecisionPolicy, - txInflightMultiplicity) -import Ouroboros.Network.TxSubmission.Inbound.State (inflightTxs) -import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxLogic (..), +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 (..)) 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 3f1ef97132e..f4b49a73be6 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 @@ -131,8 +131,8 @@ 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.Policy (TxDecisionPolicy) -import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxLogic, +import Ouroboros.Network.TxSubmission.Inbound.V2.Policy (TxDecisionPolicy) +import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TraceTxLogic, TraceTxSubmissionInbound) import Ouroboros.Network.Mock.ConcreteBlock (Block (..), BlockHeader (..)) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV1.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV1.hs index abeff672ee6..2f9a9f48817 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV1.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV1.hs @@ -40,7 +40,7 @@ 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.Inbound.V1 import Ouroboros.Network.TxSubmission.Outbound import Ouroboros.Network.Util.ShowProxy diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs index 108ab48f6b8..ab224ce569d 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs @@ -51,10 +51,10 @@ import Ouroboros.Network.Protocol.TxSubmission2.Client import Ouroboros.Network.Protocol.TxSubmission2.Codec import Ouroboros.Network.Protocol.TxSubmission2.Server import Ouroboros.Network.Protocol.TxSubmission2.Type -import Ouroboros.Network.TxSubmission.Inbound.Policy -import Ouroboros.Network.TxSubmission.Inbound.Registry -import Ouroboros.Network.TxSubmission.Inbound.Server (txSubmissionInboundV2) -import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxLogic) +import Ouroboros.Network.TxSubmission.Inbound.V2 (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 diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs index 4d6248ed6d4..f9f03a55e7d 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs @@ -2,7 +2,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -12,7 +11,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -45,14 +43,14 @@ import System.Random (mkStdGen, StdGen) import NoThunks.Class import Ouroboros.Network.Protocol.TxSubmission2.Type -import Ouroboros.Network.TxSubmission.Inbound.Decision +import Ouroboros.Network.TxSubmission.Inbound.V2.Decision (SharedDecisionContext (..), TxDecision (..)) -import Ouroboros.Network.TxSubmission.Inbound.Decision qualified as TXS -import Ouroboros.Network.TxSubmission.Inbound.Policy -import Ouroboros.Network.TxSubmission.Inbound.State (PeerTxState (..), +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.State qualified as TXS -import Ouroboros.Network.TxSubmission.Inbound.Types qualified as TXS +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 diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs index 6c09b2c10b5..06c622254fb 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs @@ -46,7 +46,7 @@ import Network.TypedProtocol.Codec import Ouroboros.Network.Protocol.TxSubmission2.Codec import Ouroboros.Network.Protocol.TxSubmission2.Type -import Ouroboros.Network.TxSubmission.Inbound +import Ouroboros.Network.TxSubmission.Inbound.V1 import Ouroboros.Network.TxSubmission.Mempool.Reader import Ouroboros.Network.Util.ShowProxy diff --git a/scripts/ci/check-stylish-ignore b/scripts/ci/check-stylish-ignore index 509dba3a0c9..4401285dfaf 100644 --- a/scripts/ci/check-stylish-ignore +++ b/scripts/ci/check-stylish-ignore @@ -2,11 +2,10 @@ 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/TxSubmission/Inbound/State.hs +ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs +ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/TxLogic.hs ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs -ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs -ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs ouroboros-network/testlib/Test/Ouroboros/Network/Testnet.hs ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs network-mux/src/Network/Mux/TCPInfo.hs From 52a2fe40f447cdbd512231e051ba202946ee13e8 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 18 Mar 2025 12:05:44 +0100 Subject: [PATCH 37/54] tx-submission: use splitLookup to combine split & lookup --- .../Network/TxSubmission/Inbound/V2/State.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs index ae2d3386a45..e91b177df8e 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs @@ -238,11 +238,13 @@ tickTimedTxs :: forall peeraddr tx txid. tickTimedTxs now st@SharedTxState{ timedTxs , referenceCounts , bufferedTxs } = - let (expiredTxs, timedTxs') = Map.split now timedTxs - expiredTxs' = -- Map.split doesn't include the `now` entry in any map - case Map.lookup now timedTxs of - Just txids -> Map.insert now txids expiredTxs - Nothing -> expiredTxs + 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' From 5c81093d049b555ab7d8da43e394d24603c380e4 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 24 Mar 2025 07:25:18 +0100 Subject: [PATCH 38/54] tx-submission: TxSubmisionLogicVersion type Renamed the `EnableNewTxSubmissionProtocol` type to `TxSubmissionLogicVersion` and moved it to `V2.Types` --- .../Ouroboros/Network/Diffusion/Configuration.hs | 13 ++++++++----- .../Ouroboros/Network/TxSubmission/Inbound/V2.hs | 7 ------- .../Network/TxSubmission/Inbound/V2/Types.hs | 10 ++++++++++ 3 files changed, 18 insertions(+), 12 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs index 9c1a55ac3b7..d53fc2adc7c 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs @@ -11,7 +11,7 @@ module Ouroboros.Network.Diffusion.Configuration , defaultDeadlineTargets , defaultDeadlineChurnInterval , defaultBulkChurnInterval - , defaultEnableNewTxSubmissionProtocol + , defaultTxSubmissionLogicVersion -- re-exports , AcceptedConnectionsLimit (..) , BlockFetchConfiguration (..) @@ -21,6 +21,7 @@ module Ouroboros.Network.Diffusion.Configuration , PeerSelectionTargets (..) , PeerSharing (..) , ConsensusMode (..) + , TxSubmissionLogicVersion (..) , defaultConsensusMode , defaultMiniProtocolParameters , deactivateTimeout @@ -58,8 +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 - (EnableNewTxSubmissionProtocol (..)) +import Ouroboros.Network.TxSubmission.Inbound.V2.Types + (TxSubmissionLogicVersion (..)) -- |Outbound governor targets -- Targets may vary depending on whether a node is operating in @@ -153,5 +154,7 @@ local_PROTOCOL_IDLE_TIMEOUT = 2 -- 2 seconds local_TIME_WAIT_TIMEOUT :: DiffTime local_TIME_WAIT_TIMEOUT = 0 -defaultEnableNewTxSubmissionProtocol :: EnableNewTxSubmissionProtocol -defaultEnableNewTxSubmissionProtocol = DisableNewTxSubmissionProtocol +-- | 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/TxSubmission/Inbound/V2.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs index 0d508d0d46c..f2ba7ec2c41 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs @@ -25,13 +25,6 @@ import Ouroboros.Network.Protocol.TxSubmission2.Server import Ouroboros.Network.TxSubmission.Inbound.V2.Registry (PeerTxAPI (..)) import Ouroboros.Network.TxSubmission.Inbound.V2.Types --- | Flag to enable/disable the usage of the new tx submission protocol --- -data EnableNewTxSubmissionProtocol = - EnableNewTxSubmissionProtocol - | DisableNewTxSubmissionProtocol - deriving (Eq, Show) - -- | A tx-submission outbound side (server, sic!). -- -- The server blocks on receiving `TxDecision` from the decision logic. If diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs index 53929a8b776..f16e952e92f 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs @@ -20,6 +20,7 @@ module Ouroboros.Network.TxSubmission.Inbound.V2.Types -- * Types shared with V1 -- ** Various , ProcessedTxCount (..) + , TxSubmissionLogicVersion (..) -- ** Mempool API , TxSubmissionMempoolWriter (..) -- ** Traces @@ -42,6 +43,15 @@ 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 -- From 38000634bc4f088872506bbd97f3ce5aa8fc576b Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 24 Mar 2025 17:12:58 +0100 Subject: [PATCH 39/54] tx-submission: added export list in the Inbound.V2 module Export all functions & supporting types. --- .../Network/TxSubmission/Inbound/V2.hs | 26 ++++++++++++++++--- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs index f2ba7ec2c41..4bf4cdc3509 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs @@ -6,7 +6,23 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} -module Ouroboros.Network.TxSubmission.Inbound.V2 where +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 @@ -22,10 +38,12 @@ import Network.TypedProtocol import Control.Monad (unless, when) import Ouroboros.Network.Protocol.TxSubmission2.Server -import Ouroboros.Network.TxSubmission.Inbound.V2.Registry (PeerTxAPI (..)) -import Ouroboros.Network.TxSubmission.Inbound.V2.Types +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 outbound side (server, sic!). +-- | 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 From 9b546d917fcf94498de4a5309e53f7ba1a9c4130 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 24 Mar 2025 17:13:45 +0100 Subject: [PATCH 40/54] tx-submission: support the txsubmission-delay cabal flag The flag enables an initial 60s delay on the inbound side in the same way as for in the V1 version. --- .../Network/TxSubmission/Inbound/V2.hs | 17 +++++++++++++---- .../Network/Diffusion/Node/MiniProtocols.hs | 1 + 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs index 4bf4cdc3509..21db23e0171 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} @@ -26,17 +27,19 @@ module Ouroboros.Network.TxSubmission.Inbound.V2 import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) import Data.Sequence.Strict qualified as StrictSeq import Data.Set qualified as Set -import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) +import Control.Monad (unless, when) import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, traceWith) import Network.TypedProtocol -import Control.Monad (unless, when) +import Ouroboros.Network.Protocol.Limits (longWait) import Ouroboros.Network.Protocol.TxSubmission2.Server import Ouroboros.Network.TxSubmission.Inbound.V2.Policy import Ouroboros.Network.TxSubmission.Inbound.V2.Registry @@ -52,7 +55,7 @@ import Ouroboros.Network.TxSubmission.Inbound.V2.Types as V2 -- txSubmissionInboundV2 :: forall txid tx idx m. - ( MonadSTM m + ( MonadDelay m , MonadThrow m , Ord txid ) @@ -70,7 +73,13 @@ txSubmissionInboundV2 submitTxToMempool } = - TxSubmissionServerPipelined serverIdle + 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 + serverIdle where serverIdle :: m (ServerStIdle Z txid tx m ()) 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 15789d730c4..26dac01da24 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -245,6 +245,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 From bd2ec26ed27625727b5542eb080fd73f74fa2fad Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 31 Mar 2025 18:16:06 +0200 Subject: [PATCH 41/54] Compilation with ghc >= 9.10 without CPPs --- .../TxSubmission/Inbound/V2/Registry.hs | 32 +++++++++---------- .../Network/TxSubmission/Inbound/V2/State.hs | 27 ++++++++-------- .../Network/TxSubmission/Inbound/V2/Types.hs | 3 +- .../Network/Diffusion/Testnet/Cardano.hs | 8 ++--- .../Ouroboros/Network/TxSubmission/TxLogic.hs | 26 ++++++--------- scripts/ci/check-stylish-ignore | 6 ---- 6 files changed, 45 insertions(+), 57 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs index 4590c798a50..8624219ab68 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} @@ -24,14 +23,10 @@ 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.MonadTimer.SI import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI -import Data.Foldable (traverse_ -#if !MIN_VERSION_base(4,20,0) - , foldl' -#endif - ) +import Data.Foldable as Foldable (foldl', traverse_) import Data.Hashable import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map @@ -40,6 +35,7 @@ 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) @@ -109,6 +105,7 @@ withPeer , MonadMonotonicTime m , Ord txid , Show txid + , Typeable txid , Ord peeraddr , Show peeraddr ) @@ -217,10 +214,12 @@ withPeer tracer peerTxStates referenceCounts' = - foldl' (flip $ Map.update - \cnt -> if cnt > 1 - then Just $! pred cnt - else Nothing) + Foldable.foldl' + (flip $ Map.update \cnt -> + if cnt > 1 + then Just $! pred cnt + else Nothing + ) referenceCounts unacknowledgedTxIds @@ -230,16 +229,17 @@ withPeer tracer `Map.restrictKeys` liveSet - inflightTxs' = foldl' purgeInflightTxs inflightTxs requestedTxsInflight + 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' = - foldl' (flip $ Map.update - \cnt -> if cnt > 1 - then Just $! pred cnt - else Nothing) + Foldable.foldl' (flip $ Map.update \cnt -> + if cnt > 1 + then Just $! pred cnt + else Nothing + ) limboTxs (Map.keysSet toMempoolTxs) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs index e91b177df8e..abe1b467771 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -24,15 +23,12 @@ module Ouroboros.Network.TxSubmission.Inbound.V2.State ) where import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadTime.SI import Control.Exception (assert) +import Control.Monad.Class.MonadTime.SI import Control.Tracer (Tracer, traceWith) -import Data.Foldable (fold, -#if !MIN_VERSION_base(4,20,0) - foldl', -#endif - toList) +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) @@ -42,6 +38,7 @@ 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) @@ -258,7 +255,7 @@ tickTimedTxs now st@SharedTxState{ timedTxs fn :: Map txid Int -> [txid] -> Map txid Int - fn m txids = foldl' gn m txids + fn m txids = Foldable.foldl' gn m txids gn :: Map txid Int -> txid @@ -353,11 +350,12 @@ receivedTxIdsImpl <> Map.map (const Nothing) ignoredTxIds referenceCounts' = - foldl' (flip $ Map.alter (\case - Nothing -> Just $! 1 - Just cnt -> Just $! succ cnt)) - referenceCounts - txidsSeq + Foldable.foldl' + (flip $ Map.alter (\case + Nothing -> Just $! 1 + Just cnt -> Just $! succ cnt)) + referenceCounts + txidsSeq st' = st { bufferedTxs = bufferedTxs', referenceCounts = referenceCounts' } @@ -372,6 +370,7 @@ collectTxsImpl ( Ord peeraddr , Ord txid , Show txid + , Typeable txid ) => (tx -> SizeInBytes) -- ^ compute tx size -> peeraddr @@ -547,7 +546,7 @@ receivedTxIds tracer sharedVar getMempoolSnapshot peeraddr reqNo txidsSeq txidsM collectTxs :: forall m peeraddr tx txid. (MonadSTM m, Ord txid, Ord peeraddr, - Show txid) + Show txid, Typeable txid) => Tracer m (TraceTxLogic peeraddr txid tx) -> (tx -> SizeInBytes) -> SharedTxStateVar m peeraddr txid tx diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs index f16e952e92f..0aee79f74b5 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs @@ -35,6 +35,7 @@ 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) @@ -384,7 +385,7 @@ data TraceTxSubmissionInbound txid tx = data TxSubmissionProtocolError = ProtocolErrorTxNotRequested | ProtocolErrorTxIdsNotRequested - | forall txid. (Show txid) + | 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. 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 b52df8049f2..4a151b644e7 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -29,7 +29,7 @@ import Data.Char (ord) import Data.Dynamic (fromDynamic) import Data.Foldable (fold, foldr') import Data.IP qualified as IP -import Data.List (foldl', intercalate, sort) +import Data.List (intercalate, sort) import Data.List qualified as List import Data.List.Trace qualified as Trace import Data.Map (Map) @@ -951,9 +951,9 @@ unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) where -- We need to make sure the transactions are unique, this simplifies -- things. - uniqueTxsA = map (\(t, i) -> t { getTxId = (foldl' (+) 0 $ map ord "0.0.0.0") + i }) + uniqueTxsA = map (\(t, i) -> t { getTxId = List.foldl' (+) 0 (map ord "0.0.0.0") + i }) (zip txsA [0 :: Int ..]) - uniqueTxsB = map (\(t, i) -> t { getTxId = (foldl' (+) 0 $ map ord "0.0.0.1") + i }) + uniqueTxsB = map (\(t, i) -> t { getTxId = List.foldl' (+) 0 (map ord "0.0.0.1") + i }) (zip txsB [100 :: Int ..]) -- This checks the property that after running the simulation for a while @@ -975,7 +975,7 @@ unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) sortedAcceptedTxidsMap :: Map NtNAddr [Int] sortedAcceptedTxidsMap = foldr (\l r -> - foldl' (\rr (WithName n (WithTime _ x)) -> + List.foldl' (\rr (WithName n (WithTime _ x)) -> case x of -- When we add txids to the mempool, we collect them -- into the map diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs index f9f03a55e7d..d8fc68966bd 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs @@ -1,6 +1,5 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} @@ -18,15 +17,10 @@ module Test.Ouroboros.Network.TxSubmission.TxLogic where import Prelude hiding (seq) -import Control.Monad.Class.MonadTime.SI (Time (..)) import Control.Exception (assert) +import Control.Monad.Class.MonadTime.SI (Time (..)) -import Data.Foldable ( - fold, -#if !MIN_VERSION_base(4,20,0) - foldl', -#endif - toList) +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 @@ -38,7 +32,7 @@ import Data.Sequence.Strict qualified as StrictSeq import Data.Set (Set) import Data.Set qualified as Set import Data.Typeable -import System.Random (mkStdGen, StdGen) +import System.Random (StdGen, mkStdGen) import NoThunks.Class @@ -151,9 +145,9 @@ sharedTxStateInvariant SharedTxState { .&&. counterexample "referenceCounts invariant violation" ( referenceCounts === - foldl' + Foldable.foldl' (\m PeerTxState { unacknowledgedTxIds = unacked } -> - foldl' + Foldable.foldl' (flip $ Map.alter (\case Nothing -> Just $! 1 @@ -411,7 +405,7 @@ genSharedTxState maxTxIdsInflight = do | (peeraddr, ArbPeerTxState { arbPeerTxState }) <- pss' ], - inflightTxs = foldl' (Map.unionWith (+)) Map.empty + inflightTxs = Foldable.foldl' (Map.unionWith (+)) Map.empty [ Map.fromSet (const 1) (Set.map getTxId arbInflightSet) | ArbPeerTxState { arbInflightSet } <- pss @@ -483,9 +477,9 @@ fixupSharedTxState _mempoolHasTx st@SharedTxState { peerTxStates } = referenceCounts' = - foldl' + Foldable.foldl' (\m PeerTxState { unacknowledgedTxIds } -> - foldl' + Foldable.foldl' (flip $ Map.alter (\case Nothing -> Just $! 1 @@ -1526,7 +1520,7 @@ instance Arbitrary ArbDecisionContextWithReceivedTxIds where peers = Map.keys (peerTxStates st') downTxsNum <- choose (0, length txIdsToAck') - let downloadedTxs = foldl' pruneTx Map.empty $ take downTxsNum $ Map.toList (bufferedTxs st') + let downloadedTxs = Foldable.foldl' pruneTx Map.empty $ take downTxsNum $ Map.toList (bufferedTxs st') ps'' = ps' { downloadedTxs = downloadedTxs } gsvs <- zip peers @@ -1545,7 +1539,7 @@ instance Arbitrary ArbDecisionContextWithReceivedTxIds where } where pruneTx :: Map TxId tx -> (TxId, Maybe tx) -> Map TxId tx - pruneTx m (_, Nothing) = m + pruneTx m (_, Nothing) = m pruneTx m (txid, Just tx) = Map.insert txid tx m shrink ArbDecisionContextWithReceivedTxIds { diff --git a/scripts/ci/check-stylish-ignore b/scripts/ci/check-stylish-ignore index 4401285dfaf..af52d6153d3 100644 --- a/scripts/ci/check-stylish-ignore +++ b/scripts/ci/check-stylish-ignore @@ -1,13 +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/TxSubmission/Inbound/V2/State.hs -ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs -ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/TxLogic.hs ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs -ouroboros-network/testlib/Test/Ouroboros/Network/Testnet.hs -ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs network-mux/src/Network/Mux/TCPInfo.hs network-mux/src/Network/Mux/Bearer.hs network-mux/src/Network/Mux/Bearer/Pipe.hs From 0998e88deb3cfc817128a2e68bcaabf0cf6b9773 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 11 Apr 2025 17:26:51 +0200 Subject: [PATCH 42/54] mux: haddock improvements --- network-mux/src/Network/Mux/Bearer/Socket.hs | 2 +- network-mux/src/Network/Mux/Codec.hs | 13 +++++++++++-- 2 files changed, 12 insertions(+), 3 deletions(-) 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 From c4d711984f649555080bc539c28e0094907da0c6 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 25 Mar 2025 13:56:07 +0100 Subject: [PATCH 43/54] net-sim: do not render saTxDecisionPolicy field of SimArgs in test coverage --- .../Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs | 2 +- .../Network/Diffusion/Testnet/Cardano/Simulation.hs | 8 ++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) 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 4a151b644e7..ffbb4158e75 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -5297,7 +5297,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 f4b49a73be6..5fd8610b946 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 (..) @@ -172,6 +173,13 @@ data SimArgs = -- ^ 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, saTxDecisionPolicy } = unwords [ "SimArgs" From 1ab2f13d0586a45327ce9593e7b662ab23dcf5b5 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 30 Apr 2025 16:30:18 +0200 Subject: [PATCH 44/54] net-sim: improved tracing --- .../src/Test/Ouroboros/Network/Utils.hs | 10 +++- .../Test/Ouroboros/Network/Diffusion/Node.hs | 8 +-- .../Network/Diffusion/Node/Kernel.hs | 15 ++++++ .../Network/Diffusion/Node/MiniProtocols.hs | 51 +++++++++++-------- .../Diffusion/Testnet/Cardano/Simulation.hs | 47 ++++++++++++----- 5 files changed, 92 insertions(+), 39 deletions(-) diff --git a/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs b/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs index 119b3def13e..c7566fb308a 100644 --- a/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs +++ b/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs @@ -167,13 +167,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/testlib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs index af427eea7be..f2db82f6132 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -45,12 +45,11 @@ import Control.Monad.Class.MonadAsync (MonadAsync (wait, withAsync)) import Control.Monad.Class.MonadFork (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) @@ -271,6 +269,8 @@ run blockGeneratorArgs limits ni na toExtraPeers requestPublicRootPeers peerChurnGovernor tracers tracerBlockFetch tracerTxSubmissionInbound tracerTxLogic = + handle (\(e :: SomeException) -> traceWith (aDebugTracer na) ("Unhandled exception: " ++ show e) + >> throwIO e) $ do Node.withNodeKernelThread blockGeneratorArgs (aTxs na) $ \ nodeKernel nodeKernelThread -> do dnsTimeoutScriptVar <- newTVarIO (aDNSTimeoutScript na) 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 35ca401f414..87914c2b775 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 @@ -60,6 +62,7 @@ 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 @@ -122,6 +125,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 @@ -142,6 +150,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 { 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 26dac01da24..547de039924 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -257,6 +257,7 @@ applications :: forall block header s m. , HasHeader header , HasHeader block , HeaderHash header ~ HeaderHash block + , Show header , Show block , ShowProxy block , ShowProxy header @@ -373,9 +374,9 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node InitiatorAndResponderProtocol (txSubmissionInitiator aaTxDecisionPolicy (nkMempool nodeKernel)) (txSubmissionResponder (nkMempool nodeKernel) - (nkTxChannelsVar nodeKernel) - (nkTxMempoolSem nodeKernel) - (nkSharedTxStateVar nodeKernel)) + (nkTxChannelsVar nodeKernel) + (nkTxMempoolSem nodeKernel) + (nkSharedTxStateVar nodeKernel)) } ] , withWarm = WithWarm @@ -461,7 +462,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node (\_ -> unregisterClientChains nodeKernel (remoteAddress connId)) (\chainVar -> runPeerWithLimits - nullTracer + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) chainSyncCodec (chainSyncSizeLimits limits) (chainSyncTimeLimits limits) @@ -474,10 +475,12 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node 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) @@ -491,7 +494,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node blockFetchInitiator = MiniProtocolCb $ \ ExpandedInitiatorContext { - eicConnectionId = ConnectionId { remoteAddress }, + eicConnectionId = connId@ConnectionId { remoteAddress }, eicControlMessage = controlMessageSTM } channel @@ -501,7 +504,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node remoteAddress $ \clientCtx -> runPeerWithLimits - nullTracer + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) blockFetchCodec (blockFetchSizeLimits limits) (blockFetchTimeLimits limits) @@ -513,10 +516,12 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node 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) @@ -545,7 +550,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node -> do labelThisThread "KeepAliveClient" let kacApp = \ctxVar -> runPeerWithLimits - ((show . (connId,)) `contramap` debugTracer) + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) keepAliveCodec (keepAliveSizeLimits limits) (keepAliveTimeLimits limits) @@ -564,10 +569,12 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node 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) @@ -610,7 +617,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node then return pingPongClient else return $ PingPong.SendMsgDone () in runPeerWithLimits - ((show . (connId,)) `contramap` debugTracer) + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) pingPongCodec (pingPongSizeLimits limits) (pingPongTimeLimits limits) @@ -622,7 +629,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node pingPongResponder = MiniProtocolCb $ \ResponderContext { rcConnectionId = connId } channel -> runPeerWithLimits - ((show . (connId,)) `contramap` debugTracer) + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) pingPongCodec (pingPongSizeLimits limits) (pingPongTimeLimits limits) @@ -644,7 +651,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node $ \controller -> do psClient <- peerSharingClient controlMessageSTM controller runPeerWithLimits - ((show . (connId,)) `contramap` debugTracer) + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) peerSharingCodec (peerSharingSizeLimits limits) (peerSharingTimeLimits limits) @@ -654,10 +661,12 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node 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) @@ -678,7 +687,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node channel -> do let client = txSubmissionOutbound - ((show . (connId,)) `contramap` debugTracer) + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) (NumTxIdsToAck $ getNumTxIdsToReq $ maxUnacknowledgedTxIds txDecisionPolicy) (getMempoolReader mempool) @@ -686,7 +695,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node controlMessageSTM labelThisThread "TxSubmissionClient" runPeerWithLimits - ((show . (connId,)) `contramap` debugTracer) + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) txSubmissionCodec (txSubmissionSizeLimits limits) (txSubmissionTimeLimits limits) @@ -718,7 +727,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node api labelThisThread "TxSubmissionServer" runPipelinedPeerWithLimits - ((show . (connId,)) `contramap` debugTracer) + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) txSubmissionCodec (txSubmissionSizeLimits limits) (txSubmissionTimeLimits limits) 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 5fd8610b946..29d4edd5ac2 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 @@ -28,6 +28,7 @@ module Test.Ouroboros.Network.Diffusion.Testnet.Cardano.Simulation , Command (..) -- * Tracing , DiffusionTestTrace (..) + , ppDiffusionTestTrace , iosimTracer -- * Re-exports , TestAddress (..) @@ -65,7 +66,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 @@ -144,7 +144,7 @@ import Test.Ouroboros.Network.Data.Script import Test.Ouroboros.Network.Diffusion.Node qualified as Node import Test.Ouroboros.Network.Diffusion.Node.Kernel (NtCAddr, NtCVersion, NtCVersionData, NtNAddr, NtNAddr_ (IPAddr), NtNVersion, - NtNVersionData) + 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 @@ -970,7 +970,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. @@ -1002,17 +1002,39 @@ data DiffusionTestTrace = | 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 @@ -1300,8 +1322,9 @@ 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 From 49c9d51c3bd099aa3775143b367177f6b57d002e Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 8 May 2025 18:51:10 +0200 Subject: [PATCH 45/54] net-sim: tune the mustReplyTimeout chain-sync timeout --- .../Diffusion/Testnet/Cardano/Simulation.hs | 40 +++++++++---------- 1 file changed, 20 insertions(+), 20 deletions(-) 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 29d4edd5ac2..2e57d0734fc 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 @@ -430,13 +430,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 txs = 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. -- @@ -450,19 +451,12 @@ genNodeArgs relays minConnected localRootPeers self txs = flip suchThat hasUpstr , (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 @@ -512,7 +506,7 @@ genNodeArgs relays minConnected localRootPeers self txs = flip suchThat hasUpstr $ 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`! @@ -690,7 +684,7 @@ genDiffusionScript genLocalRootPeers dnsMapScript <- genDomainMapScript relays txs <- makeUniqueIds 0 <$> vectorOf (length relays') (choose (10, 100) >>= \c -> vectorOf c arbitrary) - nodesWithCommands <- mapM go (zip relays' txs) + nodesWithCommands <- mapM (go simArgs) (zip relays' txs) return (simArgs, dnsMapScript, nodesWithCommands) where relays' = unTestnetRelays relays @@ -706,13 +700,13 @@ genDiffusionScript genLocalRootPeers , i + length l + 1 ) - go :: (TestnetRelayInfo, [Tx Int]) -> Gen (NodeArgs, [Command]) - go (relay, txs) = do + 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 relays' minConnected localRts relay txs + nodeArgs <- genNodeArgs simArgs relays' minConnected localRts relay txs commands <- genCommands localRts return (nodeArgs, commands) @@ -1218,6 +1212,12 @@ diffusionSimulation { Node.chainSyncLimits = defaultMiniProtocolsLimit , 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 (fromIntegral . BL.length) From 1a198158cd8867a81fbe74317c1700b3adea10f7 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 9 May 2025 10:15:49 +0200 Subject: [PATCH 46/54] net-sim: name some threads * `ctrl-` - the control thread (top level threads, e.g. [2], [3], etc..) * `node-` - the main node thread ([2,1], [3,1], etc) * `krnl-` - the kernel thread (block production) --- .../testlib/Test/Ouroboros/Network/Diffusion/Node.hs | 5 +++-- .../Test/Ouroboros/Network/Diffusion/Node/Kernel.hs | 11 ++++++++--- .../Network/Diffusion/Testnet/Cardano/Simulation.hs | 4 +++- 3 files changed, 14 insertions(+), 6 deletions(-) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs index f2db82f6132..f91c01f2ac2 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -42,7 +42,7 @@ 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 @@ -271,7 +271,8 @@ run blockGeneratorArgs limits ni na tracerTxLogic = handle (\(e :: SomeException) -> traceWith (aDebugTracer na) ("Unhandled exception: " ++ show e) >> throwIO e) $ do - Node.withNodeKernelThread blockGeneratorArgs (aTxs na) + labelThisThread ("node-" ++ Node.ppNtNAddr (aIPAddress na)) + Node.withNodeKernelThread (aIPAddress na) blockGeneratorArgs (aTxs na) $ \ nodeKernel nodeKernelThread -> do dnsTimeoutScriptVar <- newTVarIO (aDNSTimeoutScript na) dnsLookupDelayScriptVar <- newTVarIO (aDNSLookupDelayScript na) 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 87914c2b775..d003e0075f4 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs @@ -38,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 @@ -408,6 +409,7 @@ withNodeKernelThread ( Alternative (STM m) , MonadAsync m , MonadDelay m + , MonadFork m , MonadThrow m , MonadThrow (STM m) , Strict.MonadMVar m @@ -415,13 +417,15 @@ withNodeKernelThread , RandomGen seed , Eq txid ) - => BlockGeneratorArgs block seed + => 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 txSeed txs @@ -436,7 +440,8 @@ withNodeKernelThread BlockGeneratorArgs { bgaSlotDuration, bgaBlockGenerator, bg -> 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/Testnet/Cardano/Simulation.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs index 2e57d0734fc..4be6e3b6c80 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 @@ -1067,7 +1067,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 From f59130792b77739beda458c01d0fe168ef35f5ba Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 30 Apr 2025 21:06:55 +0200 Subject: [PATCH 47/54] tx-submission: tracing improvements --- .../Network/TxSubmission/Inbound/V1.hs | 5 ++--- .../Network/TxSubmission/Inbound/V2.hs | 8 ++++---- .../TxSubmission/Inbound/V2/Registry.hs | 19 ++++++++++--------- .../Network/TxSubmission/Inbound/V2/Types.hs | 5 +++-- 4 files changed, 19 insertions(+), 18 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V1.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V1.hs index 999dac46b3c..4c941152d21 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V1.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V1.hs @@ -311,9 +311,8 @@ 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 @@ -325,7 +324,7 @@ txSubmissionInbound tracer (NumTxIdsToAck maxUnacked) mpReader mpWriter _version traceWith tracer $ TraceTxSubmissionProcessed ProcessedTxCount { ptxcAccepted = accepted - , ptxcRejected = collected - accepted + , ptxcRejected = length txs - accepted , ptxcScore = 0 -- This implementatin does not track score } diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs index 21db23e0171..ccbc2f10246 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs @@ -94,10 +94,9 @@ txSubmissionInboundV2 -- Only attempt to add TXs if we have some work to do when (collected > 0) $ do - mapM_ (uncurry $ submitTxToMempool tracer) listOfTxsToMempool - - traceWith tracer $ - TraceTxSubmissionCollected collected + -- submitTxToMempool traces: `TraceTxSubmissionProcessed` and + -- `TraceTxInboundAddedToMempool` events + mapM_ (uncurry $ submitTxToMempool tracer) listOfTxsToMempool -- TODO: -- We can update the state so that other `tx-submission` servers will @@ -207,6 +206,7 @@ txSubmissionInboundV2 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 diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs index 8624219ab68..15fa954748f 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs @@ -258,8 +258,14 @@ withPeer tracer (atomically $ signalTSem mempoolSem) $ do res <- addTx - now <- getMonotonicTime - atomically $ modifyTVar sharedStateVar (updateBufferedTx now res) + 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 @@ -280,13 +286,8 @@ withPeer tracer } return TxRejected else do - !start <- getMonotonicTime acceptedTxs <- mempoolAddTxs [tx] - !end <- getMonotonicTime - let duration = diffTime end start - - traceWith txTracer $ - TraceTxInboundAddedToMempool acceptedTxs duration + end <- getMonotonicTime if null acceptedTxs then do !s <- countRejectedTxs end 1 @@ -310,7 +311,7 @@ withPeer tracer -> SharedTxState peeraddr txid tx -> SharedTxState peeraddr txid tx updateBufferedTx _ TxRejected st@SharedTxState { peerTxStates - , limboTxs } = + , limboTxs } = st { peerTxStates = peerTxStates' , limboTxs = limboTxs' } where diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs index 0aee79f74b5..f362cf09f7d 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs @@ -363,13 +363,13 @@ data TxSubmissionMempoolWriter txid tx idx m = data TraceTxSubmissionInbound txid tx = -- | Number of transactions just about to be inserted. - TraceTxSubmissionCollected Int + TraceTxSubmissionCollected [txid] -- | Just processed transaction pass/fail breakdown. | TraceTxSubmissionProcessed ProcessedTxCount - -- | Server received 'MsgDone' | TraceTxInboundCanRequestMoreTxs Int | TraceTxInboundCannotRequestMoreTxs Int | TraceTxInboundAddedToMempool [txid] DiffTime + | TraceTxInboundRejectedFromMempool [txid] DiffTime -- -- messages emitted by the new implementation of the server in @@ -377,6 +377,7 @@ data TraceTxSubmissionInbound txid tx = -- used in this module. -- + -- | Server received 'MsgDone' | TraceTxInboundTerminated | TraceTxInboundDecision (TxDecision txid tx) deriving (Eq, Show) From 7706397b32851ddabb74a496b0e8a57b560a76a4 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 30 Apr 2025 21:08:53 +0200 Subject: [PATCH 48/54] tx-submission: test refactoring Removed the `TurbulentCommands` generator. --- .../Network/Diffusion/Testnet/Cardano.hs | 85 ++++++++++--------- .../Diffusion/Testnet/Cardano/Simulation.hs | 43 ---------- 2 files changed, 46 insertions(+), 82 deletions(-) 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 ffbb4158e75..fd54e8e7796 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -105,7 +105,7 @@ 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 (..)) +import Test.Ouroboros.Network.TxSubmission.Types (Tx (..), TxId) import Test.Ouroboros.Network.Utils hiding (SmallDelay, debugTracer) @@ -862,12 +862,12 @@ prop_no_txSubmission_error_iosim -- but eventually stay online. We manage to get all transactions. -- unit_txSubmission_allTransactions :: ArbTxDecisionPolicy - -> TurbulentCommands - -> (NonEmptyList (Tx Int), NonEmptyList (Tx Int)) + -> NonEmptyList (Tx TxId) + -> NonEmptyList (Tx TxId) -> Property unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) - (TurbulentCommands commands) - (NonEmpty txsA, NonEmpty txsB) = + (NonEmpty txsA) + (NonEmpty txsB) = let localRootConfig = LocalRootConfig DoNotAdvertisePeer InitiatorAndResponderDiffusionMode @@ -885,10 +885,7 @@ unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) (Script (DontUseBootstrapPeers :| [])) (TestAddress (IPAddr (read "0.0.0.0") 0)) PeerSharingDisabled - [ (2,2,Map.fromList [ (RelayAccessAddress "0.0.0.1" 0, localRootConfig) - , (RelayAccessAddress "0.0.0.2" 0, localRootConfig) - ]) - ] + [(2,2,Map.fromList [(RelayAccessAddress "0.0.0.1" 0, localRootConfig)])] (Script (LedgerPools [] :| [])) (let targets = PeerSelectionTargets { @@ -908,8 +905,7 @@ unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) False (Script (PraosFetchMode FetchModeDeadline :| [])) uniqueTxsA - , [ JoinNetwork 0 - ]) + , [JoinNetwork 0]) , (NodeArgs (-1) InitiatorAndResponderDiffusionMode @@ -940,21 +936,23 @@ unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) False (Script (PraosFetchMode FetchModeDeadline :| [])) uniqueTxsB - , commands) + , [JoinNetwork 0]) ] in checkAllTransactions (runSimTrace (diffusionSimulation noAttenuation diffScript iosimTracer) ) - 500000 -- ^ Running for 500k might not be enough. + 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 :: Int ..]) + (zip txsA [0 :: TxId ..]) uniqueTxsB = map (\(t, i) -> t { getTxId = List.foldl' (+) 0 (map ord "0.0.0.1") + i }) - (zip txsB [100 :: Int ..]) + (zip txsB [100 :: TxId ..]) -- This checks the property that after running the simulation for a while -- both nodes manage to get all valid transactions. @@ -963,16 +961,17 @@ unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) -> Int -> Property checkAllTransactions ioSimTrace traceNumber = - let events = fmap (\(WithTime t (WithName name b)) -> WithName name (WithTime t b)) + let trace = Trace.take traceNumber ioSimTrace + + events = fmap (\(WithTime t (WithName name b)) -> WithName name (WithTime t b)) . withTimeNameTraceEvents @DiffusionTestTrace @NtNAddr - . Trace.take traceNumber - $ ioSimTrace + $ trace -- Build the accepted (sorted) txids map for each peer -- - sortedAcceptedTxidsMap :: Map NtNAddr [Int] + sortedAcceptedTxidsMap :: Map NtNAddr [TxId] sortedAcceptedTxidsMap = foldr (\l r -> List.foldl' (\rr (WithName n (WithTime _ x)) -> @@ -981,10 +980,8 @@ unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) -- into the map DiffusionTxSubmissionInbound (TraceTxInboundAddedToMempool txids _) -> Map.alter (maybe (Just txids) (Just . sort . (txids ++))) n rr - -- When the node is shutdown we have to reset the accepted - -- txids list - DiffusionDiffusionSimulationTrace TrKillingNode -> - Map.alter (Just . const []) n rr + -- 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 @@ -1000,24 +997,34 @@ unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) . filter (\Tx {getTxValid} -> getTxValid) in bimap f f (uniqueTxsA, uniqueTxsB) - in counterexample (intercalate "\n" $ map show $ Trace.toList $ events) - $ counterexample ("unique txs: " ++ show uniqueTxsA ++ " " ++ show uniqueTxsB) + 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 ("valid transactions that should be accepted: " - ++ show validSortedTxidsA ++ " " ++ show validSortedTxidsB) - - -- Success criteria, after running for 500k events, we check the map - -- for the two nodes involved in the simulation and verify that indeed - -- each peer managed to learn about the other peer' transactions. - -- - $ case ( Map.lookup (TestAddress (IPAddr (read "0.0.0.0") 0)) sortedAcceptedTxidsMap - , Map.lookup (TestAddress (IPAddr (read "0.0.0.1") 0)) sortedAcceptedTxidsMap - ) of - (Just acceptedTxidsA, Just acceptedTxidsB) -> + $ 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) + + -- 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 - .&&. acceptedTxidsB === validSortedTxidsA - _ -> counterexample "Didn't find any entry in the map!" - $ False + 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. 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 4be6e3b6c80..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 @@ -23,7 +23,6 @@ module Test.Ouroboros.Network.Diffusion.Testnet.Cardano.Simulation , prop_diffusionScript_fixupCommands , prop_diffusionScript_commandScript_valid , fixupCommands - , TurbulentCommands (..) , diffusionSimulation , Command (..) -- * Tracing @@ -332,48 +331,6 @@ fixupCommands (jn@(JoinNetwork _):t) = jn : go jn t _ -> cmd : go cmd cmds fixupCommands (_:t) = fixupCommands t --- | Turbulent commands have some turbulence by connecting and disconnecting --- the node, but eventually keeping the node online. --- -newtype TurbulentCommands = TurbulentCommands [Command] - deriving (Eq, Show) - -instance Arbitrary TurbulentCommands where - arbitrary = do - turbulenceNumber <- choose (2, 7) - -- Make sure turbulenceNumber is an even number - -- This simplifies making sure we keep the node online. - let turbulenceNumber' = - if odd turbulenceNumber - then turbulenceNumber + 1 - else turbulenceNumber - delays <- vectorOf turbulenceNumber' delay - let commands = zipWith (\f d -> f d) (cycle [JoinNetwork, Kill]) delays - ++ [JoinNetwork 0] - return (TurbulentCommands commands) - where - delay = frequency [ (3, genDelayWithPrecision 65) - , (1, (/ 10) <$> genDelayWithPrecision 60) - ] - shrink (TurbulentCommands xs) = - [ TurbulentCommands xs' | xs' <- shrinkList shrinkCommand xs, invariant xs' ] ++ - [ TurbulentCommands (take n xs) | n <- [0, length xs - 3], n `mod` 3 == 0, invariant (take n xs) ] - - where - shrinkDelay = map fromRational . shrink . toRational - - shrinkCommand :: Command -> [Command] - shrinkCommand (JoinNetwork d) = JoinNetwork <$> shrinkDelay d - shrinkCommand (Kill d) = Kill <$> shrinkDelay d - shrinkCommand (Reconfigure d lrp) = Reconfigure <$> shrinkDelay d - <*> pure lrp - - invariant :: [Command] -> Bool - invariant [JoinNetwork _] = True - invariant [JoinNetwork _, Kill _, JoinNetwork _] = True - invariant (JoinNetwork _ : Kill _ : JoinNetwork _ : rest) = invariant rest - invariant _ = False - -- | Simulation arguments. -- -- Slot length needs to be greater than 0 else we get a livelock on the IOSim. From 923d4611b572fb3e3f0bb7f76f16b7f7d8315114 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 7 May 2025 12:25:56 +0200 Subject: [PATCH 49/54] tx-submission: configurable initial delay --- .../Network/TxSubmission/Inbound/V1.hs | 19 ++++++++----------- .../Network/TxSubmission/Inbound/V2.hs | 13 +++++-------- .../Network/TxSubmission/Inbound/V2/Types.hs | 9 +++++++++ .../Network/Diffusion/Node/MiniProtocols.hs | 4 +++- .../Ouroboros/Network/TxSubmission/AppV1.hs | 1 + .../Ouroboros/Network/TxSubmission/AppV2.hs | 4 +++- 6 files changed, 29 insertions(+), 21 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V1.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V1.hs index 4c941152d21..79c77b45d76 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V1.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 #-} @@ -11,6 +10,7 @@ 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 @@ -43,12 +42,11 @@ 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 (..), TxSubmissionMempoolWriter (..), - TxSubmissionProtocolError (..)) + TraceTxSubmissionInbound (..), TxSubmissionInitDelay (..), + TxSubmissionMempoolWriter (..), TxSubmissionProtocolError (..)) import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..), TxSubmissionMempoolReader (..)) @@ -133,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 diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs index ccbc2f10246..8add4ae6ed0 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} @@ -27,7 +26,6 @@ module Ouroboros.Network.TxSubmission.Inbound.V2 import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe) import Data.Sequence.Strict qualified as StrictSeq import Data.Set qualified as Set @@ -39,7 +37,6 @@ import Control.Tracer (Tracer, traceWith) import Network.TypedProtocol -import Ouroboros.Network.Protocol.Limits (longWait) import Ouroboros.Network.Protocol.TxSubmission2.Server import Ouroboros.Network.TxSubmission.Inbound.V2.Policy import Ouroboros.Network.TxSubmission.Inbound.V2.Registry @@ -60,11 +57,13 @@ txSubmissionInboundV2 , 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, @@ -74,11 +73,9 @@ txSubmissionInboundV2 } = 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 () serverIdle where serverIdle diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs index f362cf09f7d..9e0f376f02e 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs @@ -17,6 +17,8 @@ module Ouroboros.Network.TxSubmission.Inbound.V2.Types , emptyTxDecision , SharedDecisionContext (..) , TraceTxLogic (..) + , TxSubmissionInitDelay (..) + , defaultTxSubmissionInitDelay -- * Types shared with V1 -- ** Various , ProcessedTxCount (..) @@ -400,3 +402,10 @@ instance Exception TxSubmissionProtocolError where "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/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs index 547de039924..926a678a950 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -101,7 +101,8 @@ import Ouroboros.Network.Protocol.TxSubmission2.Server import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..), NumTxIdsToReq (..), TxSubmission2) import Ouroboros.Network.RethrowPolicy -import Ouroboros.Network.TxSubmission.Inbound.V2 (txSubmissionInboundV2) +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) @@ -723,6 +724,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node them $ \api -> do let server = txSubmissionInboundV2 txSubmissionInboundTracer + NoTxSubmissionInitDelay (getMempoolWriter mempool) api labelThisThread "TxSubmissionServer" diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV1.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV1.hs index 2f9a9f48817..88899bf8ec1 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV1.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV1.hs @@ -130,6 +130,7 @@ txSubmissionSimulation tracer maxUnacked outboundTxs inboundPeer inboundMempool = txSubmissionInbound nullTracer + NoTxSubmissionInitDelay maxUnacked (getMempoolReader inboundMempool) (getMempoolWriter inboundMempool) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs index ab224ce569d..622bfea1210 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/AppV2.hs @@ -51,7 +51,8 @@ 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 (txSubmissionInboundV2) +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) @@ -224,6 +225,7 @@ runTxSubmission tracer tracerTxLogic state txDecisionPolicy = do getTxSize addr $ \api -> do let server = txSubmissionInboundV2 verboseTracer + NoTxSubmissionInitDelay (getMempoolWriter inboundMempool) api runPipelinedPeerWithLimits From 24118611f98e5ddc2af2c7df478c2e6730f80d65 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 7 May 2025 12:28:13 +0200 Subject: [PATCH 50/54] tx-submission: code style / ghc-9.12 --- .../TxSubmission/Inbound/V2/Decision.hs | 23 ++++++++++--------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs index 0231794f351..a1982866c51 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs @@ -22,7 +22,7 @@ import Control.Exception (assert) import Data.Bifunctor (second) import Data.Hashable -import Data.List (foldl', mapAccumR, sortOn) +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 @@ -91,7 +91,7 @@ orderByRejections :: Hashable peeraddr -> Map peeraddr (PeerTxState txid tx) -> [ (peeraddr, PeerTxState txid tx)] orderByRejections salt = - sortOn (\(peeraddr, ps) -> (score ps, hashWithSalt salt peeraddr)) + List.sortOn (\(peeraddr, ps) -> (score ps, hashWithSalt salt peeraddr)) . Map.toList -- | Order peers by `DeltaQ`. @@ -102,12 +102,13 @@ _orderByDeltaQ :: forall peeraddr txid tx. -> Map peeraddr (PeerTxState txid tx) -> [(peeraddr, PeerTxState txid tx)] _orderByDeltaQ dq = - sortOn (\(peeraddr, _) -> - gsvRequestResponseDuration - (Map.findWithDefault defaultGSV peeraddr dq) - reqSize - respSize - ) + List.sortOn + (\(peeraddr, _) -> + gsvRequestResponseDuration + (Map.findWithDefault defaultGSV peeraddr dq) + reqSize + respSize + ) . Map.toList where -- according to calculations in `txSubmissionProtocolLimits`: sizes of @@ -176,7 +177,7 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, limboTxs, referenceCounts } = -- outer fold: fold `[(peeraddr, PeerTxState txid tx)]` - mapAccumR + List.mapAccumR accumFn -- initial state St { stInflight = inflightTxs, @@ -383,7 +384,7 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, `Map.restrictKeys` liveSet - limboTxs' = foldl' updateLimboTxs limboTxs as + limboTxs' = List.foldl' updateLimboTxs limboTxs as in ( sharedState { peerTxStates = peerTxStates', @@ -412,7 +413,7 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, -> (a, TxDecision txid tx) -> Map txid Int updateLimboTxs m (_,TxDecision { txdTxsToMempool } ) = - foldl' fn m (listOfTxsToMempool txdTxsToMempool) + List.foldl' fn m (listOfTxsToMempool txdTxsToMempool) where fn :: Map txid Int -> (txid,tx) From 70a409b3a33aaa9783e7c2c80aec89010de2ac06 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 8 May 2025 15:36:10 +0200 Subject: [PATCH 51/54] tx-submission: show number of txs transferred in test simulations --- ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs | 3 ++- .../Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs b/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs index c7566fb308a..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) 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 fd54e8e7796..856fb5b127d 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -1004,6 +1004,7 @@ unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) $ 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 From a762ab802a637f8b3df6a3734fd83acf28c98bd3 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 9 May 2025 10:18:51 +0200 Subject: [PATCH 52/54] tx-submission: improved logging for prop_accept_failure test failures --- .../Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) 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 856fb5b127d..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, @@ -2259,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) ) From 38b0c7152e34b9fea43fcfc445f5a7959ac524dc Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 9 May 2025 13:13:56 +0200 Subject: [PATCH 53/54] tx-submission: submit txs to the mempool even if we don't send MsgRequestTxIds --- .../src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs index abe1b467771..52ef228ceee 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs @@ -139,7 +139,7 @@ acknowledgeTxIds else ( 0 , 0 - , TxsToMempool [] + , TxsToMempool txsToMempool , RefCountDiff Map.empty , ps ) From ff2b9953294653b7e3bc4732ad4031c9ea44b362 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 8 May 2025 19:22:22 +0200 Subject: [PATCH 54/54] Updated changelog files --- ouroboros-network-api/CHANGELOG.md | 1 + ouroboros-network-protocols/CHANGELOG.md | 3 +++ ouroboros-network-testing/CHANGELOG.md | 4 ++++ ouroboros-network/CHANGELOG.md | 5 +++++ ouroboros-network/ouroboros-network.cabal | 8 -------- 5 files changed, 13 insertions(+), 8 deletions(-) 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-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-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/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 3402e6af48d..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 @@ -188,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