diff --git a/cardano-diffusion/cardano-diffusion.cabal b/cardano-diffusion/cardano-diffusion.cabal index 831bae38e52..b8f586a3bd9 100644 --- a/cardano-diffusion/cardano-diffusion.cabal +++ b/cardano-diffusion/cardano-diffusion.cabal @@ -168,7 +168,7 @@ library contra-tracer, deepseq, dns, - io-classes:{io-classes, si-timers, strict-stm} ^>=1.8, + io-classes:{io-classes, si-timers, strict-stm} ^>=1.8 || ^>= 1.9, monoidal-synchronisation, network ^>=3.2.7, network-mux, @@ -297,7 +297,7 @@ library protocols bytestring >=0.10 && <0.13, cardano-diffusion:api, cborg >=0.2.1 && <0.3, - io-classes:{io-classes, si-timers} ^>=1.8, + io-classes:{io-classes, si-timers} ^>=1.8 || ^>= 1.9, ouroboros-network:{api, framework, protocols}, random, typed-protocols:{typed-protocols, cborg, stateful} ^>=1.2, @@ -487,6 +487,7 @@ library cardano-diffusion-tests-lib exposed-modules: Test.Cardano.Network.Diffusion.Policies Test.Cardano.Network.Diffusion.Testnet + Test.Cardano.Network.Diffusion.Testnet.ChainedTxs Test.Cardano.Network.Diffusion.Testnet.MiniProtocols Test.Cardano.Network.Diffusion.Testnet.Simulation Test.Cardano.Network.OrphanInstances.Tests @@ -535,7 +536,7 @@ library subscription containers >=0.5 && <0.9, contra-tracer >=0.1 && <0.3, deepseq, - io-classes:si-timers ^>=1.8.0.1, + io-classes:si-timers ^>=1.8.0.1 || ^>= 1.9, network-mux ^>=0.10.1.0, ouroboros-network:{api, framework}, @@ -558,7 +559,7 @@ library tracing base >=4.14 && <4.23, cardano-diffusion, text, - trace-dispatcher ^>=2.11.0, + trace-dispatcher ^>=2.11.0 || ^>=2.12.0, if flag(asserts) ghc-options: -fno-ignore-asserts diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs index 4a89605a9a0..7b83621e1aa 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs @@ -37,6 +37,7 @@ import Data.Dynamic (fromDynamic) import Data.Foldable (fold, foldr') import Data.Functor (void) import Data.IP qualified as IP +import Data.IntMap.Strict qualified as IntMap import Data.List (intercalate, sort) import Data.List qualified as List import Data.List.Trace qualified as Trace @@ -97,7 +98,11 @@ import Ouroboros.Network.TxSubmission.Outbound (TxSubmissionProtocolError (..)) import Simulation.Network.Snocket (BearerInfo (..), noAttenuation) +import Test.Cardano.Network.Diffusion.Testnet.ChainedTxs (ChainedPeerTxs (..)) +import Test.Cardano.Network.Diffusion.Testnet.ChainedTxs qualified as ChainedTxs import Test.Cardano.Network.Diffusion.Testnet.Simulation +import Test.Ouroboros.Network.TxSubmission.Impaired (Impairment (..), + noImpairment) import Test.Ouroboros.Network.ConnectionManager.Timeouts import Test.Ouroboros.Network.ConnectionManager.Utils @@ -179,6 +184,8 @@ tests = , testGroup "Tx Submission" [ nightlyTest $ testProperty "no protocol errors" prop_no_txSubmission_error_iosimpor + , nightlyTest $ testProperty "tx chain integrity" + prop_txSubmission_chainIntegrity_iosimpor ] , testGroup "Churn" [ nightlyTest $ testProperty "no timeouts" @@ -265,12 +272,17 @@ tests = prop_no_peershare_unwilling_iosim ] , testGroup "Tx Submission" - [ testProperty "no protocol errors" + [ ChainedTxs.tests + , testProperty "no protocol errors" prop_no_txSubmission_error_iosim , testProperty "all transactions" prop_txSubmission_allTransactions , testProperty "inflight coverage" prop_check_inflight_ratio + , testProperty "tx chain integrity" + prop_txSubmission_chainIntegrity_iosim + , testProperty "score impairment" + prop_txSubmission_score_impairment ] , testGroup "Churn" [ testProperty "no timeouts" prop_churn_notimeouts_iosim @@ -452,6 +464,7 @@ unit_cm_valid_transitions = False (Script (PraosFetchMode FetchModeBulkSync :| [PraosFetchMode FetchModeBulkSync])) [] + noImpairment , [JoinNetwork 0.5] ) , ( NodeArgs @@ -493,6 +506,7 @@ unit_cm_valid_transitions = False (Script (PraosFetchMode FetchModeDeadline :| [])) [] + noImpairment , [JoinNetwork 1.484_848_484_848] ) ] @@ -653,7 +667,8 @@ unit_connection_manager_trace_coverage = naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), - naTxs = [] + naTxs = [], + naTxImpairment = noImpairment } , [JoinNetwork 0] @@ -688,7 +703,8 @@ unit_connection_manager_trace_coverage = naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), - naTxs = [] + naTxs = [], + naTxImpairment = noImpairment } , [JoinNetwork 0] ) @@ -777,7 +793,8 @@ unit_connection_manager_transitions_coverage = naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), - naTxs = [] + naTxs = [], + naTxImpairment = noImpairment } , [JoinNetwork 0] ) @@ -811,7 +828,8 @@ unit_connection_manager_transitions_coverage = naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), - naTxs = [] + naTxs = [], + naTxImpairment = noImpairment } , [JoinNetwork 0] ) @@ -952,6 +970,7 @@ prop_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) False (Script (PraosFetchMode FetchModeDeadline :| [])) uniqueTxsA + noImpairment , [JoinNetwork 0]) , (NodeArgs (-1) @@ -982,6 +1001,7 @@ prop_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) False (Script (PraosFetchMode FetchModeDeadline :| [])) uniqueTxsB + noImpairment , [JoinNetwork 0]) ] in checkAllTransactions (runSimTrace @@ -1026,7 +1046,7 @@ prop_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 txids) (Just . sort . (txids ++))) n rr -- if a node would be killed, we could download some txs -- multiple times, but this is not possible in the schedule @@ -1076,6 +1096,444 @@ prop_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) | otherwise -> counterexample "Didn't found any entry in the map!" False +-- | Three-node diffusion topology used by the Tx Chain Integrity +-- property: one node (0.0.0.0) downloading txs from two downstream +-- peers (0.0.0.1 and 0.0.0.2). The node has no outbound txs of its own; +-- each downstream peer advertises the tx list it was assigned by +-- 'ChainedPeerTxs'. +txChainIntegrityDiffScript :: ArbTxDecisionPolicy + -> ChainedPeerTxs + -> DiffusionScript +txChainIntegrityDiffScript (ArbTxDecisionPolicy decisionPolicy) + (ChainedPeerTxs chainedTxsB chainedTxsC) = + let localRootConfig = LocalRootConfig + DoNotAdvertisePeer + InitiatorAndResponderDiffusionMode + Outbound + IsNotTrustable + + noPeerTargets = PeerSelectionTargets { + targetNumberOfRootPeers = 0, + targetNumberOfKnownPeers = 0, + targetNumberOfEstablishedPeers = 0, + targetNumberOfActivePeers = 0, + targetNumberOfKnownBigLedgerPeers = 0, + targetNumberOfEstablishedBigLedgerPeers = 0, + targetNumberOfActiveBigLedgerPeers = 0 + } + + upstreamTargets = PeerSelectionTargets { + targetNumberOfRootPeers = 1, + targetNumberOfKnownPeers = 1, + targetNumberOfEstablishedPeers = 1, + targetNumberOfActivePeers = 1, + targetNumberOfKnownBigLedgerPeers = 0, + targetNumberOfEstablishedBigLedgerPeers = 0, + targetNumberOfActiveBigLedgerPeers = 0 + } + + in DiffusionScript + (SimArgs 1 10 decisionPolicy) + (singletonTimedScript Map.empty) + [ ( NodeArgs + (-1) + InitiatorAndResponderDiffusionMode + Map.empty + PraosMode + (Script (DontUseBootstrapPeers :| [])) + (TestAddress (IPAddr (read "0.0.0.0") 0)) + PeerSharingDisabled + [] + (Script (LedgerPools [] :| [])) + (noPeerTargets, noPeerTargets) + (Script (DNSTimeout {getDNSTimeout = 10} :| [])) + (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) + Nothing + False + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] + noImpairment + , [JoinNetwork 0] ) + , ( NodeArgs + (-2) + InitiatorAndResponderDiffusionMode + 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 [] :| [])) + (upstreamTargets, upstreamTargets) + (Script (DNSTimeout {getDNSTimeout = 10} :| [])) + (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) + Nothing + False + (Script (PraosFetchMode FetchModeDeadline :| [])) + chainedTxsB + noImpairment + , [JoinNetwork 0] ) + , ( NodeArgs + (-3) + InitiatorAndResponderDiffusionMode + Map.empty + PraosMode + (Script (DontUseBootstrapPeers :| [])) + (TestAddress (IPAddr (read "0.0.0.2") 0)) + PeerSharingDisabled + [(1, 1, Map.fromList + [(RelayAccessAddress "0.0.0.0" 0, localRootConfig)])] + (Script (LedgerPools [] :| [])) + (upstreamTargets, upstreamTargets) + (Script (DNSTimeout {getDNSTimeout = 10} :| [])) + (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) + Nothing + False + (Script (PraosFetchMode FetchModeDeadline :| [])) + chainedTxsC + noImpairment + , [JoinNetwork 0] ) + ] + +-- | Txs guaranteed to reach the node's mempool: at least one downstream +-- peer carries the tx together with all of its ancestors, and every +-- member of that chain is valid. Txs whose chain isn't fully represented +-- on either downstream peer are legitimately unreachable and correctly +-- excluded from this lower bound. V2 may deliver additional txs when a +-- split chain is assembled across downstream peers via favourable +-- ordering, but those are not guaranteed. +txChainIntegrityExpected :: ChainedPeerTxs -> Set TxId +txChainIntegrityExpected (ChainedPeerTxs chainedTxsB chainedTxsC) = + Set.union + (perPeerDeliverable chainedTxsB) + (perPeerDeliverable chainedTxsC) + where + perPeerDeliverable :: [Tx TxId] -> Set TxId + perPeerDeliverable peerTxs = + let txMap = Map.fromList [(getTxId t, t) | t <- peerTxs] + complete tid = case Map.lookup tid txMap of + Nothing -> False + Just t -> getTxValid t + && maybe True complete (getTxParent t) in + Set.fromList [ getTxId t | t <- peerTxs, complete (getTxId t) ] + +checkTxChainIntegrity :: forall r. + ChainedPeerTxs + -> Set TxId + -> SimTrace r + -> Int + -> Property +checkTxChainIntegrity (ChainedPeerTxs chainedTxsB chainedTxsC) + expectedAtReceiver + ioSimTrace + traceNumber = + let trace = Trace.take traceNumber ioSimTrace + + events = fmap (\(WithTime t (WithName name b)) -> + WithName name (WithTime t b)) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + $ trace + + sortedAcceptedTxidsMap :: Map NtNAddr [TxId] + sortedAcceptedTxidsMap = + foldr (\l r -> + List.foldl' (\rr (WithName n (WithTime _ x)) -> + case x of + DiffusionTxSubmissionInbound _ (TraceTxInboundAddedToMempool txids _) -> + Map.alter (maybe (Just txids) (Just . sort . (txids ++))) n rr + _ -> rr) r l + ) Map.empty + . Trace.toList + . splitWithNameTrace + $ events + + receiverAddr = TestAddress (IPAddr (read "0.0.0.0") 0) + accepted = Map.lookup receiverAddr sortedAcceptedTxidsMap + actualSet = maybe Set.empty Set.fromList accepted + missing = expectedAtReceiver `Set.difference` actualSet in + + counterexample ("accepted txids map: " ++ show sortedAcceptedTxidsMap) + $ counterexample ("downstream peer B outbound: " ++ show chainedTxsB) + $ counterexample ("downstream peer C outbound: " ++ show chainedTxsC) + $ counterexample ("expected (reliably deliverable): " + ++ show (Set.toList expectedAtReceiver)) + $ counterexample ("missing from node: " ++ show (Set.toList missing)) + $ label ("expected count: " + ++ renderRanges 5 (Set.size expectedAtReceiver)) + $ label ("accepted count: " + ++ renderRanges 5 (Set.size actualSet)) + $ counterexample "node (0.0.0.0)" + $ property (Set.null missing) + +-- | Tx Chain Integrity property: the node's mempool accumulates every +-- transaction reachable via a complete, valid ancestor chain on at least +-- one of its downstream peers. +-- +-- This exercises V2's cross-peer retry path: if an adversarial downstream +-- peer delivers a child out-of-order and the mempool rejects with +-- 'MissingParent', the tx must still reach the node via the well-behaved +-- downstream peer's re-advertisement. +prop_txSubmission_chainIntegrity :: ArbTxDecisionPolicy + -> ChainedPeerTxs + -> Property +prop_txSubmission_chainIntegrity argPolicy chainedTxs = + let diffScript = txChainIntegrityDiffScript argPolicy chainedTxs + expected = txChainIntegrityExpected chainedTxs in + checkTxChainIntegrity + chainedTxs + expected + (runSimTrace (diffusionSimulation noAttenuation diffScript)) + long_trace + +prop_txSubmission_chainIntegrity_iosimpor :: ArbTxDecisionPolicy + -> ChainedPeerTxs + -> Property +prop_txSubmission_chainIntegrity_iosimpor argPolicy chainedTxs = + let diffScript = txChainIntegrityDiffScript argPolicy chainedTxs + expected = txChainIntegrityExpected chainedTxs + sim :: forall s. IOSim s Void + sim = do + exploreRaces + diffusionSimulation noAttenuation diffScript + in labelDiffusionScript diffScript + $ exploreSimTrace (\a -> a { explorationScheduleBound = 10 }) sim $ \_ trace -> + checkTxChainIntegrity chainedTxs expected trace long_trace + +prop_txSubmission_chainIntegrity_iosim :: ArbTxDecisionPolicy + -> ChainedPeerTxs + -> Property +prop_txSubmission_chainIntegrity_iosim = prop_txSubmission_chainIntegrity + + +-- | Policy used by the score-impairment fixture. Default policy with a +-- guaranteed inflight cap of 2 so the receiver can request bodies from +-- B and C in parallel. +txScoreImpairmentPolicy :: TxDecisionPolicy +txScoreImpairmentPolicy = + defaultTxDecisionPolicy { txInflightMultiplicity = 2 } + +-- | Inputs for 'prop_txSubmission_score_impairment'. Body delays are +-- expressed as multipliers of 'interTxSpace' so the test is robust to +-- changes in the policy default. The generator enforces: +-- +-- * 'siiBDelayMul' > 1, so B's lease expires before B delivers, freeing +-- the cap=2 slot for C to claim in parallel. +-- * 'siiCDelayMul' > 'siiBDelayMul', so C's body is consistently later +-- than B's. +data ScoreImpairmentInput = ScoreImpairmentInput + { siiTxCount :: Int + , siiBDelayMul :: Double + , siiCDelayMul :: Double + } deriving Show + +instance Arbitrary ScoreImpairmentInput where + arbitrary = do + n <- choose (1, 20) + bMul <- choose (1.5, 4.0) + cMul <- (bMul +) <$> choose (1.0, 6.0) + pure (ScoreImpairmentInput n bMul cMul) + -- Only shrink the tx count: the delay constraint cMul > bMul > 1 is + -- delicate and shrinking either independently could violate it. + shrink (ScoreImpairmentInput n bMul cMul) = + [ ScoreImpairmentInput n' bMul cMul + | n' <- shrink n, n' >= 1 + ] + +-- | Fixture for the score-impairment test. Topology: 1 receiver (-1) + +-- 2 upstream peers (-2 = B well-behaved, -3 = C delays bodies). Both +-- upstreams carry the same valid tx set so they race to deliver each tx; +-- C's body-delay impairment makes its replies consistently late, exposing +-- the receiver's late-body penalty path. +txScoreImpairmentDiffScript :: ScoreImpairmentInput -> DiffusionScript +txScoreImpairmentDiffScript ScoreImpairmentInput { siiTxCount, siiBDelayMul, siiCDelayMul } = + let localRootConfig = LocalRootConfig + DoNotAdvertisePeer + InitiatorAndResponderDiffusionMode + Outbound + IsNotTrustable + + noPeerTargets = PeerSelectionTargets { + targetNumberOfRootPeers = 0, + targetNumberOfKnownPeers = 0, + targetNumberOfEstablishedPeers = 0, + targetNumberOfActivePeers = 0, + targetNumberOfKnownBigLedgerPeers = 0, + targetNumberOfEstablishedBigLedgerPeers = 0, + targetNumberOfActiveBigLedgerPeers = 0 + } + + upstreamTargets = PeerSelectionTargets { + targetNumberOfRootPeers = 1, + targetNumberOfKnownPeers = 1, + targetNumberOfEstablishedPeers = 1, + targetNumberOfActivePeers = 1, + targetNumberOfKnownBigLedgerPeers = 0, + targetNumberOfEstablishedBigLedgerPeers = 0, + targetNumberOfActiveBigLedgerPeers = 0 + } + + validTx i sz = Tx { getTxId = i + , getTxSize = sz + , getTxAdvSize = sz + , getTxValid = True + , getTxParent = Nothing + } + sharedTxs = [ validTx i sz + | (i, sz) <- zip [0 .. siiTxCount - 1] (cycle [100, 250, 500]) + ] + + bDelay = realToFrac siiBDelayMul * interTxSpace txScoreImpairmentPolicy + cDelay = realToFrac siiCDelayMul * interTxSpace txScoreImpairmentPolicy + + bImpairment = noImpairment { impairBodyDelay = Just bDelay } + cImpairment = noImpairment { impairBodyDelay = Just cDelay } + + in DiffusionScript + (SimArgs 1 10 txScoreImpairmentPolicy) + (singletonTimedScript Map.empty) + [ ( NodeArgs + (-1) + InitiatorAndResponderDiffusionMode + Map.empty + PraosMode + (Script (DontUseBootstrapPeers :| [])) + (TestAddress (IPAddr (read "0.0.0.0") 0)) + PeerSharingDisabled + [] + (Script (LedgerPools [] :| [])) + (noPeerTargets, noPeerTargets) + (Script (DNSTimeout {getDNSTimeout = 10} :| [])) + (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) + Nothing + False + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] + noImpairment + , [JoinNetwork 0] ) + , ( NodeArgs + (-2) + InitiatorAndResponderDiffusionMode + 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 [] :| [])) + (upstreamTargets, upstreamTargets) + (Script (DNSTimeout {getDNSTimeout = 10} :| [])) + (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) + Nothing + False + (Script (PraosFetchMode FetchModeDeadline :| [])) + sharedTxs + bImpairment + , [JoinNetwork 0] ) + , ( NodeArgs + (-3) + InitiatorAndResponderDiffusionMode + Map.empty + PraosMode + (Script (DontUseBootstrapPeers :| [])) + (TestAddress (IPAddr (read "0.0.0.2") 0)) + PeerSharingDisabled + [(1, 1, Map.fromList + [(RelayAccessAddress "0.0.0.0" 0, localRootConfig)])] + (Script (LedgerPools [] :| [])) + (upstreamTargets, upstreamTargets) + (Script (DNSTimeout {getDNSTimeout = 10} :| [])) + (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) + Nothing + False + (Script (PraosFetchMode FetchModeDeadline :| [])) + sharedTxs + cImpairment + , [JoinNetwork 0] ) + ] + +-- | Score-targeted impairment property. Asserts that the receiver +-- accumulates a higher peak peer-score for the body-delaying upstream +-- (C) than for the well-behaved one (B). With all txs valid and B +-- typically winning the body race, B should accumulate no rejection +-- penalty while C's late deliveries should drive its score up. +prop_txSubmission_score_impairment :: ScoreImpairmentInput -> Property +prop_txSubmission_score_impairment input@ScoreImpairmentInput { siiTxCount, siiBDelayMul, siiCDelayMul } = + let trace = runSimTrace + $ diffusionSimulation noAttenuation + (txScoreImpairmentDiffScript input) + + receiverAddr = TestAddress (IPAddr (read "0.0.0.0") 0) + peerB = TestAddress (IPAddr (read "0.0.0.1") 0) + peerC = TestAddress (IPAddr (read "0.0.0.2") 0) + + scores :: Map NtNAddr Double + scores = + Map.fromListWith max + [ (peer, ptxcScore ptxc) + | WithTime _ (WithName receiver ev) <- + Trace.toList + . withTimeNameTraceEvents @DiffusionTestTrace @NtNAddr + . Trace.take 500_000 + $ trace + , receiver == receiverAddr + , DiffusionTxSubmissionInbound peer (TraceTxSubmissionProcessed ptxc) <- [ev] + ] + + scoreB = Map.findWithDefault 0 peerB scores + scoreC = Map.findWithDefault 0 peerC scores + + allEvents :: [(NtNAddr, NtNAddr, TraceTxSubmissionInbound Int (Tx Int))] + allEvents = + [ (receiver, peer, tr) + | WithTime _ (WithName receiver ev) <- + Trace.toList + . withTimeNameTraceEvents @DiffusionTestTrace @NtNAddr + . Trace.take 500_000 + $ trace + , DiffusionTxSubmissionInbound peer tr <- [ev] + ] + + -- Count txs each upstream successfully delivered into the receiver's + -- mempool, by tagged peer of the corresponding inbound connection. + -- This is the behavioural test of the score subsystem: a node should + -- prefer peers that deliver valid txs quickly, so B (well-behaved) + -- should outperform C (delayed) in the race to land bodies first. + deliveredByPeer :: Map NtNAddr Int + deliveredByPeer = + Map.fromListWith (+) + [ (peer, length txids) + | (receiver, peer, TraceTxInboundAddedToMempool txids _) <- allEvents + , receiver == receiverAddr + ] + + deliveredB = Map.findWithDefault 0 peerB deliveredByPeer + deliveredC = Map.findWithDefault 0 peerC deliveredByPeer + + in counterexample ("inbound events seen: " ++ show (length allEvents)) + . counterexample ("scores: " ++ show scores) + . counterexample ("scoreB=" ++ show scoreB ++ " scoreC=" ++ show scoreC) + . counterexample ("deliveredB=" ++ show deliveredB + ++ " deliveredC=" ++ show deliveredC) + . tabulate "tx count" [show siiTxCount] + . tabulate "B delay (xITS)" [show (round siiBDelayMul :: Int)] + . tabulate "C delay (xITS)" [show (round siiCDelayMul :: Int)] + . tabulate "C/B delay ratio" [show (round (siiCDelayMul / siiBDelayMul) :: Int)] + $ conjoin + [ counterexample "B must not accumulate any penalty" + $ scoreB == 0 + , counterexample "C must accumulate a penalty" + $ scoreC > 0 + , counterexample "C's score must stay within scoreMax" + $ scoreC <= scoreMax txScoreImpairmentPolicy + , counterexample "B should deliver strictly more txs than C" + $ deliveredB > deliveredC + ] + + -- | This test checks the ratio of the inflight txs against the allowed by the -- TxDecisionPolicy. -- @@ -1106,13 +1564,24 @@ prop_check_inflight_ratio bi ds@(DiffusionScript simArgs _ _) = $ Signal.eventsToList $ Signal.selectEvents (\case - DiffusionTxLogic (TraceSharedTxState _ d) -> Just (inflightTxs d) + DiffusionTxLogic (TraceSharedTxState _ d) -> Just (inflightAttemptCounts d) _ -> Nothing ) events txDecisionPolicy = saTxDecisionPolicy simArgs + inflightAttemptCounts :: SharedTxState NtNAddr Int -> Map Int Int + inflightAttemptCounts SharedTxState { sharedTxTable, sharedKeyToTxId } = + Map.fromList + [ (txid, activeAttemptCount txEntry) + | (txKey, txEntry) <- IntMap.toList sharedTxTable + , Just txid <- [IntMap.lookup txKey sharedKeyToTxId] + ] + + activeAttemptCount :: TxEntry peeraddr -> Int + activeAttemptCount TxEntry { txAttempt } = txAttempt + 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)) @@ -1472,6 +1941,7 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script False (Script (PraosFetchMode FetchModeDeadline :| [])) [] + noImpairment , [JoinNetwork 1.742_857_142_857 ,Reconfigure 6.333_333_333_33 [(1,1,Map.fromList [(RelayAccessDomain "test2" 65_535,LocalRootConfig DoAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable)]), (1,1,Map.fromList [(RelayAccessAddress "0:6:0:3:0:6:0:5" 65_530,LocalRootConfig DoAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable) @@ -1506,6 +1976,7 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script False (Script (PraosFetchMode FetchModeDeadline :| [])) [] + noImpairment , [JoinNetwork 0.183_783_783_783 ,Reconfigure 4.533_333_333_333 [(1,1,Map.empty)] ] @@ -2169,6 +2640,7 @@ unit_4191 = testWithIOSim prop_diffusion_dns_can_recover long_trace absInfo scri False (Script (PraosFetchMode FetchModeDeadline :| [])) [] + noImpairment , [ JoinNetwork 6.710_144_927_536 , Kill 7.454_545_454_545 , JoinNetwork 10.763_157_894_736 @@ -2257,7 +2729,8 @@ prop_connect_failure (AbsIOError ioerr) = naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), - naTxs = [] + naTxs = [], + naTxImpairment = noImpairment } , [JoinNetwork 10] ), @@ -2286,7 +2759,8 @@ prop_connect_failure (AbsIOError ioerr) = naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), - naTxs = [] + naTxs = [], + naTxImpairment = noImpairment } , [JoinNetwork 0] ) @@ -2385,7 +2859,8 @@ prop_accept_failure (AbsIOError ioerr) = naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), - naTxs = [] + naTxs = [], + naTxImpairment = noImpairment } , [JoinNetwork 10] ), @@ -2414,7 +2889,8 @@ prop_accept_failure (AbsIOError ioerr) = naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), - naTxs = [] + naTxs = [], + naTxImpairment = noImpairment } , [JoinNetwork 0] ) @@ -3501,7 +3977,8 @@ async_demotion_network_script = = False, naPeerSharing = PeerSharingDisabled, naFetchModeScript = singletonScript (PraosFetchMode FetchModeDeadline), - naTxs = [] + naTxs = [], + naTxImpairment = noImpairment } @@ -4068,6 +4545,7 @@ prop_unit_4258 = False (Script (PraosFetchMode FetchModeDeadline :| [])) [] + noImpairment , [ JoinNetwork 4.166_666_666_666, Kill 0.3, JoinNetwork 1.517_857_142_857, @@ -4111,6 +4589,7 @@ prop_unit_4258 = False (Script (PraosFetchMode FetchModeDeadline :| [])) [] + noImpairment , [ 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 Outbound IsNotTrustable)])], Kill 15.555_555_555_55, @@ -4174,6 +4653,7 @@ prop_unit_reconnect = False (Script (PraosFetchMode FetchModeDeadline :| [])) [] + noImpairment , [ JoinNetwork 0 ]) , (NodeArgs @@ -4202,6 +4682,7 @@ prop_unit_reconnect = False (Script (PraosFetchMode FetchModeDeadline :| [])) [] + noImpairment , [ JoinNetwork 10 ]) ] @@ -4627,7 +5108,8 @@ unit_peer_sharing = naChainSyncExitOnBlockNo = Nothing, naFetchModeScript = singletonScript (PraosFetchMode FetchModeDeadline), naConsensusMode, - naTxs = [] + naTxs = [], + naTxImpairment = noImpairment } script = DiffusionScript @@ -5337,7 +5819,8 @@ unit_local_root_diffusion_mode diffusionMode = naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), - naTxs = [] + naTxs = [], + naTxImpairment = noImpairment } , [JoinNetwork 0] ) @@ -5371,7 +5854,8 @@ unit_local_root_diffusion_mode diffusionMode = naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), - naTxs = [] + naTxs = [], + naTxImpairment = noImpairment } , [JoinNetwork 0] ) diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/ChainedTxs.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/ChainedTxs.hs new file mode 100644 index 00000000000..1cdedf129f8 --- /dev/null +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/ChainedTxs.hs @@ -0,0 +1,259 @@ +module Test.Cardano.Network.Diffusion.Testnet.ChainedTxs + ( ChainedPeerTxs (..) + , tests + ) where + +import Data.Function (on) +import Data.List as List (foldl', nub, nubBy) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set + +import Test.Ouroboros.Network.TxSubmission.Types (Tx (..), TxId) + +import Test.QuickCheck +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + + +-- | A randomly generated transaction forest distributed across two peers, +-- used by chain-integrity tests at the diffusion layer. +-- +-- Each tx may carry a parent pointer ('getTxParent') to any earlier tx in +-- the forest, with some probability of having no parent at all. Invalidity +-- propagates down the chain at generation time: a descendant of an invalid +-- tx is itself generated as invalid, matching mainnet semantics where a tx +-- that consumes an invalid parent's output is itself invalid by construction. +-- +-- Peer assignment reflects realistic mainnet conditions: +-- +-- * Each peer carries a random subset of the forest (peers may lack txs +-- that, for example, were already included in an adopted block). +-- * Well-behaved peers (the common case) advertise their subset in +-- chain-topological order: parents before children. +-- * Adversarial or buggy peers (the occasional case) advertise in a +-- shuffled order to stress V2's handling of out-of-order streams. +-- * Every tx is carried by at least one /well-behaved/ peer so the full +-- forest is reachable via the reliable path, even when adversarial +-- peers misorder or mishandle their share. +data ChainedPeerTxs = ChainedPeerTxs { + chainedTxsA :: [Tx TxId] + , chainedTxsB :: [Tx TxId] + } + deriving Show + +instance Arbitrary ChainedPeerTxs where + arbitrary = do + chainLen <- choose (3, 15) + chain <- genChainedTxs chainLen + perPeer <- distributeAcrossPeers 2 chain + case perPeer of + [txsA, txsB] -> return (ChainedPeerTxs txsA txsB) + _ -> error "ChainedPeerTxs: distributeAcrossPeers invariant broken" + + shrink (ChainedPeerTxs txsA txsB) = + [ ChainedPeerTxs (dropDoomed txsA) (dropDoomed txsB) + | tid <- nub (map getTxId (txsA ++ txsB)) + , let doomed = transitiveDescendants tid (txsA ++ txsB) + dropDoomed = filter (\t -> getTxId t `Set.notMember` doomed) + ] + where + -- | All txids reachable as descendants of @root@, including @root@ + -- itself. Used so that dropping a parent also drops every + -- transitive child, avoiding dangling parent pointers in the + -- shrunken value. + transitiveDescendants :: TxId -> [Tx TxId] -> Set TxId + transitiveDescendants root txs = + let children p = [ getTxId t | t <- txs, getTxParent t == Just p ] + go acc p + | p `Set.member` acc = acc + | otherwise = List.foldl' go (Set.insert p acc) (children p) in + go Set.empty root + + +-- | Generate a forest of @n@ transactions. +-- +-- Tx 0 has no parent. Each subsequent tx picks its parent uniformly from +-- @{Nothing}@ unioned with the ids of earlier txs, weighted so a parent +-- link is more common than no parent. Invalidity is propagated: if the +-- parent is invalid, the tx is also invalid regardless of its own drawn +-- validity. +genChainedTxs :: Int -> Gen [Tx TxId] +genChainedTxs n = go 0 Map.empty [] + where + baseId :: TxId + baseId = 1 + + go :: Int -> Map TxId Bool -> [Tx TxId] -> Gen [Tx TxId] + go i validMap acc + | i >= n = return (reverse acc) + | otherwise = do + let txid = baseId + i + parent <- if i == 0 + then return Nothing + else frequency + [ (1, return Nothing) + , (3, Just . (baseId +) <$> choose (0, i - 1)) + ] + ownValid <- frequency [ (3, return True), (1, return False) ] + size <- chooseEnum (0, 1024) + let parentValid = maybe True (validMap Map.!) parent + effectiveValid = ownValid && parentValid + tx = Tx + { getTxId = txid + , getTxSize = size + , getTxAdvSize = size + , getTxValid = effectiveValid + , getTxParent = parent + } + go (i + 1) (Map.insert txid effectiveValid validMap) (tx : acc) + + +-- | Per-peer behaviour selected up front so chain-coverage constraints +-- can be satisfied against the well-behaved subset before any lists are +-- emitted. +data PeerBehaviour = WellBehaved | Adversarial + deriving (Eq, Show) + +-- | Distribute a forest across @peerCount@ peers. +-- +-- Each peer is classified as well-behaved (advertises in chain-topological +-- order, the common case) or adversarial (advertises in a shuffled order, +-- the occasional case). To keep the property invariant clean, every tx +-- is guaranteed to be carried by at least one /well-behaved/ peer: +-- adversarial peers add noise and races but cannot singly strand a tx. At +-- least one peer is always well-behaved. +-- +-- Adversarial peers may duplicate txs already carried by well-behaved +-- peers; this exercises V2's cross-peer retry path when an adversarial +-- peer's out-of-order delivery causes a rejection. +distributeAcrossPeers :: Int -> [Tx TxId] -> Gen [[Tx TxId]] +distributeAcrossPeers peerCount chain = do + behaviours <- ensureSomeWellBehaved <$> + vectorOf peerCount + (frequency [ (4, pure WellBehaved) + , (1, pure Adversarial) ]) + + subsets <- vectorOf peerCount (sublistOf chain) + + let wellBehavedIxs = + [ i | (i, WellBehaved) <- zip [0..] behaviours ] + wellBehavedCov = + Set.unions + [ Set.fromList (map getTxId (subsets !! i)) + | i <- wellBehavedIxs ] + uncovered = + [ t | t <- chain, getTxId t `Set.notMember` wellBehavedCov ] + additions <- traverse + (\t -> do i <- elements wellBehavedIxs; pure (i, t)) + uncovered + + let subsetsWithCoverage :: [[Tx TxId]] + subsetsWithCoverage = + zipWith + (\i base -> base ++ [ t | (p, t) <- additions, p == i ]) + [0 .. peerCount - 1] + subsets + + inChainOrder :: Set TxId -> [Tx TxId] + inChainOrder peerSet = + filter (\t -> getTxId t `Set.member` peerSet) chain + + traverse + (\(b, s) -> case b of + WellBehaved -> pure (inChainOrder (Set.fromList (map getTxId s))) + Adversarial -> shuffle s) + (zip behaviours subsetsWithCoverage) + where + ensureSomeWellBehaved bs + | WellBehaved `elem` bs = bs + | otherwise = WellBehaved : drop 1 bs + + +-- +-- Meta-tests: verify generator and shrinker invariants. +-- + +-- | Every parent pointer in the combined peer lists resolves to a tx that +-- also appears somewhere in the union. No dangling parents. +prop_parentsResolvable :: ChainedPeerTxs -> Bool +prop_parentsResolvable (ChainedPeerTxs txsA txsB) = + let ids = Set.fromList (map getTxId (txsA ++ txsB)) + parents = [ p | t <- txsA ++ txsB, Just p <- [getTxParent t] ] in + all (`Set.member` ids) parents + +-- | Invalidity propagates along the dependency chain: if a tx's parent is +-- present in the union and invalid, the tx itself must be invalid too. +prop_invalidityPropagates :: ChainedPeerTxs -> Bool +prop_invalidityPropagates (ChainedPeerTxs txsA txsB) = + let allTxs = nubBy ((==) `on` getTxId) (txsA ++ txsB) + txMap = Map.fromList [(getTxId t, t) | t <- allTxs] in + all (\t -> case getTxParent t of + Nothing -> True + Just p -> case Map.lookup p txMap of + Nothing -> True + Just pt -> getTxValid pt || not (getTxValid t)) + -- not (getTxValid pt) => not (getTxValid t) + allTxs + +-- | At least one peer's tx list is in chain-topological order (parents +-- before children), and the union of all such peers' txids covers every +-- tx in the value. This is the external face of the "every tx is carried +-- by at least one well-behaved peer" guarantee from +-- 'distributeAcrossPeers': adversarial peers may exist and misorder, but +-- the full forest is always reachable via the chain-ordered subset. +prop_wellBehavedCoverage :: ChainedPeerTxs -> Property +prop_wellBehavedCoverage (ChainedPeerTxs txsA txsB) = + let allIds = Set.fromList (map getTxId (txsA ++ txsB)) + chainOrdered = filter isChainOrdered [txsA, txsB] + coverage = Set.unions + [ Set.fromList (map getTxId txs) | txs <- chainOrdered ] in + counterexample ("peer A: " ++ show txsA) + $ counterexample ("peer B: " ++ show txsB) + $ counterexample ("chain-ordered peers: " ++ show (length chainOrdered)) + $ counterexample ("coverage: " ++ show (Set.toList coverage)) + $ counterexample ("all ids: " ++ show (Set.toList allIds)) + $ property (not (null chainOrdered) && coverage == allIds) + where + isChainOrdered :: [Tx TxId] -> Bool + isChainOrdered txs = + let positions = Map.fromList (zip (map getTxId txs) [(0 :: Int) ..]) in + all (\t -> case getTxParent t of + Nothing -> True + Just p -> case Map.lookup p positions of + Nothing -> True + Just ppos -> ppos < positions Map.! getTxId t) + txs + + +-- | Every shrink of a value satisfies the same structural invariants as +-- a freshly generated one. +prop_shrinkPreservesInvariants :: ChainedPeerTxs -> Property +prop_shrinkPreservesInvariants cpt = + conjoin + [ counterexample ("shrunk: " ++ show s) $ + prop_parentsResolvable s + .&&. prop_invalidityPropagates s + .&&. prop_wellBehavedCoverage s + | s <- shrink cpt + ] + +-- | Each shrink strictly reduces the total tx count so shrinking converges. +prop_shrinkMakesProgress :: ChainedPeerTxs -> Property +prop_shrinkMakesProgress cpt = + let size (ChainedPeerTxs a b) = length a + length b + origSize = size cpt in + conjoin + [ counterexample ("shrunk: " ++ show s) (size s < origSize) + | s <- shrink cpt + ] + +tests :: TestTree +tests = testGroup "ChainedTxs" + [ testProperty "parents resolvable" prop_parentsResolvable + , testProperty "invalidity propagates" prop_invalidityPropagates + , testProperty "well-behaved coverage" prop_wellBehavedCoverage + , testProperty "shrink preserves invariants" prop_shrinkPreservesInvariants + , testProperty "shrink makes progress" prop_shrinkMakesProgress + ] diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs index 6f56fa53972..e102f102b98 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs @@ -108,14 +108,17 @@ import Ouroboros.Network.RethrowPolicy import Ouroboros.Network.TxSubmission.Inbound.V2 (TxSubmissionInitDelay (..), txSubmissionInboundV2) import Ouroboros.Network.TxSubmission.Inbound.V2.Policy (TxDecisionPolicy (..)) -import Ouroboros.Network.TxSubmission.Inbound.V2.Registry (SharedTxStateVar, - TxChannelsVar, TxMempoolSem, withPeer) +import Ouroboros.Network.TxSubmission.Inbound.V2.Registry + (PeerTxInFlightRegistry, SharedTxStateVar, + TxSubmissionCountersVar, withPeer) import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TraceTxLogic, TraceTxSubmissionInbound) import Ouroboros.Network.TxSubmission.Outbound (txSubmissionOutbound) import Ouroboros.Network.Util.ShowProxy import Test.Ouroboros.Network.Diffusion.Node.Kernel +import Test.Ouroboros.Network.TxSubmission.Impaired (Impairment, + applyImpairment) import Test.Ouroboros.Network.TxSubmission.Types (Mempool, Tx (..), TxId, getMempoolReader, getMempoolWriter, txSubmissionCodec2) @@ -241,6 +244,9 @@ data AppArgs header block m = AppArgs , aaPeerMetrics :: PeerMetrics m NtNAddr , aaTxDecisionPolicy :: TxDecisionPolicy + , aaTxImpairment :: Impairment + -- ^ behavioural fault injection on this node's outbound + -- 'TxSubmissionClient' (default: 'noImpairment') } @@ -269,7 +275,9 @@ applications :: forall block header s m. , RandomGen s ) => Tracer m String - -> Tracer m (TraceTxSubmissionInbound Int (Tx Int)) + -> Tracer m (NtNAddr, TraceTxSubmissionInbound Int (Tx Int)) + -- ^ tagged with the remote peer address so per-peer scoring + -- events can be folded out of the trace -> Tracer m (TraceTxLogic NtNAddr Int (Tx Int)) -> NodeKernel header block s Int m -> Codecs NtNAddr header block m @@ -280,7 +288,7 @@ applications :: forall block header s m. -> Diffusion.Applications NtNAddr NtNVersion NtNVersionData NtCAddr NtCVersion NtCVersionData PeerTrustable m () -applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug nodeKernel +applications debugTracer txSubmissionInboundTracer _txSubmissionInboundDebug nodeKernel Codecs { chainSyncCodec, blockFetchCodec , keepAliveCodec, pingPongCodec , peerSharingCodec @@ -298,6 +306,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node , aaPeerSharing , aaPeerMetrics , aaTxDecisionPolicy + , aaTxImpairment } toHeader duplicateTxVar = @@ -382,9 +391,9 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node InitiatorAndResponderProtocol (txSubmissionInitiator aaTxDecisionPolicy (nkMempool nodeKernel)) (txSubmissionResponder (nkMempool nodeKernel) - (nkTxChannelsVar nodeKernel) - (nkTxMempoolSem nodeKernel) - (nkSharedTxStateVar nodeKernel)) + (nkTxCountersVar nodeKernel) + (nkSharedTxStateVar nodeKernel) + (nkPeerTxInFlightRegistry nodeKernel)) } ] , withWarm = WithWarm @@ -697,13 +706,14 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node } channel -> do - let client = txSubmissionOutbound - (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) - (NumTxIdsToAck $ getNumTxIdsToReq - $ maxUnacknowledgedTxIds txDecisionPolicy) - (getMempoolReader mempool) - (maxBound :: UnversionedProtocol) - controlMessageSTM + let baseClient = txSubmissionOutbound + (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) + (NumTxIdsToAck $ getNumTxIdsToReq + $ maxUnacknowledgedTxIds txDecisionPolicy) + (getMempoolReader mempool) + (maxBound :: UnversionedProtocol) + controlMessageSTM + client <- applyImpairment aaTxImpairment baseClient labelThisThread "TxSubmissionClient" runPeerWithLimits (((ppNtNConnId connId ++) . (" " ++) . show) `contramap` debugTracer) @@ -715,27 +725,26 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node txSubmissionResponder :: Mempool m TxId (Tx TxId) - -> TxChannelsVar m NtNAddr Int (Tx Int) - -> TxMempoolSem m - -> SharedTxStateVar m NtNAddr Int (Tx Int) + -> TxSubmissionCountersVar m + -> SharedTxStateVar m NtNAddr Int + -> PeerTxInFlightRegistry m NtNAddr -> MiniProtocolCb (ResponderContext NtNAddr) ByteString m () - txSubmissionResponder mempool txChannelsVar txMempoolSem sharedTxStateVar = + txSubmissionResponder mempool txCountersVar sharedTxStateVar inFlightRegistry = MiniProtocolCb $ \ ResponderContext { rcConnectionId = connId@ConnectionId { remoteAddress = them }} channel -> do - withPeer txSubmissionInboundDebug - txChannelsVar - txMempoolSem - aaTxDecisionPolicy - sharedTxStateVar + withPeer aaTxDecisionPolicy (getMempoolReader mempool) - (getMempoolWriter duplicateTxVar mempool) - getTxSize + sharedTxStateVar + inFlightRegistry + txCountersVar them $ \api -> do let server = txSubmissionInboundV2 - txSubmissionInboundTracer + ((them,) `contramap` txSubmissionInboundTracer) NoTxSubmissionInitDelay + aaTxDecisionPolicy (getMempoolWriter duplicateTxVar mempool) + getTxSize api labelThisThread "TxSubmissionServer" runPipelinedPeerWithLimits diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs index 957bd854aca..934e0f2e90b 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs @@ -146,6 +146,7 @@ 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.Impaired (Impairment, noImpairment) import Test.Ouroboros.Network.TxSubmission.TxLogic (ArbTxDecisionPolicy (..)) import Test.Ouroboros.Network.TxSubmission.Types (Tx (..)) import Test.Ouroboros.Network.Utils @@ -238,6 +239,9 @@ data NodeArgs = , naChainSyncEarlyExit :: Bool , naFetchModeScript :: Script FetchMode , naTxs :: [Tx Int] + , naTxImpairment :: Impairment + -- ^ behavioural fault injection on this node's outbound + -- 'TxSubmissionClient' (default: 'noImpairment') } instance Show NodeArgs where @@ -246,7 +250,7 @@ instance Show NodeArgs where naLocalRootPeers, naPeerTargets, naDNSTimeoutScript, naDNSLookupDelayScript, naChainSyncExitOnBlockNo, naChainSyncEarlyExit, naFetchModeScript, naConsensusMode, - naTxs } = + naTxs, naTxImpairment } = unwords [ "NodeArgs" , "(" ++ show naSeed ++ ")" , show naDiffusionMode @@ -264,6 +268,7 @@ instance Show NodeArgs where , show naChainSyncEarlyExit , "(" ++ show naFetchModeScript ++ ")" , show naTxs + , "(" ++ show naTxImpairment ++ ")" ] data Command = JoinNetwork DiffTime @@ -478,6 +483,7 @@ genNodeArgs relays minConnected localRootPeers self txs = flip suchThat hasUpstr , naPeerSharing = peerSharing , naFetchModeScript = fetchModeScript , naTxs = txs + , naTxImpairment = noImpairment } where makeRelayAccessPoint (relay, _, _, _) = relay @@ -970,7 +976,7 @@ data DiffusionTestTrace = | DiffusionServerTrace (Server.Trace NtNAddr) | DiffusionFetchTrace (TraceFetchClientState BlockHeader) | DiffusionChurnModeTrace TraceChurnMode - | DiffusionTxSubmissionInbound (TraceTxSubmissionInbound Int (Tx Int)) + | DiffusionTxSubmissionInbound NtNAddr (TraceTxSubmissionInbound Int (Tx Int)) | DiffusionTxLogic (TraceTxLogic NtNAddr Int (Tx Int)) | DiffusionDebugTrace String | DiffusionDNSTrace DNSTrace @@ -993,7 +999,7 @@ 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 (DiffusionTxSubmissionInbound peer tr) = ppNtNAddr peer ++ " " ++ show tr ppDiffusionTestTrace (DiffusionTxLogic tr) = show tr ppDiffusionTestTrace (DiffusionDebugTrace tr) = tr ppDiffusionTestTrace (DiffusionDNSTrace tr) = show tr @@ -1178,6 +1184,7 @@ diffusionSimulationM , naPeerSharing = peerSharing , naDiffusionMode = diffusionMode , naTxs = txs + , naTxImpairment = txImpairment } ntnSnocket ntcSnocket @@ -1365,7 +1372,7 @@ diffusionSimulationM duplicateTxVar where tracerTxSubmissionInbound = - contramap DiffusionTxSubmissionInbound + contramap (uncurry DiffusionTxSubmissionInbound) . tracerWithName addr . tracerWithTime $ nodeTracer @@ -1382,6 +1389,7 @@ diffusionSimulationM , Node.aaPeerSharing = Node.aPeerSharing arguments , Node.aaPeerMetrics = peerMetrics , Node.aaTxDecisionPolicy = Node.aTxDecisionPolicy arguments + , Node.aaTxImpairment = txImpairment } Node.run diff --git a/ouroboros-network/api/lib/Ouroboros/Network/Tx.hs b/ouroboros-network/api/lib/Ouroboros/Network/Tx.hs new file mode 100644 index 00000000000..a51052e68a1 --- /dev/null +++ b/ouroboros-network/api/lib/Ouroboros/Network/Tx.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Abstract view over transactions +-- +-- The network layer does not make any concrete assumptions about what +-- transactions or transaction identifiers look like. +module Ouroboros.Network.Tx + ( HasRawTxId (..) + , RawTxId (..) + ) where + +import Control.DeepSeq (NFData) +import Data.ByteString.Short (ShortByteString) +import NoThunks.Class (NoThunks) + +-- | Raw byte representation of a transaction identifier. +newtype RawTxId = RawTxId ShortByteString + deriving newtype (Eq, Ord, Show, NFData, NoThunks) + +-- | Abstract over transaction identifiers, providing access to their raw byte +-- representation for efficient comparison. +-- +-- Laws: +-- +-- * If @getRawTxId x == getRawTxId y@ then @x == y@ +-- (the raw bytes must uniquely identify the transaction) +class HasRawTxId txid where + getRawTxId :: txid -> RawTxId diff --git a/ouroboros-network/bench/Bench/TxSubmissionV2Server.hs b/ouroboros-network/bench/Bench/TxSubmissionV2Server.hs new file mode 100644 index 00000000000..1160b7565d9 --- /dev/null +++ b/ouroboros-network/bench/Bench/TxSubmissionV2Server.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Bench.TxSubmissionV2Server + ( DirectServerFixture + , DirectServerResult + , mkDirectServerFixture + , mkMultiPeerFixture + , runDirectServerBenchmark + ) where + +import Control.Concurrent.Class.MonadSTM qualified as Lazy +import Control.Concurrent.Class.MonadSTM.Strict +import Control.DeepSeq (NFData) +import Control.Monad.Class.MonadAsync (mapConcurrently_) +import Control.Tracer (nullTracer) + +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import GHC.Generics (Generic) + +import Ouroboros.Network.Protocol.TxSubmission2.Server +import Ouroboros.Network.Protocol.TxSubmission2.Type + (NumTxIdsToReq (getNumTxIdsToReq), SizeInBytes (..)) +import Ouroboros.Network.TxSubmission.Inbound.V2 + (TxSubmissionInitDelay (NoTxSubmissionInitDelay), + defaultTxDecisionPolicy, txSubmissionInboundV2) +import Ouroboros.Network.TxSubmission.Inbound.V2.Registry + (newPeerTxInFlightRegistry, newSharedTxStateVar, + newTxSubmissionCountersVar, withPeer) +import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TxSubmissionCounters, + emptySharedTxState) + +import Test.Ouroboros.Network.TxSubmission.Types + (Tx (..), TxId, + emptyMempool, getMempoolReader, getMempoolWriter, readMempool) + + +data DirectServerFixture = DirectServerFixture + { dsPeerCount :: !Int + , dsTxIdReplyBatches :: !Int + , dsTxSize :: !SizeInBytes + } + deriving stock (Eq, Show, Generic) + deriving anyclass NFData + + +data DirectServerResult = DirectServerResult + { dsAcceptedTxs :: !Int + , dsCounters :: !TxSubmissionCounters + } + deriving stock (Eq, Show, Generic) + deriving anyclass NFData + + +data PendingReply + = PendingTxIds !NumTxIdsToReq ![(TxId, SizeInBytes)] + | PendingTxs !(Map TxId SizeInBytes) + + +mkDirectServerFixture + :: Int -> DirectServerFixture +mkDirectServerFixture batches = + DirectServerFixture + { dsPeerCount = 1 + , dsTxIdReplyBatches = batches + , dsTxSize = SizeInBytes 1024 + } + + +-- | Multi-peer fixture: @peers@ peers each playing back the same txid stream. +-- +-- Models the mainnet steady state where many upstream peers advertise the +-- same fresh txids. The first peer downloads each tx body and submits it to +-- the mempool, which puts the key into 'sharedRetainedTxs'. Subsequent +-- peers find the txid in the retained set and ack-skip without ever +-- requesting the body. +mkMultiPeerFixture + :: Int -- ^ peer count + -> Int -- ^ batches per peer + -> DirectServerFixture +mkMultiPeerFixture peers batches = + DirectServerFixture + { dsPeerCount = peers + , dsTxIdReplyBatches = batches + , dsTxSize = SizeInBytes 1024 + } + + +runDirectServerBenchmark + :: DirectServerFixture -> IO DirectServerResult +runDirectServerBenchmark DirectServerFixture { + dsPeerCount, + dsTxIdReplyBatches, + dsTxSize + } = do + inboundMempool <- emptyMempool + duplicateTxIdsVar <- Lazy.newTVarIO [] + sharedStateVar <- newSharedTxStateVar emptySharedTxState + inFlightRegistry <- newPeerTxInFlightRegistry + countersVar <- newTxSubmissionCountersVar mempty + + let writer = getMempoolWriter duplicateTxIdsVar inboundMempool + + runPeer addr = + withPeer + defaultTxDecisionPolicy + (getMempoolReader inboundMempool) + sharedStateVar + inFlightRegistry + countersVar + addr + $ \api -> do + let server = + txSubmissionInboundV2 + nullTracer + NoTxSubmissionInitDelay + defaultTxDecisionPolicy + writer + getTxSize + api + stream = [1 .. dsTxIdReplyBatches * 6] + case server of + TxSubmissionServerPipelined initServer -> do + st0 <- initServer + driveServer dsTxSize stream [] st0 + + mapConcurrently_ runPeer [1 .. dsPeerCount] + + (DirectServerResult + . length <$> readMempool inboundMempool) + <*> readTVarIO countersVar + + +driveServer + :: SizeInBytes + -> [TxId] + -> [PendingReply] + -> ServerStIdle n TxId (Tx TxId) IO () + -> IO () +driveServer !txSize !stream !pending = + \case + SendMsgRequestTxIdsBlocking _ req kDone k + | null stream -> kDone + | otherwise -> do + let (txids, stream') = takeReply txSize req stream + st' <- k (NonEmpty.fromList txids) + driveServer txSize stream' pending st' + + SendMsgRequestTxIdsPipelined _ req k -> do + let (txids, stream') = takeReply txSize req stream + pending' = pending ++ [PendingTxIds req txids] + st' <- k + driveServer txSize stream' pending' st' + + SendMsgRequestTxsPipelined requested k -> do + st' <- k + driveServer + txSize + stream + (pending ++ [PendingTxs requested]) + st' + + CollectPipelined mNone collect -> + case pending of + reply : pending' -> do + st' <- collect (renderPendingReply reply) + driveServer txSize stream pending' st' + [] -> + case mNone of + Just k -> k >>= driveServer txSize stream [] + Nothing -> + error $ + "TxSubmissionV2 direct benchmark: unexpected " + ++ "CollectPipelined with no pending replies" + + +-- | Take the next @req@-sized chunk from the precomputed txid stream. If +-- the stream is exhausted, return an empty reply and the empty stream. +takeReply + :: SizeInBytes + -> NumTxIdsToReq + -> [TxId] + -> ([(TxId, SizeInBytes)], [TxId]) +takeReply txSize req stream = + let (taken, rest) = splitAt replyCount stream + in ([ (t, txSize) | t <- taken ], rest) + where + replyCount = fromIntegral (getNumTxIdsToReq req) + + +renderPendingReply + :: PendingReply -> Collect TxId (Tx TxId) +renderPendingReply = \case + PendingTxIds req txids -> + CollectTxIds req txids + + PendingTxs requested -> + CollectTxs requested + [ Tx { + getTxId = txid, + getTxSize = txSize, + getTxAdvSize = txSize, + getTxValid = True, + getTxParent = Nothing + } + | (txid, txSize) <- Map.toAscList requested + ] diff --git a/ouroboros-network/bench/Main.hs b/ouroboros-network/bench/Main.hs index cbfbd6a6235..2f697ae894e 100644 --- a/ouroboros-network/bench/Main.hs +++ b/ouroboros-network/bench/Main.hs @@ -1,27 +1,20 @@ {-# LANGUAGE NumericUnderscores #-} --- pPrint -{-# OPTIONS_GHC -Wno-unused-imports #-} - module Main (main) where -import Control.DeepSeq +import Bench.TxSubmissionV2Server qualified as DirectV2 + +import Control.DeepSeq (NFData, rnf) import Control.Exception (evaluate) -import Data.Map (Map) -import Debug.Trace (traceMarkerIO) import System.Mem (performMajorGC) -import System.Random.SplitMix qualified as SM import Test.Tasty.Bench -import Text.Pretty.Simple (pPrint) - -import Ouroboros.Network.TxSubmission.Inbound.V2.Decision qualified as Tx -import Ouroboros.Network.TxSubmission.Inbound.V2.Policy -import Ouroboros.Network.TxSubmission.Inbound.V2.State (SharedTxState (..)) import Test.Ouroboros.Network.PeerSelection.PeerMetric (microbenchmark1GenerateInput, microbenchmark1ProcessInput) -import Test.Ouroboros.Network.TxSubmission.TxLogic as TX -import Test.Ouroboros.Network.TxSubmission.Types +import Test.Ouroboros.Network.TxSubmission.TxLogic qualified as TX + +benchLoops :: Int +benchLoops = 1_0000 main :: IO () main = @@ -35,73 +28,42 @@ main = , env (microbenchmark1GenerateInput False 100_000) $ \i -> bench "100k" $ nfAppIO microbenchmark1ProcessInput i ] - , bgroup "TxLogic" - [ env (do let a = TX.mkDecisionContext (SM.mkSMGen 131) 10 - evaluate (rnf a) - -- pPrint a - performMajorGC - traceMarkerIO "evaluated decision context" - return a - ) - (\(~a@(_policy, state)) -> - bench "makeDecisions: 10" - $ let f :: (TxDecisionPolicy, SharedTxState PeerAddr TxId (Tx TxId)) - -> ( SharedTxState PeerAddr TxId (Tx TxId) - , Map PeerAddr (Tx.TxDecision TxId (Tx TxId)) - ) - f = flip (uncurry Tx.makeDecisions) (peerTxStates state) - in nf f a - ) - , env (do let a = TX.mkDecisionContext (SM.mkSMGen 131) 100 - evaluate (rnf a) - -- pPrint a - performMajorGC - traceMarkerIO "evaluated decision context" - return a - ) - (\(~a@(_policy, state)) -> - bench "makeDecisions: 100" - $ let f :: ( TxDecisionPolicy - , SharedTxState PeerAddr TxId (Tx TxId) - ) - -> ( SharedTxState PeerAddr TxId (Tx TxId) - , Map PeerAddr (Tx.TxDecision TxId (Tx TxId)) - ) - f = flip (uncurry Tx.makeDecisions) (peerTxStates state) - in nf f a - ) - , env (do let a = TX.mkDecisionContext (SM.mkSMGen 361) 1_000 - evaluate (rnf a) - -- pPrint a - performMajorGC - traceMarkerIO "evaluated decision context" - return a - ) - (\(~a@(_policy, state)) -> - bench "makeDecisions: 1000" - $ let f :: ( TxDecisionPolicy - , SharedTxState PeerAddr TxId (Tx TxId) - ) - -> ( SharedTxState PeerAddr TxId (Tx TxId) - , Map PeerAddr (Tx.TxDecision TxId (Tx TxId)) - ) - f = flip (uncurry Tx.makeDecisions) (peerTxStates state) - in nf f a - ) -{- - , env (do - smGen <- SM.initSMGen - print smGen - let a = TX.mkDecisionContext smGen 1000 - evaluate (rnf a) - traceMarkerIO "evaluated decision context" - return a - ) - (\a -> - bench "makeDecisions: random" - $ nf (uncurry Tx.makeDecisions) a - ) --} + , bgroup "TxSubmissionV2" + [ env (prepareEnv (TX.mkReceiveDuplicateFixture 100 3)) $ \fixture -> + bench "handleReceivedTxIds/duplicate-active/100existing/3txids/x1000" $ + nfAppIO (TX.runReceiveDuplicateLoop benchLoops) fixture + , env (prepareEnv (TX.mkResolvedAckFixture 100 10)) $ \fixture -> + bench "nextPeerAction/ack-resolved-retained/100advertisers/10txids/x1000" $ + nfAppIO (TX.runPeerActionLoop benchLoops) fixture + , env (prepareEnv (TX.mkFanoutFixture 100 3)) $ \fixture -> + bench "scenario/fanout-retained/100peers/3txids/x1000" $ + nfAppIO (TX.runFanoutLoop benchLoops) fixture + , env + (prepareEnv (DirectV2.mkDirectServerFixture 1_000)) + $ \fixture -> + bench "server/direct-interpreter/single-peer/1000batches" $ + nfAppIO DirectV2.runDirectServerBenchmark fixture + , env + (prepareEnv (DirectV2.mkMultiPeerFixture 10 1_000)) + $ \fixture -> + bench "server/direct-interpreter/multi-peer/10peers/1000batches" $ + nfAppIO DirectV2.runDirectServerBenchmark fixture + , env + (prepareEnv (DirectV2.mkMultiPeerFixture 100 100)) + $ \fixture -> + bench "server/direct-interpreter/multi-peer/100peers/100batches" $ + nfAppIO DirectV2.runDirectServerBenchmark fixture + , env + (prepareEnv (DirectV2.mkMultiPeerFixture 100 1_000)) + $ \fixture -> + bench "server/direct-interpreter/multi-peer/100peers/1000batches" $ + nfAppIO DirectV2.runDirectServerBenchmark fixture ] ] ] + +prepareEnv :: NFData a => a -> IO a +prepareEnv a = do + _ <- evaluate (rnf a) + performMajorGC + pure a diff --git a/ouroboros-network/framework/lib/NoThunks/Class/Orphans.hs b/ouroboros-network/framework/lib/NoThunks/Class/Orphans.hs index 8bfa119b075..a61c1c6cb8d 100644 --- a/ouroboros-network/framework/lib/NoThunks/Class/Orphans.hs +++ b/ouroboros-network/framework/lib/NoThunks/Class/Orphans.hs @@ -7,6 +7,7 @@ module NoThunks.Class.Orphans where import Data.IntPSQ (IntPSQ) import Data.IntPSQ qualified as IntPSQ +import Data.IntSet (IntSet) import Data.OrdPSQ (OrdPSQ) import Data.OrdPSQ qualified as OrdPSQ @@ -33,3 +34,5 @@ instance (NoThunks k, NoThunks v) => NoThunks (IntPSQ k v) where showTypeOf _ = "IntPSQ" deriving via InspectHeap SockAddr instance NoThunks SockAddr + +deriving via InspectHeap IntSet instance NoThunks IntSet diff --git a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2.hs b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2.hs index cf25071361e..d5fd2ae6550 100644 --- a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2.hs +++ b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2.hs @@ -7,33 +7,69 @@ {-# LANGUAGE ScopedTypeVariables #-} module Ouroboros.Network.TxSubmission.Inbound.V2 - ( -- * TxSubmision Inbound client + ( -- * TxSubmission Inbound client txSubmissionInboundV2 -- * Supporting types and APIs , module V2 , TxDecisionPolicy (..) , defaultTxDecisionPolicy + , TxSubmissionInitDelay (..) ) 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 Data.Typeable (Typeable) -import Control.Exception (assert) -import Control.Monad (unless, when) +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad (unless) import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, traceWith) import Network.TypedProtocol import Ouroboros.Network.Protocol.TxSubmission2.Server +import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck, + SizeInBytes) import Ouroboros.Network.TxSubmission.Inbound.V2.Policy import Ouroboros.Network.TxSubmission.Inbound.V2.Registry as V2 -import Ouroboros.Network.TxSubmission.Inbound.V2.State +import Ouroboros.Network.TxSubmission.Inbound.V2.State qualified as State import Ouroboros.Network.TxSubmission.Inbound.V2.Types as V2 +-- The same Stateful types as V1 uses. +newtype Stateful s n txid tx m = Stateful (s -> ServerStIdle n txid tx m ()) + +newtype StatefulM s n txid tx m + = StatefulM (s -> m (ServerStIdle n txid tx m ())) + +newtype StatefulCollect s n txid tx m + = StatefulCollect (s -> Collect txid tx -> m (ServerStIdle n txid tx m ())) + +continueWithState :: Stateful s n txid tx m + -> s + -> ServerStIdle n txid tx m () +continueWithState (Stateful f) !st = + f st +{-# INLINE continueWithState #-} + +continueWithStateM :: StatefulM s n txid tx m + -> s + -> m (ServerStIdle n txid tx m ()) +continueWithStateM (StatefulM f) !st = + f st +{-# INLINE continueWithStateM #-} + +collectAndContinueWithState :: StatefulCollect s n txid tx m + -> s + -> Collect txid tx + -> m (ServerStIdle n txid tx m ()) +collectAndContinueWithState (StatefulCollect f) !st c = + f st c +{-# INLINE collectAndContinueWithState #-} + -- | A tx-submission inbound side (server, sic!). -- -- The server blocks on receiving `TxDecision` from the decision logic. If @@ -44,162 +80,299 @@ import Ouroboros.Network.TxSubmission.Inbound.V2.Types as V2 txSubmissionInboundV2 :: forall txid tx idx m err. ( MonadDelay m + , MonadSTM m , MonadThrow m , Ord txid + , Show txid + , Typeable txid ) => Tracer m (TraceTxSubmissionInbound txid tx) -> TxSubmissionInitDelay + -> TxDecisionPolicy -> TxSubmissionMempoolWriter txid tx idx m err + -> (tx -> SizeInBytes) -> PeerTxAPI m txid tx -> TxSubmissionServerPipelined txid tx m () txSubmissionInboundV2 tracer initDelay - TxSubmissionMempoolWriter { txId } + policy + TxSubmissionMempoolWriter { txId, mempoolAddTxs } + txSize PeerTxAPI { - readTxDecision, - handleReceivedTxIds, - handleReceivedTxs, - submitTxToMempool - } - = + awaitSharedChange, + runNextPeerAction, + runNextPeerActionPipelined, + applyReceivedTxIds, + applyReceivedTxs, + applySubmittedTxs, + resolveTxRequest, + resolveBufferedTxs, + addCounters + } = TxSubmissionServerPipelined $ do case initDelay of TxSubmissionInitDelay delay -> threadDelay delay NoTxSubmissionInitDelay -> return () - serverIdle + continueWithStateM serverIdle emptyPeerTxLocalState where - serverIdle - :: m (ServerStIdle Z txid tx m ()) - serverIdle = do - -- Block on next decision. - txd@TxDecision { txdTxsToRequest = txsToRequest, - txdTxsToMempool = TxsToMempool { listOfTxsToMempool } } - <- readTxDecision - traceWith tracer (TraceTxInboundDecision txd) - - let !collected = length listOfTxsToMempool - - -- Only attempt to add TXs if we have some work to do - when (collected > 0) $ do - -- submitTxToMempool traces: - -- * `TraceTxSubmissionProcessed`, - -- * `TraceTxInboundAddedToMempool`, and - -- * `TraceTxInboundRejectedFromMempool` - -- events. - mapM_ (uncurry $ submitTxToMempool tracer) listOfTxsToMempool - - -- TODO: - -- We can update the state so that other `tx-submission` servers will - -- not try to add these txs to the mempool. - if Map.null txsToRequest - then serverReqTxIds Zero txd - else serverReqTxs txd - - -- Pipelined request of txs - serverReqTxs :: TxDecision txid tx - -> m (ServerStIdle Z txid tx m ()) - serverReqTxs txd@TxDecision { txdTxsToRequest = txdTxsToRequest } = - pure $ SendMsgRequestTxsPipelined txdTxsToRequest - (serverReqTxIds (Succ Zero) txd) + -- Entry point and reset state for the non-pipelined server loop. + -- + -- This function is called when: + -- 1. The server first starts + -- 2. All pipelined requests have completed and the counter returns to zero + -- 3. An idle peer wakes up after a @PeerDoNothing@ wait + serverIdle :: StatefulM (PeerTxLocalState tx) Z txid tx m + serverIdle = StatefulM $ \peerState -> do + now <- getMonotonicTime + -- When the pipeline fully drains, emit the body-download episode + -- duration (covers all overlapping body and txid pipelined requests). + peerState' <- case peerDownloadStartTime peerState of + Nothing -> pure peerState + Just startTime -> do + addCounters mempty { txPipelineWaitMs = + diffTimeToMilliseconds (now `diffTime` startTime) } + pure $ peerState { peerDownloadStartTime = Nothing } + (peerAction, peerState'') <- runNextPeerAction now (State.drainPeerScore policy now peerState') + case peerAction of + PeerDoNothing generation mDelay -> do + -- An Active->Idle transition means this peer has just become + -- eligible for actions it could not take before (e.g. claiming + -- expired leases as an idle claimant). Re-run the scheduler + -- immediately rather than parking on a wake condition that may + -- not fire. + let cameToIdle = peerPhase peerState' /= PeerIdle + && peerPhase peerState'' == PeerIdle + if cameToIdle + then continueWithStateM serverIdle peerState'' + else do + awaitSharedChange generation mDelay + continueWithStateM serverIdle peerState'' + PeerSubmitTxs txKeys -> + continueWithStateM (submitBufferedTxs txKeys serverIdle) peerState'' + PeerRequestTxs txKeys -> + continueWithStateM (requestTxBodies Zero txKeys) peerState'' + PeerRequestTxIds _flavour txIdsToAck txIdsToReq -> + continueWithStateM (serverReqTxIds Zero txIdsToAck txIdsToReq) peerState'' + + -- | Submit buffered transaction bodies to the mempool. + submitBufferedTxs :: forall (n :: N). + [TxKey] + -> StatefulM (PeerTxLocalState tx) n txid tx m + -> StatefulM (PeerTxLocalState tx) n txid tx m + submitBufferedTxs txKeys k = StatefulM $ \peerState -> do + bufferedTxs <- resolveBufferedTxs peerState txKeys + + start <- getMonotonicTime + let submitted = [ (txKey, txid') | (txKey, txid', _) <- bufferedTxs ] + toSubmit = [ tx | (_, _, tx) <- bufferedTxs ] + + (acceptedTxIds, _) <- if null toSubmit + then pure ([], []) + else mempoolAddTxs toSubmit + end <- getMonotonicTime + + let (acceptedTxs, rejectedTxs) = + classifySubmittedTxs submitted (Set.fromList acceptedTxIds) + resolvedTxKeys = fmap fst acceptedTxs + rejectedForTrace = fmap snd rejectedTxs + rejectedCount = length rejectedForTrace + delta = end `diffTime` start + + addCounters mempty { txSubmissionWaitMs = diffTimeToMilliseconds delta } + peerState' <- applySubmittedTxs end resolvedTxKeys (fmap fst rejectedTxs) peerState + let (score, peerState'') = State.applyPeerRejections policy end rejectedCount peerState' + traceWith tracer $ + TraceTxSubmissionProcessed ProcessedTxCount { + ptxcAccepted = length acceptedTxs, + ptxcRejected = rejectedCount, + ptxcScore = score + } + unless (null acceptedTxs) $ + traceWith tracer (TraceTxInboundAddedToMempool (snd <$> acceptedTxs) delta) + unless (null rejectedForTrace) $ + traceWith tracer (TraceTxInboundRejectedFromMempool rejectedForTrace delta) + continueWithStateM k peerState'' + + -- Request transaction bodies from the peer. + requestTxBodies :: forall (n :: N). + Nat n + -> [TxKey] + -> StatefulM (PeerTxLocalState tx) n txid tx m + requestTxBodies n txKeys = StatefulM $ \peerState -> do + txsToRequest <- resolveTxRequest peerState txKeys + traceWith tracer (TraceTxInboundRequestTxs (Map.keys txsToRequest)) + + -- Record the start of the download episode on the first outstanding + -- body request. Subsequent pipelined requests leave the start time + -- unchanged so we measure from first-send to last-receive. + sendTime <- getMonotonicTime + let peerState' = case peerDownloadStartTime peerState of + Nothing -> peerState { peerDownloadStartTime = Just sendTime } + Just _ -> peerState + pure $ SendMsgRequestTxsPipelined txsToRequest + (continueWithStateM (continueAfterBodyRequests (Succ n)) peerState') + -- Continue processing after receiving replies from the peer in pipelined mode. + continueAfterReplies :: forall (n :: N). + Nat n + -> StatefulM (PeerTxLocalState tx) n txid tx m + continueAfterReplies Zero = serverIdle + continueAfterReplies n@Succ{} = StatefulM $ \peerState -> do + now <- getMonotonicTime + (peerAction, peerState') <- runNextPeerActionPipelined now (State.drainPeerScore policy now peerState) + case peerAction of + PeerSubmitTxs txKeys -> + continueWithStateM (submitBufferedTxs txKeys (continueAfterReplies n)) peerState' + PeerRequestTxs txKeys -> + continueWithStateM (requestTxBodies n txKeys) peerState' + PeerRequestTxIds _flavour txIdsToAck txIdsToReq -> + continueWithStateM (serverReqTxIds n txIdsToAck txIdsToReq) peerState' + PeerDoNothing {} -> + pure $ continueWithState (handleReplies n) peerState' + + -- Continue processing after receiving transaction body replies in pipelined mode. + continueAfterBodyRequests :: forall (n :: N). + Nat (S n) + -> StatefulM (PeerTxLocalState tx) (S n) txid tx m + continueAfterBodyRequests n = StatefulM $ \peerState -> do + now <- getMonotonicTime + (peerAction, peerState') <- runNextPeerActionPipelined now (State.drainPeerScore policy now peerState) + case peerAction of + PeerSubmitTxs txKeys -> + continueWithStateM (submitBufferedTxs txKeys (continueAfterReplies n)) peerState' + PeerRequestTxs txKeys -> + continueWithStateM (requestTxBodies n txKeys) peerState' + PeerRequestTxIds _flavour txIdsToAck txIdsToReq -> + continueWithStateM (serverReqTxIds n txIdsToAck txIdsToReq) peerState' + PeerDoNothing {} -> + pure $ continueWithState (handleReplies n) peerState' + + -- Construct and send a txid request message to the peer. serverReqTxIds :: forall (n :: N). Nat n - -> TxDecision txid tx - -> m (ServerStIdle n txid tx m ()) - serverReqTxIds - n TxDecision { txdTxIdsToRequest = 0 } - = - case n of - Zero -> serverIdle - Succ _ -> handleReplies n - - serverReqTxIds - -- if there are no unacknowledged txids, the protocol requires sending - -- a blocking `MsgRequestTxIds` request. This is important, as otherwise - -- the client side wouldn't have a chance to terminate the - -- mini-protocol. - Zero TxDecision { txdTxIdsToAcknowledge = txIdsToAck, - txdPipelineTxIds = False, - txdTxIdsToRequest = txIdsToReq - } - = - pure $ SendMsgRequestTxIdsBlocking - txIdsToAck txIdsToReq - -- Our result if the client terminates the protocol - (traceWith tracer TraceTxInboundTerminated) - (\txids -> do - let txids' = NonEmpty.toList txids - txidsSeq = StrictSeq.fromList $ fst <$> txids' - txidsMap = Map.fromList txids' - unless (StrictSeq.length txidsSeq <= fromIntegral txIdsToReq) $ - throwIO ProtocolErrorTxIdsNotRequested - handleReceivedTxIds txIdsToReq txidsSeq txidsMap - serverIdle - ) - - serverReqTxIds - n@Zero TxDecision { txdTxIdsToAcknowledge = txIdsToAck, - txdPipelineTxIds = True, - txdTxIdsToRequest = txIdsToReq - } - = - pure $ SendMsgRequestTxIdsPipelined - txIdsToAck txIdsToReq - (handleReplies (Succ n)) - - serverReqTxIds - n@Succ{} TxDecision { txdTxIdsToAcknowledge = txIdsToAck, - txdPipelineTxIds, - txdTxIdsToRequest = txIdsToReq - } - = - -- it is impossible that we have had `tx`'s to request (Succ{} - is an - -- evidence for that), but no unacknowledged `txid`s. - assert txdPipelineTxIds $ - pure $ SendMsgRequestTxIdsPipelined - txIdsToAck txIdsToReq - (handleReplies (Succ n)) + -> NumTxIdsToAck + -> NumTxIdsToReq + -> StatefulM (PeerTxLocalState tx) n txid tx m + -- No requests pending; transitions back to @serverIdle@ + serverReqTxIds Zero 0 0 = serverIdle + + -- Requests complete but pipeline not empty, continues to + -- @handleReplies@ to process remaining in-flight replies + serverReqTxIds n@Succ{} 0 0 = StatefulM $ \peerState -> + pure $ continueWithState (handleReplies n) peerState + -- Non-pipelined request, may send a blocking request + serverReqTxIds Zero txIdsToAck txIdsToReq = StatefulM $ \peerState -> + if StrictSeq.null (peerUnacknowledgedTxIds peerState) + then do + sendTime <- getMonotonicTime + pure $ SendMsgRequestTxIdsBlocking + txIdsToAck + txIdsToReq + (traceWith tracer TraceTxInboundTerminated) + (\txids -> do + now <- getMonotonicTime + addCounters mempty { txIdBlockingWaitMs = diffTimeToMilliseconds (now `diffTime` sendTime) } + let txids' = NonEmpty.toList txids + unless (length txids' <= fromIntegral txIdsToReq) $ + throwIO ProtocolErrorTxIdsNotRequested + peerState' <- applyReceivedTxIds now txIdsToReq txids' peerState + continueWithStateM serverIdle peerState') + else + pure $ SendMsgRequestTxIdsPipelined + txIdsToAck + txIdsToReq + (pure $ continueWithState (handleReplies (Succ Zero)) peerState) + -- Pipelined request at depth > 0. Sends a pipelined message and continues + -- to @handleReplies@. + serverReqTxIds n@Succ{} txIdsToAck txIdsToReq = StatefulM $ \peerState -> + pure $ SendMsgRequestTxIdsPipelined + txIdsToAck + txIdsToReq + (pure $ continueWithState (handleReplies (Succ n)) peerState) + + -- Prepare to collect pipelined replies from the peer. 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) + Nat (S n) + -> Stateful (PeerTxLocalState tx) (S n) txid tx m + handleReplies (Succ Zero) = Stateful $ \peerState -> + CollectPipelined Nothing (collectAndContinueWithState (handleReply Zero) peerState) + + handleReplies (Succ n'@Succ{}) = Stateful $ \peerState -> + CollectPipelined Nothing (collectAndContinueWithState (handleReply n') peerState) + -- Process a single pipelined reply from the peer. handleReply :: forall (n :: N). - m (ServerStIdle n txid tx m ()) - -- continuation - -> Collect txid tx - -> m (ServerStIdle n txid tx m ()) - handleReply k = \case + Nat n + -> StatefulCollect (PeerTxLocalState tx) n txid tx m + handleReply n = StatefulCollect $ \peerState -> \case CollectTxIds txIdsToReq txids -> do - let txidsSeq = StrictSeq.fromList $ fst <$> txids - txidsMap = Map.fromList txids - unless (StrictSeq.length txidsSeq <= fromIntegral txIdsToReq) $ + unless (length txids <= fromIntegral txIdsToReq) $ throwIO ProtocolErrorTxIdsNotRequested - handleReceivedTxIds txIdsToReq txidsSeq txidsMap - k - CollectTxs txids txs -> do - let requested = Map.keysSet txids - received = Map.fromList [ (txId tx, tx) | tx <- txs ] + now <- getMonotonicTime + peerState' <- applyReceivedTxIds now txIdsToReq txids peerState + continueWithStateM (continueAfterReplies n) peerState' - unless (Map.keysSet received `Set.isSubsetOf` requested) $ + CollectTxs requested txs -> do + let received = Map.fromList [ (txId tx, tx) | tx <- txs ] + wrongSizedTxs = collectWrongSizedTxs requested received + unless (Map.keysSet received `Set.isSubsetOf` Map.keysSet requested) $ throwIO ProtocolErrorTxNotRequested + traceWith tracer $ TraceTxSubmissionCollected (txId <$> txs) + unless (null wrongSizedTxs) $ do + let protocolError = ProtocolErrorTxSizeError wrongSizedTxs + traceWith tracer (TraceTxInboundError protocolError) + throwIO protocolError + now <- getMonotonicTime + (penaltyCount, peerState') <- applyReceivedTxs now [ (txId tx, tx) | tx <- txs ] peerState + peerState'' <- + if penaltyCount == 0 + then pure peerState' + else do + let (score, ps) = State.applyPeerRejections policy now penaltyCount peerState' + traceWith tracer $ + TraceTxSubmissionProcessed ProcessedTxCount { + ptxcAccepted = 0, + ptxcRejected = penaltyCount, + ptxcScore = score + } + pure ps + continueWithStateM (continueAfterReplies n) peerState'' + + -- Partition submitted transactions into accepted and rejected groups + classifySubmittedTxs :: [(TxKey, txid)] + -> Set.Set txid + -> ([(TxKey, txid)], [(TxKey, txid)]) + classifySubmittedTxs submitted accepted = + foldr classify ([], []) submitted + where + classify entry@(_, txid') (acceptedTxs, rejectedTxs) + | Set.member txid' accepted = (entry : acceptedTxs, rejectedTxs) + | otherwise = (acceptedTxs, entry : rejectedTxs) + + -- Collect transactions with size mismatches between advertised and actual. + collectWrongSizedTxs :: Map.Map txid SizeInBytes + -> Map.Map txid tx + -> [(txid, SizeInBytes, SizeInBytes)] + collectWrongSizedTxs requestedTxIds receivedTxs = + [ (txid', receivedSize, advertisedSize) + | (txid', tx) <- Map.toList receivedTxs + , let receivedSize = txSize tx + , Just advertisedSize <- [Map.lookup txid' requestedTxIds] + , not (checkTxSize receivedSize advertisedSize) + ] + + -- Fuzzy size comparison that allows for +/- const_MAX_TX_SIZE_DISCREPANCY. + checkTxSize :: SizeInBytes + -> SizeInBytes + -> Bool + checkTxSize received advertised + | received > advertised = + received - advertised <= const_MAX_TX_SIZE_DISCREPANCY + | otherwise = + advertised - received <= const_MAX_TX_SIZE_DISCREPANCY + - mbe <- handleReceivedTxs txids received - traceWith tracer $ TraceTxSubmissionCollected (txId `map` txs) - case mbe of - -- one of `tx`s had a wrong size - Just e -> traceWith tracer (TraceTxInboundError e) - >> throwIO e - Nothing -> k diff --git a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs deleted file mode 100644 index 552d2f728e9..00000000000 --- a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs +++ /dev/null @@ -1,417 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -module Ouroboros.Network.TxSubmission.Inbound.V2.Decision - ( TxDecision (..) - , emptyTxDecision - -- * Internal API exposed for testing - , makeDecisions - , filterActivePeers - , pickTxsToDownload - ) where - -import Control.Arrow ((>>>)) -import Control.Exception (assert) - -import Data.Bifunctor (second) -import Data.Hashable -import Data.List qualified as List -import Data.Map.Merge.Strict qualified as Map -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Maybe (mapMaybe) -import Data.Set (Set) -import Data.Set qualified as Set -import System.Random (random) - -import Data.Sequence.Strict qualified as StrictSeq -import Ouroboros.Network.Protocol.TxSubmission2.Type -import Ouroboros.Network.TxSubmission.Inbound.V2.Policy -import Ouroboros.Network.TxSubmission.Inbound.V2.State -import Ouroboros.Network.TxSubmission.Inbound.V2.Types - - --- | Make download decisions. --- -makeDecisions - :: forall peeraddr txid tx. - ( Ord peeraddr - , Ord txid - , Hashable peeraddr - ) - => TxDecisionPolicy - -- ^ decision policy - -> SharedTxState 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 st = - let (salt, rng') = random (peerRng st) - st' = st { peerRng = rng' } - in fn - . pickTxsToDownload policy st' - . orderByRejections salt - where - fn :: forall a. - (a, [(peeraddr, TxDecision txid tx)]) - -> (a, Map peeraddr (TxDecision txid tx)) - fn (a, as) = (a, Map.fromList as) - - --- | Order peers by how useful the TXs they have provided are. --- --- TXs delivered late will fail to apply because they were included in --- a recently adopted block. Peers can race against each other by setting --- `txInflightMultiplicity` to > 1. In case of a tie a hash of the peeraddr --- is used as a tie breaker. Since every invocation use a new salt a given --- peeraddr does not have an advantage over time. --- -orderByRejections :: Hashable peeraddr - => Int - -> Map peeraddr (PeerTxState txid tx) - -> [(peeraddr, PeerTxState txid tx)] -orderByRejections salt = - List.sortOn (\(peeraddr, ps) -> (score ps, hashWithSalt salt peeraddr)) - . Map.toList - - --- | Internal state of `pickTxsToDownload` computation. --- -data St peeraddr txid tx = - St { stInflight :: !(Map txid Int), - -- ^ `txid`s in-flight. - - stAcknowledged :: !(Map txid Int), - -- ^ acknowledged `txid` with multiplicities. It is used to update - -- `referenceCounts`. - - stInSubmissionToMempoolTxs :: !(Set txid) - -- ^ TXs on their way to the mempool. Used to prevent issueing new - -- fetch requests for them. - } - - --- | Distribute `tx`'s to download among available peers. Peers are considered --- in the given order. --- --- * pick txs from the set of available tx's (in `txid` order, note these sets --- might be different for different peers). --- * pick txs until the peers in-flight limit (we can go over the limit by one tx) --- (`txsSizeInflightPerPeer` limit) --- * 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, - txInflightMultiplicity } - sharedState@SharedTxState { peerTxStates, - inflightTxs, - bufferedTxs, - inSubmissionToMempoolTxs, - referenceCounts } = - -- outer fold: fold `[(peeraddr, PeerTxState txid tx)]` - List.mapAccumR - accumFn - -- initial state - St { stInflight = inflightTxs, - stAcknowledged = Map.empty, - stInSubmissionToMempoolTxs = Map.keysSet inSubmissionToMempoolTxs } - - >>> - 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, - stAcknowledged, - stInSubmissionToMempoolTxs } - ( peeraddr - , peerTxState@PeerTxState { availableTxIds, - unknownTxs, - requestedTxsInflight, - requestedTxsInflightSize - } - ) - = - let requestedTxsInflightSize' :: SizeInBytes - txsToRequestMap :: Map txid SizeInBytes - - (requestedTxsInflightSize', txsToRequestMap) = - -- 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 - -- 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, txSize)) - 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 - <> stInSubmissionToMempoolTxs - ) - ) - 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). - - txsToRequest = Map.keysSet txsToRequestMap - peerTxState' = peerTxState { - requestedTxsInflightSize = requestedTxsInflightSize', - requestedTxsInflight = requestedTxsInflight - <> txsToRequest - } - - ( numTxIdsToAck - , numTxIdsToReq - , txsToMempool@TxsToMempool { listOfTxsToMempool } - , RefCountDiff { txIdsToAck } - , peerTxState'' - ) = acknowledgeTxIds policy sharedState peerTxState' - - stAcknowledged' = Map.unionWith (+) stAcknowledged txIdsToAck - - stInflightDelta :: Map txid Int - stInflightDelta = Map.fromSet (\_ -> 1) txsToRequest - -- note: this is right since every `txid` - -- could be picked at most once - - stInflight' :: Map txid Int - stInflight' = Map.unionWith (+) stInflightDelta stInflight - - stInSubmissionToMempoolTxs' = stInSubmissionToMempoolTxs - <> Set.fromList (map fst listOfTxsToMempool) - in - if requestedTxIdsInflight peerTxState'' > 0 - then - -- we can request `txid`s & `tx`s - ( St { stInflight = stInflight', - stAcknowledged = stAcknowledged', - stInSubmissionToMempoolTxs = stInSubmissionToMempoolTxs' } - , ( (peeraddr, peerTxState'') - , TxDecision { txdTxIdsToAcknowledge = numTxIdsToAck, - txdPipelineTxIds = not - . StrictSeq.null - . unacknowledgedTxIds - $ peerTxState'', - txdTxIdsToRequest = numTxIdsToReq, - txdTxsToRequest = txsToRequestMap, - txdTxsToMempool = txsToMempool - } - ) - ) - else - -- there are no `txid`s to request, only `tx`s. - ( st { stInflight = stInflight', - stInSubmissionToMempoolTxs = stInSubmissionToMempoolTxs' - } - , ( (peeraddr, peerTxState'') - , emptyTxDecision { txdTxsToRequest = txsToRequestMap } - ) - ) - - gn :: ( St peeraddr txid tx - , [((peeraddr, PeerTxState txid tx), TxDecision txid tx)] - ) - -> ( SharedTxState peeraddr txid tx - , [(peeraddr, TxDecision txid tx)] - ) - gn - ( St { stInflight, - 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 - - inSubmissionToMempoolTxs' = - List.foldl' updateInSubmissionToMempoolTxs inSubmissionToMempoolTxs as - - in ( sharedState { - peerTxStates = peerTxStates', - inflightTxs = stInflight, - bufferedTxs = bufferedTxs', - referenceCounts = referenceCounts', - inSubmissionToMempoolTxs = inSubmissionToMempoolTxs'} - , -- exclude empty results - mapMaybe (\((a, _), b) -> case b of - TxDecision { txdTxIdsToAcknowledge = 0, - txdTxIdsToRequest = 0, - txdTxsToRequest, - txdTxsToMempool = TxsToMempool { listOfTxsToMempool } } - | null txdTxsToRequest - , null listOfTxsToMempool - -> Nothing - _ -> Just (a, b) - ) - as - ) - - where - updateInSubmissionToMempoolTxs - :: forall a. - Map txid Int - -> (a, TxDecision txid tx) - -> Map txid Int - updateInSubmissionToMempoolTxs m (_,TxDecision { txdTxsToMempool } ) = - List.foldl' fn m (listOfTxsToMempool txdTxsToMempool) - where - fn :: Map txid Int - -> (txid,tx) - -> Map txid Int - fn x (txid,_) = Map.alter (\case Nothing -> Just 1 - Just n -> Just $! succ n) txid x - - --- | Filter peers which can either download a `tx` or acknowledge `txid`s. --- -filterActivePeers - :: forall peeraddr txid tx. - Ord txid - => TxDecisionPolicy - -> SharedTxState peeraddr txid tx - -> Map peeraddr (PeerTxState txid tx) -filterActivePeers - policy@TxDecisionPolicy { - maxUnacknowledgedTxIds, - txsSizeInflightPerPeer, - txInflightMultiplicity - } - sharedTxState@SharedTxState { - peerTxStates, - bufferedTxs, - inflightTxs, - inSubmissionToMempoolTxs - } = Map.filter gn peerTxStates - where - unrequestable = Map.keysSet (Map.filter (>= txInflightMultiplicity) inflightTxs) - <> Map.keysSet bufferedTxs - - gn :: PeerTxState txid tx -> Bool - gn peerTxState@PeerTxState { unacknowledgedTxIds, - requestedTxIdsInflight, - requestedTxsInflight, - requestedTxsInflightSize, - availableTxIds, - unknownTxs - } = - ( requestedTxIdsInflight == 0 - && requestedTxIdsInflight + numOfUnacked <= maxUnacknowledgedTxIds - && txIdsToRequest > 0 - ) - || (underSizeLimit && not (Map.null downloadable)) - where - numOfUnacked = fromIntegral (StrictSeq.length unacknowledgedTxIds) - underSizeLimit = requestedTxsInflightSize <= txsSizeInflightPerPeer - downloadable = availableTxIds - `Map.withoutKeys` requestedTxsInflight - `Map.withoutKeys` unknownTxs - `Map.withoutKeys` unrequestable - `Map.withoutKeys` Map.keysSet inSubmissionToMempoolTxs - - -- Split `unacknowledgedTxIds'` into the longest prefix of `txid`s which - -- can be acknowledged and the unacknowledged `txid`s. - (txIdsToRequest, _, _) = splitAcknowledgedTxIds policy sharedTxState peerTxState - --- --- Auxiliary functions --- - --- | A fold with state implemented as a `foldr` to take advantage of fold-build --- fusion optimisation. --- -foldWithState - :: forall s a b c. - Ord b - => (a -> s -> Maybe (s, (b, c))) - -> [a] -> s -> (s, Map b c) -{-# INLINE foldWithState #-} - -foldWithState f = foldr cons nil - where - cons :: a - -> (s -> (s, Map b c)) - -> (s -> (s, Map b c)) - cons a k = \ !s -> - case f a s of - Nothing -> nil s - Just (!s', (!b, !c)) -> - case Map.insert b c `second` k s' of - r@(!_s, !_bs) -> r - - nil :: s -> (s, Map b c) - nil = \ !s -> (s, Map.empty) diff --git a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/Policy.hs b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/Policy.hs index a9d2fad9a4e..b912adca4a9 100644 --- a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/Policy.hs +++ b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/Policy.hs @@ -45,6 +45,9 @@ data TxDecisionPolicy = TxDecisionPolicy { -- ^ a limit of tx size in-flight from a single peer. -- It can be exceed by max tx size. + maxOutstandingTxBatchesPerPeer :: !Int, + -- ^ a limit of outstanding tx-body request batches from a single peer. + txInflightMultiplicity :: !Int, -- ^ from how many peers download the `txid` simultaneously @@ -55,11 +58,18 @@ data TxDecisionPolicy = TxDecisionPolicy { scoreRate :: !Double, -- ^ rate at which "rejected" TXs drain. Unit: TX/seconds. - scoreMax :: !Double + scoreMax :: !Double, -- ^ Maximum number of "rejections". Unit: seconds + interTxSpace :: !DiffTime, + -- ^ space between actual requests for the same TX. + + inflightTimeout :: !DiffTime + -- ^ Maximum time a peer's attempt may sit between claim and + -- entering submission before the per-entry inflight-multiplicity + -- cap is bumped, allowing another peer to attempt in parallel. } - deriving Show + deriving (Eq, Show) instance NFData TxDecisionPolicy where rnf TxDecisionPolicy{} = () @@ -67,11 +77,14 @@ instance NFData TxDecisionPolicy where defaultTxDecisionPolicy :: TxDecisionPolicy defaultTxDecisionPolicy = TxDecisionPolicy { - maxNumTxIdsToRequest = 3, + maxNumTxIdsToRequest = 6, maxUnacknowledgedTxIds = 10, -- must be the same as txSubmissionMaxUnacked txsSizeInflightPerPeer = max_TX_SIZE * 6, + maxOutstandingTxBatchesPerPeer = 4, txInflightMultiplicity = 2, bufferedTxsMinLifetime = 2, scoreRate = 0.1, - scoreMax = 15 * 60 + scoreMax = 15 * 60, + interTxSpace = 0.250, + inflightTimeout = 1.0 -- = 4 * interTxSpace } diff --git a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs index 3da6691bd00..b4ec49619b6 100644 --- a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs +++ b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/Registry.hs @@ -1,547 +1,552 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} module Ouroboros.Network.TxSubmission.Inbound.V2.Registry - ( TxChannels (..) - , TxChannelsVar - , TxMempoolSem - , SharedTxStateVar - , newSharedTxStateVar - , newTxChannelsVar - , newTxMempoolSem + ( SharedTxStateVar + , PeerTxInFlightRegistry , PeerTxAPI (..) - , decisionLogicThreads + , TxSubmissionCountersVar + , newSharedTxStateVar + , newPeerTxInFlightRegistry + , newTxSubmissionCountersVar + , txCountersThreadV2 , withPeer ) where -import Control.Concurrent.Class.MonadMVar.Strict +import Control.Concurrent.Class.MonadSTM qualified as Lazy import Control.Concurrent.Class.MonadSTM.Strict -import Control.Concurrent.Class.MonadSTM.TSem -import Control.Exception (assert) -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadFork +import Control.Monad (when) import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, traceWith) - -import Data.Foldable as Foldable (foldl', traverse_) -import Data.Hashable +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet 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 qualified as Set -import Data.Typeable (Typeable) import Data.Void (Void) +import Data.Word (Word64) import Ouroboros.Network.Protocol.TxSubmission2.Type -import Ouroboros.Network.TxSubmission.Inbound.V2.Decision -import Ouroboros.Network.TxSubmission.Inbound.V2.Policy -import Ouroboros.Network.TxSubmission.Inbound.V2.State +import Ouroboros.Network.Tx (HasRawTxId) +import Ouroboros.Network.TxSubmission.Inbound.V2.Policy (TxDecisionPolicy (..)) +import Ouroboros.Network.TxSubmission.Inbound.V2.State qualified as State import Ouroboros.Network.TxSubmission.Inbound.V2.Types import Ouroboros.Network.TxSubmission.Mempool.Reader --- | Communication channels between `TxSubmission` client mini-protocol and --- decision logic. --- -newtype TxChannels m peeraddr txid tx = TxChannels { - txChannelMap :: Map peeraddr (StrictMVar m (TxDecision txid tx)) - } +-- | Shared STM handle for V2 coordination state. +type SharedTxStateVar m peeraddr txid = StrictTVar m (SharedTxState peeraddr txid) -type TxChannelsVar m peeraddr txid tx = StrictMVar m (TxChannels m peeraddr txid tx) +-- | STM handle for V2 monotonic counters. +type TxSubmissionCountersVar m = StrictTVar m TxSubmissionCounters -newTxChannelsVar :: MonadMVar m => m (TxChannelsVar m peeraddr txid tx) -newTxChannelsVar = newMVar (TxChannels Map.empty) +-- | Per-peer in-flight TVar. +type PeerTxInFlightVar m = StrictTVar m PeerTxInFlight -newtype TxMempoolSem m = TxMempoolSem (TSem m) - -newTxMempoolSem :: MonadSTM m => m (TxMempoolSem m) -newTxMempoolSem = TxMempoolSem <$> atomically (newTSem 1) +-- | Registry of every live peer's 'PeerTxInFlightVar'. +-- +-- 'withPeer' adds the peer's TVar on bracket-enter and removes it on +-- bracket-exit (after scrubbing any contributions the peer still has +-- to shared state). The sweep snapshots this map to compute the +-- @liveAdvertised@ union without touching peer-local protocol state. +type PeerTxInFlightRegistry m peeraddr = + StrictTVar m (Map peeraddr (PeerTxInFlightVar m)) + +newSharedTxStateVar + :: MonadSTM m + => SharedTxState peeraddr txid + -> m (SharedTxStateVar m peeraddr txid) +newSharedTxStateVar = newTVarIO + +newTxSubmissionCountersVar + :: MonadSTM m + => TxSubmissionCounters + -> m (TxSubmissionCountersVar m) +newTxSubmissionCountersVar = newTVarIO + +newPeerTxInFlightRegistry + :: MonadSTM m + => m (PeerTxInFlightRegistry m peeraddr) +newPeerTxInFlightRegistry = newTVarIO Map.empty + +-- | Central bookkeeping thread for V2. +-- +-- Wakes every @'bufferedTxsMinLifetime' policy \/ 4@ seconds (capped +-- between 100 ms and 1 s) to run 'State.sweepSharedState' on the +-- shared tx state. The sweep needs the union of every live peer's +-- 'pifAdvertised' to decide which entries are still wanted; the +-- registry is read inside the same STM transaction as the sweep so +-- the snapshot is coherent. On a slower cadence (every +-- 'countersInterval' seconds of elapsed time) it also emits the +-- current counters when they differ from the last emission. +txCountersThreadV2 + :: forall m peeraddr txid. + (MonadDelay m, MonadSTM m, HasRawTxId txid) + => TxDecisionPolicy + -> Tracer m TxSubmissionCounters + -> TxSubmissionCountersVar m + -> SharedTxStateVar m peeraddr txid + -> PeerTxInFlightRegistry m peeraddr + -> m Void +txCountersThreadV2 policy tracer countersVar sharedStateVar registry = do + now <- getMonotonicTime + go mempty (addTime countersInterval now) + where + sweepInterval :: DiffTime + sweepInterval = max 0.1 (min 1 (bufferedTxsMinLifetime policy / 4)) + + countersInterval :: DiffTime + countersInterval = 7 + + go !previous !nextEmitAt = do + threadDelay sweepInterval + now <- getMonotonicTime + atomically $ do + liveReferences <- snapshotLiveReferences registry + modifyTVar sharedStateVar (State.sweepSharedState now liveReferences) + if now >= nextEmitAt + then do + current <- readTVarIO countersVar + when (current /= previous) $ traceWith tracer current + go current (addTime countersInterval now) + else go previous nextEmitAt + +-- | Read every live peer's 'pifAdvertised' and 'pifAcksPending' and +-- union them. This is the set of keys still referenced by some peer +-- (advertised for fetch, or held in @peerUnacknowledgedTxIds@ awaiting +-- ack) and is used by the sweep to know which lookup table entries +-- can be safely reclaimed. +snapshotLiveReferences + :: MonadSTM m + => PeerTxInFlightRegistry m peeraddr + -> STM m IntSet +snapshotLiveReferences registry = do + peers <- readTVar registry + foldr step (pure IntSet.empty) (Map.elems peers) + where + step var k = do + pif <- readTVar var + acc <- k + pure $! IntSet.union (pifAdvertised pif) + $ IntSet.union (pifAcksPending pif) acc --- | API to access `PeerTxState` inside `PeerTxStateVar`. +-- | Peer-facing coordination API. -- +-- The peer thread keeps its local protocol state in a local +-- variable. Registry helpers operate only on the shared STM state +-- and the per-peer 'PeerTxInFlight' TVar (closure-captured); any +-- helper that needs peer-local state should take it explicitly as an +-- argument. 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 :: Map txid SizeInBytes - -- ^ requested txids - -> Map txid tx - -- ^ received txs - -> m (Maybe TxSubmissionProtocolError), - -- ^ handle received txs - - submitTxToMempool :: Tracer m (TraceTxSubmissionInbound txid tx) - -> txid -> tx -> m () - -- ^ submit the given (txid, tx) to the mempool. + -- | Wait until either 'sharedGeneration' moves past the given + -- value or the optional timeout expires. + awaitSharedChange :: Word64 + -> Maybe DiffTime + -> m (), + + -- | Compute the next action for this peer in non-pipelined mode. + runNextPeerAction :: Time + -> PeerTxLocalState tx + -> m (PeerAction, PeerTxLocalState tx), + + -- | Compute the next action for this peer in pipelined mode. + runNextPeerActionPipelined :: Time + -> PeerTxLocalState tx + -> m (PeerAction, PeerTxLocalState tx), + + -- | Process a batch of txids received from this peer. + applyReceivedTxIds :: Time + -> NumTxIdsToReq + -> [(txid, SizeInBytes)] + -> PeerTxLocalState tx + -> m (PeerTxLocalState tx), + + -- | Process a batch of tx bodies received from this peer. + applyReceivedTxs :: Time + -> [(txid, tx)] + -> PeerTxLocalState tx + -> m (Int, PeerTxLocalState tx), + + -- | Mark txs as submitted to the mempool and update shared state. + applySubmittedTxs :: Time + -> [TxKey] + -> [TxKey] + -> PeerTxLocalState tx + -> m (PeerTxLocalState tx), + + -- | Resolve txids and advertised sizes for a batch of tx keys to request. + resolveTxRequest :: PeerTxLocalState tx + -> [TxKey] + -> m (Map txid SizeInBytes), + -- | Resolve buffered tx bodies into full submission records. + resolveBufferedTxs :: PeerTxLocalState tx + -> [TxKey] + -> m [(TxKey, txid, tx)], + + -- | Add a delta to the V2 monotonic counters. + addCounters :: TxSubmissionCounters -> m () } - -data TxMempoolResult = TxAccepted | TxRejected - +-- -- | A bracket function which registers / de-registers a new peer in --- `SharedTxStateVar` and `PeerTxStateVar`s, which exposes `PeerTxStateAPI`. +-- `SharedTxStateVar`, which exposes `PeerTxStateAPI`. -- `PeerTxStateAPI` is only safe inside the `withPeer` scope. -- withPeer - :: forall tx peeraddr txid idx m err a. - ( MonadMask m - , MonadMVar m - , MonadSTM m - , MonadMonotonicTime m - , Ord txid - , Show txid - , Typeable txid - , Ord peeraddr - , Show peeraddr - ) - => Tracer m (TraceTxLogic peeraddr txid tx) - -> TxChannelsVar m peeraddr txid tx - -> TxMempoolSem m - -> TxDecisionPolicy - -> SharedTxStateVar m peeraddr txid tx - -> TxSubmissionMempoolReader txid tx idx m - -> TxSubmissionMempoolWriter txid tx idx m err - -> (tx -> SizeInBytes) - -> peeraddr - -- ^ new peer - -> (PeerTxAPI m txid tx -> m a) - -- ^ callback which gives access to `PeerTxStateAPI` - -> m a -withPeer tracer - channelsVar - (TxMempoolSem mempoolSem) - policy@TxDecisionPolicy { bufferedTxsMinLifetime } - sharedStateVar - TxSubmissionMempoolReader { mempoolGetSnapshot } - TxSubmissionMempoolWriter { mempoolAddTxs } - txSize - peeraddr io = - bracket - (do -- create a communication channel - !peerTxAPI <- - modifyMVar channelsVar - \ TxChannels { txChannelMap } -> do - chann <- newEmptyMVar - let (chann', txChannelMap') = - Map.alterF (\mbChann -> - let !chann'' = fromMaybe chann mbChann - in (chann'', Just chann'')) - peeraddr - txChannelMap - return - ( TxChannels { txChannelMap = txChannelMap' } - , PeerTxAPI { readTxDecision = takeMVar chann', - handleReceivedTxIds, - handleReceivedTxs, - submitTxToMempool } - ) - - atomically $ modifyTVar sharedStateVar registerPeer - return peerTxAPI - ) - -- the handler is a short blocking operation, thus we need to use - -- `uninterruptibleMask_` - (\_ -> uninterruptibleMask_ do - atomically $ modifyTVar sharedStateVar unregisterPeer - modifyMVar_ channelsVar - \ TxChannels { txChannelMap } -> - return TxChannels { txChannelMap = Map.delete peeraddr txChannelMap } - ) - io + :: forall peeraddr txid tx idx m a. + ( MonadMask m + , MonadTimer m + , Ord peeraddr + , Ord txid + , HasRawTxId txid + ) + => TxDecisionPolicy + -> TxSubmissionMempoolReader txid tx idx m + -> SharedTxStateVar m peeraddr txid + -> PeerTxInFlightRegistry m peeraddr + -> TxSubmissionCountersVar m + -> peeraddr + -> (PeerTxAPI m txid tx -> m a) + -> m a +withPeer policy TxSubmissionMempoolReader { mempoolGetSnapshot } + sharedStateVar registry countersVar peeraddr io = + bracket acquire release run where - registerPeer :: SharedTxState peeraddr txid tx - -> SharedTxState peeraddr txid tx - registerPeer st@SharedTxState { peerTxStates } = - st { peerTxStates = - Map.insert - peeraddr - PeerTxState { - availableTxIds = Map.empty, - requestedTxIdsInflight = 0, - requestedTxsInflightSize = 0, - requestedTxsInflight = Set.empty, - unacknowledgedTxIds = StrictSeq.empty, - unknownTxs = Set.empty, - score = 0, - scoreTs = Time 0, - downloadedTxs = Map.empty, - toMempoolTxs = Map.empty } - peerTxStates - } - - -- TODO: this function needs to be tested! - -- Issue: https://github.com/IntersectMBO/ouroboros-network/issues/5151 - unregisterPeer :: SharedTxState peeraddr txid tx - -> SharedTxState peeraddr txid tx - unregisterPeer st@SharedTxState { peerTxStates, - bufferedTxs, - referenceCounts, - inflightTxs, - inSubmissionToMempoolTxs } = - st { peerTxStates = peerTxStates', - bufferedTxs = bufferedTxs', - referenceCounts = referenceCounts', - inflightTxs = inflightTxs', - inSubmissionToMempoolTxs = inSubmissionToMempoolTxs' } - where - (PeerTxState { unacknowledgedTxIds, - requestedTxsInflight, - toMempoolTxs } - , peerTxStates') - = - Map.alterF - (\case - Nothing -> error ("TxSubmission.withPeer: invariant violation for peer " ++ show peeraddr) - Just a -> (a, Nothing)) - peeraddr - peerTxStates - - referenceCounts' = - Foldable.foldl' - (flip $ Map.update \cnt -> - if cnt > 1 - then Just $! pred cnt - else Nothing - ) - referenceCounts - unacknowledgedTxIds - - liveSet = Map.keysSet referenceCounts' - - bufferedTxs' = bufferedTxs - `Map.restrictKeys` - liveSet - - inflightTxs' = Foldable.foldl' purgeInflightTxs inflightTxs requestedTxsInflight - - -- When we unregister a peer, we need to subtract all txs in the - -- `toMempoolTxs`, as they will not be submitted to the mempool. - inSubmissionToMempoolTxs' = - Foldable.foldl' (flip $ Map.update \cnt -> - if cnt > 1 - then Just $! pred cnt - else Nothing - ) - inSubmissionToMempoolTxs - (Map.keysSet toMempoolTxs) - - purgeInflightTxs m txid = Map.alter fn txid m - where - fn (Just n) | n > 1 = Just $! pred n - fn _ = Nothing - - -- - -- PeerTxAPI - -- - - submitTxToMempool :: Tracer m (TraceTxSubmissionInbound txid tx) -> txid -> tx -> m () - submitTxToMempool txTracer txid tx = - bracket_ (atomically $ waitTSem mempoolSem) - (atomically $ signalTSem mempoolSem) - $ do - start <- getMonotonicTime - res <- addTx - end <- getMonotonicTime - atomically $ modifyTVar sharedStateVar (updateBufferedTx end res) - let duration = end `diffTime` start - case res of - TxAccepted -> traceWith txTracer (TraceTxInboundAddedToMempool [txid] duration) - TxRejected -> traceWith txTracer (TraceTxInboundRejectedFromMempool [txid] duration) - - where - -- add the tx to the mempool - addTx :: m TxMempoolResult - addTx = do - mpSnapshot <- atomically mempoolGetSnapshot - - -- Note that checking if the mempool contains a TX before - -- spending several ms attempting to add it to the pool has - -- been judged immoral. - if mempoolHasTx mpSnapshot txid - then do - !now <- getMonotonicTime - !s <- countRejectedTxs now 1 - traceWith txTracer $ TraceTxSubmissionProcessed ProcessedTxCount { - ptxcAccepted = 0 - , ptxcRejected = 1 - , ptxcScore = s - } - return TxRejected - else do - (acceptedTxs, _) <- mempoolAddTxs [tx] - end <- getMonotonicTime - case acceptedTxs of - [] -> do - !s <- countRejectedTxs end 1 - traceWith txTracer $ TraceTxSubmissionProcessed ProcessedTxCount { - ptxcAccepted = 0 - , ptxcRejected = 1 - , ptxcScore = s - } - return TxRejected - (_:_) -> do - !s <- countRejectedTxs end 0 - traceWith txTracer $ TraceTxSubmissionProcessed ProcessedTxCount { - ptxcAccepted = 1 - , ptxcRejected = 0 - , ptxcScore = s - } - return TxAccepted - - updateBufferedTx :: Time - -> TxMempoolResult - -> SharedTxState peeraddr txid tx - -> SharedTxState peeraddr txid tx - updateBufferedTx _ TxRejected st@SharedTxState { peerTxStates - , inSubmissionToMempoolTxs } = - st { peerTxStates = peerTxStates' - , inSubmissionToMempoolTxs = inSubmissionToMempoolTxs' } - where - inSubmissionToMempoolTxs' = - Map.update (\case 1 -> Nothing; n -> Just $! pred n) - txid inSubmissionToMempoolTxs - - peerTxStates' = Map.update fn peeraddr peerTxStates - where - fn ps = Just $! ps { toMempoolTxs = Map.delete txid (toMempoolTxs ps)} - - updateBufferedTx now TxAccepted - st@SharedTxState { peerTxStates - , bufferedTxs - , referenceCounts - , timedTxs - , inSubmissionToMempoolTxs } = - st { peerTxStates = peerTxStates' - , bufferedTxs = bufferedTxs' - , timedTxs = timedTxs' - , referenceCounts = referenceCounts' - , inSubmissionToMempoolTxs = inSubmissionToMempoolTxs' - } - where - inSubmissionToMempoolTxs' = - Map.update (\case 1 -> Nothing; n -> Just $! pred n) - txid inSubmissionToMempoolTxs - - timedTxs' = Map.alter fn (addTime bufferedTxsMinLifetime now) timedTxs - where - fn :: Maybe [txid] -> Maybe [txid] - fn Nothing = Just [txid] - fn (Just txids) = Just $! (txid:txids) - - referenceCounts' = Map.alter fn txid referenceCounts - where - fn :: Maybe Int -> Maybe Int - fn Nothing = Just 1 - fn (Just n) = Just $! succ n - - bufferedTxs' = Map.insert txid (Just tx) bufferedTxs - - peerTxStates' = Map.update fn peeraddr peerTxStates - where - fn ps = Just $! ps { toMempoolTxs = Map.delete txid (toMempoolTxs ps)} - - handleReceivedTxIds :: NumTxIdsToReq - -> StrictSeq txid - -> Map txid SizeInBytes - -> m () - handleReceivedTxIds numTxIdsToReq txidsSeq txidsMap = - receivedTxIds tracer - sharedStateVar - mempoolGetSnapshot - peeraddr - numTxIdsToReq - txidsSeq - txidsMap - - - handleReceivedTxs :: Map txid SizeInBytes - -- ^ requested txids with their announced size - -> Map txid tx - -- ^ received txs - -> m (Maybe TxSubmissionProtocolError) - handleReceivedTxs txids txs = - collectTxs tracer txSize sharedStateVar peeraddr txids txs - - -- Update `score` & `scoreTs` fields of `PeerTxState`, return the new - -- updated `score`. - -- - -- PRECONDITION: the `Double` argument is non-negative. - countRejectedTxs :: Time - -> Double - -> m Double - countRejectedTxs _ n | n < 0 = - error ("TxSubmission.countRejectedTxs: invariant violation for peer " ++ show peeraddr) - countRejectedTxs now n = atomically $ stateTVar sharedStateVar $ \st -> - let (result, peerTxStates') = Map.alterF fn peeraddr (peerTxStates st) - in (result, st { peerTxStates = peerTxStates' }) - where - fn :: Maybe (PeerTxState txid tx) -> (Double, Maybe (PeerTxState txid tx)) - fn Nothing = error ("TxSubmission.withPeer: invariant violation for peer " ++ show peeraddr) - fn (Just ps) = (score ps', Just $! ps') - where - ps' = updateRejects policy now n ps - - -updateRejects :: TxDecisionPolicy - -> Time - -> Double - -> PeerTxState txid tx - -> PeerTxState txid tx -updateRejects _ now 0 pts | score pts == 0 = pts {scoreTs = now} -updateRejects TxDecisionPolicy { scoreRate, scoreMax } now n - pts@PeerTxState { score, scoreTs } = - let duration = diffTime now scoreTs - !drain = realToFrac duration * scoreRate - !drained = max 0 $ score - drain in - pts { score = min scoreMax $ drained + n - , scoreTs = now + acquire = do + peerInFlightVar <- newTVarIO emptyPeerTxInFlight + atomically $ modifyTVar registry (Map.insert peeraddr peerInFlightVar) + pure peerInFlightVar + + release peerInFlightVar = do + now <- getMonotonicTime + atomically $ do + pif <- readTVar peerInFlightVar + modifyTVar sharedStateVar (scrubFromPeerInFlight peeraddr now pif) + modifyTVar registry (Map.delete peeraddr) + + run peerInFlightVar = io PeerTxAPI { + awaitSharedChange = awaitSharedChangeImp sharedStateVar + , runNextPeerAction = runNextPeerActionImp policy sharedStateVar + peerInFlightVar countersVar peeraddr + , runNextPeerActionPipelined = runNextPeerActionPipelinedImp policy + sharedStateVar peerInFlightVar + countersVar peeraddr + , applyReceivedTxIds = applyReceivedTxIdsImp policy mempoolGetSnapshot + sharedStateVar peerInFlightVar countersVar + , applyReceivedTxs = applyReceivedTxsImp policy mempoolGetSnapshot + sharedStateVar peerInFlightVar countersVar peeraddr + , applySubmittedTxs = applySubmittedTxsImp policy sharedStateVar + peerInFlightVar countersVar peeraddr + , resolveTxRequest = resolveTxRequestImp sharedStateVar + , resolveBufferedTxs = resolveBufferedTxsImp sharedStateVar + , addCounters = \delta -> atomically $ modifyTVar countersVar (<> delta) } - -drainRejectionThread - :: forall m peeraddr txid tx. - ( MonadDelay m - , MonadSTM m - , MonadThread m - , Ord txid - ) - => Tracer m (TraceTxLogic peeraddr txid tx) - -> TxDecisionPolicy - -> SharedTxStateVar m peeraddr txid tx - -> m Void -drainRejectionThread tracer 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 - st'' <- 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 - { peerTxStates = ptss } - writeTVar sharedStateVar st' - return st' - traceWith tracer (TraceSharedTxState "drainRejectionThread" st'') - - if now > nextDrain - then go $ addTime drainInterval now - else go nextDrain - - -decisionLogicThread - :: forall m peeraddr txid tx. - ( MonadDelay m - , MonadMVar m - , MonadSTM m - , MonadMask m - , MonadFork m - , Ord peeraddr - , Ord txid - , Hashable peeraddr - ) - => Tracer m (TraceTxLogic peeraddr txid tx) - -> Tracer m TxSubmissionCounters - -> TxDecisionPolicy - -> TxChannelsVar m peeraddr txid tx - -> SharedTxStateVar m peeraddr txid tx - -> m Void -decisionLogicThread tracer counterTracer policy txChannelsVar sharedStateVar = do - labelThisThread "tx-decision" - go +-- | Reverse this peer's still-outstanding contributions to the shared +-- 'TxEntry' counters. Run by the bracket finalizer; uses the per-peer +-- TVar snapshot taken at exit time. +-- +-- 'pifLeased' is best-effort (another peer can steal the lease in the +-- meantime), so the lease release verifies the entry still names this +-- peer as owner before claiming. +scrubFromPeerInFlight + :: Eq peeraddr + => peeraddr + -> Time + -> PeerTxInFlight + -> SharedTxState peeraddr txid + -> SharedTxState peeraddr txid +scrubFromPeerInFlight peeraddr now pif st + | nothingToDo = st + | otherwise = st { + sharedTxTable = sharedTxTable', + sharedGeneration = sharedGeneration st + 1 + } 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 _DECISION_LOOP_DELAY - - (decisions, st) <- atomically do - sharedTxState <- readTVar sharedStateVar - let activePeers = filterActivePeers policy sharedTxState - - -- block until at least one peer is active - check (not (Map.null activePeers)) - - let (sharedState, decisions) = makeDecisions policy sharedTxState activePeers - writeTVar sharedStateVar sharedState - return (decisions, sharedState) - traceWith tracer (TraceSharedTxState "decisionLogicThread" st) - traceWith tracer (TraceTxDecisions decisions) - TxChannels { txChannelMap } <- readMVar txChannelsVar - traverse_ - (\(mvar, d) -> - modifyMVarWithDefault_ mvar d (\d' -> - let left = Set.fromList . fmap fst $ listOfTxsToMempool (txdTxsToMempool d) - right = Set.fromList . fmap fst $ listOfTxsToMempool (txdTxsToMempool d') - shared = Set.intersection left right - in assert (Set.null shared) $ pure (d' <> d))) - (Map.intersectionWith (,) - txChannelMap - decisions) - traceWith counterTracer (mkTxSubmissionCounters st) - 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 - - --- | Run `decisionLogicThread` and `drainRejectionThread`. + nothingToDo = + IntSet.null (pifLeased pif) + && IntSet.null (pifAttempting pif) + && IntSet.null (pifSubmitting pif) + + sharedTxTable' = + IntSet.foldl' clearSubmission + (IntSet.foldl' decAttempt + (IntSet.foldl' releaseLease (sharedTxTable st) + (pifLeased pif)) + (pifAttempting pif)) + (pifSubmitting pif) + + releaseLease tbl k = + IntMap.adjust + (\entry -> case txLease entry of + TxLeased owner _ | owner == peeraddr -> + entry { txLease = TxClaimable now } + _ -> entry) + k tbl + + decAttempt tbl k = + IntMap.adjust + (\entry -> entry { txAttempt = max 0 (txAttempt entry - 1) }) + k tbl + + clearSubmission tbl k = + IntMap.adjust + (\entry -> entry { txInSubmission = False }) + k tbl + +-- | Wait until either 'sharedGeneration' moves past the given value or the +-- optional timeout expires. -- -decisionLogicThreads - :: forall m peeraddr txid tx. - ( MonadDelay m - , MonadMVar m - , MonadMask m - , MonadAsync m - , MonadFork m - , Ord peeraddr - , Ord txid - , Hashable peeraddr - ) - => Tracer m (TraceTxLogic peeraddr txid tx) - -> Tracer m TxSubmissionCounters - -> TxDecisionPolicy - -> TxChannelsVar m peeraddr txid tx - -> SharedTxStateVar m peeraddr txid tx - -> m Void -decisionLogicThreads tracer counterTracer policy txChannelsVar sharedStateVar = - uncurry (<>) <$> - drainRejectionThread tracer policy sharedStateVar - `concurrently` - decisionLogicThread tracer counterTracer policy txChannelsVar sharedStateVar - - --- `5ms` delay -_DECISION_LOOP_DELAY :: DiffTime -_DECISION_LOOP_DELAY = 0.005 +-- Used by idle peers to avoid busy-waiting while still being woken when +-- shared state changes (lease expiries, new tx advertisements, mempool +-- resolutions). A spurious wake on a change that doesn't grant this peer +-- new work is harmless: the peer immediately re-runs 'nextPeerAction', +-- selects 'PeerDoNothing' again, and goes back to sleep on the new +-- generation value. +awaitSharedChangeImp :: MonadTimer m + => SharedTxStateVar m peeraddr txid + -> Word64 + -> Maybe DiffTime + -> m () +awaitSharedChangeImp sharedStateVar generation mDelay = + case mDelay of + Nothing -> + atomically $ do + sharedState <- readTVar sharedStateVar + check (sharedGeneration sharedState /= generation) + Just delay -> do + delayVar <- registerDelay delay + atomically $ do + sharedState <- readTVar sharedStateVar + expired <- Lazy.readTVar delayVar + check (sharedGeneration sharedState /= generation || expired) + +-- | Avoid rewriting the shared TVar when the pure state step made no shared +-- change. Callers use 'sharedGeneration' as the dirty bit for shared state. +writeSharedStateIfChanged :: MonadSTM m + => SharedTxStateVar m peeraddr txid + -> Word64 + -> SharedTxState peeraddr txid + -> STM m () +writeSharedStateIfChanged sharedStateVar sharedGeneration0 sharedState' + | sharedGeneration sharedState' == sharedGeneration0 = pure () + | otherwise = writeTVar sharedStateVar sharedState' + +-- | Avoid rewriting the per-peer TVar when nothing changed. +writePeerInFlightIfChanged :: MonadSTM m + => PeerTxInFlightVar m + -> PeerTxInFlight + -> PeerTxInFlight + -> STM m () +writePeerInFlightIfChanged var before after + | before == after = pure () + | otherwise = writeTVar var after + +-- | Update the counters for the action chosen by the peer scheduler. +-- +updateCountersForAction :: MonadSTM m + => TxSubmissionCountersVar m + -> PeerAction + -> STM m () +updateCountersForAction countersVar peerAction = + case peerAction of + PeerRequestTxIds flavour txIdsToAck txIdsToReq + | txIdsToAck /= 0 || txIdsToReq /= 0 -> + modifyTVar countersVar (<> mempty + { txIdMessagesSent = 1 + , txIdsRequested = fromIntegral txIdsToReq + , txIdBlockingReqsSent = case flavour of + TxIdsBlockingReq -> 1 + TxIdsPipelinedReq -> 0 + , txIdPipelinedReqsSent = case flavour of + TxIdsBlockingReq -> 0 + TxIdsPipelinedReq -> 1 + }) + PeerRequestTxs txKeys -> + modifyTVar countersVar (<> mempty { txMessagesSent = 1 + , txsRequested = fromIntegral (length txKeys) }) + _ -> pure () + +-- | Compute the next action for this peer in non-pipelined mode. +runNextPeerActionImp :: ( MonadSTM m + , Ord peeraddr ) + => TxDecisionPolicy + -> SharedTxStateVar m peeraddr txid + -> PeerTxInFlightVar m + -> TxSubmissionCountersVar m + -> peeraddr + -> Time + -> PeerTxLocalState tx + -> m (PeerAction, PeerTxLocalState tx) +runNextPeerActionImp policy sharedStateVar peerInFlightVar countersVar peeraddr + now peerState = atomically $ do + sharedState <- readTVar sharedStateVar + peerInFlight <- readTVar peerInFlightVar + let sharedGeneration0 = sharedGeneration sharedState + (peerAction, peerState', peerInFlight', sharedState') = + State.nextPeerAction now policy peeraddr peerState peerInFlight sharedState + writeSharedStateIfChanged sharedStateVar sharedGeneration0 sharedState' + writePeerInFlightIfChanged peerInFlightVar peerInFlight peerInFlight' + updateCountersForAction countersVar peerAction + return (peerAction, peerState') + +-- | Compute the next action for this peer in pipelined mode. +runNextPeerActionPipelinedImp :: ( MonadSTM m + , Ord peeraddr ) + => TxDecisionPolicy + -> SharedTxStateVar m peeraddr txid + -> PeerTxInFlightVar m + -> TxSubmissionCountersVar m + -> peeraddr + -> Time + -> PeerTxLocalState tx + -> m (PeerAction, PeerTxLocalState tx) +runNextPeerActionPipelinedImp policy sharedStateVar peerInFlightVar countersVar + peeraddr now peerState = + atomically $ do + sharedState <- readTVar sharedStateVar + peerInFlight <- readTVar peerInFlightVar + let sharedGeneration0 = sharedGeneration sharedState + (peerAction, peerState', peerInFlight', sharedState') = + State.nextPeerActionPipelined now policy peeraddr peerState + peerInFlight sharedState + writeSharedStateIfChanged sharedStateVar sharedGeneration0 sharedState' + writePeerInFlightIfChanged peerInFlightVar peerInFlight peerInFlight' + updateCountersForAction countersVar peerAction + return (peerAction, peerState') + +-- | Process a batch of txids received from this peer. +applyReceivedTxIdsImp :: ( MonadSTM m + , HasRawTxId txid ) + => TxDecisionPolicy + -> STM m (MempoolSnapshot txid tx idx) + -> SharedTxStateVar m peeraddr txid + -> PeerTxInFlightVar m + -> TxSubmissionCountersVar m + -> Time + -> NumTxIdsToReq + -> [(txid, SizeInBytes)] + -> PeerTxLocalState tx + -> m (PeerTxLocalState tx) +applyReceivedTxIdsImp policy mempoolGetSnapshot sharedStateVar peerInFlightVar + countersVar now txIdsToReq txidsAndSizes peerState = do + -- Snapshot the mempool outside the per-peer STM transaction so mempool + -- writers don't kick the hot path into retries. Stale answers are + -- benign: a false positive delays re-fetch by 'bufferedTxsMinLifetime' + -- via the retained set; a false negative wastes one body fetch that + -- 'handleReceivedTxs' will reclassify as late. + MempoolSnapshot { mempoolHasTx } <- atomically mempoolGetSnapshot + atomically $ do + sharedState <- readTVar sharedStateVar + peerInFlight <- readTVar peerInFlightVar + let sharedGeneration0 = sharedGeneration sharedState + (peerState', peerInFlight', sharedState') = + State.handleReceivedTxIds mempoolHasTx now policy txIdsToReq txidsAndSizes + peerState peerInFlight sharedState + writeSharedStateIfChanged sharedStateVar sharedGeneration0 sharedState' + writePeerInFlightIfChanged peerInFlightVar peerInFlight peerInFlight' + modifyTVar countersVar (<> mempty { txIdRepliesReceived = 1 + , txIdsReceived = fromIntegral (length txidsAndSizes) }) + return peerState' + +-- | Process a batch of tx bodies received from this peer. +applyReceivedTxsImp :: ( MonadSTM m + , Eq peeraddr + , HasRawTxId txid ) + => TxDecisionPolicy + -> STM m (MempoolSnapshot txid tx idx) + -> SharedTxStateVar m peeraddr txid + -> PeerTxInFlightVar m + -> TxSubmissionCountersVar m + -> peeraddr + -> Time + -> [(txid, tx)] + -> PeerTxLocalState tx + -> m (Int, PeerTxLocalState tx) +applyReceivedTxsImp policy mempoolGetSnapshot sharedStateVar peerInFlightVar + countersVar peeraddr now txs peerState = do + -- Mempool snapshot taken in its own STM tx; see 'applyReceivedTxIdsImp'. + MempoolSnapshot { mempoolHasTx } <- atomically mempoolGetSnapshot + atomically $ do + sharedState <- readTVar sharedStateVar + peerInFlight <- readTVar peerInFlightVar + let sharedGeneration0 = sharedGeneration sharedState + (omittedCount, lateCount, peerState', peerInFlight', sharedState') = + State.handleReceivedTxs mempoolHasTx now policy peeraddr txs + peerState peerInFlight sharedState + writeSharedStateIfChanged sharedStateVar sharedGeneration0 sharedState' + writePeerInFlightIfChanged peerInFlightVar peerInFlight peerInFlight' + modifyTVar countersVar (<> mempty { + txRepliesReceived = 1, + txsReceived = fromIntegral (length txs), + txsOmitted = fromIntegral omittedCount, + lateBodies = fromIntegral lateCount + }) + return (omittedCount + lateCount, peerState') + +-- | Mark txs as submitted to the mempool and update shared state. +applySubmittedTxsImp :: ( MonadSTM m + , Eq peeraddr ) + => TxDecisionPolicy + -> SharedTxStateVar m peeraddr txid + -> PeerTxInFlightVar m + -> TxSubmissionCountersVar m + -> peeraddr + -> Time + -> [TxKey] + -> [TxKey] + -> PeerTxLocalState tx + -> m (PeerTxLocalState tx) +applySubmittedTxsImp policy sharedStateVar peerInFlightVar countersVar peeraddr + now acceptedTxs rejectedTxs peerState = + atomically $ do + sharedState <- readTVar sharedStateVar + peerInFlight <- readTVar peerInFlightVar + let sharedGeneration0 = sharedGeneration sharedState + (peerState', peerInFlight', sharedState') = + State.handleSubmittedTxs now policy peeraddr acceptedTxs + rejectedTxs peerState peerInFlight sharedState + writeSharedStateIfChanged sharedStateVar sharedGeneration0 sharedState' + writePeerInFlightIfChanged peerInFlightVar peerInFlight peerInFlight' + modifyTVar countersVar (<> mempty { txsAccepted = fromIntegral (length acceptedTxs) + , txsRejected = fromIntegral (length rejectedTxs) }) + return peerState' + +-- | Resolve txids and advertised sizes for a batch of tx keys to request. +resolveTxRequestImp :: ( MonadSTM m + , Ord txid ) + => SharedTxStateVar m peeraddr txid + -> PeerTxLocalState tx + -> [TxKey] + -> m (Map txid SizeInBytes) +resolveTxRequestImp sharedStateVar peerState txKeys = atomically $ do + sharedState <- readTVar sharedStateVar + return $ Map.fromList (fmap (resolveOne sharedState) txKeys) + where + resolveOne sharedState key@(TxKey k) = + ( resolveTxKey sharedState key + , case IntMap.lookup k (peerAvailableTxIds peerState) of + Just txSize -> txSize + Nothing -> error "TxSubmission.V2.resolveTxRequestImp: missing tx size" + ) + +-- | Resolve buffered tx bodies into full submission records. +resolveBufferedTxsImp :: ( MonadSTM m + ) + => SharedTxStateVar m peeraddr txid + -> PeerTxLocalState tx + -> [TxKey] + -> m [(TxKey, txid, tx)] +resolveBufferedTxsImp sharedStateVar peerState txKeys = atomically $ do + sharedState <- readTVar sharedStateVar + return $ fmap (resolveOne sharedState) txKeys + where + resolveOne sharedState key@(TxKey k) = + ( key + , resolveTxKey sharedState key + , case IntMap.lookup k (peerDownloadedTxs peerState) of + Just tx -> tx + Nothing -> error "TxSubmission.V2.resolveBufferedTxsImp: missing buffered tx" + ) diff --git a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs index d80c3910f69..b88bc62f789 100644 --- a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs +++ b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs @@ -1,580 +1,1303 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Ouroboros.Network.TxSubmission.Inbound.V2.State - ( -- * Core API - SharedTxState (..) - , PeerTxState (..) - , SharedTxStateVar - , newSharedTxStateVar - , receivedTxIds - , collectTxs - , acknowledgeTxIds - , splitAcknowledgedTxIds - , tickTimedTxs - , const_MAX_TX_SIZE_DISCREPANCY - -- * Internals, only exported for testing purposes: - , RefCountDiff (..) - , updateRefCounts - , receivedTxIdsImpl - , collectTxsImpl + ( handleReceivedTxIds + , handleReceivedTxs + , handleSubmittedTxs + , markSubmittingTxs + , nextPeerAction + , nextPeerActionPipelined + , currentPeerScore + , drainPeerScore + , applyPeerRejections + , sweepSharedState ) where -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Exception (assert) -import Control.Monad.Class.MonadTime.SI -import Control.Tracer (Tracer, traceWith) - -import Data.Foldable (fold, toList) -import Data.Foldable qualified as Foldable -import Data.Functor (($>)) -import Data.Map.Merge.Strict qualified as Map -import Data.Map.Strict (Map) +import Control.Monad.Class.MonadTime.SI (DiffTime, Time, addTime, diffTime) +import Data.Foldable (foldl', toList) +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet import Data.Map.Strict qualified as Map -import Data.Maybe (fromJust) -import Data.Sequence.Strict (StrictSeq) import Data.Sequence.Strict qualified as StrictSeq -import Data.Set qualified as Set -import Data.Typeable (Typeable) -import GHC.Stack (HasCallStack) -import System.Random (StdGen) +import Data.Word (Word64) -import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..)) -import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) +import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck, + SizeInBytes) +import Ouroboros.Network.Tx (HasRawTxId (..)) import Ouroboros.Network.TxSubmission.Inbound.V2.Policy import Ouroboros.Network.TxSubmission.Inbound.V2.Types -import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..)) +data TxIdRequestMode = AllowAnyTxIdRequests | AllowPipelinedTxIdRequests + deriving Eq + +-- | Precomputed context for selecting the next action for one peer. +-- +data PeerActionContext peeraddr txid tx = PeerActionContext { + -- | Current time used for lease expiry and score decay decisions. + pacNow :: !Time, + -- | Decision policy that governs request, retry, and scoring limits. + pacPolicy :: !TxDecisionPolicy, + -- | Address of the peer whose next action is being chosen. + pacPeerAddr :: !peeraddr, + -- | Current peer-local state after local pruning has been applied. + pacPeerState :: !(PeerTxLocalState tx), + -- | This peer's contribution counters mirroring shared-state writes. + pacPeerInFlight :: !PeerTxInFlight, + -- | Shared tx-submission state after shared pruning has been applied. + pacSharedState :: !(SharedTxState peeraddr txid), + -- | Score-derived delay this peer must wait after a tx becomes claimable. + pacClaimDelay :: !DiffTime + } + +data PeerActionChoice peeraddr = + ChooseSubmit ![TxKey] + | ChooseRequestTxs ![TxKey] !SizeInBytes !(IntMap.IntMap (TxEntry peeraddr)) + | ChooseRequestTxIds !TxIdsReqFlavour ![TxKey] !NumTxIdsToAck !NumTxIdsToReq !(StrictSeq.StrictSeq TxKey) + | ChooseDoNothing !Word64 !(Maybe DiffTime) +-- | Build a precomputed context for selecting the next action for a peer. -- --- Pure public API -- +mkPeerActionContext :: Time + -> TxDecisionPolicy + -> peeraddr + -> PeerTxLocalState tx + -> PeerTxInFlight + -> SharedTxState peeraddr txid + -> PeerActionContext peeraddr txid tx +mkPeerActionContext now policy peeraddr peerState peerInFlight sharedState = + PeerActionContext { + pacNow = now, + pacPolicy = policy, + pacPeerAddr = peeraddr, + pacPeerState = peerState', + pacPeerInFlight = peerInFlight, + pacSharedState = sharedState, + pacClaimDelay = peerClaimDelay policy now (peerScore peerState') + } + where + -- Remove downloaded tx bodies that are no longer in the shared state. + peerState' = + let downloaded = peerDownloadedTxs peerState + in if IntMap.null downloaded + then peerState + else peerState { + peerDownloadedTxs = IntMap.intersection downloaded (sharedTxTable sharedState) + } -acknowledgeTxIds - :: forall peeraddr tx txid. - Ord txid - => TxDecisionPolicy - -> SharedTxState peeraddr txid tx - -> PeerTxState txid tx - -> ( NumTxIdsToAck - , NumTxIdsToReq - , TxsToMempool txid tx - , RefCountDiff txid - , PeerTxState txid tx - ) - -- ^ number of txid to acknowledge, requests, txs which we can submit to the - -- mempool, txids to acknowledge with multiplicities, updated PeerTxState. -{-# INLINE acknowledgeTxIds #-} - -acknowledgeTxIds - policy - sharedTxState - ps@PeerTxState { availableTxIds, - unknownTxs, - requestedTxIdsInflight, - downloadedTxs, - score, - toMempoolTxs - } - = - -- We can only acknowledge txids when we can request new ones, since - -- a `MsgRequestTxIds` for 0 txids is a protocol error. - if txIdsToRequest > 0 - then - ( txIdsToAcknowledge - , txIdsToRequest - , TxsToMempool txsToMempool - , refCountDiff - , ps { unacknowledgedTxIds = unacknowledgedTxIds', - availableTxIds = availableTxIds', - unknownTxs = unknownTxs', - requestedTxIdsInflight = requestedTxIdsInflight - + txIdsToRequest, - downloadedTxs = downloadedTxs', - score = score', - toMempoolTxs = toMempoolTxs' } - ) - else - ( 0 - , 0 - , TxsToMempool txsToMempool - , RefCountDiff Map.empty - , ps { toMempoolTxs = toMempoolTxs' } - ) +-- | Compute the next peer-local action. +nextPeerAction :: Ord peeraddr + => Time + -> TxDecisionPolicy + -> peeraddr + -> PeerTxLocalState tx + -> PeerTxInFlight + -> SharedTxState peeraddr txid + -> (PeerAction, PeerTxLocalState tx, PeerTxInFlight, SharedTxState peeraddr txid) +nextPeerAction = nextPeerActionWithMode AllowAnyTxIdRequests +{-# INLINABLE nextPeerAction #-} + +-- | Pipelined version of nextPeerAction +nextPeerActionPipelined :: Ord peeraddr + => Time + -> TxDecisionPolicy + -> peeraddr + -> PeerTxLocalState tx + -> PeerTxInFlight + -> SharedTxState peeraddr txid + -> (PeerAction, PeerTxLocalState tx, PeerTxInFlight, SharedTxState peeraddr txid) +nextPeerActionPipelined = nextPeerActionWithMode AllowPipelinedTxIdRequests +{-# INLINABLE nextPeerActionPipelined #-} + +-- | V2 peer-thread scheduler +-- +-- nextPeerActionWithMode handles body requests for txs this peer may currently +-- fetch, tx submission for bodies buffered locally by this peer, and txid ack/request +-- messages. Updates 'peerPhase' on the returned 'PeerTxLocalState' to +-- reflect the chosen action and threads the per-peer 'PeerTxInFlight' +-- counters. +nextPeerActionWithMode :: Ord peeraddr + => TxIdRequestMode + -> Time + -> TxDecisionPolicy + -> peeraddr + -> PeerTxLocalState tx + -> PeerTxInFlight + -> SharedTxState peeraddr txid + -> (PeerAction, PeerTxLocalState tx, PeerTxInFlight, SharedTxState peeraddr txid) +nextPeerActionWithMode txIdRequestMode now policy peeraddr peerState peerInFlight sharedState = + let (action, peerState', peerInFlight', sharedState'') = + applyPeerActionChoice ctx (pickPeerActionChoice txIdRequestMode ctx) + peerState'' = peerState' { + peerPhase = phaseForAction txIdRequestMode (peerPhase peerState) action + } + in (action, peerState'', peerInFlight', sharedState'') where - -- Split `unacknowledgedTxIds'` into the longest prefix of `txid`s which - -- can be acknowledged and the unacknowledged `txid`s. - (txIdsToRequest, acknowledgedTxIds, unacknowledgedTxIds') - = splitAcknowledgedTxIds policy sharedTxState ps - - txsToMempool = [ (txid, downloadedTxs Map.! txid) - | txid <- toList toMempoolTxIds - , txid `Map.notMember` bufferedTxs sharedTxState - -- without the guard below we could potentially enqueue - -- the same tx into the mempool multiple times over - -- several decision loop iterations before the tx - -- is finally in the mempool, or rejected. - , txid `Map.notMember` toMempoolTxs - ] - -- Select downloaded txs from the prefix of `acknowledgedTxIds`, ignoring - -- unknown and buffered txs. - toMempoolTxIds = - StrictSeq.filter (`Map.member` downloadedTxs) acknowledgedTxIds - - txsToMempoolMap = Map.fromList txsToMempool - - toMempoolTxs' = toMempoolTxs <> txsToMempoolMap - - (downloadedTxs', ackedDownloadedTxs) = - Map.partitionWithKey (\txid _ -> txid `Set.member` liveSet) downloadedTxs - - -- latexTxs: transactions which were downloaded by another peer before we - -- downloaded them; it relies on that `txToMempool` filters out - -- `bufferedTxs`. - lateTxs = - Map.filterWithKey (\txid _ -> txid `Map.member` bufferedTxs sharedTxState) ackedDownloadedTxs - - score' = score + fromIntegral (Map.size lateTxs) - - -- the set of live `txids` - liveSet = Set.fromList (toList unacknowledgedTxIds') - - availableTxIds' = availableTxIds - `Map.restrictKeys` - liveSet - - -- We remove all acknowledged `txid`s which are not in - -- `unacknowledgedTxIds''`, but also return the unknown set before any - -- modifications (which is used to compute `unacknowledgedTxIds''` - -- above). - unknownTxs' = unknownTxs `Set.intersection` liveSet - - refCountDiff = RefCountDiff - $ foldr (Map.alter fn) - Map.empty acknowledgedTxIds - where - fn :: Maybe Int -> Maybe Int - fn Nothing = Just 1 - fn (Just n) = Just $! n + 1 + sharedState' = bumpStuckEntries now policy peerState sharedState + ctx = mkPeerActionContext now policy peeraddr peerState peerInFlight sharedState' + +-- | Compute the new 'PeerPhase' for the chosen 'PeerAction'. +-- +-- In pipelined mode a 'PeerDoNothing' keeps the current phase (the peer +-- is still mid-pipeline, just waiting for replies). In non-pipelined mode +-- a 'PeerDoNothing' transitions to 'PeerIdle'. +phaseForAction :: TxIdRequestMode -> PeerPhase -> PeerAction -> PeerPhase +phaseForAction txIdRequestMode currentPhase action = case action of + PeerDoNothing {} -> case txIdRequestMode of + AllowPipelinedTxIdRequests -> currentPhase + AllowAnyTxIdRequests -> PeerIdle + PeerSubmitTxs {} -> PeerSubmittingToMempool + PeerRequestTxs {} -> PeerWaitingTxs + PeerRequestTxIds {} -> PeerWaitingTxIds - txIdsToAcknowledge :: NumTxIdsToAck - txIdsToAcknowledge = fromIntegral $ StrictSeq.length acknowledgedTxIds +-- | Pick which action to perform next. +-- +pickPeerActionChoice :: Ord peeraddr + => TxIdRequestMode + -> PeerActionContext peeraddr txid tx + -> PeerActionChoice peeraddr +pickPeerActionChoice txIdRequestMode ctx + -- Pick TXs to submit to the mempool + | Just txsToSubmit <- pickSubmitAction ctx = + ChooseSubmit txsToSubmit + -- Pick TXs to fetch + | Just (txsToRequest, txsToRequestSize, txTable') <- pickRequestTxsAction ctx = + ChooseRequestTxs txsToRequest txsToRequestSize txTable' + -- Pick TXids to ack and/or request more TXids. + | Just (acknowledgedTxIds, txIdsToAcknowledge, txIdsToRequest, unacknowledgedTxIds') <- + pickRequestTxIdsAction txIdRequestMode ctx = + let flavour + | txIdRequestMode == AllowAnyTxIdRequests + , StrictSeq.null unacknowledgedTxIds' = TxIdsBlockingReq + | otherwise = TxIdsPipelinedReq + in ChooseRequestTxIds flavour acknowledgedTxIds txIdsToAcknowledge txIdsToRequest unacknowledgedTxIds' + -- Do nothing + | otherwise = + ChooseDoNothing (sharedGeneration (pacSharedState ctx)) (nextWakeDelay ctx) +-- | Execute a chosen peer action and compute resulting state updates +applyPeerActionChoice :: PeerActionContext peeraddr txid tx + -> PeerActionChoice peeraddr + -> (PeerAction, PeerTxLocalState tx, PeerTxInFlight, SharedTxState peeraddr txid) +applyPeerActionChoice ctx choice = + case choice of + ChooseSubmit txsToSubmit -> + applySubmitChoice ctx txsToSubmit + ChooseRequestTxs txsToRequest txsToRequestSize txTable' -> + applyRequestTxsChoice ctx txsToRequest txsToRequestSize txTable' + ChooseRequestTxIds flavour acknowledgedTxIds txIdsToAcknowledge txIdsToRequest + unacknowledgedTxIds' -> + applyRequestTxIdsChoice ctx flavour acknowledgedTxIds txIdsToAcknowledge txIdsToRequest + unacknowledgedTxIds' + ChooseDoNothing generation wakeDelay -> + applyDoNothingChoice ctx generation wakeDelay --- | Split unacknowledged txids into acknowledged and unacknowledged parts, also --- return number of txids which can be requested. +-- | Construct a 'PeerSubmitTxs' action for buffered transactions. -- -splitAcknowledgedTxIds - :: Ord txid - => TxDecisionPolicy - -> SharedTxState peer txid tx - -> PeerTxState txid tx - -> (NumTxIdsToReq, StrictSeq.StrictSeq txid, StrictSeq.StrictSeq txid) - -- ^ number of txids to request, acknowledged txids, unacknowledged txids -splitAcknowledgedTxIds - TxDecisionPolicy { - maxUnacknowledgedTxIds, - maxNumTxIdsToRequest - } - SharedTxState { - bufferedTxs - } - PeerTxState { - unacknowledgedTxIds, - unknownTxs, - downloadedTxs, - requestedTxsInflight, - requestedTxIdsInflight - } - = - (txIdsToRequest, acknowledgedTxIds', unacknowledgedTxIds') +-- Marks the selected txs as in-submission on this peer. Other peers +-- skip them via 'txSubmittingByOther'. STM serialisation guarantees +-- only one peer can win the @ChooseSubmit@ race for a given key. +applySubmitChoice :: PeerActionContext peeraddr txid tx + -> [TxKey] + -> (PeerAction, PeerTxLocalState tx, PeerTxInFlight, SharedTxState peeraddr txid) +applySubmitChoice ctx txsToSubmit = + let keys = IntSet.fromList (unTxKey <$> txsToSubmit) + pif = pacPeerInFlight ctx + pif' = pif { + pifAttempting = pifAttempting pif `IntSet.difference` keys, + pifSubmitting = pifSubmitting pif `IntSet.union` keys + } + in ( PeerSubmitTxs txsToSubmit + , pacPeerState ctx + , pif' + , markSubmittingTxs txsToSubmit (pacSharedState ctx) + ) + +-- | Construct a 'PeerRequestTxs' action and update local and shared tx state. +applyRequestTxsChoice :: PeerActionContext peeraddr txid tx + -> [TxKey] + -> SizeInBytes + -> IntMap.IntMap (TxEntry peeraddr) + -> (PeerAction, PeerTxLocalState tx, PeerTxInFlight, SharedTxState peeraddr txid) +applyRequestTxsChoice ctx txsToRequest txsToRequestSize txTable = + ( PeerRequestTxs txsToRequest + , peerState'' + , peerInFlight'' + , sharedState'' + ) + where + requestedKeys = IntSet.fromList (unTxKey <$> txsToRequest) + peerState'' = + (pacPeerState ctx) { + peerRequestedTxs = + peerRequestedTxs (pacPeerState ctx) `IntSet.union` requestedKeys, + peerRequestedTxBatches = + peerRequestedTxBatches (pacPeerState ctx) StrictSeq.|> RequestedTxBatch { + requestedTxBatchSet = requestedKeys, + requestedTxBatchSize = txsToRequestSize + }, + peerRequestedTxsSize = peerRequestedTxsSize (pacPeerState ctx) + txsToRequestSize + } + pif = pacPeerInFlight ctx + peerInFlight'' = pif { + pifLeased = pifLeased pif `IntSet.union` requestedKeys, + pifAttempting = pifAttempting pif `IntSet.union` requestedKeys + } + -- Take the lease without waking other advertisers: claiming doesn't + -- give them a new option (they couldn't claim before this commit, and + -- they still can't), and they'll be bumped on submit / lease release. + sharedState'' = + (pacSharedState ctx) { + sharedTxTable = txTable, + sharedGeneration = sharedGeneration (pacSharedState ctx) + 1 + } + +-- | Construct a 'PeerRequestTxIds' action and update local and shared txid state. +applyRequestTxIdsChoice + :: PeerActionContext peeraddr txid tx + -> TxIdsReqFlavour + -> [TxKey] + -> NumTxIdsToAck + -> NumTxIdsToReq + -> StrictSeq.StrictSeq TxKey + -> (PeerAction, PeerTxLocalState tx, PeerTxInFlight, SharedTxState peeraddr txid) +applyRequestTxIdsChoice ctx flavour acknowledgedTxIds txIdsToAcknowledge txIdsToRequest unacknowledgedTxIds' = + ( PeerRequestTxIds flavour txIdsToAcknowledge txIdsToRequest + , peerState'' + , peerInFlight'' + , pacSharedState ctx + ) + where + peerState0 = pacPeerState ctx + acknowledgedKeys = IntSet.fromList (unTxKey <$> acknowledgedTxIds) + peerState'' = + peerState0 { + peerAvailableTxIds = + IntMap.withoutKeys (peerAvailableTxIds peerState0) acknowledgedKeys, + peerUnacknowledgedTxIds = unacknowledgedTxIds', + peerRequestedTxIds = peerRequestedTxIds peerState0 + txIdsToRequest + } + pif = pacPeerInFlight ctx + peerInFlight'' = pif { + pifAdvertised = pifAdvertised pif `IntSet.difference` acknowledgedKeys, + pifAcksPending = pifAcksPending pif `IntSet.difference` acknowledgedKeys + } + +-- | Construct a 'PeerDoNothing' action. +applyDoNothingChoice + :: PeerActionContext peeraddr txid tx + -> Word64 + -> Maybe DiffTime + -> (PeerAction, PeerTxLocalState tx, PeerTxInFlight, SharedTxState peeraddr txid) +applyDoNothingChoice ctx generation wakeDelay = + ( PeerDoNothing generation wakeDelay + , pacPeerState ctx + , pacPeerInFlight ctx + , pacSharedState ctx + ) + +-- | Select downloaded transactions that this peer may submit to the mempool. +pickSubmitAction + :: PeerActionContext peeraddr txid tx + -> Maybe [TxKey] +pickSubmitAction PeerActionContext { pacPeerState, pacPeerInFlight, pacSharedState } = + let txsToSubmit = pickBufferedTxsToSubmit in + if null txsToSubmit + then Nothing + else Just txsToSubmit where - (acknowledgedTxIds', unacknowledgedTxIds') - = StrictSeq.spanl (\txid -> - txid `Set.notMember` requestedTxsInflight - && ( - txid `Map.member` downloadedTxs - || txid `Set.member` unknownTxs - || txid `Map.member` bufferedTxs - ) - ) - unacknowledgedTxIds - - numOfUnacked = StrictSeq.length unacknowledgedTxIds - numOfAcked = StrictSeq.length acknowledgedTxIds' - unackedAndRequested = fromIntegral numOfUnacked + requestedTxIdsInflight - - txIdsToRequest = - assert (unackedAndRequested <= maxUnacknowledgedTxIds) $ - assert (requestedTxIdsInflight <= maxNumTxIdsToRequest) $ - (maxUnacknowledgedTxIds - unackedAndRequested + fromIntegral numOfAcked) - `min` - (maxNumTxIdsToRequest - requestedTxIdsInflight) - - --- | `RefCountDiff` represents a map of `txid` which can be acknowledged --- together with their multiplicities. + + -- Walk the unacknowledged txid queue in peer advertisement order, + -- picking bodies buffered by this peer for immediate submission. + -- Classification of each entry: + -- + -- * 'sharedTxTable' has 'Nothing' for the key: the tx was resolved at + -- some point (a peer submitted it to the mempool) and the entry was + -- deleted. Orphan sweep cannot drop an entry while any peer still + -- tracks the key, so 'Nothing' here implies resolution; safe to skip + -- and continue past, regardless of whether the retained marker has + -- since expired or the mempool has since evicted. + -- * 'sharedTxTable' has 'Just' but we don't have the body buffered, or + -- another peer is already submitting: the tx is in flight elsewhere. + -- Stop, otherwise later txs in our stream might run ahead of an + -- unresolved earlier tx they depend on. + -- * 'sharedTxTable' has 'Just' and we have the body buffered: submit. + pickBufferedTxsToSubmit = go [] (toList (peerUnacknowledgedTxIds pacPeerState)) + where + go acc [] = reverse acc + go acc (txKey@(TxKey k) : rest) = + case IntMap.lookup k (sharedTxTable pacSharedState) of + Just txEntry + | txBufferedByPeer pacPeerState k + , not (txSubmittingByOther pacPeerInFlight k txEntry) -> + go (txKey : acc) rest + Just _ -> reverse acc + Nothing -> go acc rest + +-- | Select transactions to request from the peer, if within policy limits. -- -newtype RefCountDiff txid = RefCountDiff { - txIdsToAck :: Map txid Int +-- Returns a triple of: +-- Tx keys to request (in ascending key order for deterministic selection) +-- Total serialized size of the requested txs +-- Updated shared state with new lease ownership for selected txs +pickRequestTxsAction :: Ord peeraddr + => PeerActionContext peeraddr txid tx + -> Maybe ([TxKey], SizeInBytes, IntMap.IntMap (TxEntry peeraddr)) +pickRequestTxsAction ctx@PeerActionContext { pacNow, pacPolicy, pacPeerState, pacSharedState } = + let (txsToRequest, txsToRequestSize, sharedState') = pickTxsToRequest in + if null txsToRequest + then Nothing + else Just (txsToRequest, txsToRequestSize, sharedState') + where + + -- Picks txs from the peer's available set that are not yet requested or + -- downloaded, assigning leases with expiry timestamps. + -- Respects 'maxOutstandingTxBatchesPerPeer' and 'txsSizeInflightPerPeer' policy + -- constraints. + pickTxsToRequest = + if StrictSeq.length (peerRequestedTxBatches pacPeerState) >= + maxOutstandingTxBatchesPerPeer pacPolicy + then ([], 0, sharedTxTable pacSharedState) + else go [] 0 (sharedTxTable pacSharedState) candidates + where + -- Remaining bytes available for requesting new tx, based on the + -- per-peer inflight size limit. + sizeBudget = + if peerRequestedTxsSize pacPeerState >= txsSizeInflightPerPeer pacPolicy + then 0 + else txsSizeInflightPerPeer pacPolicy - peerRequestedTxsSize pacPeerState + + leaseUntil = addTime (interTxSpace pacPolicy) pacNow + + -- Iterate the peer's unacknowledged queue, which preserves the peer's + -- advertisement order. Peers are expected to advertise in chain- + -- topological order (parents before children), so walking in that + -- order aligns fetch order with submission-validity order and a + -- child is never requested ahead of its parent when the same peer + -- carries both. + candidates = + [ (k, txSize) + | TxKey k <- toList (peerUnacknowledgedTxIds pacPeerState) + , IntSet.notMember k (peerRequestedTxs pacPeerState) + , IntMap.notMember k (peerDownloadedTxs pacPeerState) + , Just txSize <- [IntMap.lookup k (peerAvailableTxIds pacPeerState)] + ] + + -- Select transactions to request by iterating through candidates in + -- peer advertisement order until the size budget is consumed. + go selectedRev selectedSize txTable [] = (reverse selectedRev, selectedSize, txTable) + go selectedRev selectedSize txTable ((k, txSize) : rest) = + if exceedsBudget selectedSize txSize + then (reverse selectedRev, selectedSize, txTable) + else + case IntMap.lookup k txTable of + Just txEntry -> + if txSelectable ctx (TxKey k) txEntry + then + go (TxKey k : selectedRev) + (selectedSize + txSize) + (IntMap.insert k (claimTx (pacPeerAddr ctx) leaseUntil txEntry) + txTable) + rest + else go selectedRev selectedSize txTable rest + Nothing -> go selectedRev selectedSize txTable rest + + exceedsBudget selectedSize txSize + | selectedSize + txSize <= sizeBudget = False + | selectedSize /= 0 = True + -- The inflight size limit is soft by up to one tx size, so a peer with + -- spare capacity may still request its first tx in a batch even when + -- that single tx exceeds the remaining byte budget. + | otherwise = peerRequestedTxsSize pacPeerState >= txsSizeInflightPerPeer pacPolicy + +-- | Determine txid acknowledgment and request counts, if any work is available. +pickRequestTxIdsAction :: Ord peeraddr + => TxIdRequestMode + -> PeerActionContext peeraddr txid tx + -> Maybe ([TxKey], NumTxIdsToAck, NumTxIdsToReq, StrictSeq.StrictSeq TxKey) +pickRequestTxIdsAction txIdRequestMode ctx@PeerActionContext { pacPolicy, pacPeerState } + | txIdsToAcknowledge <= 0 && txIdsToRequest <= 0 = Nothing + | txIdRequestMode == AllowPipelinedTxIdRequests + , txIdsToAcknowledge <= 0 || txIdsToRequest <= 0 = Nothing + | otherwise = Just (acknowledgedTxIds, txIdsToAcknowledge, txIdsToRequest, unacknowledgedTxIds') + where + + -- Split the unacknowledged txid queue into acknowledged and remaining portions. + -- + -- acknowledgedTxIds is the longest prefix of "ackable" txids. + -- unacknowledgedTxIds is the remaining txids + (acknowledgedTxIds, txIdsToAcknowledge, txIdsToRequest, unacknowledgedTxIds') = + ( toList acknowledgedTxIdsSeq + , fromIntegral numOfAcked + , txIdsToRequest' + , unacknowledgedTxIds + ) + where + ackablePrefix = StrictSeq.takeWhileL (txIdAckable ctx) (peerUnacknowledgedTxIds + pacPeerState) + + numOfUnacked = StrictSeq.length (peerUnacknowledgedTxIds pacPeerState) + numOfRequested = fromIntegral (peerRequestedTxIds pacPeerState) :: Int + hasOutstandingBodyReplies = + not (StrictSeq.null (peerRequestedTxBatches pacPeerState)) + keepOneUnackedForPipelinedRequest = + txIdRequestMode == AllowPipelinedTxIdRequests + && (numOfRequested > 0 || hasOutstandingBodyReplies) + numOfAcked0 = StrictSeq.length ackablePrefix + numOfAcked + -- A pipelined txid request becomes a non-blocking protocol message + -- while any txid or body reply is still in flight. The outbound side + -- requires at least one txid to remain unacknowledged in that case. + | keepOneUnackedForPipelinedRequest = + min numOfAcked0 (max 0 (numOfUnacked - 1)) + | otherwise = numOfAcked0 + + acknowledgedTxIdsSeq = StrictSeq.take numOfAcked ackablePrefix + unacknowledgedTxIds = StrictSeq.drop numOfAcked (peerUnacknowledgedTxIds pacPeerState) + unackedAndRequested = numOfUnacked + numOfRequested + + txIdsToRequest' + | numOfAcked == 0 && numOfUnacked > 0 = 0 + | otherwise = + fromIntegral $ max 0 $ min + (fromIntegral (maxUnacknowledgedTxIds pacPolicy) - unackedAndRequested + numOfAcked) + (fromIntegral (maxNumTxIdsToRequest pacPolicy) - numOfRequested) + +-- | Compute the time delay until the peer should next wake to check for work. +nextWakeDelay :: PeerActionContext peeraddr txid tx -> Maybe DiffTime +nextWakeDelay PeerActionContext { pacNow, pacPolicy, pacClaimDelay + , pacPeerState, pacPeerInFlight, pacSharedState } = + (`diffTime` pacNow) <$> minMaybe (minMaybe nextClaimWake nextBumpWake) nextRetainWake + where + -- Wake at the earliest claim-ready time among txs this peer advertises. + nextClaimWake = + IntSet.foldl' stepClaim Nothing (pifAdvertised pacPeerInFlight) + + -- Wake at the earliest bump-ready time among txs this peer holds buffered. + -- Scoped to 'peerDownloadedTxs' to match 'bumpStuckEntries': only the + -- leaseholder schedules a bump-wake, so non-leaseholders don't busy-loop + -- at exact bumpAt with no entry to bump. + nextBumpWake = + IntMap.foldlWithKey' stepBump Nothing (peerDownloadedTxs pacPeerState) + + stepClaim acc k = + case IntMap.lookup k (sharedTxTable pacSharedState) of + Just txEntry -> minMaybe acc (futureClaimWake txEntry) + Nothing -> acc + + stepBump acc k _tx = + case IntMap.lookup k (sharedTxTable pacSharedState) of + Just txEntry -> minMaybe acc (nextStuckBumpWake pacNow pacPolicy txEntry) + Nothing -> acc + + nextRetainWake = retainedNextWake pacNow (sharedRetainedTxs pacSharedState) + + futureClaimWake txEntry = + let claimWake = txClaimReadyAt pacClaimDelay txEntry + in if claimWake > pacNow then Just claimWake else Nothing + + minMaybe :: Ord a => Maybe a -> Maybe a -> Maybe a + minMaybe Nothing y = y + minMaybe x Nothing = x + minMaybe (Just x) (Just y) = Just (min x y) + +-- | Assign a tx lease to a peer and increment the attempt count. +claimTx :: peeraddr + -> Time + -> TxEntry peeraddr + -> TxEntry peeraddr +claimTx peeraddr leaseUntil txEntry@TxEntry { txAttempt } = + txEntry { + txLease = TxLeased peeraddr leaseUntil, + txAttempt = txAttempt + 1 } -updateRefCounts :: Ord txid - => Map txid Int - -> RefCountDiff txid - -> Map txid Int -updateRefCounts referenceCounts (RefCountDiff diff) = - Map.merge (Map.mapMaybeMissing \_ x -> Just x) - (Map.mapMaybeMissing \_ _ -> Nothing) - (Map.zipWithMaybeMatched \_ x y -> assert (x >= y) - if x > y then Just $! x - y - else Nothing) - referenceCounts - diff - - -tickTimedTxs :: forall peeraddr tx txid. - (Ord txid) - => Time - -> SharedTxState peeraddr txid tx - -> SharedTxState peeraddr txid tx -tickTimedTxs now st@SharedTxState{ timedTxs - , referenceCounts - , bufferedTxs } = - let (expiredTxs', timedTxs') = - case Map.splitLookup now timedTxs of - (expired, Just txids, timed) -> - (expired, -- Map.split doesn't include the `now` entry in the map - Map.insert now txids timed) - (expired, Nothing, timed) -> - (expired, timed) - refDiff = Map.foldl' fn Map.empty expiredTxs' - referenceCounts' = updateRefCounts referenceCounts (RefCountDiff refDiff) - liveSet = Map.keysSet referenceCounts' - bufferedTxs' = bufferedTxs `Map.restrictKeys` liveSet in - st { timedTxs = timedTxs' - , referenceCounts = referenceCounts' - , bufferedTxs = bufferedTxs' - } +-- | Time at which a leased entry becomes eligible for an inflight cap bump. +-- +-- The leaseholder's claim time is recovered from the lease deadline. If the +-- entry has been re-claimed since the original peer's attempt, this reflects +-- the latest claim instead. That is intentional: each successful claim earns +-- its own 'inflightTimeout' grace period before the next bump, so cap growth +-- is rate-limited at one bump per 'inflightTimeout' per claim. +stuckBumpReadyAt :: TxDecisionPolicy -> Time -> Time +stuckBumpReadyAt policy = + addTime (inflightTimeout policy - interTxSpace policy) + +-- | Bump 'currentMaxInflightMultiplicity' by one when the leaseholder has +-- held the lease past 'inflightTimeout' without anyone reaching submission, +-- and the cap is the bottleneck preventing another peer from joining. +bumpCurrentMaxIfStuck :: Time -> TxDecisionPolicy -> TxEntry peeraddr -> TxEntry peeraddr +bumpCurrentMaxIfStuck now policy + entry@TxEntry { txLease = TxLeased _ leaseUntil + , currentMaxInflightMultiplicity = cap } + | txAttempt entry >= cap + , now >= stuckBumpReadyAt policy leaseUntil + , not (txInSubmission entry) + = entry { currentMaxInflightMultiplicity = cap + 1 } +bumpCurrentMaxIfStuck _ _ entry = entry + +-- | Future wake time at which an entry would become eligible for a cap bump. +-- +-- Returns 'Just' for any bump-eligible entry whose 'bumpAt' is at or after +-- 'now'. Using '>=' (rather than '>') means a peer that runs 'nextWakeDelay' +-- without 'bumpStuckEntries' having already fired still schedules a wake. +nextStuckBumpWake :: Time -> TxDecisionPolicy -> TxEntry peeraddr -> Maybe Time +nextStuckBumpWake now policy + entry@TxEntry { txLease = TxLeased _ leaseUntil + , currentMaxInflightMultiplicity = cap } + | txAttempt entry >= cap + , not (txInSubmission entry) + , let bumpAt = stuckBumpReadyAt policy leaseUntil + , bumpAt >= now + = Just bumpAt +nextStuckBumpWake _ _ _ = Nothing + +-- | Sweep the txs this peer has buffered locally and bump any whose lease +-- has been held past 'inflightTimeout'. The leaseholder is in the best +-- position to detect that it is holding others up: its 'peerDownloadedTxs' +-- is small (usually empty) so the sweep is cheap, and any tx it has buffered +-- is one it has at some point claimed itself. +-- +-- 'sharedGeneration' is bumped when entries change so other peers wake out +-- of 'awaitSharedChange' and re-evaluate eligibility under the new cap. +bumpStuckEntries :: Time + -> TxDecisionPolicy + -> PeerTxLocalState tx + -> SharedTxState peeraddr txid + -> SharedTxState peeraddr txid +bumpStuckEntries now policy peerState st = + if IntSet.null bumpedKeys + then st + else st { sharedTxTable = txTable', + sharedGeneration = sharedGeneration st + 1 } where - fn :: Map txid Int - -> [txid] - -> Map txid Int - fn m txids = Foldable.foldl' gn m txids + (bumpedKeys, txTable') = + IntMap.foldlWithKey' bumpOne (IntSet.empty, sharedTxTable st) + (peerDownloadedTxs peerState) + bumpOne (bumpedAcc, tbl) k _tx = + case IntMap.lookup k tbl of + Nothing -> (bumpedAcc, tbl) + Just entry -> + let entry' = bumpCurrentMaxIfStuck now policy entry in + if currentMaxInflightMultiplicity entry' + /= currentMaxInflightMultiplicity entry + then (IntSet.insert k bumpedAcc, IntMap.insert k entry' tbl) + else (bumpedAcc, tbl) - gn :: Map txid Int - -> txid - -> Map txid Int - gn m txid = Map.alter af txid m +-- | Determine if a tx is eligible for this peer to request. +-- +-- A tx is selectable if it can be claimed or is already owned by this peer +-- and this peer's score-derived claim delay has elapsed. +-- +-- Callers iterate candidates from the peer's own 'peerAvailableTxIds', so +-- the "this peer advertises @txKey@" precondition is established by the +-- caller. +txSelectable :: Eq peeraddr + => PeerActionContext peeraddr txid tx + -> TxKey + -> TxEntry peeraddr + -> Bool +txSelectable PeerActionContext { pacNow, pacPeerAddr, pacClaimDelay + , pacPeerInFlight } + (TxKey k) + txEntry + | txInSubmission txEntry = False + | txPeerHasAttempt = False + | txAttempt txEntry >= currentMaxInflightMultiplicity txEntry = False + | txOwnedByPeer txEntry = True + | otherwise = txClaimReadyAt pacClaimDelay txEntry <= pacNow + where + -- txOwnedByPeer :: TxEntry peeraddr -> Bool + txOwnedByPeer TxEntry { txLease = TxLeased owner _ } = owner == pacPeerAddr + txOwnedByPeer TxEntry { txLease = TxClaimable _ } = False - af :: Maybe Int - -> Maybe Int - af Nothing = Just 1 - af (Just n) = Just $! succ n + txPeerHasAttempt = + IntSet.member k (pifAttempting pacPeerInFlight) + || IntSet.member k (pifSubmitting pacPeerInFlight) +-- | Does the peer have the TX entry buffered locally? -- --- Pure internal API +-- The peer's own 'peerDownloadedTxs' is the source of truth for "buffered +-- body present", so this is a peer-local lookup. +txBufferedByPeer :: PeerTxLocalState tx -> Int -> Bool +txBufferedByPeer peerState k = IntMap.member k (peerDownloadedTxs peerState) + +-- | Check whether some other peer is already submitting this tx. -- +-- True iff the entry's @txInSubmission@ flag is set and this peer is not +-- the submitter. +txSubmittingByOther :: PeerTxInFlight -> Int -> TxEntry peeraddr -> Bool +txSubmittingByOther pif k txEntry = + txInSubmission txEntry + && IntSet.notMember k (pifSubmitting pif) --- | Insert received `txid`s and return the number of txids to be acknowledged --- and the updated `SharedTxState`. +-- | Compute the current usefulness score for a peer after time-based decay. -- -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' } +-- Scores drain at 'scoreRate' (txs/second) from the last update timestamp. +-- Returns zero for peers whose accumulated rejections have fully decayed. +currentPeerScore :: TxDecisionPolicy + -> Time + -> PeerScore + -> Double +currentPeerScore TxDecisionPolicy { scoreRate } currentTime + PeerScore { peerScoreValue, peerScoreTs } + | peerScoreValue == 0 = 0 + | currentTime <= peerScoreTs = peerScoreValue + | otherwise = max 0 $ peerScoreValue - realToFrac (diffTime currentTime peerScoreTs) * scoreRate + +peerClaimDelay :: TxDecisionPolicy + -> Time + -> PeerScore + -> DiffTime +peerClaimDelay policy currentTime peerScore + | peerScoreValue peerScore == 0 = 0 + | otherwise = + -- Delay contribution in milliseconds is peerScore / 20, then converted to seconds. + realToFrac . (/ 20000) $ currentPeerScore policy currentTime peerScore + +-- | Decay the peer's score to @now@, updating the timestamp. +drainPeerScore :: TxDecisionPolicy + -> Time + -> PeerTxLocalState tx + -> PeerTxLocalState tx +drainPeerScore policy now peerState@PeerTxLocalState { peerScore } + | peerScoreValue peerScore == 0 = + peerState { peerScore = peerScore { peerScoreTs = now } } + | otherwise = + let drained = currentPeerScore policy now peerScore in + peerState { peerScore = PeerScore { peerScoreValue = drained, peerScoreTs = now } } +{-# INLINE drainPeerScore #-} +-- | Apply a rejection penalty to the peer's local score. +-- Returns the new score value (for tracing) and the updated local state. +applyPeerRejections :: TxDecisionPolicy + -> Time + -> Int + -> PeerTxLocalState tx + -> (Double, PeerTxLocalState tx) +applyPeerRejections TxDecisionPolicy { scoreRate, scoreMax } now rejectedCount + peerState@PeerTxLocalState { peerScore } = + (peerScoreValue peerScore', peerState { peerScore = peerScore' }) where - -- update `PeerTxState` and return number of `txid`s to acknowledged and - -- updated `SharedTxState`. - fn :: PeerTxState txid tx - -> ( SharedTxState peeraddr txid tx - , PeerTxState txid tx - ) - fn ps@PeerTxState { availableTxIds, - requestedTxIdsInflight, - unacknowledgedTxIds } = - (st', ps') - where - -- - -- Handle new `txid`s - -- - - -- Divide the new txids in two: those that are already in the mempool - -- and those that are not. We'll request some txs from the latter. - (ignoredTxIds, availableTxIdsMap) = - Map.partitionWithKey - (\txid _ -> mempoolHasTx txid) - txidsMap - - -- Add all `txids` from `availableTxIdsMap` which are not - -- unacknowledged or already buffered. Unacknowledged txids must have - -- already been added to `availableTxIds` map before. - availableTxIds' = - Map.foldlWithKey - (\m txid sizeInBytes -> Map.insert txid sizeInBytes m) - availableTxIds - (Map.filterWithKey - (\txid _ -> txid `notElem` unacknowledgedTxIds - && txid `Map.notMember` bufferedTxs) - availableTxIdsMap) - - -- Add received txids to `unacknowledgedTxIds`. - unacknowledgedTxIds' = unacknowledgedTxIds <> txidsSeq - - -- Add ignored `txs` to buffered ones. - -- Note: we prefer to keep the `tx` if it's already in `bufferedTxs`. - bufferedTxs' = bufferedTxs - <> Map.map (const Nothing) ignoredTxIds - - referenceCounts' = - Foldable.foldl' - (flip $ Map.alter (\case - Nothing -> Just $! 1 - Just cnt -> Just $! succ cnt)) - referenceCounts - txidsSeq - - st' = st { bufferedTxs = bufferedTxs', - referenceCounts = referenceCounts' } - ps' = assert (requestedTxIdsInflight >= reqNo) - ps { availableTxIds = availableTxIds', - unacknowledgedTxIds = unacknowledgedTxIds', - requestedTxIdsInflight = requestedTxIdsInflight - reqNo } - --- | We check advertised sizes up in a fuzzy way. The advertised and received --- sizes need to agree up to `const_MAX_TX_SIZE_DISCREPANCY`. + n = fromIntegral rejectedCount :: Double + peerScore' = applyRejects n peerScore + applyRejects 0 ps@PeerScore { peerScoreValue = 0 } = ps { peerScoreTs = now } + applyRejects n' ps@PeerScore { peerScoreValue, peerScoreTs } = + let duration = diffTime now peerScoreTs + !drain = realToFrac duration * scoreRate + !drained = max 0 (peerScoreValue - drain) in + ps { peerScoreValue = min scoreMax (drained + n'), peerScoreTs = now } +{-# INLINE applyPeerRejections #-} + +txClaimReadyAt :: DiffTime -> TxEntry peeraddr -> Time +txClaimReadyAt claimDelay TxEntry { txLease } = + addTime claimDelay claimableAt + where + claimableAt = + case txLease of + TxLeased _ leaseUntil -> leaseUntil + TxClaimable readyAt -> readyAt + +-- | Determine if an unacknowledged txid is ready to be acknowledged. -- -const_MAX_TX_SIZE_DISCREPANCY :: SizeInBytes -const_MAX_TX_SIZE_DISCREPANCY = 32 - -collectTxsImpl - :: forall peeraddr tx txid. - ( Ord peeraddr - , Ord txid - , Show txid - , Typeable txid - ) - => (tx -> SizeInBytes) -- ^ compute tx size - -> peeraddr - -> Map txid SizeInBytes -- ^ requested txids - -> Map txid tx -- ^ received txs - -> SharedTxState peeraddr txid tx - -> Either TxSubmissionProtocolError - (SharedTxState peeraddr txid tx) - -- ^ Return list of `txid` which sizes didn't match or a new state. - -- If one of the `tx` has wrong size, we return an error. The - -- mini-protocol will throw, which will clean the state map from this peer. -collectTxsImpl txSize peeraddr requestedTxIdsMap receivedTxs - st@SharedTxState { peerTxStates } = - - -- using `alterF` so the update of `PeerTxState` is done in one lookup - case Map.alterF (fmap Just . fn . fromJust) - peeraddr - peerTxStates of - (Right st', peerTxStates') -> - Right st' { peerTxStates = peerTxStates' } - (Left e, _) -> - Left $ ProtocolErrorTxSizeError e +-- A txid remains ackable after it has been resolved and removed from shared +-- state. The wire protocol only needs an ack count for the peer-local +-- unacknowledged prefix, so a late ack is still safe even after the active +-- entry and retained marker have been pruned. +txIdAckable :: Eq peeraddr + => PeerActionContext peeraddr txid tx + -> TxKey + -> Bool +txIdAckable PeerActionContext { pacPeerAddr, pacPeerState, pacPeerInFlight, pacSharedState } + (TxKey k) + | retainedMember k (sharedRetainedTxs pacSharedState) = True + | IntMap.member k (peerDownloadedTxs pacPeerState) = False + -- We hold the body in our local buffer; we must submit it before + -- acking the txid, otherwise the body would orphan in + -- 'peerDownloadedTxs' if 'pickSubmitAction' is blocked from + -- reaching this entry by an earlier in-flight tx. + | not (IntSet.member k (pifAdvertised pacPeerInFlight)) = True + -- The peer no longer tracks the txid as advertised. This covers + -- mempool/retained txids that 'handleReceivedTxIds' kept out of the + -- advertised set, as well as txids the peer has already attempted + -- and submitted (or that another peer resolved). + | otherwise = + case IntMap.lookup k (sharedTxTable pacSharedState) of + Just txEntry -> + let peerHasStake = + IntSet.member k (pifAttempting pacPeerInFlight) + || IntSet.member k (pifSubmitting pacPeerInFlight) + ackWhenBuffered = + case txLease txEntry of + TxLeased owner _ -> owner == pacPeerAddr || peerHasStake + TxClaimable _ -> peerHasStake + in + -- Ack the txid if we downloaded it and no other + -- peer is in the process of submitting it to the + -- mempool. + ackWhenBuffered + && IntMap.member k (peerDownloadedTxs pacPeerState) + && not (txBufferedByPeer pacPeerState k + && txSubmittingByOther pacPeerInFlight k txEntry) + Nothing -> True -- Safe late ack after the resolved tx was pruned from shared state. +-- | Remove transaction entries from all shared state maps by key. +dropTxKeys :: HasRawTxId txid + => IntSet.IntSet + -> SharedTxState peeraddr txid + -> SharedTxState peeraddr txid +dropTxKeys keys st@SharedTxState { sharedTxTable, sharedRetainedTxs, sharedTxIdToKey + , sharedKeyToTxId } + | IntSet.null keys = st + | otherwise = + st { + sharedTxTable = IntMap.withoutKeys sharedTxTable keys, + sharedRetainedTxs = retainedDeleteKeys keys sharedRetainedTxs, + sharedTxIdToKey = IntSet.foldl' deleteTxId sharedTxIdToKey keys, + sharedKeyToTxId = IntMap.withoutKeys sharedKeyToTxId keys + } where - -- Update `PeerTxState` and partially update `SharedTxState` (except of - -- `peerTxStates`). - fn :: PeerTxState txid tx - -> ( Either [(txid, SizeInBytes, SizeInBytes)] - (SharedTxState peeraddr txid tx) - , PeerTxState txid tx - ) - fn ps = - case wrongSizedTxs of - [] -> ( Right st' - , ps'' - ) - _ -> ( Left wrongSizedTxs - , ps - ) - where - wrongSizedTxs :: [(txid, SizeInBytes, SizeInBytes)] - wrongSizedTxs = - map (\(a, (b,c)) -> (a,b,c)) - . Map.toList - $ Map.merge - Map.dropMissing - Map.dropMissing - (Map.zipWithMaybeMatched \_ receivedSize advertisedSize -> - if receivedSize `checkTxSize` advertisedSize - then Nothing - else Just (receivedSize, advertisedSize) - ) - (txSize `Map.map` receivedTxs) - requestedTxIdsMap - - checkTxSize :: SizeInBytes - -> SizeInBytes - -> Bool - checkTxSize received advertised - = abs (received - advertised) <= const_MAX_TX_SIZE_DISCREPANCY - - requestedTxIds = Map.keysSet requestedTxIdsMap - notReceived = requestedTxIds Set.\\ Map.keysSet receivedTxs - downloadedTxs' = downloadedTxs ps <> receivedTxs - -- Add not received txs to `unknownTxs` before acknowledging txids. - unknownTxs' = unknownTxs ps <> notReceived - - requestedTxsInflight' = - assert (requestedTxIds `Set.isSubsetOf` requestedTxsInflight ps) $ - requestedTxsInflight ps Set.\\ requestedTxIds - - requestedSize = fold $ availableTxIds ps `Map.restrictKeys` requestedTxIds - requestedTxsInflightSize' = - assert (requestedTxsInflightSize ps >= requestedSize) $ - requestedTxsInflightSize ps - requestedSize - - -- subtract requested from in-flight - inflightTxs'' = - Map.merge - (Map.mapMaybeMissing \_ x -> Just x) - (Map.mapMaybeMissing \_ _ -> assert False Nothing) - (Map.zipWithMaybeMatched \_ x y -> assert (x >= y) - let z = x - y in - if z > 0 - then Just z - else Nothing) - (inflightTxs st) - (Map.fromSet (const 1) requestedTxIds) - - st' = st { inflightTxs = inflightTxs'' } - - -- - -- Update PeerTxState - -- - - -- Remove the downloaded `txid`s from the availableTxIds map, this - -- guarantees that we won't attempt to download the `txids` from this peer - -- once we collect the `txid`s. Also restrict keys to `liveSet`. - -- - -- NOTE: we could remove `notReceived` from `availableTxIds`; and - -- possibly avoid using `unknownTxs` field at all. - -- - availableTxIds'' = availableTxIds ps - `Map.withoutKeys` - requestedTxIds - - -- Remove all acknowledged `txid`s from unknown set, but only those - -- which are not present in `unacknowledgedTxIds'` - unknownTxs'' = unknownTxs' - `Set.intersection` - live - where - -- We cannot use `liveSet` as `unknown <> notReceived` might - -- contain `txids` which are in `liveSet` but are not `live`. - live = Set.fromList (toList (unacknowledgedTxIds ps)) - - ps'' = ps { availableTxIds = availableTxIds'', - unknownTxs = unknownTxs'', - requestedTxsInflightSize = requestedTxsInflightSize', - requestedTxsInflight = requestedTxsInflight', - downloadedTxs = downloadedTxs' } + deleteTxId txIdToKey k = + case IntMap.lookup k sharedKeyToTxId of + Just txid -> Map.delete (getRawTxId txid) txIdToKey + Nothing -> txIdToKey +-- | Remove only the txid <-> key lookup entries for the given keys. +-- Used by the sweep for keys that have outlived their 'sharedTxTable' +-- and retained residence but had their lookup entries kept while peers +-- still carried the txid in 'peerUnacknowledgedTxIds'. +dropLookupOnly :: HasRawTxId txid + => IntSet.IntSet + -> SharedTxState peeraddr txid + -> SharedTxState peeraddr txid +dropLookupOnly keys st@SharedTxState { sharedTxIdToKey, sharedKeyToTxId } + | IntSet.null keys = st + | otherwise = + st { + sharedTxIdToKey = IntSet.foldl' deleteTxId sharedTxIdToKey keys, + sharedKeyToTxId = IntMap.withoutKeys sharedKeyToTxId keys + } + where + deleteTxId txIdToKey k = + case IntMap.lookup k sharedKeyToTxId of + Just txid -> Map.delete (getRawTxId txid) txIdToKey + Nothing -> txIdToKey + +-- | Shared-state cleanup +-- +-- Drops three kinds of dead entries in one pass: -- --- Monadic public API +-- * Retained entries whose retention deadline has passed. Only the +-- 'sharedRetainedTxs' membership is removed; the txid lookup tables +-- ('sharedTxIdToKey', 'sharedKeyToTxId') are preserved here because +-- peers may still hold the key in 'peerUnacknowledgedTxIds' until +-- they ack it. +-- * Orphaned 'sharedTxTable' entries: entries with a released lease, +-- no in-flight attempt, and no live peer still tracking the key. +-- These are safe to fully tear down (lookup tables included): by +-- definition no peer references them. +-- * Stale lookup-table entries: keys present only in 'sharedTxIdToKey' +-- / 'sharedKeyToTxId' with no peer still referencing them. Bounds +-- the lookup tables so they don't grow unboundedly. -- +-- The @liveReferences@ set is the union of every active peer's +-- 'pifAdvertised' and 'pifAcksPending'. Caller (the sweep thread) +-- snapshots all per-peer TVars in the same STM transaction that runs +-- this function so the snapshot is coherent with the sharedTxTable +-- read. +-- +-- Bumps 'sharedGeneration' if anything changed so sleeping peer workers wake +-- and re-evaluate. +sweepSharedState :: HasRawTxId txid + => Time + -> IntSet + -> SharedTxState peeraddr txid + -> SharedTxState peeraddr txid +sweepSharedState now liveReferences st + | IntSet.null orphans + && IntSet.null expiredRetained + && IntSet.null staleLookups = st + | otherwise = + ( dropLookupOnly staleLookups + . dropTxKeys orphans + $ st { sharedRetainedTxs = + retainedDeleteKeys expiredRetained (sharedRetainedTxs st) } + ) { sharedGeneration = sharedGeneration st + 1 } + where + expiredRetained = retainedExpiredKeys now (sharedRetainedTxs st) + orphans = + IntMap.keysSet + (IntMap.filterWithKey isOrphan (sharedTxTable st)) -type SharedTxStateVar m peeraddr txid tx = StrictTVar m (SharedTxState peeraddr txid tx) - -newSharedTxStateVar :: MonadSTM m - => StdGen - -> m (SharedTxStateVar m peeraddr txid tx) -newSharedTxStateVar rng = newTVarIO SharedTxState { - peerTxStates = Map.empty, - inflightTxs = Map.empty, - bufferedTxs = Map.empty, - referenceCounts = Map.empty, - timedTxs = Map.empty, - inSubmissionToMempoolTxs = Map.empty, - peerRng = rng - } + retainedAfter = retainedKeysSet (sharedRetainedTxs st) + `IntSet.difference` expiredRetained + referencedKeys = IntMap.keysSet (sharedTxTable st) + `IntSet.union` retainedAfter + `IntSet.union` liveReferences + staleLookups = IntMap.keysSet (sharedKeyToTxId st) + `IntSet.difference` referencedKeys + `IntSet.difference` orphans + isOrphan _ TxEntry { txLease = TxLeased {} } = False + isOrphan k TxEntry { txAttempt, txInSubmission } + | txAttempt > 0 = False + | txInSubmission = False + | IntSet.member k liveReferences = False + | otherwise = True +{-# INLINABLE sweepSharedState #-} --- | Acknowledge `txid`s, return the number of `txids` to be acknowledged to the --- remote side. +-- | Handle a batch of tx bodies received from one peer. -- -receivedTxIds - :: forall m peeraddr idx tx txid. - (MonadSTM m, Ord txid, Ord peeraddr) - => Tracer m (TraceTxLogic peeraddr txid tx) - -> SharedTxStateVar m peeraddr txid tx - -> STM m (MempoolSnapshot txid tx idx) - -> peeraddr - -> NumTxIdsToReq - -- ^ number of requests to subtract from - -- `requestedTxIdsInflight` - -> StrictSeq txid - -- ^ sequence of received `txids` - -> Map txid SizeInBytes - -- ^ received `txid`s with sizes - -> m () -receivedTxIds tracer sharedVar getMempoolSnapshot peeraddr reqNo txidsSeq txidsMap = do - st <- atomically $ do - MempoolSnapshot{mempoolHasTx} <- getMempoolSnapshot - stateTVar sharedVar ((\a -> (a,a)) . receivedTxIdsImpl mempoolHasTx peeraddr reqNo txidsSeq txidsMap) - traceWith tracer (TraceSharedTxState "receivedTxIds" st) - - --- | Include received `tx`s in `SharedTxState`. Return number of `txids` --- to be acknowledged and list of `tx` to be added to the mempool. +-- Received bodies are buffered locally in the peer state. Bodies that are +-- already retained or already in the mempool are counted as late and dropped. +-- Any requested tx omitted from the reply releases this peer's ownership. +-- Late TXs contributes to the returned penalty count. +handleReceivedTxs :: (Eq peeraddr, HasRawTxId txid) + => (txid -> Bool) + -> Time + -> TxDecisionPolicy + -> peeraddr + -> [(txid, tx)] + -> PeerTxLocalState tx + -> PeerTxInFlight + -> SharedTxState peeraddr txid + -> (Int, Int, PeerTxLocalState tx, PeerTxInFlight, SharedTxState peeraddr txid) +handleReceivedTxs mempoolHasTx now policy peeraddr txs peerState peerInFlight sharedState = + (omittedCount, lateCount, peerState', peerInFlight', sharedState') + where + txidToKey = sharedTxIdToKey sharedState + + requestedKeys = requestedTxBatchSet requestedBatch + retainUntil = addTime (bufferedTxsMinLifetime policy) now + + -- Dequeue the next requested tx batch to process. + (requestedBatch, remainingRequestedBatches) = + case peerRequestedTxBatches peerState of + StrictSeq.Empty -> + error "TxSubmission.Inbound.V2.handleReceivedTxs null requestedBatches" + batch StrictSeq.:<| batches -> + (batch, batches) + + -- Process each received tx, collecting late counts, pending + -- requests, the keys still buffered by this peer, and updated + -- shared state. @bufferedKeys@ is the subset of @requestedKeys@ + -- that ended up buffered locally; the rest are released below. + ( lateCount + , pendingRequestedKeys + , bufferedKeys + , sharedStateHandled + , peerDownloadedTxs' + ) = + foldl' + handleOne + ( 0 + , requestedKeys + , IntSet.empty + , sharedState + , peerDownloadedTxs peerState + ) + txs + + -- Process omitted (not received) txs: count a penalty for every omitted + -- request and release this peer's lease where it still held one. + (omittedCount, sharedStateReleased) = + IntSet.foldl' handleOmitted (0, sharedStateHandled) pendingRequestedKeys + + -- Keys this peer is no longer attempting (everything in the batch + -- except still-buffered keys). Used to update both the per-peer + -- in-flight set and the shared 'txAttempt' counters via 'releaseLease'. + releasedKeys = requestedKeys `IntSet.difference` bufferedKeys + + sharedState' = + sharedStateReleased { + sharedGeneration = sharedGeneration sharedState + 1 + } + + -- Update peer state: remove processed keys, update batch tracking, + -- and record downloaded txs. + peerState' = peerState { + peerAvailableTxIds = + IntMap.withoutKeys (peerAvailableTxIds peerState) requestedKeys + , peerRequestedTxs = peerRequestedTxs peerState `IntSet.difference` requestedKeys + , peerRequestedTxBatches = remainingRequestedBatches + , peerRequestedTxsSize = peerRequestedTxsSize peerState - requestedTxBatchSize requestedBatch + , peerDownloadedTxs = peerDownloadedTxs' + } + + peerInFlight' = peerInFlight { + pifLeased = pifLeased peerInFlight `IntSet.difference` releasedKeys, + pifAttempting = pifAttempting peerInFlight `IntSet.difference` releasedKeys, + pifAdvertised = pifAdvertised peerInFlight `IntSet.difference` releasedKeys + } + + keyWasLive k = + IntMap.member k (sharedTxTable sharedState) + || retainedMember k (sharedRetainedTxs sharedState) + + -- Fold function over received txs: classify as late, already in mempool, or buffer for + -- download. + handleOne + ( lateCountAcc + , pendingKeysAcc + , bufferedAcc + , sharedAcc + , downloadedAcc + ) + (txid, tx) = + case Map.lookup (getRawTxId txid) txidToKey of + Nothing -> + ( lateCountAcc + 1 + , pendingKeysAcc + , bufferedAcc + , sharedAcc + , downloadedAcc + ) + Just (TxKey k) + | retainedMember k (sharedRetainedTxs sharedAcc) -> + let sharedAcc' = + sharedAcc { + sharedTxTable = + IntMap.adjust decAttempt k (sharedTxTable sharedAcc) + } + in ( lateCountAcc + 1 + , IntSet.delete k pendingKeysAcc + , bufferedAcc + , sharedAcc' + , downloadedAcc + ) + | mempoolHasTx txid -> + let sharedAcc' = + sharedAcc { + sharedTxTable = IntMap.delete k (sharedTxTable sharedAcc), + sharedRetainedTxs = + retainedInsertMax k retainUntil (sharedRetainedTxs sharedAcc) + } + in ( lateCountAcc + 1 + , IntSet.delete k pendingKeysAcc + , bufferedAcc + , sharedAcc' + , downloadedAcc + ) + | otherwise -> + case IntMap.lookup k (sharedTxTable sharedAcc) of + Just _txEntry + | IntSet.member k (pifAttempting peerInFlight) -> + ( lateCountAcc + , IntSet.delete k pendingKeysAcc + , IntSet.insert k bufferedAcc + , sharedAcc + , IntMap.insert k tx downloadedAcc + ) + _ -> + ( lateCountAcc + 1 + , IntSet.delete k pendingKeysAcc + , bufferedAcc + , sharedAcc + , downloadedAcc + ) + + -- Handle omitted (not received) txs: release this peer's lease so + -- another advertiser can claim the tx, decrement 'txAttempt'. + handleOmitted (omittedCountAcc, sharedAcc) k + | keyWasLive k = + let sharedAcc' = + case IntMap.lookup k (sharedTxTable sharedAcc) of + Just txEntry -> + sharedAcc { + sharedTxTable = + IntMap.insert k (releaseLease txEntry) + (sharedTxTable sharedAcc) + } + Nothing -> + sharedAcc + in (omittedCountAcc + 1, sharedAcc') + | otherwise = + (omittedCountAcc + 1, sharedAcc) + + -- Decrement the entry's attempt counter (e.g. when its body arrived + -- but the tx had been retained meanwhile, so the peer's attempt is + -- effectively over). Lease unaffected: if this peer didn't hold it, + -- nothing to do; if it did, the decrement still leaves @txAttempt@ + -- non-negative because every increment had a paired peer. + decAttempt entry@TxEntry { txAttempt } = + entry { txAttempt = max 0 (txAttempt - 1) } + + releaseLease txEntry@TxEntry { txLease, txAttempt } = + txEntry { + txLease = case txLease of + TxLeased owner _ | owner == peeraddr -> TxClaimable now + _ -> txLease, + txAttempt = max 0 (txAttempt - 1) + } +{-# INLINABLE handleReceivedTxs #-} + + +-- | Handle the result of submitting buffered txs to the mempool. +-- +-- Accepted txs leave the active table and move into the retained set so later +-- txid advertisements can be acknowledged without re-requesting the body. +-- Txs rejected by the mempool release this peer's lease and clear +-- 'txInSubmission' so another advertiser may try later. +handleSubmittedTxs :: Eq peeraddr + => Time + -> TxDecisionPolicy + -> peeraddr + -> [TxKey] + -> [TxKey] + -> PeerTxLocalState tx + -> PeerTxInFlight + -> SharedTxState peeraddr txid + -> (PeerTxLocalState tx, PeerTxInFlight, SharedTxState peeraddr txid) +handleSubmittedTxs now policy peeraddr acceptedTxs rejectedTxs peerState peerInFlight sharedState = + (peerState', peerInFlight', sharedState') + where + acceptedKeys = IntSet.fromList (unTxKey <$> acceptedTxs) + rejectedKeys = IntSet.fromList (unTxKey <$> rejectedTxs) + submittedKeys = acceptedKeys `IntSet.union` rejectedKeys + + peerState' = peerState { + peerDownloadedTxs = + IntMap.withoutKeys (peerDownloadedTxs peerState) submittedKeys, + peerAvailableTxIds = + IntMap.withoutKeys (peerAvailableTxIds peerState) submittedKeys + } + + -- Submission outcomes clear the peer's submission and advertised + -- contributions for these keys; the peer is done with them. The + -- attempt was already taken off 'pifAttempting' (and 'txAttempt') + -- when 'markSubmittingTxs' fired. + peerInFlight' = peerInFlight { + pifLeased = pifLeased peerInFlight `IntSet.difference` submittedKeys, + pifSubmitting = pifSubmitting peerInFlight `IntSet.difference` submittedKeys, + pifAdvertised = pifAdvertised peerInFlight `IntSet.difference` submittedKeys + } + + sharedStateAfterAccepted = + foldl' acceptSubmittedTx sharedState acceptedTxs + + sharedStateAfterRejected = + IntSet.foldl' updateRejected sharedStateAfterAccepted rejectedKeys + + sharedState' = + sharedStateAfterRejected { + sharedGeneration = sharedGeneration sharedState + 1 + } + + retainedUntil = addTime (bufferedTxsMinLifetime policy) now + + acceptSubmittedTx sharedAcc (TxKey k) = + sharedAcc { + sharedTxTable = IntMap.delete k (sharedTxTable sharedAcc), + sharedRetainedTxs = + retainedInsertMax k retainedUntil (sharedRetainedTxs sharedAcc) + } + + updateRejected sharedAcc k = + case IntMap.lookup k (sharedTxTable sharedAcc) of + Just txEntry -> + sharedAcc { + sharedTxTable = + IntMap.insert k (markRejected txEntry) (sharedTxTable sharedAcc) + } + Nothing -> + sharedAcc + + markRejected txEntry@TxEntry { txLease } = + txEntry { + txLease = case txLease of + TxLeased owner _ | owner == peeraddr -> TxClaimable now + _ -> txLease, + txInSubmission = False + } +{-# INLINABLE handleSubmittedTxs #-} + + +-- | Mark buffered txs as entering mempool submission. -- -collectTxs - :: forall m peeraddr tx txid. - (MonadSTM m, Ord txid, Ord peeraddr, - Show txid, Typeable txid) - => Tracer m (TraceTxLogic peeraddr txid tx) - -> (tx -> SizeInBytes) - -> SharedTxStateVar m peeraddr txid tx - -> peeraddr - -> Map txid SizeInBytes -- ^ set of requested txids with their announced size - -> Map txid tx -- ^ received txs - -> m (Maybe TxSubmissionProtocolError) - -- ^ number of txids to be acknowledged and txs to be added to the - -- mempool -collectTxs tracer txSize sharedVar peeraddr txidsRequested txsMap = do - r <- atomically $ do - st <- readTVar sharedVar - case collectTxsImpl txSize peeraddr txidsRequested txsMap st of - r@(Right st') -> writeTVar sharedVar st' - $> r - r@Left {} -> pure r - case r of - Right st -> traceWith tracer (TraceSharedTxState "collectTxs" st) - $> Nothing - Left e -> return (Just e) +-- Decrements 'txAttempt' (the peer is leaving the @attempting@ state) +-- and sets 'txInSubmission'. STM serialisation around the +-- @ChooseSubmit@ choice guarantees only one peer ever flips +-- 'txInSubmission' from @False@ to @True@ for a given key. +markSubmittingTxs :: [TxKey] + -> SharedTxState peeraddr txid + -> SharedTxState peeraddr txid +markSubmittingTxs [] st = st +markSubmittingTxs txKeys st = + st { + sharedTxTable = foldl' markOne (sharedTxTable st) txKeys, + sharedGeneration = sharedGeneration st + 1 + } + where + markOne txTable (TxKey k) = IntMap.adjust markSubmitting k txTable + + markSubmitting txEntry@TxEntry { txAttempt } = + txEntry { + txAttempt = max 0 (txAttempt - 1), + txInSubmission = True + } + + +-- | Handle a batch of txids received from one peer. +-- +-- Newly seen txids are interned, appended to the peer's unacknowledged queue, +-- and entered into the shared tx table as claimable work. Any peer that later +-- advertises the txid may claim it once its score-derived delay has elapsed, +-- which avoids pinning fresh work to the first peer that happened to announce +-- it. +handleReceivedTxIds :: forall peeraddr txid tx. HasRawTxId txid + => (txid -> Bool) + -> Time + -> TxDecisionPolicy + -> NumTxIdsToReq + -> [(txid, SizeInBytes)] + -> PeerTxLocalState tx + -> PeerTxInFlight + -> SharedTxState peeraddr txid + -> (PeerTxLocalState tx, PeerTxInFlight, SharedTxState peeraddr txid) +handleReceivedTxIds mempoolHasTx now policy requestedTxIds txidsAndSizes + peerState peerInFlight sharedState = + (peerState'', peerInFlight'', sharedState'') + where + peerAdvertisedKeys0 = pifAdvertised peerInFlight + peerAcksPending0 = pifAcksPending peerInFlight + + -- Fold over received txids: build unacknowledged list, update tables. + ( receivedTxKeysRev + , peerAvailableTxIds' + , sharedStateHandled + , peerAdvertisedKeys' + , peerAcksPending' + , sharedChanged + ) = + foldl' + step + ( [] + , peerAvailableTxIds peerState + , sharedState + , peerAdvertisedKeys0 + , peerAcksPending0 + , False + ) + txidsAndSizes + + peerUnacknowledgedTxIds' = + peerUnacknowledgedTxIds peerState <> StrictSeq.fromList (reverse receivedTxKeysRev) + + peerState'' = peerState { + peerUnacknowledgedTxIds = peerUnacknowledgedTxIds', + peerRequestedTxIds = fromIntegral $ + max 0 ( fromIntegral (peerRequestedTxIds peerState) - + fromIntegral requestedTxIds :: Int ), + peerAvailableTxIds = peerAvailableTxIds' + } + + peerInFlight'' = peerInFlight { + pifAdvertised = peerAdvertisedKeys', + pifAcksPending = peerAcksPending' + } + + sharedState'' + | sharedChanged = + sharedStateHandled { + sharedGeneration = sharedGeneration sharedState + 1 + } + | otherwise = + sharedState + + retainUntil = addTime (bufferedTxsMinLifetime policy) now + + -- Process each received txid: classify as retained, in mempool, or new entry. + step + :: ( [TxKey] + , IntMap.IntMap SizeInBytes + , SharedTxState peeraddr txid + , IntSet.IntSet + , IntSet.IntSet + , Bool + ) + -> (txid, SizeInBytes) + -> ( [TxKey] + , IntMap.IntMap SizeInBytes + , SharedTxState peeraddr txid + , IntSet.IntSet + , IntSet.IntSet + , Bool + ) + step + ( !unacknowledgedAcc + , !availableAcc + , !sharedAcc + , !peerAdvertisedKeysAcc + , !peerAcksPendingAcc + , !sharedChangedAcc + ) + (txid, txSize) + | retainedMember k retainedAcc = + ( txKey : unacknowledgedAcc + , IntMap.delete k availableAcc + , sharedAcc' + , IntSet.delete k peerAdvertisedKeysAcc + , IntSet.insert k peerAcksPendingAcc + , sharedChangedAcc' + ) + | mempoolHasTx txid = + ( txKey : unacknowledgedAcc + , IntMap.delete k availableAcc + , sharedAcc' { + sharedTxTable = IntMap.delete k (sharedTxTable sharedAcc'), + sharedRetainedTxs = + retainedInsertMax k retainUntil (sharedRetainedTxs sharedAcc') + } + , IntSet.delete k peerAdvertisedKeysAcc + , IntSet.insert k peerAcksPendingAcc + , True + ) + | otherwise = + case IntMap.lookup k (sharedTxTable sharedAcc') of + Nothing -> + let txEntry = TxEntry { + txLease = TxClaimable now, + txAttempt = 0, + txInSubmission = False, + currentMaxInflightMultiplicity = + txInflightMultiplicity policy + } + in ( txKey : unacknowledgedAcc + , IntMap.insert k txSize availableAcc + , sharedAcc' { + sharedTxTable = IntMap.insert k txEntry (sharedTxTable sharedAcc') + } + , IntSet.insert k peerAdvertisedKeysAcc + , IntSet.insert k peerAcksPendingAcc + , True + ) + Just _ -> + ( txKey : unacknowledgedAcc + , IntMap.insert k txSize availableAcc + , sharedAcc' + , IntSet.insert k peerAdvertisedKeysAcc + , IntSet.insert k peerAcksPendingAcc + , sharedChangedAcc' + ) + where + retainedAcc = sharedRetainedTxs sharedAcc' + sharedChangedAcc' = sharedChangedAcc || txKeyWasNew + (txKey@(TxKey k), txKeyWasNew, sharedAcc') = lookupOrInternTxId txid sharedAcc + + lookupOrInternTxId txid st@SharedTxState { sharedTxIdToKey, sharedKeyToTxId, sharedNextTxKey } + | Just key <- Map.lookup rawId sharedTxIdToKey = (key, False, st) + | otherwise = + let key = TxKey sharedNextTxKey + in ( key + , True + , st { + sharedTxIdToKey = Map.insert rawId key sharedTxIdToKey, + sharedKeyToTxId = IntMap.insert sharedNextTxKey txid sharedKeyToTxId, + sharedNextTxKey = sharedNextTxKey + 1 + } + ) + where rawId = getRawTxId txid +{-# INLINABLE handleReceivedTxIds #-} diff --git a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs index 0fa246e4a88..6ec6271b602 100644 --- a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs +++ b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs @@ -1,27 +1,41 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} module Ouroboros.Network.TxSubmission.Inbound.V2.Types - ( -- * PeerTxState - PeerTxState (..) - -- * SharedTxState - , SharedTxState (..) - -- * Decisions - , TxsToMempool (..) - , TxDecision (..) - , emptyTxDecision + ( -- * Shared state + SharedTxState (..) + -- * RetainedTxs with helper functions + , RetainedTxs + , retainedEmpty + , retainedSingleton + , retainedFromList + , retainedToList + , retainedSize + , retainedLookup + , retainedMember + , retainedInsertMax + , retainedDeleteKeys + , retainedKeysSet + , retainedRestrictKeys + , retainedNextWake + , retainedExpiredKeys + -- * Traces , TraceTxLogic (..) , TxSubmissionInitDelay (..) , defaultTxSubmissionInitDelay + , const_MAX_TX_SIZE_DISCREPANCY -- * Types shared with V1 -- ** Various , ProcessedTxCount (..) @@ -31,307 +45,633 @@ module Ouroboros.Network.TxSubmission.Inbound.V2.Types -- ** Traces , TraceTxSubmissionInbound (..) , TxSubmissionCounters (..) - , mkTxSubmissionCounters -- ** Protocol Error , TxSubmissionProtocolError (..) + , TxOwnerAckState (..) + , TxAdvertiser (..) + , RequestedTxBatch (..) + , TxLease (..) + , TxEntry (..) + , TxIdsReqFlavour (..) + , PeerAction (..) + , PeerPhase (..) + , PeerScore (..) + , PeerTxLocalState (..) + , PeerTxInFlight (..) + , emptyPeerTxInFlight + -- TxKey with helper functions + , TxKey (..) + , lookupTxKey + , resolveTxKey + , internTxId + , internTxIds + , emptyPeerScore + , emptyPeerTxLocalState + , emptySharedTxState + , diffTimeToMilliseconds ) where -import Control.DeepSeq +import Control.DeepSeq (NFData) import Control.Exception (Exception (..)) import Control.Monad.Class.MonadTime.SI +import NoThunks.Class (NoThunks) +import NoThunks.Class.Orphans () + import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Monoid (Sum (..)) import Data.Sequence.Strict (StrictSeq) -import Data.Set (Set) -import Data.Set qualified as Set +import Data.Time.Clock (diffTimeToPicoseconds) import Data.Typeable (Typeable, eqT, (:~:) (Refl)) import GHC.Generics (Generic) -import System.Random (StdGen) - -import NoThunks.Class (NoThunks (..)) import Ouroboros.Network.Protocol.TxSubmission2.Type - --- | Flag to enable/disable the usage of the new tx-submission logic. +import Ouroboros.Network.Tx (HasRawTxId (..), RawTxId) + +import Data.Foldable (foldl') +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.IntPSQ (IntPSQ) +import Data.IntPSQ qualified as IntPSQ +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet +import Data.List (sortOn) +import Data.Sequence.Strict qualified as StrictSeq +import Data.Word (Word64) + + +-- | We check advertised sizes in a fuzzy way. The advertised and received +-- sizes need to agree up to this discrepancy. +const_MAX_TX_SIZE_DISCREPANCY :: SizeInBytes +const_MAX_TX_SIZE_DISCREPANCY = 32 + +-- | Compact internal transaction key used by V2 state. +newtype TxKey = TxKey { unTxKey :: Int } + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (Enum, NFData, NoThunks) + +-- | State which determines when a peer that advertised a txid may +-- acknowledge it. -- -data TxSubmissionLogicVersion = - -- | the legacy `Ouroboros.Network.TxSubmission.Inbound.V1` - TxSubmissionLogicV1 - -- | the new `Ouroboros.Network.TxSubmission.Inbound.V2` - | TxSubmissionLogicV2 - deriving (Eq, Show, Enum, Bounded) - --- --- PeerTxState, SharedTxState +-- The owner peer may acknowledge once the body is buffered locally, +-- while other peers must wait until the tx is either accepted by the +-- mempool or fully exhausted. +data TxOwnerAckState + = AckWhenBuffered + | AckWhenResolved + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass NFData + +instance NoThunks TxOwnerAckState + +-- | Per-peer advertisement state for a tx. -- - -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. - -- - requestedTxsInflightSize :: !SizeInBytes, - - -- | The set of requested `txid`s. - -- - requestedTxsInflight :: !(Set txid), - - -- | A subset of `unacknowledgedTxIds` which were unknown to the peer - -- (i.e. requested but not received). We need to track these `txid`s - -- since they need to be acknowledged. - -- - -- We track these `txid` per peer, rather than in `bufferedTxs` map, - -- since that could potentially lead to corrupting the node, not being - -- able to download a `tx` which is needed & available from other nodes. - -- - unknownTxs :: !(Set txid), - - -- | Score is a metric that tracks how usefull a peer has been. - -- The larger the value the less usefull peer. It slowly decays towards - -- zero. - score :: !Double, - - -- | Timestamp for the last time `score` was drained. - scoreTs :: !Time, - - -- | A set of TXs downloaded from the peer. They are not yet - -- acknowledged and haven't been sent to the mempool yet. - -- - -- Life cycle of entries: - -- * added when a tx is downloaded (see `collectTxsImpl`) - -- * follows `unacknowledgedTxIds` (see `acknowledgeTxIds`) - -- - downloadedTxs :: !(Map txid tx), - - -- | A set of TXs on their way to the mempool. - -- Tracked here so that we can cleanup `inSubmissionToMempoolTxs` if the - -- peer dies. - -- - -- Life cycle of entries: - -- * added by `acknowledgeTxIds` (where decide which txs can be - -- submitted to the mempool) - -- * removed by `withMempoolSem` - -- - toMempoolTxs :: !(Map txid tx) - - } - deriving (Eq, Show, Generic, NFData) - -instance ( NoThunks txid - , NoThunks tx - ) => NoThunks (PeerTxState txid tx) +newtype TxAdvertiser = TxAdvertiser { + txAckState :: TxOwnerAckState + } + deriving stock (Eq, Show, Generic) + deriving newtype NFData --- | Shared state of all `TxSubmission` clients. +-- | The current download lease for a tx body. -- --- New `txid` enters `unacknowledgedTxIds` it is also added to `availableTxIds` --- and `referenceCounts` (see `acknowledgeTxIdsImpl`). +-- A tx is either currently leased to a peer until a deadline or it is +-- unowned and became claimable at a specific time. Peers use their decayed +-- score as an additional per-peer delay after that claimable time before +-- attempting to steal the lease. +data TxLease peeraddr = TxLeased !peeraddr !Time + | TxClaimable !Time + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData, NoThunks) + +-- | Shared per-tx state. -- --- When a `txid` id is selected to be downloaded, it's added to --- `requestedTxsInflightSize` (see --- `Ouroboros.Network.TxSubmission.Inbound.Decision.pickTxsToDownload`). +-- V2 keeps all cross-peer coordination at tx granularity. The first +-- peer that advertises a new txid becomes its initial owner. If the +-- lease expires without a successful outcome, the tx becomes claimable +-- and another eligible advertiser may atomically claim it. -- --- 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`). +-- Per-peer attempt detail is tracked in each peer's 'PeerTxInFlight' +-- TVar (owned by 'withPeer'). The shared entry only carries +-- aggregate counts: how many peers are currently attempting this body +-- and whether any peer is mid mempool submission. +data TxEntry peeraddr = TxEntry { + -- | Current owner lease for downloading the tx body. When + -- 'TxClaimable', the embedded 'Time' also doubles as the + -- last-activity stamp used by the orphan sweep. + txLease :: !(TxLease peeraddr), + + -- | Number of peers currently attempting the body (claimed lease + -- and/or buffered locally). Incremented on claim, decremented on + -- omit / lease release / 'PeerSubmitTxs' transition (the + -- submitting peer no longer counts as an attempter). + txAttempt :: !Int, + + -- | At least one peer is currently inside @mempoolAddTxs@ for this + -- body. Other peers use this flag, combined with their own + -- 'pifSubmitting' set, to skip 'PeerSubmitTxs' for the same key. + -- STM serialisation guarantees at most one peer is the submitter + -- at any moment. + txInSubmission :: !Bool, + + -- | Effective per-tx inflight multiplicity cap. + -- + -- Initialised from 'txInflightMultiplicity' of the policy when the + -- entry is created, and bumped by one when a peer's attempt sits past + -- 'inflightTimeout' without reaching submission, allowing another + -- peer to attempt in parallel. + currentMaxInflightMultiplicity :: !Int + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData, NoThunks) + +-- | Per-peer in-flight tracking, owned by 'withPeer'. -- --- 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`). +-- The peer thread updates this TVar in the same STM transaction as +-- the shared 'TxEntry' so the two stay coherent. Two readers: -- -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), - - -- | Map of `tx` which: - -- - -- * were downloaded and added to the mempool, - -- * are already in the mempool (`Nothing` is inserted in that case), - -- - -- We only keep live `txid`, e.g. ones which `txid` is unacknowledged by - -- at least one peer or has a `timedTxs` entry. - -- - -- /Note:/ `txid`s which `tx` were unknown by a peer are tracked - -- separately in `unknownTxs`. - -- - -- /Note:/ previous implementation also needed to explicitly track - -- `txid`s which were already acknowledged, but are still unacknowledged. - -- In this implementation, this is done using reference counting. - -- - -- This map is useful to acknowledge `txid`s, it's basically taking the - -- longest prefix which contains entries in `bufferedTxs` or `unknownTxs`. - -- - bufferedTxs :: !(Map txid (Maybe tx)), - - -- | We track reference counts of all unacknowledged and timedTxs txids. - -- Once the count reaches 0, a tx is removed from `bufferedTxs`. - -- - -- The `bufferedTx` map contains a subset of `txid` which - -- `referenceCounts` contains. - -- - -- /Invariants:/ - -- - -- * the txid count is equal to multiplicity of txid in all - -- `unacknowledgedTxIds` sequences; - -- * @Map.keysSet bufferedTxs `Set.isSubsetOf` Map.keysSet referenceCounts@; - -- * all counts are positive integers. - -- - referenceCounts :: !(Map txid Int), - - -- | A set of timeouts for txids that have been added to bufferedTxs after being - -- inserted into the mempool. - -- - -- We need these short timeouts to avoid re-downloading a `tx`. We could - -- acknowledge this `txid` to all peers, when a peer from another - -- continent presents us it again. - -- - -- Every txid entry has a reference count in `referenceCounts`. - -- - timedTxs :: !(Map Time [txid]), - - -- | A set of txids that have been downloaded by a peer and are on their - -- way to the mempool. We won't issue further fetch-requests for TXs in - -- this state. We track these txs to not re-download them from another - -- peer. - -- - -- * We subtract from the counter when a given tx is added or rejected by - -- the mempool or do that for all txs in `toMempoolTxs` when a peer is - -- unregistered. - -- * We add to the counter when a given tx is selected to be added to the - -- mempool in `pickTxsToDownload`. - -- - inSubmissionToMempoolTxs :: !(Map txid Int), - - -- | Rng used to randomly order peers - peerRng :: !StdGen - } - deriving (Eq, Show, Generic, NFData) - -instance ( NoThunks peeraddr - , NoThunks tx - , NoThunks txid - , NoThunks StdGen - ) => NoThunks (SharedTxState peeraddr txid tx) +-- * On exception, 'withPeer's bracket finalizer reads it and reverses +-- each per-peer contribution: releases any held lease, decrements +-- 'txAttempt' for each attempted key, clears 'txInSubmission' for +-- any in-flight submission. +-- +-- * The sweep walks every live peer's TVar to compute the union of +-- advertised keys and skips those entries when looking for orphans +-- to retire (the entry is still wanted by an active peer that +-- may simply be slow to claim). +data PeerTxInFlight = PeerTxInFlight { + -- | Keys this peer currently has in its advertised window. Used + -- by the orphan sweep to know the entry is still wanted, and by + -- 'nextWakeDelay' to scan for the earliest claim wake. + pifAdvertised :: !IntSet, + + -- | Keys this peer currently holds 'TxLeased' on. Cleared on + -- omit, accept, reject, lease-loss and bracket exit. + pifLeased :: !IntSet, + + -- | Keys this peer currently counts toward 'txAttempt'. Spans + -- the @claim -> download -> buffer@ phases; the key moves to + -- 'pifSubmitting' on the @submit@ transition. + pifAttempting :: !IntSet, + + -- | Keys this peer currently counts toward 'txInSubmission'. + -- Set on 'PeerSubmitTxs' / 'markSubmittingTxs', cleared on accept + -- or reject. + pifSubmitting :: !IntSet, + + -- | Keys this peer holds in 'peerUnacknowledgedTxIds'. A superset + -- of 'pifAdvertised': also tracks keys the peer learned about via + -- the retained-or-mempool path of 'handleReceivedTxIds' that are + -- not advertised for fetch but still pending an ack. Used by the + -- sweep to know whether the txid lookup tables can be reclaimed. + pifAcksPending :: !IntSet + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData, NoThunks) + +emptyPeerTxInFlight :: PeerTxInFlight +emptyPeerTxInFlight = PeerTxInFlight { + pifAdvertised = IntSet.empty, + pifLeased = IntSet.empty, + pifAttempting = IntSet.empty, + pifSubmitting = IntSet.empty, + pifAcksPending = IntSet.empty + } +-- | Whether a txid request will be sent as a blocking or pipelined wire +-- message. +data TxIdsReqFlavour + = TxIdsBlockingReq + | TxIdsPipelinedReq + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData, NoThunks) +-- | The next peer-local action chosen by the V2 worker thread. -- --- Decisions +-- V2 drives progress from the peer thread itself. Shared state only decides +-- whether a peer is allowed to perform an action; the peer thread then carries +-- it out directly. +data PeerAction + = -- | No immediate work is available. The peer should wait for either a + -- shared-state generation change or the optional timeout. + PeerDoNothing !Word64 !(Maybe DiffTime) + | -- | Send a txid protocol message acknowledging the second argument and + -- requesting the third argument. + PeerRequestTxIds !TxIdsReqFlavour !NumTxIdsToAck !NumTxIdsToReq + | -- | Request tx bodies for the given internally keyed txs from this peer. + PeerRequestTxs ![TxKey] + | -- | Submit the buffered txs identified by the given keys to the local + -- mempool. + PeerSubmitTxs ![TxKey] + deriving stock (Eq, Show, Generic) + deriving anyclass NFData + + +-- | A batch of transaction body requests sent to a peer. -- +-- Tracks the set of requested txids and the total expected +-- size in bytes for the batch. Used to manage inflight requests and match +-- responses to the original request. +data RequestedTxBatch = RequestedTxBatch { + -- | The set of transaction keys requested in this batch. + requestedTxBatchSet :: !IntSet + + -- | Total expected size in bytes for all tx bodies in this batch. + , requestedTxBatchSize :: !SizeInBytes + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData, NoThunks) -newtype TxsToMempool txid tx = TxsToMempool { listOfTxsToMempool :: [(txid, tx)] } - deriving newtype (Eq, Show, Semigroup, Monoid, NFData) - - --- | Decision made by the decision logic. Each peer will receive a 'Decision'. +-- | Coarse phase of a peer worker thread. -- --- /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. +-- The phase is used when deciding whether a peer is currently eligible +-- to claim an expired tx lease. +data PeerPhase + = -- | The peer worker is idle and may claim work for advertised txs. + PeerIdle + | -- | The peer worker is waiting for a txid reply from the remote peer. + PeerWaitingTxIds + | -- | The peer worker is waiting for a tx-body reply from the remote peer. + PeerWaitingTxs + | -- | The peer worker is submitting buffered txs to the local mempool. + PeerSubmittingToMempool + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass NFData + +instance NoThunks PeerPhase + +-- | Peer usefulness score. -- -data TxDecision txid tx = TxDecision { - txdTxIdsToAcknowledge :: !NumTxIdsToAck, - -- ^ txid's to acknowledge +-- Lower is better. The current score is also interpreted as milliseconds of +-- extra delay before an idle peer may steal a claimable or expired tx lease. +data PeerScore = PeerScore { + peerScoreValue :: !Double, + peerScoreTs :: !Time + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData, NoThunks) - txdTxIdsToRequest :: !NumTxIdsToReq, - -- ^ number of txid's to request +-- | Low-cost monotonic counters for the V2 peer protocol and coordination path. +-- +-- These counters are updated incrementally at the points where V2 performs +-- protocol sends, receives replies, or cheaply classifies received bodies. +-- They are kept separate from 'SharedTxState' so that emission can read a +-- small dedicated counter cell without scanning protocol state. +data TxSubmissionCounters = TxSubmissionCounters { + txIdMessagesSent :: !Word64, + -- ^ Number of txid request messages sent (@MsgRequestTxIds@, blocking or + -- pipelined). + txIdsRequested :: !Word64, + -- ^ Total number of txids requested across all txid request messages (sum + -- of @NumTxIdsToReq@ values). + txIdRepliesReceived :: !Word64, + -- ^ Number of txid reply messages received (@MsgReplyTxIds@). + txIdsReceived :: !Word64, + -- ^ Total number of txid-size pairs received across all txid replies. + txMessagesSent :: !Word64, + -- ^ Number of tx body request messages sent (@MsgRequestTxs@). + txsRequested :: !Word64, + -- ^ Total number of tx bodies requested across all body request messages. + txRepliesReceived :: !Word64, + -- ^ Number of tx body reply messages received (@MsgReplyTxs@). + txsReceived :: !Word64, + -- ^ Total number of tx bodies received across all body replies. + txsOmitted :: !Word64, + -- ^ Number of requested tx bodies the peer omitted from its reply. + lateBodies :: !Word64, + -- ^ Number of tx bodies received after the local state had already + -- resolved them (txid was found in the mempool before the body arrived). + txsAccepted :: !Word64, + -- ^ Tx bodies resolved into the mempool (includes txs found already present + -- before attempting submission). + txsRejected :: !Word64, + -- ^ Tx bodies rejected by the mempool. + txIdBlockingReqsSent :: !Word64, + -- ^ Txid request messages sent as blocking requests. + txIdPipelinedReqsSent :: !Word64, + -- ^ Txid request messages sent as pipelined (non-blocking) requests. + txIdBlockingWaitMs :: !Word64, + -- ^ Cumulative milliseconds spent waiting for replies to blocking txid + -- requests. High values indicate the system is mostly idle (no new + -- transactions available from peers). + txPipelineWaitMs :: !Word64, + -- ^ Cumulative milliseconds the pipeline was active, measured from the + -- first 'MsgRequestTxs' send until all pipelined requests (both body and + -- txid) have been replied to and the pipeline fully drains. Proxy for + -- the "loading" state where the peer is actively downloading transactions. + txSubmissionWaitMs :: !Word64 + -- ^ Cumulative milliseconds spent inside 'mempoolAddTxs'. Covers both + -- normal submission latency and time blocked due to a full mempool. + -- High values relative to the other duration fields indicate mempool + -- backpressure. + } + deriving stock (Eq, Show, Generic) + deriving anyclass NFData + +instance Semigroup TxSubmissionCounters where + a <> b = TxSubmissionCounters { + txIdMessagesSent = txIdMessagesSent a + txIdMessagesSent b, + txIdsRequested = txIdsRequested a + txIdsRequested b, + txIdRepliesReceived = txIdRepliesReceived a + txIdRepliesReceived b, + txIdsReceived = txIdsReceived a + txIdsReceived b, + txMessagesSent = txMessagesSent a + txMessagesSent b, + txsRequested = txsRequested a + txsRequested b, + txRepliesReceived = txRepliesReceived a + txRepliesReceived b, + txsReceived = txsReceived a + txsReceived b, + txsOmitted = txsOmitted a + txsOmitted b, + lateBodies = lateBodies a + lateBodies b, + txsAccepted = txsAccepted a + txsAccepted b, + txsRejected = txsRejected a + txsRejected b, + txIdBlockingReqsSent = txIdBlockingReqsSent a + txIdBlockingReqsSent b, + txIdPipelinedReqsSent = txIdPipelinedReqsSent a + txIdPipelinedReqsSent b, + txIdBlockingWaitMs = txIdBlockingWaitMs a + txIdBlockingWaitMs b, + txPipelineWaitMs = txPipelineWaitMs a + txPipelineWaitMs b, + txSubmissionWaitMs = txSubmissionWaitMs a + txSubmissionWaitMs b + } - txdPipelineTxIds :: !Bool, - -- ^ the tx-submission protocol only allows to pipeline `txid`'s requests - -- if we have non-acknowledged `txid`s. +instance Monoid TxSubmissionCounters where + mempty = TxSubmissionCounters { + txIdMessagesSent = 0, + txIdsRequested = 0, + txIdRepliesReceived = 0, + txIdsReceived = 0, + txMessagesSent = 0, + txsRequested = 0, + txRepliesReceived = 0, + txsReceived = 0, + txsOmitted = 0, + lateBodies = 0, + txsAccepted = 0, + txsRejected = 0, + txIdBlockingReqsSent = 0, + txIdPipelinedReqsSent = 0, + txIdBlockingWaitMs = 0, + txPipelineWaitMs = 0, + txSubmissionWaitMs = 0 + } - txdTxsToRequest :: !(Map txid SizeInBytes), - -- ^ txid's to download. +-- | Convert a non-negative 'DiffTime' to whole milliseconds (truncated). +-- +-- Works directly on the underlying picosecond 'Integer' to avoid the +-- 'realToFrac' detour through 'Rational' and 'Double'. +diffTimeToMilliseconds :: DiffTime -> Word64 +diffTimeToMilliseconds = fromInteger . (`div` 1_000_000_000) . diffTimeToPicoseconds + +emptyPeerScore :: Time -> PeerScore +emptyPeerScore scoreTs = PeerScore { + peerScoreValue = 0, + peerScoreTs = scoreTs + } - txdTxsToMempool :: !(TxsToMempool txid tx) - -- ^ list of `tx`s to submit to the mempool. +-- | Per-peer protocol state. +-- +-- Owned by the worker thread for one peer. Includes the peer's coarse +-- protocol phase ('peerPhase'), which is purely peer-local: only this +-- peer's own scheduler reads and updates it, so it doesn't belong in +-- shared state. +data PeerTxLocalState tx = PeerTxLocalState { + -- | Coarse phase of this peer's worker thread. Updated by + -- 'nextPeerAction' / 'nextPeerActionPipelined' when an action is + -- chosen and inspected in 'serverIdle' to decide whether to skip + -- 'awaitSharedChange' on an Active->Idle transition. + peerPhase :: !PeerPhase, + + -- | Unacknowledged txids in the order advertised by the peer. + peerUnacknowledgedTxIds :: !(StrictSeq TxKey), + + -- | Txids this peer currently advertises and that may be requested from + -- it if the peer becomes the owner. + peerAvailableTxIds :: !(IntMap SizeInBytes), + + -- | Requested txids that have not yet been replied to. + peerRequestedTxs :: !IntSet, + peerRequestedTxBatches :: !(StrictSeq RequestedTxBatch), + peerRequestedTxsSize :: !SizeInBytes, + peerRequestedTxIds :: !NumTxIdsToReq, + + -- | Tx bodies downloaded from this peer and buffered locally until they + -- are either submitted to the mempool or superseded by shared-state + -- resolution. + peerDownloadedTxs :: !(IntMap tx), + + -- | Time at which the first outstanding body-request batch was + -- sent in the current download episode. + peerDownloadStartTime :: !(Maybe Time), + + -- | Usefulness score for this peer, tracking rejection penalties and + -- time-based decay. + peerScore :: !PeerScore + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData, NoThunks) + +emptyPeerTxLocalState :: PeerTxLocalState tx +emptyPeerTxLocalState = PeerTxLocalState { + peerPhase = PeerIdle, + peerUnacknowledgedTxIds = StrictSeq.empty, + peerAvailableTxIds = IntMap.empty, + peerRequestedTxs = IntSet.empty, + peerRequestedTxBatches = StrictSeq.empty, + peerRequestedTxsSize = 0, + peerRequestedTxIds = 0, + peerDownloadedTxs = IntMap.empty, + peerDownloadStartTime = Nothing, + peerScore = emptyPeerScore (Time 0) } - deriving (Show, Eq) -instance (NFData txid, NFData tx) => NFData (TxDecision txid tx) where - -- all fields except `txdTxsToMempool` when evaluated to WHNF evaluate to NF. - rnf TxDecision {txdTxsToMempool} = rnf txdTxsToMempool +-- | Shared V2 state. +-- +-- There is no global decision thread. Peer worker threads coordinate by +-- atomically reading and updating this shared state. +data SharedTxState peeraddr txid = SharedTxState { + -- | Active unresolved txs that still participate in leasing, buffering, + -- submission and advertiser tracking. + sharedTxTable :: !(IntMap (TxEntry peeraddr)), + -- | Accepted txs retained locally for a bounded time so later txid + -- advertisements can be acked without re-requesting the body. + sharedRetainedTxs :: !RetainedTxs, + sharedTxIdToKey :: !(Map RawTxId TxKey), + sharedKeyToTxId :: !(IntMap txid), + sharedNextTxKey :: !Int, + sharedGeneration :: !Word64 + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData, NoThunks) --- | A non-commutative semigroup instance. +-- | Retained tx-key set with two indexes: -- --- /note:/ this instance must be consistent with `pickTxsToDownload` and how --- `PeerTxState` is updated. It is designed to work with `TMergeVar`s. +-- * 'retainedQueue' is keyed on 'Time' for cheap earliest-expiry queries. +-- * 'retainedSet' shadows the keys for O(min(n, W)) 'retainedMember' +-- queries (the hot path: every received txid is checked here). -- -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 = Map.empty, - txdTxsToMempool = mempty +-- Both are kept in lockstep by the 'retained*' helpers below. +data RetainedTxs = RetainedTxs { + retainedQueue :: !(IntPSQ Time ()), + retainedSet :: !IntSet } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData, NoThunks) + +emptySharedTxState :: SharedTxState peeraddr txid +emptySharedTxState = SharedTxState { + sharedTxTable = IntMap.empty, + sharedRetainedTxs = retainedEmpty, + sharedTxIdToKey = Map.empty, + sharedKeyToTxId = IntMap.empty, + sharedNextTxKey = 0, + sharedGeneration = 0 + } + +retainedEmpty :: RetainedTxs +retainedEmpty = RetainedTxs IntPSQ.empty IntSet.empty + +retainedSingleton :: Int -> Time -> RetainedTxs +retainedSingleton k retainUntil = + RetainedTxs (IntPSQ.insert k retainUntil () IntPSQ.empty) + (IntSet.singleton k) + +retainedFromList :: [(Int, Time)] -> RetainedTxs +retainedFromList = + foldl' (\retained (k, retainUntil) -> retainedInsertMax k retainUntil retained) retainedEmpty + +retainedToList :: RetainedTxs -> [(Int, Time)] +retainedToList = + sortOn fst + . fmap (\(k, retainUntil, ()) -> (k, retainUntil)) + . IntPSQ.toList + . retainedQueue + +retainedSize :: RetainedTxs -> Int +retainedSize = IntSet.size . retainedSet +{-# INLINE retainedSize #-} + +retainedLookup :: Int -> RetainedTxs -> Maybe Time +retainedLookup k retained = + fmap fst (IntPSQ.lookup k (retainedQueue retained)) +{-# INLINE retainedLookup #-} + +retainedMember :: Int -> RetainedTxs -> Bool +retainedMember k = IntSet.member k . retainedSet +{-# INLINE retainedMember #-} + +retainedInsertMax :: Int -> Time -> RetainedTxs -> RetainedTxs +retainedInsertMax k retainUntil (RetainedTxs queue keys) = + RetainedTxs (IntPSQ.insert k retainUntil' () queue) + (IntSet.insert k keys) + where + retainUntil' = + case IntPSQ.lookup k queue of + Just (existing, ()) -> max existing retainUntil + Nothing -> retainUntil +{-# INLINE retainedInsertMax #-} + +retainedDeleteKeys :: IntSet -> RetainedTxs -> RetainedTxs +retainedDeleteKeys ks (RetainedTxs queue keys) = + RetainedTxs (IntSet.foldl' (flip IntPSQ.delete) queue ks) + (keys `IntSet.difference` ks) +{-# INLINE retainedDeleteKeys #-} + +retainedKeysSet :: RetainedTxs -> IntSet +retainedKeysSet = retainedSet +{-# INLINE retainedKeysSet #-} + +retainedRestrictKeys :: RetainedTxs -> IntSet -> RetainedTxs +retainedRestrictKeys (RetainedTxs queue keys) ks = + RetainedTxs (IntPSQ.fold' keep IntPSQ.empty queue) + (IntSet.intersection keys ks) + where + keep k retainUntil _ + | IntSet.member k ks = IntPSQ.insert k retainUntil () + | otherwise = id +{-# INLINE retainedRestrictKeys #-} + +retainedNextWake :: Time -> RetainedTxs -> Maybe Time +retainedNextWake currentTime = + go . retainedQueue + where + go retained = + case IntPSQ.minView retained of + Just (_, retainUntil, (), retained') + | retainUntil > currentTime -> Just retainUntil + | otherwise -> go retained' + Nothing -> + Nothing +{-# INLINE retainedNextWake #-} + +retainedExpiredKeys :: Time -> RetainedTxs -> IntSet +retainedExpiredKeys currentTime retained = + -- Quick exit if no TX has expired. + case IntPSQ.findMin queue of + Just (_, earliest, _) | earliest <= currentTime -> go IntSet.empty queue + _ -> IntSet.empty + where + queue = retainedQueue retained + go expired r = + case IntPSQ.minView r of + Just (k, retainUntil, (), r') + | retainUntil <= currentTime -> + go (IntSet.insert k expired) r' + | otherwise -> + expired + Nothing -> + expired +{-# INLINE retainedExpiredKeys #-} + +lookupTxKey :: HasRawTxId txid + => txid + -> SharedTxState peeraddr txid + -> Maybe TxKey +lookupTxKey txid SharedTxState { sharedTxIdToKey } = + Map.lookup (getRawTxId txid) sharedTxIdToKey + +resolveTxKey :: SharedTxState peeraddr txid + -> TxKey + -> txid +resolveTxKey SharedTxState { sharedKeyToTxId } (TxKey k) = + case IntMap.lookup k sharedKeyToTxId of + Just txid -> txid + Nothing -> error "TxSubmission.V2.resolveTxKey: missing tx key" + +internTxId :: HasRawTxId txid + => txid + -> SharedTxState peeraddr txid + -> (RawTxId, TxKey, SharedTxState peeraddr txid) +internTxId txid st@SharedTxState { sharedTxIdToKey, sharedKeyToTxId, sharedNextTxKey } + | Just key <- Map.lookup rawId sharedTxIdToKey = (rawId, key, st) + | otherwise = + let key = TxKey sharedNextTxKey in + ( rawId + , key + , st { sharedTxIdToKey = Map.insert rawId key sharedTxIdToKey + , sharedKeyToTxId = IntMap.insert sharedNextTxKey txid sharedKeyToTxId + , sharedNextTxKey = sharedNextTxKey + 1 + } + ) + where + rawId = getRawTxId txid + +internTxIds :: (Foldable f, HasRawTxId txid) + => f txid + -> SharedTxState peeraddr txid + -> (Map RawTxId TxKey, SharedTxState peeraddr txid) +internTxIds txids st0 = foldl' step (Map.empty, st0) txids + where + step (acc, st) txid = + let (rawId, key, st') = internTxId txid st in + (Map.insert rawId key acc, st') +-- | 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, Enum, Bounded) -- | TxLogic tracer. -- data TraceTxLogic peeraddr txid tx = - TraceSharedTxState String (SharedTxState peeraddr txid tx) - | TraceTxDecisions (Map peeraddr (TxDecision txid tx)) + TraceSharedTxState String (SharedTxState peeraddr txid) deriving Show @@ -380,6 +720,7 @@ data TraceTxSubmissionInbound txid tx = | TraceTxInboundAddedToMempool [txid] DiffTime | TraceTxInboundRejectedFromMempool [txid] DiffTime | TraceTxInboundError TxSubmissionProtocolError + | TraceTxInboundRequestTxs [txid] -- -- messages emitted by the new implementation of the server in @@ -389,47 +730,9 @@ data TraceTxSubmissionInbound txid tx = -- | Server received 'MsgDone' | TraceTxInboundTerminated - | TraceTxInboundDecision (TxDecision txid tx) deriving (Eq, Show) -data TxSubmissionCounters = - TxSubmissionCounters { - numOfOutstandingTxIds :: Int, - -- ^ txids which are not yet downloaded. This is a diff of keys sets of - -- `referenceCounts` and a sum of `bufferedTxs` and - -- `insubmissionToMempoolTxs` maps. - numOfBufferedTxs :: Int, - -- ^ number of all buffered txs (downloaded or not available) - numOfInSubmissionToMempoolTxs :: Int, - -- ^ number of all tx's which were submitted to the mempool - numOfTxIdsInflight :: Int - -- ^ number of all in-flight txid's. - } - deriving (Eq, Show) - -mkTxSubmissionCounters - :: Ord txid - => SharedTxState peeraddr txid tx - -> TxSubmissionCounters -mkTxSubmissionCounters - SharedTxState { - inflightTxs, - bufferedTxs, - referenceCounts, - inSubmissionToMempoolTxs - } - = - TxSubmissionCounters { - numOfOutstandingTxIds = Set.size $ Map.keysSet referenceCounts - Set.\\ Map.keysSet bufferedTxs - Set.\\ Map.keysSet inSubmissionToMempoolTxs, - numOfBufferedTxs = Map.size bufferedTxs, - numOfInSubmissionToMempoolTxs = Map.size inSubmissionToMempoolTxs, - numOfTxIdsInflight = getSum $ foldMap Sum inflightTxs - } - - data TxSubmissionProtocolError = ProtocolErrorTxNotRequested | ProtocolErrorTxIdsNotRequested diff --git a/ouroboros-network/orphan-instances/Ouroboros/Network/OrphanInstances.hs b/ouroboros-network/orphan-instances/Ouroboros/Network/OrphanInstances.hs index fdd077339aa..4f069422748 100644 --- a/ouroboros-network/orphan-instances/Ouroboros/Network/OrphanInstances.hs +++ b/ouroboros-network/orphan-instances/Ouroboros/Network/OrphanInstances.hs @@ -29,6 +29,7 @@ import Data.Bifunctor (first) import Data.Bool (bool) import Data.Foldable (toList) import Data.IP (fromHostAddress, fromHostAddress6) +import Data.IntMap.Strict qualified as IntMap import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text (Text, pack) @@ -86,10 +87,12 @@ import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Server.RateLimiting (AcceptConnectionsPolicyTrace (..), AcceptedConnectionsLimit (..)) import Ouroboros.Network.Snocket (LocalAddress (..), RemoteAddress) -import Ouroboros.Network.TxSubmission.Inbound.V2 (ProcessedTxCount (..), - TraceTxLogic (..), TraceTxSubmissionInbound (..)) import Ouroboros.Network.TxSubmission.Inbound.V2.Types - (TxSubmissionLogicVersion (..)) + (ProcessedTxCount (..), + SharedTxState (..), TraceTxLogic (..), + TraceTxSubmissionInbound (..), TxEntry (..), + TxLease (..), TxSubmissionLogicVersion (..), retainedSize, + retainedToList) import Ouroboros.Network.TxSubmission.Outbound (TraceTxSubmissionOutbound (..)) -- Helper function for ToJSON instances with a "kind" field @@ -1769,6 +1772,11 @@ instance ( ToJSON txid , "txids" .= toJSON txids , "time" .= diffTime ] + toJSON (TraceTxInboundRequestTxs txids) = + object + [ "kind" .= String "TxInboundRequestTxs" + , "txids" .= toJSON txids + ] toJSON (TraceTxInboundError err) = object [ "kind" .= String "TxInboundError" @@ -1778,12 +1786,52 @@ instance ( ToJSON txid object [ "kind" .= String "TxInboundTerminated" ] - toJSON (TraceTxInboundDecision decision) = + +traceSharedTxStateToJSON + :: (Show addr, Show txid) + => SharedTxState addr txid + -> Value +traceSharedTxStateToJSON SharedTxState { + sharedTxTable, + sharedRetainedTxs, + sharedTxIdToKey, + sharedKeyToTxId, + sharedGeneration + } = object - [ "kind" .= String "TxInboundDecision" - -- TODO: this is too verbose, it will show full tx's - , "decision" .= String (pack $ show decision) + [ "sharedGeneration" .= sharedGeneration + , "activeTxCount" .= IntMap.size sharedTxTable + , "retainedTxCount" .= retainedSize sharedRetainedTxs + , "internedTxCount" .= Map.size sharedTxIdToKey + , "leasedTxCount" .= leasedTxCount + , "claimableTxCount" .= claimableTxCount + , "totalAttemptCount" .= totalAttemptCount + , "submittingTxCount" .= submittingTxCount + , "sharedTxTable" .= [ (renderTxId txKey, show txEntry) + | (txKey, txEntry) <- IntMap.toList sharedTxTable + ] + , "sharedRetainedTxs" .= [ (renderTxId txKey, show retainUntil) + | (txKey, retainUntil) <- retainedToList sharedRetainedTxs + ] + , "internedTxIds" .= fmap show (Map.keys sharedTxIdToKey) ] + where + activeEntries = IntMap.elems sharedTxTable + + leasedTxCount = + length [ () | TxEntry { txLease = TxLeased _ _ } <- activeEntries ] + + claimableTxCount = + length [ () | TxEntry { txLease = TxClaimable _ } <- activeEntries ] + + totalAttemptCount = + sum [ txAttempt | TxEntry { txAttempt } <- activeEntries ] + + submittingTxCount = + length [ () | TxEntry { txInSubmission = True } <- activeEntries ] + + renderTxId txKey = + maybe "" show (IntMap.lookup txKey sharedKeyToTxId) -- TODO: in cardano-node in the `coot/tx-submission-10.5` branch there's -- a better instance. @@ -1795,11 +1843,7 @@ instance ( Show addr toJSON (TraceSharedTxState tag st) = object [ "kind" .= String "SharedTxState" , "tag" .= String (pack tag) - , "sharedTxState" .= String (pack . show $ st) - ] - toJSON (TraceTxDecisions decisions) = - object [ "kind" .= String "TxDecisions" - , "decisions" .= String (pack . show $ decisions) + , "sharedTxState" .= traceSharedTxStateToJSON st ] diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 95819b7ef30..af86d13a840 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -103,6 +103,7 @@ library api Ouroboros.Network.Point Ouroboros.Network.Protocol.Limits Ouroboros.Network.SizeInBytes + Ouroboros.Network.Tx Ouroboros.Network.Util.ShowProxy build-depends: @@ -118,7 +119,7 @@ library api contra-tracer, deepseq, dns, - io-classes:{io-classes, si-timers, strict-stm} ^>=1.8, + io-classes:{io-classes, si-timers, strict-stm} ^>=1.8 || ^>= 1.9, iproute ^>=1.7.15, measures, network ^>=3.2.7, @@ -253,7 +254,6 @@ library Ouroboros.Network.PeerSharing 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 @@ -310,7 +310,7 @@ library dlist, dns, hashable, - io-classes:{io-classes, mtl, si-timers, strict-mvar, strict-stm} ^>=1.8, + io-classes:{io-classes, mtl, si-timers, strict-stm} ^>=1.8 || ^>= 1.9, iproute, monoidal-synchronisation, mtl, @@ -321,6 +321,7 @@ library psqueues >=0.2.3 && <0.3, random, strict-checked-vars ^>=0.2, + time, transformers, typed-protocols ^>=1.2, @@ -383,7 +384,7 @@ library framework contra-tracer, deepseq, hashable, - io-classes:{io-classes, si-timers, strict-stm} ^>=1.8, + io-classes:{io-classes, si-timers, strict-stm} ^>=1.8 || ^>= 1.9, monoidal-synchronisation ^>=0.1.0.7, network ^>=3.2.7, network-mux ^>=0.10.1.0, @@ -424,7 +425,7 @@ library framework-tracing network-mux, ouroboros-network:{framework, orphan-instances}, text, - trace-dispatcher ^>=2.11.0, + trace-dispatcher ^>=2.11.0 || ^>=2.12.0, typed-protocols:{typed-protocols, stateful} ^>=1.2, library tests-lib @@ -473,8 +474,8 @@ library tests-lib contra-tracer, deepseq, deque ^>=0.4, - io-classes:{io-classes, si-timers, strict-stm} ^>=1.8, - io-sim, + io-classes:{io-classes, si-timers, strict-stm} ^>=1.8 || ^>= 1.9, + io-sim ^>=1.8 || ^>= 1.9, network-mux, pretty-simple, psqueues >=0.2.3 && <0.3, @@ -658,11 +659,10 @@ library tracing aeson, base >=4.14 && <4.23, containers, - io-classes:si-timers, iproute, ouroboros-network:{ouroboros-network, orphan-instances, protocols}, text, - trace-dispatcher ^>=2.11.0, + trace-dispatcher ^>=2.11.0 || ^>=2.12.0, if flag(asserts) ghc-options: -fno-ignore-asserts @@ -816,7 +816,7 @@ library protocols constraints, containers, deepseq, - io-classes:{io-classes, si-timers} ^>=1.8, + io-classes:{io-classes, si-timers} ^>=1.8 || ^>= 1.9, nothunks, ouroboros-network:api, quiet, @@ -928,7 +928,7 @@ library ouroboros-network-tests-lib deepseq, dns, hashable, - io-classes:{io-classes, si-timers, strict-mvar, strict-stm}, + io-classes:{io-classes, si-timers, strict-stm}, io-sim, iproute, monoidal-synchronisation, @@ -971,7 +971,9 @@ library ouroboros-network-tests-lib Test.Ouroboros.Network.TxSubmission Test.Ouroboros.Network.TxSubmission.AppV1 Test.Ouroboros.Network.TxSubmission.AppV2 + Test.Ouroboros.Network.TxSubmission.Impaired Test.Ouroboros.Network.TxSubmission.Mempool.Simple + Test.Ouroboros.Network.TxSubmission.MempoolWriter Test.Ouroboros.Network.TxSubmission.TxLogic Test.Ouroboros.Network.TxSubmission.Types @@ -1051,11 +1053,17 @@ benchmark sim-benchmarks type: exitcode-stdio-1.0 hs-source-dirs: bench main-is: Main.hs + other-modules: + Bench.TxSubmissionV2Server build-depends: base, containers, + contra-tracer, deepseq, - ouroboros-network:{ouroboros-network, ouroboros-network-tests-lib}, + io-classes:{io-classes, strict-stm}, + ouroboros-network:ouroboros-network, + ouroboros-network:ouroboros-network-tests-lib, + ouroboros-network:protocols, pretty-simple, splitmix, tasty-bench >=0.3.5, diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs index 47c8080dbb7..2f4e42c88b5 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -110,7 +110,6 @@ import Ouroboros.Network.Snocket (MakeBearer, Snocket, TestAddress (..), invalidFileDescriptor) import Ouroboros.Network.TxSubmission.Inbound.V2.Policy (TxDecisionPolicy) -import Ouroboros.Network.TxSubmission.Inbound.V2.Registry (decisionLogicThreads) import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TraceTxLogic) import Simulation.Network.Snocket (AddressType (..), FD) @@ -126,7 +125,6 @@ import Test.Ouroboros.Network.PeerSelection.RootPeersDNS (DNSLookupDelay, DNSTimeout, DomainAccessPoint (..), MockDNSLookupResult, mockDNSActions) import Test.Ouroboros.Network.TxSubmission.Types (Tx) -import Test.Ouroboros.Network.Utils @@ -255,7 +253,7 @@ run blockGeneratorArgs ni na extraPeersAPI psArgs toExtraPeers requestPublicRootPeers peerChurnGovernor tracers tracerBlockFetch - tracerTxLogic mkApps = do + _tracerTxLogic mkApps = do labelThisThread ("node-" ++ Node.ppNtNAddr (aIPAddress na)) Node.withNodeKernelThread (aIPAddress na) blockGeneratorArgs (aTxs na) $ \ nodeKernel nodeKernelThread -> do @@ -340,17 +338,9 @@ run blockGeneratorArgs ni na (mkApps nodeKernel keepAliveStdGen)) $ \ diffusionThread -> withAsync (blockFetch nodeKernel) $ \blockFetchLogicThread -> - - withAsync (decisionLogicThreads - tracerTxLogic - sayTracer - (aTxDecisionPolicy na) - (nkTxChannelsVar nodeKernel) - (nkSharedTxStateVar nodeKernel)) $ \decLogicThread -> - wait diffusionThread - <> wait blockFetchLogicThread - <> wait nodeKernelThread - <> wait decLogicThread + wait diffusionThread + <> wait blockFetchLogicThread + <> wait nodeKernelThread where blockFetch :: NodeKernel BlockHeader Block s txid m -> m Void diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs index e0301c7149d..c0a5ac392c8 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs @@ -33,7 +33,6 @@ module Test.Ouroboros.Network.Diffusion.Node.Kernel ) where import Control.Applicative (Alternative) -import Control.Concurrent.Class.MonadMVar.Strict qualified as Strict import Control.Concurrent.Class.MonadSTM qualified as LazySTM import Control.Concurrent.Class.MonadSTM.Strict import Control.DeepSeq (NFData (..)) @@ -84,9 +83,11 @@ 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.V2.Registry (SharedTxStateVar, - TxChannels (..), TxChannelsVar, TxMempoolSem, newSharedTxStateVar, - newTxMempoolSem) +import Ouroboros.Network.TxSubmission.Inbound.V2.Registry + (PeerTxInFlightRegistry, SharedTxStateVar, TxSubmissionCountersVar, + newPeerTxInFlightRegistry, newSharedTxStateVar, + newTxSubmissionCountersVar) +import Ouroboros.Network.TxSubmission.Inbound.V2.Types (emptySharedTxState) import Test.Ouroboros.Network.Diffusion.Node.ChainDB (ChainDB (..)) import Test.Ouroboros.Network.Diffusion.Node.ChainDB qualified as ChainDB @@ -318,19 +319,18 @@ data NodeKernel header block s txid m = NodeKernel { nkMempool :: Mempool m txid (Tx txid), - nkTxChannelsVar - :: TxChannelsVar m NtNAddr txid (Tx txid), - - nkTxMempoolSem - :: TxMempoolSem m, + nkTxCountersVar + :: TxSubmissionCountersVar m, nkSharedTxStateVar - :: SharedTxStateVar m NtNAddr txid (Tx txid) + :: SharedTxStateVar m NtNAddr txid, + + nkPeerTxInFlightRegistry + :: PeerTxInFlightRegistry m NtNAddr } newNodeKernel :: ( MonadTraceSTM m , MonadLabelledSTM m - , Strict.MonadMVar m , RandomGen rng , Ord txid , Eq txid @@ -339,7 +339,7 @@ newNodeKernel :: ( MonadTraceSTM m -> Int -> [Tx txid] -> m (NodeKernel header block rng txid m) -newNodeKernel psRng txSeed txs = do +newNodeKernel psRng _txSeed txs = do publicStateVar <- makePublicPeerSelectionStateVar labelTVarIO publicStateVar "public-peer-selection-state-var" traceTVarIO publicStateVar (\_ a -> return $ TraceString (show a)) @@ -354,9 +354,9 @@ newNodeKernel psRng txSeed txs = do ps_POLICY_PEER_SHARE_MAX_PEERS <*> pure publicStateVar <*> newMempool txs - <*> Strict.newMVar (TxChannels Map.empty) - <*> newTxMempoolSem - <*> newSharedTxStateVar (Random.mkStdGen txSeed) + <*> newTxSubmissionCountersVar mempty + <*> newSharedTxStateVar emptySharedTxState + <*> newPeerTxInFlightRegistry -- | Register a new upstream chain-sync client. -- @@ -434,7 +434,6 @@ withNodeKernelThread , MonadThrow (STM m) , MonadTraceSTM m , MonadLabelledSTM m - , Strict.MonadMVar m , HasFullHeader block , RandomGen seed , SplitGen seed diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission.hs index 7ea9de6269f..cbfe4db4bc4 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission.hs @@ -2,6 +2,7 @@ module Test.Ouroboros.Network.TxSubmission (tests) where import Test.Ouroboros.Network.TxSubmission.AppV1 qualified as AppV1 import Test.Ouroboros.Network.TxSubmission.AppV2 qualified as AppV2 +import Test.Ouroboros.Network.TxSubmission.MempoolWriter qualified as MempoolWriter import Test.Ouroboros.Network.TxSubmission.TxLogic qualified as TxLogic import Test.Tasty (TestTree, testGroup) @@ -9,6 +10,7 @@ import Test.Tasty (TestTree, testGroup) tests :: TestTree tests = testGroup "Ouroboros.Network.TxSubmission" [ AppV1.tests + , MempoolWriter.tests , TxLogic.tests , AppV2.tests ] diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV2.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV2.hs index b33d29b9bb8..d91639e4b03 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV2.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV2.hs @@ -19,7 +19,6 @@ import Prelude hiding (seq) import NoThunks.Class -import Control.Concurrent.Class.MonadMVar.Strict import Control.Concurrent.Class.MonadSTM qualified as Lazy import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadAsync @@ -35,7 +34,6 @@ import Control.Tracer (Tracer (..), contramap) import Data.ByteString.Lazy qualified as BSL import Data.Foldable (traverse_) import Data.Function (on) -import Data.Hashable import Data.List (nubBy) import Data.List qualified as List import Data.List.Trace qualified as Trace @@ -46,7 +44,7 @@ import Data.Maybe (fromMaybe, isJust) import Data.Monoid (Sum (..)) import Data.Set qualified as Set import Data.Typeable (Typeable) -import System.Random (mkStdGen) +import Data.Word (Word64) import Ouroboros.Network.Channel import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM) @@ -62,6 +60,8 @@ import Ouroboros.Network.TxSubmission.Inbound.V2.Types import Ouroboros.Network.TxSubmission.Outbound import Ouroboros.Network.Util.ShowProxy +import Test.Ouroboros.Network.TxSubmission.Impaired (Impairment (..), + applyImpairment, noImpairment) import Test.Ouroboros.Network.TxSubmission.TxLogic hiding (tests) import Test.Ouroboros.Network.TxSubmission.Types import Test.Ouroboros.Network.Utils hiding (debugTracer) @@ -76,8 +76,18 @@ import Test.Tasty.QuickCheck (testProperty) tests :: TestTree tests = testGroup "AppV2" - [ testProperty "txSubmission" prop_txSubmission - , testProperty "inflight" prop_txSubmission_inflight + [ testGroup "Generators" + [ testProperty "TxSubmissionState/validGen" prop_TxSubmissionState_validGen + , testProperty "TxSubmissionState/shrinkValid" + $ prop_TxSubmissionState_shrinkValid + , testProperty "TxSubmissionState/shrinkSmaller" + $ prop_TxSubmissionState_shrinkSmaller + , testProperty "TxSubmissionState/shrinkNoDups" + $ prop_TxSubmissionState_shrinkNoDups + ] + , testProperty "txSubmission" prop_txSubmission + , testProperty "inflight" prop_txSubmission_inflight + , testProperty "resilientToImpairment" prop_txSubmission_resilientToImpairment , testProperty "SharedTxState" $ withMaxSize 25 $ withMaxSuccess 25 prop_sharedTxStateInvariant @@ -95,8 +105,9 @@ data TxSubmissionState = -- delay is less than 10s, otherwise 'smallDelay' in -- 'timeLimitsTxSubmission2' will kick in. ) + , peerImpairment :: Map Int Impairment , decisionPolicy :: TxDecisionPolicy - } deriving (Show) + } deriving (Eq, Show) instance Arbitrary TxSubmissionState where arbitrary = do @@ -111,24 +122,28 @@ instance Arbitrary TxSubmissionState where peersState <- zipWith (curry (\(a, (b, c)) -> (a, b, c))) txs <$> vectorOf peersN arbitrary return TxSubmissionState { peerMap = Map.fromList (zip peers peersState), + peerImpairment = Map.empty, decisionPolicy } - shrink TxSubmissionState { peerMap, decisionPolicy } = - TxSubmissionState <$> shrinkMap1 peerMap - <*> [ policy - | ArbTxDecisionPolicy policy <- shrink (ArbTxDecisionPolicy decisionPolicy) - ] + shrink TxSubmissionState { peerMap, peerImpairment, decisionPolicy } = + [ TxSubmissionState peerMap' peerImpairment decisionPolicy + | peerMap' <- shrinkMap1 peerMap + ] + ++ [ TxSubmissionState peerMap peerImpairment policy + | ArbTxDecisionPolicy policy <- shrink (ArbTxDecisionPolicy decisionPolicy) + ] where - shrinkMap1 :: (Ord k, Arbitrary k, Arbitrary v) => Map k v -> [Map k v] + shrinkMap1 :: (Eq v, 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 + | Map.size m <= 1 = [] + | otherwise = + List.nub $ [Map.delete k m | k <- Map.keys m] ++ singletonMaps where singletonMaps = [Map.singleton k v | (k, v) <- Map.toList m] newtype TxStateTrace peeraddr txid = - TxStateTrace (SharedTxState peeraddr txid (Tx txid)) + TxStateTrace (SharedTxState peeraddr txid) type TxStateTraceType = TxStateTrace PeerAddr TxId @@ -139,7 +154,6 @@ runTxSubmission , MonadEvaluate m , MonadFork m , MonadMask m - , MonadMVar m , MonadSay m , MonadST m , MonadLabelledSTM m @@ -156,93 +170,88 @@ runTxSubmission , Typeable txid , Show peeraddr , Ord peeraddr - , Hashable peeraddr , Typeable peeraddr , txid ~ Int ) => Tracer m (String, TraceSendRecv (TxSubmission2 txid (Tx txid))) -> Tracer m (TraceTxLogic peeraddr txid (Tx txid)) + -> Tracer m TxSubmissionCounters -> Map peeraddr ( [Tx txid] , ControlMessageSTM m , Maybe DiffTime , Maybe DiffTime ) + -> Map peeraddr Impairment -> TxDecisionPolicy -> m ([Tx txid], [[Tx txid]]) -- ^ inbound and outbound mempools -runTxSubmission tracer tracerTxLogic st0 txDecisionPolicy = do +runTxSubmission tracer _tracerTxLogic countersTracer st0 peerImpairmentMap txDecisionPolicy = do st <- traverse (\(b, c, d, e) -> do mempool <- newMempool b (outChannel, inChannel) <- createConnectedChannels return (mempool, c, d, e, outChannel, inChannel) ) st0 inboundMempool <- emptyMempool - let txRng = mkStdGen 42 -- TODO - txMap = Map.fromList [ (getTxId tx, tx) + let txMap = Map.fromList [ (getTxId tx, tx) | (txs, _, _, _) <- Map.elems st0 , tx <- txs] - - txChannelsVar <- newMVar (TxChannels Map.empty) - txMempoolSem <- newTxMempoolSem duplicateTxIdsVar <- Lazy.newTVarIO [] - sharedTxStateVar <- newSharedTxStateVar txRng + sharedTxStateVar <- newSharedTxStateVar emptySharedTxState + inFlightRegistry <- newPeerTxInFlightRegistry + txCountersVar <- newTxSubmissionCountersVar mempty traceTVarIO sharedTxStateVar \_ -> return . TraceDynamic . TxStateTrace labelTVarIO sharedTxStateVar "shared-tx-state" - withAsync (decisionLogicThreads tracerTxLogic sayTracer - txDecisionPolicy txChannelsVar sharedTxStateVar) $ \a -> do - -- Construct txSubmission outbound client - let clients = (\(addr, (mempool {- txs -}, ctrlMsgSTM, outDelay, _, outChannel, _)) -> do - let client = txSubmissionOutbound - (Tracer $ say . show) - (NumTxIdsToAck $ getNumTxIdsToReq - $ maxUnacknowledgedTxIds txDecisionPolicy) - (getMempoolReader mempool) - (maxBound :: TestVersion) - ctrlMsgSTM - runPeerWithLimits (("OUTBOUND " ++ show addr,) `contramap` tracer) - txSubmissionCodec2 - (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) - timeLimitsTxSubmission2 - (maybe id delayChannel outDelay outChannel) - (txSubmissionClientPeer client) - ) - <$> Map.assocs st - - -- Construct txSubmission inbound server - servers = (\(addr, (_, _, _, inDelay, _, inChannel)) -> - withPeer tracerTxLogic - txChannelsVar - txMempoolSem - txDecisionPolicy - sharedTxStateVar - (getMempoolReader inboundMempool) - (getMempoolWriter duplicateTxIdsVar inboundMempool) - getTxSize - addr $ \api -> do - let server = - txSubmissionInboundV2 sayTracer --verboseTracer - NoTxSubmissionInitDelay - (getMempoolWriter duplicateTxIdsVar - inboundMempool) - api - runPipelinedPeerWithLimits - - (("INBOUND " ++ show addr,) `contramap` sayTracer) - txSubmissionCodec2 - (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) - timeLimitsTxSubmission2 - (maybe id delayChannel inDelay inChannel) - (txSubmissionServerPeerPipelined server) - ) <$> Map.assocs st - - -- Run clients and servers + let clients = (\(addr, (mempool {- txs -}, ctrlMsgSTM, outDelay, _, outChannel, _)) -> do + let baseClient = txSubmissionOutbound + (Tracer $ say . show) + (NumTxIdsToAck $ getNumTxIdsToReq + $ maxUnacknowledgedTxIds txDecisionPolicy) + (getMempoolReader mempool) + (maxBound :: TestVersion) + ctrlMsgSTM + imp = Map.findWithDefault noImpairment addr peerImpairmentMap + client <- applyImpairment imp baseClient + runPeerWithLimits (("OUTBOUND " ++ show addr,) `contramap` tracer) + txSubmissionCodec2 + (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) + timeLimitsTxSubmission2 + (maybe id delayChannel outDelay outChannel) + (txSubmissionClientPeer client) + ) + <$> Map.assocs st + + servers = (\(addr, (_, _, _, inDelay, _, inChannel)) -> + withPeer txDecisionPolicy + (getMempoolReader inboundMempool) + sharedTxStateVar + inFlightRegistry + txCountersVar + addr $ \api -> do + let server = + txSubmissionInboundV2 sayTracer + NoTxSubmissionInitDelay + txDecisionPolicy + (getMempoolWriter duplicateTxIdsVar inboundMempool) + getTxSize + api + runPipelinedPeerWithLimits + (("INBOUND " ++ show addr,) `contramap` sayTracer) + txSubmissionCodec2 + (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) + timeLimitsTxSubmission2 + (maybe id delayChannel inDelay inChannel) + (txSubmissionServerPeerPipelined server) + ) <$> Map.assocs st + + withAsync (txCountersThreadV2 txDecisionPolicy countersTracer + txCountersVar sharedTxStateVar inFlightRegistry) + \countersAid -> withAsyncAll (zip clients servers) $ \as -> do _ <- waitAllServers as - -- cancel decision logic thread - cancel a + cancel countersAid inmp <- readMempool inboundMempool dupTxIds <- Lazy.readTVarIO duplicateTxIdsVar @@ -274,7 +283,7 @@ runTxSubmission tracer tracerTxLogic st0 txDecisionPolicy = do txSubmissionSimulation :: forall s . TxSubmissionState -> IOSim s ([Tx Int], [[Tx Int]]) -- ^ inbound & outbound mempools -txSubmissionSimulation (TxSubmissionState state txDecisionPolicy) = do +txSubmissionSimulation (TxSubmissionState state peerImpairment txDecisionPolicy) = do state' <- traverse (\(txs, mbOutDelay, mbInDelay) -> do let mbOutDelayTime = getSmallDelay . getPositive <$> mbOutDelay mbInDelayTime = getSmallDelay . getPositive <$> mbInDelay @@ -312,19 +321,160 @@ txSubmissionSimulation (TxSubmissionState state txDecisionPolicy) = do ) \_ -> do let tracer :: forall a. (Show a, Typeable a) => Tracer (IOSim s) a tracer = dynamicTracer <> sayTracer -- <> verboseTracer <> debugTracer - runTxSubmission tracer tracer state'' txDecisionPolicy + runTxSubmission tracer tracer tracer state'' peerImpairment txDecisionPolicy filterValidTxs :: [Tx txid] -> [Tx txid] filterValidTxs = filter getTxValid . takeWhile (\Tx{getTxSize, getTxAdvSize} -> getTxSize == getTxAdvSize) +-- | Pretty-print only the say-tracer events of an IOSim trace, prefixed +-- with their simulation time. The full 'ppTrace' includes scheduling +-- noise (ThreadDelay, Deschedule, TxCommitted, etc.) that obscures the +-- protocol-relevant events; this helper restricts the output to the +-- events that the test infrastructure forwards through 'sayTracer' +-- (protocol messages, counter snapshots, shared-state changes). +ppSayTrace :: SimTrace a -> String +ppSayTrace tr = + List.intercalate "\n" + $ map (\(Time t, ev) -> show t <> " " <> ev) + $ selectTraceEventsSayWithTime' tr + +-- | Documented invariants of a 'TxSubmissionState' produced by the +-- 'Arbitrary' instance. Used by the generator/shrinker meta-tests. +validTxSubmissionState :: TxSubmissionState -> Bool +validTxSubmissionState (TxSubmissionState peerMap peerImpairment policy) = + not (Map.null peerMap) + && Map.keysSet peerImpairment `Set.isSubsetOf` Map.keysSet peerMap + && all validPeer (Map.elems peerMap) + && validPolicy policy + where + validPeer (txs, _, _) = + let txids = getTxId <$> txs in + not (null txs) + && length txids == Set.size (Set.fromList txids) + +validPolicy :: TxDecisionPolicy -> Bool +validPolicy TxDecisionPolicy + { maxNumTxIdsToRequest, maxUnacknowledgedTxIds + , txsSizeInflightPerPeer, maxOutstandingTxBatchesPerPeer + , txInflightMultiplicity, bufferedTxsMinLifetime + , scoreRate, scoreMax, interTxSpace, inflightTimeout + } = + getNumTxIdsToReq maxNumTxIdsToRequest >= 1 + && getNumTxIdsToReq maxUnacknowledgedTxIds >= 1 + && getSizeInBytes txsSizeInflightPerPeer >= 1 + && maxOutstandingTxBatchesPerPeer >= 1 + && txInflightMultiplicity >= 1 + && bufferedTxsMinLifetime >= 0 + && scoreRate >= 0 + && scoreMax >= 0 + && interTxSpace >= 0 + && inflightTimeout > interTxSpace + +prop_TxSubmissionState_validGen :: TxSubmissionState -> Property +prop_TxSubmissionState_validGen st = + counterexample (show st) + $ validTxSubmissionState st + +prop_TxSubmissionState_shrinkValid :: TxSubmissionState -> Property +prop_TxSubmissionState_shrinkValid st = conjoin + [ counterexample (show s) (validTxSubmissionState s) + | s <- shrink st + ] + +-- | Every shrunk state differs from the input. Catches base cases like +-- 'shrinkMap1 = [m]' that re-emit the original. +prop_TxSubmissionState_shrinkSmaller :: TxSubmissionState -> Property +prop_TxSubmissionState_shrinkSmaller st = conjoin + [ counterexample ("shrink emitted self: " ++ show s) (s /= st) + | s <- shrink st + ] + +-- | Shrink output contains no duplicates. Catches 'shrinkMap1' generating +-- the same singleton via different paths and the cross-product producing +-- equivalent candidates. +prop_TxSubmissionState_shrinkNoDups :: TxSubmissionState -> Property +prop_TxSubmissionState_shrinkNoDups st = + let shrunk = shrink st in + counterexample ("duplicates: " ++ show (shrunk List.\\ List.nub shrunk)) + $ length (List.nub shrunk) === length shrunk + + +-- | Invariants over the counter snapshots emitted by 'txCountersThreadV2'. +-- Asserts monotonicity of every field, protocol-level causality bounds, +-- decomposition of total txid sends into blocking and pipelined, and body +-- accounting (received bounded by requested, classified bounded by received). +prop_counterInvariants :: SimTrace a -> Property +prop_counterInvariants tr = + let snapshots :: [TxSubmissionCounters] + snapshots = selectTraceEventsDynamic tr in + counterexample ("snapshots: " ++ show (length snapshots)) + $ conjoin + [ counterexample "monotonicity" (checkMonotonic snapshots) + , counterexample "causality" (conjoin (checkCausality <$> snapshots)) + , counterexample "decomposition" (conjoin (checkDecomp <$> snapshots)) + , counterexample "body-accounting" + (conjoin (checkBodyAccounting <$> snapshots)) + ] + where + counterFields :: [(String, TxSubmissionCounters -> Word64)] + counterFields = + [ ("txIdMessagesSent", txIdMessagesSent) + , ("txIdsRequested", txIdsRequested) + , ("txIdRepliesReceived", txIdRepliesReceived) + , ("txIdsReceived", txIdsReceived) + , ("txMessagesSent", txMessagesSent) + , ("txsRequested", txsRequested) + , ("txRepliesReceived", txRepliesReceived) + , ("txsReceived", txsReceived) + , ("txsOmitted", txsOmitted) + , ("lateBodies", lateBodies) + , ("txsAccepted", txsAccepted) + , ("txsRejected", txsRejected) + , ("txIdBlockingReqsSent", txIdBlockingReqsSent) + , ("txIdPipelinedReqsSent", txIdPipelinedReqsSent) + , ("txIdBlockingWaitMs", txIdBlockingWaitMs) + , ("txPipelineWaitMs", txPipelineWaitMs) + , ("txSubmissionWaitMs", txSubmissionWaitMs) + ] + + checkMonotonic xs = conjoin + [ counterexample (name ++ ": " ++ show (f a) ++ " > " ++ show (f b)) + (f a <= f b) + | (name, f) <- counterFields + , (a, b) <- zip xs (drop 1 xs) + ] + + checkCausality s = conjoin + [ counterexample "txIdRepliesReceived > txIdMessagesSent" + (txIdRepliesReceived s <= txIdMessagesSent s) + , counterexample "txRepliesReceived > txMessagesSent" + (txRepliesReceived s <= txMessagesSent s) + , counterexample "txIdsReceived > txIdsRequested" + (txIdsReceived s <= txIdsRequested s) + , counterexample "txsReceived > txsRequested" + (txsReceived s <= txsRequested s) + ] + + checkDecomp s = + counterexample "txIdMessagesSent /= blocking + pipelined" + $ txIdMessagesSent s + === txIdBlockingReqsSent s + txIdPipelinedReqsSent s + + checkBodyAccounting s = + counterexample + ("accepted + rejected + late > received: " + ++ show (txsAccepted s, txsRejected s, lateBodies s, txsReceived s)) + (txsAccepted s + txsRejected s + lateBodies s <= txsReceived s) + + -- | Tests overall tx submission semantics. The properties checked in this -- property test are the same as for tx submission v1. We need this to know we -- didn't regress. -- prop_txSubmission :: TxSubmissionState -> Property -prop_txSubmission st@(TxSubmissionState peers _) = +prop_txSubmission st@(TxSubmissionState peers _ _) = let tr = runSimTrace (txSubmissionSimulation st) numPeersWithWronglySizedTx :: Int numPeersWithWronglySizedTx = @@ -348,61 +498,55 @@ prop_txSubmission st@(TxSubmissionState peers _) = $ case traceResult True tr of Left e -> counterexample (show e) - . counterexample (ppTrace tr) + . counterexample (ppSayTrace tr) $ False Right (inmp, outmps) -> - counterexample (ppTrace tr) - $ conjoin (validate inmp `map` outmps) + counterexample (ppSayTrace tr) + $ conjoin (validate inmp `map` outmps) .&&. prop_counterInvariants tr where - checkMempools :: [Tx Int] -> [Tx Int] -> Bool + -- | Asserts that every txid produced is present in the consumer set. + -- On failure the counterexample names the missing txids so the + -- diagnostic points directly at what's wrong. + checkMempools :: [Tx Int] -> [Tx Int] -> Property checkMempools consumer producer = - let producer' = Set.fromList $ getTxId <$> producer - consumer' = Set.fromList $ getTxId <$> consumer - in producer' `Set.isSubsetOf` consumer' + let producer' = Set.fromList (getTxId <$> producer) + consumer' = Set.fromList (getTxId <$> consumer) + missing = producer' `Set.difference` consumer' in + counterexample ("missing from inbound mempool: " ++ show (Set.toList missing)) + $ Set.null missing validate :: [Tx Int] -- the inbound mempool -> [Tx Int] -- one of the outbound mempools -> Property validate inmp outmp = let outUniqueTxIds = nubBy (on (==) getTxId) outmp - outValidTxs = filterValidTxs 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) + outValidTxs = filterValidTxs outmp in + counterexample ("inbound mempool: " ++ show (getTxId <$> inmp)) + . counterexample ("outbound mempool: " ++ show (getTxId <$> outmp)) + $ case ( length outUniqueTxIds == length outmp + , length outValidTxs == length outmp + ) of + (True, True) -> + counterexample + "case (unique-txids, all-valid): every valid tx must reach inbound" $ checkMempools inmp outValidTxs - x@(True, False) | Nothing <- List.find (\tx -> getTxAdvSize tx /= getTxSize tx) outmp -> - -- If we are presented with a stream of unique txids then we should have - -- fetched all valid transactions if all txs have valid sizes. - counterexample (show x) - . counterexample (show inmp) - . counterexample (show outValidTxs) - + (True, False) | Nothing <- List.find (\tx -> getTxAdvSize tx /= getTxSize tx) outmp -> + counterexample + "case (unique-txids, has-invalid, sizes-match): every valid tx must reach inbound" $ checkMempools inmp outValidTxs - | otherwise -> - -- If there's one tx with an invalid size, we will download only - -- some of them, but we don't guarantee how many we will download. - -- - -- This is ok, the peer is cheating. - property True - - - 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 inmp - (filterValidTxs outUniqueTxIds) + + (True, False) -> + -- One tx has a wrong advertised size: the peer is cheating, no + -- guarantee on how much we download. + counterexample + "case (unique-txids, has-invalid, has-size-mismatch): peer cheating, no guarantee" + $ property True + + (False, True) -> + counterexample + "case (duplicate-txids, all-valid): some version of every valid txid must reach inbound" + $ checkMempools inmp (filterValidTxs outUniqueTxIds) (False, False) -> -- If we are presented with a stream of valid and invalid Txs with @@ -417,7 +561,7 @@ prop_txSubmission st@(TxSubmissionState peers _) = -- TODO: have we generated enough outbound mempools which interact in interesting -- ways? prop_txSubmission_inflight :: TxSubmissionState -> Property -prop_txSubmission_inflight st@(TxSubmissionState state policy) = +prop_txSubmission_inflight st@(TxSubmissionState state _ policy) = let maxRepeatedValidTxs = Map.foldr (\(txs, _, _) r -> foldr fn r txs) Map.empty state @@ -428,34 +572,40 @@ prop_txSubmission_inflight st@(TxSubmissionState state policy) = ) state trace = runSimTrace (txSubmissionSimulation st) - pTrace = List.intercalate "\n" $ map (\(Time t, ev) -> show t <> " " <> ev) $ - selectTraceEventsSayWithTime' trace + pTrace = ppSayTrace trace in case traceResult True trace of - Left err -> counterexample pTrace --(ppTrace trace) + Left err -> counterexample pTrace $ counterexample (show err) $ property False Right (inmp, _) -> let resultRepeatedValidTxs = foldr fn Map.empty inmp in label (if hasInvalidSize then "has wrongly sized tx" else "has no wrongly sized tx") - . counterexample pTrace --(ppTrace trace) + . counterexample pTrace . counterexample ("hasInvalidSize: " <> show hasInvalidSize) . counterexample ("Result valid [(txid, repeated)]:\n" <> show resultRepeatedValidTxs) . counterexample ("Testcase max valid [(txid, repeated)]:\n" <> show maxRepeatedValidTxs) + . (\p -> p .&&. prop_counterInvariants trace) . conjoin . Map.elems $ if hasInvalidSize then merge (mapMissing \_txid _left -> error "impossible") (mapMissing \_txid _right -> True) (zipWithMatched \_txid left right -> - left <= right `min` txInflightMultiplicity policy) + left <= right `min` inflightLimit) resultRepeatedValidTxs maxRepeatedValidTxs else merge (mapMissing \_txid _left -> error "impossible") (mapMissing \_txid _right -> False) (zipWithMatched \_txid left right -> - left <= right `min` txInflightMultiplicity policy) + left <= right `min` inflightLimit) resultRepeatedValidTxs maxRepeatedValidTxs where + -- Loosened from txInflightMultiplicity to account for the per-tx + -- 'currentMaxInflightMultiplicity' bumps that fire when a peer holds + -- a lease past 'inflightTimeout'. Each peer can contribute at most one + -- bump per stuck claim, so 'cap + peers' is a safe static upper bound. + inflightLimit = txInflightMultiplicity policy + Map.size state + -- we work with txid's because a repeated tx may have different advertised/actual -- byte size by different peers in this test, but otherwise multiplicity -- should be determined by txid. @@ -469,38 +619,121 @@ prop_txSubmission_inflight st@(TxSubmissionState state policy) = = r' +-- | Resilience to per-peer impairment. With a non-empty subset of peers +-- wrapped in any combination of 'omitBodies' and 'delayBodies', every tx +-- contributed by a well-behaved peer must still reach the inbound mempool. +-- Exercises V2's cross-peer retry path (omission) and stuck-leaseholder +-- bump path (delay). +-- +-- Contributions from an impaired peer are not asserted: omitted bodies +-- may never reach the mempool, and severely delayed bodies may not arrive +-- before the simulation terminates. +prop_txSubmission_resilientToImpairment :: TxSubmissionState -> Property +prop_txSubmission_resilientToImpairment baseSt = + forAll (genImpairment (Map.keys (peerMap baseSt))) $ \imp -> + not (Map.null imp) ==> + let st = baseSt { peerImpairment = imp } + allAddrs = Map.keysSet (peerMap st) + wbAddrs = allAddrs `Set.difference` Map.keysSet imp + wbPeerTxs = [ txs + | addr <- Set.toList wbAddrs + , let (txs, _, _) = peerMap st Map.! addr ] + tr = runSimTrace (txSubmissionSimulation st) + in not (Set.null wbAddrs) ==> + label ("impaired peers: " ++ show (Map.size imp)) $ + label ("well-behaved peers: " ++ show (Set.size wbAddrs)) $ + tabulate "impairment kind" (kindOf <$> Map.elems imp) $ + case traceResult True tr of + Left e -> + counterexample (show e) + . counterexample (ppSayTrace tr) + $ False + Right (inmp, _) -> + counterexample (ppSayTrace tr) + $ conjoin (validateWellBehaved inmp `map` wbPeerTxs) + .&&. prop_counterInvariants tr + where + -- Pick a non-empty proper subset of peers to impair. Each impaired + -- peer gets some mix of body delay and per-body omission (at least + -- one of the two). + genImpairment :: [Int] -> Gen (Map Int Impairment) + genImpairment addrs + | length addrs < 2 = pure Map.empty + | otherwise = do + n <- choose (1, length addrs - 1) + shuffled <- shuffle addrs + let impaired = take n shuffled + imps <- traverse (const genOneImpairment) impaired + pure (Map.fromList (zip impaired imps)) + + genOneImpairment :: Gen Impairment + genOneImpairment = oneof [genOmit, genDelay, genBoth] + + genOmit = do + p <- choose (0.1 :: Double, 0.9) + seed <- arbitrary + pure Impairment { impairBodyDelay = Nothing + , impairOmitProb = p + , impairSeed = seed + } + genDelay = do + d <- choose (0.1 :: Double, 2.0) + pure Impairment { impairBodyDelay = Just (realToFrac d) + , impairOmitProb = 0 + , impairSeed = 0 + } + genBoth = do + p <- choose (0.1 :: Double, 0.9) + seed <- arbitrary + d <- choose (0.1 :: Double, 2.0) + pure Impairment { impairBodyDelay = Just (realToFrac d) + , impairOmitProb = p + , impairSeed = seed + } + + kindOf Impairment { impairBodyDelay = Nothing, impairOmitProb = _ } = "omit-only" + kindOf Impairment { impairBodyDelay = Just _, impairOmitProb = 0 } = "delay-only" + kindOf Impairment { impairBodyDelay = Just _, impairOmitProb = _ } = "delay+omit" + + -- Same shape as 'validate' inside 'prop_txSubmission'. Only assert + -- coverage when the peer's stream is all-unique-and-all-valid; the + -- duplicate / invalid-prefix cases are out of scope here and covered + -- by the existing 'prop_txSubmission'. + validateWellBehaved :: [Tx Int] -> [Tx Int] -> Property + validateWellBehaved inmp outmp = + let outUnique = nubBy ((==) `on` getTxId) outmp + outValid = filterValidTxs outmp in + if length outUnique == length outmp && length outValid == length outmp + then + let outIds = Set.fromList (getTxId <$> outValid) + inIds = Set.fromList (getTxId <$> inmp) + missing = outIds `Set.difference` inIds in + counterexample ("missing: " ++ show (Set.toList missing)) + $ property (Set.null missing) + else + property True + + prop_sharedTxStateInvariant :: TxSubmissionState -> Property -prop_sharedTxStateInvariant initialState@(TxSubmissionState st0 _) = +prop_sharedTxStateInvariant initialState@(TxSubmissionState st0 _ _) = let tr = runSimTrace (() <$ txSubmissionSimulation initialState) - pTrace = List.intercalate "\n" $ map (\(Time t, ev) -> show t <> " " <> ev) $ - selectTraceEventsSayWithTime' tr + pTrace = ppSayTrace tr in case traceResult True tr of - Left err -> counterexample pTrace --(ppTrace tr) + Left err -> counterexample pTrace . counterexample (show err) $ False Right _ -> - let lookBack, tr' :: [TxStateTraceType] - lookBack = Trace.toList $ traceSelectTraceEventsDynamic tr - tr' = drop 1 lookBack + let tracedStates :: [TxStateTraceType] + tracedStates = Trace.toList $ traceSelectTraceEventsDynamic tr in counterexample pTrace case foldMap (\case - (TxStateTrace stBack, TxStateTrace st)-> - (Every . counterexample (show st) $ - sharedTxStateInvariant WeakInvariant st - .&&. let inflight = Map.keysSet $ inflightTxs st - buffered = Map.keysSet $ bufferedTxs st - inflightBack = Map.keysSet $ inflightTxs stBack - in - -- here we account for a very slow peer from whom we requested - -- a transaction, but it didn't arrive until we have also requested - -- it from another peer, received it, and placed it into the mempool, - -- and so it ended up in bufferedTxs when the first one is still - -- in flight. It is an error when the opposite happens. - null $ (inflight Set.\\ inflightBack) `Set.intersection` buffered - , Sum 1 - ) + TxStateTrace st -> + ( Every . counterexample (show st) $ + sharedTxStateInvariant WeakInvariant st + , Sum 1 + ) ) - (zip lookBack tr') + tracedStates of (p, Sum c) -> label ("number of txs: " ++ @@ -513,7 +746,6 @@ prop_sharedTxStateInvariant initialState@(TxSubmissionState st0 _) = ++ renderRanges 100 c) $ p - -- -- Utils -- diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Impaired.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Impaired.hs new file mode 100644 index 00000000000..93b8c13575d --- /dev/null +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Impaired.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Test-only impairment shims for 'TxSubmissionClient'. They wrap an +-- existing outbound peer with behavioural faults at the typed-protocol +-- level: 'delayBodies' adds latency to body replies, 'omitBodies' drops +-- bodies probabilistically. Both pass txid replies through unchanged so +-- the impaired peer still advertises promptly. +-- +-- The wrappers are polymorphic in @txid@ and @tx@ and depend only on the +-- TxSubmission2 client types. +module Test.Ouroboros.Network.TxSubmission.Impaired + ( delayBodies + , omitBodies + , Impairment (..) + , noImpairment + , applyImpairment + ) where + +import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM, StrictTVar, + atomically, newTVarIO, stateTVar) +import Control.Monad (filterM) +import Control.Monad.Class.MonadTime.SI (DiffTime) +import Control.Monad.Class.MonadTimer.SI (MonadDelay, threadDelay) +import System.Random (StdGen, mkStdGen, uniformR) + +import Ouroboros.Network.Protocol.TxSubmission2.Client + + +-- | Add a fixed delay before every 'MsgReplyTxs' (body reply); txid +-- replies pass through unchanged. Models a peer that advertises promptly +-- but is slow to deliver bodies. +-- +-- The wrapper is recursive: every 'ClientStIdle' continuation produced +-- by the inner peer is wrapped in turn, so the delay applies to every +-- body reply through the protocol session — not just the first. +delayBodies + :: forall txid tx m a. + MonadDelay m + => DiffTime + -> TxSubmissionClient txid tx m a + -> TxSubmissionClient txid tx m a +delayBodies d (TxSubmissionClient mIdle) = + TxSubmissionClient (wrapIdle <$> mIdle) + where + wrapIdle :: ClientStIdle txid tx m a -> ClientStIdle txid tx m a + wrapIdle ClientStIdle { recvMsgRequestTxIds, recvMsgRequestTxs } = ClientStIdle + { recvMsgRequestTxIds = \blocking ack req -> do + reply <- recvMsgRequestTxIds blocking ack req + pure (wrapTxIds reply) + , recvMsgRequestTxs = \txids -> do + reply <- recvMsgRequestTxs txids + threadDelay d + pure (wrapTxs reply) + } + + wrapTxIds :: ClientStTxIds blocking txid tx m a + -> ClientStTxIds blocking txid tx m a + wrapTxIds (SendMsgReplyTxIds reply k) = SendMsgReplyTxIds reply (wrapIdle k) + wrapTxIds (SendMsgDone a) = SendMsgDone a + + wrapTxs :: ClientStTxs txid tx m a -> ClientStTxs txid tx m a + wrapTxs (SendMsgReplyTxs txs k) = SendMsgReplyTxs txs (wrapIdle k) + + +-- | Drop each body in 'MsgReplyTxs' independently with the given +-- probability; txid replies pass through unchanged. Models a peer whose +-- mempool evicts entries between advertise and fetch — the receiver sees +-- a body list that is a subset of what it requested. +-- +-- Randomness is threaded through a 'StrictTVar' so the test can seed it +-- from a QuickCheck-generated value and produce reproducible drop +-- patterns. Each body is decided independently. +-- +-- Recursive in the same way as 'delayBodies'. +omitBodies + :: forall txid tx m a. + MonadSTM m + => StrictTVar m StdGen + -> Double + -- ^ drop probability for each body, in [0, 1] + -> TxSubmissionClient txid tx m a + -> TxSubmissionClient txid tx m a +omitBodies genVar p (TxSubmissionClient mIdle) = + TxSubmissionClient (wrapIdle <$> mIdle) + where + wrapIdle :: ClientStIdle txid tx m a -> ClientStIdle txid tx m a + wrapIdle ClientStIdle { recvMsgRequestTxIds, recvMsgRequestTxs } = ClientStIdle + { recvMsgRequestTxIds = \blocking ack req -> do + reply <- recvMsgRequestTxIds blocking ack req + pure (wrapTxIds reply) + , recvMsgRequestTxs = \txids -> do + SendMsgReplyTxs txs k <- recvMsgRequestTxs txids + kept <- atomically (filterM (const rollKeep) txs) + pure (SendMsgReplyTxs kept (wrapIdle k)) + } + + wrapTxIds :: ClientStTxIds blocking txid tx m a + -> ClientStTxIds blocking txid tx m a + wrapTxIds (SendMsgReplyTxIds reply k) = SendMsgReplyTxIds reply (wrapIdle k) + wrapTxIds (SendMsgDone a) = SendMsgDone a + + rollKeep = stateTVar genVar $ \g -> + case uniformR (0 :: Double, 1) g of + (x, g') -> (x >= p, g') + + +-- | Behavioural fault injection on a peer's outbound 'TxSubmissionClient'. +-- Peers configured with 'noImpairment' run unwrapped. +data Impairment = Impairment + { impairBodyDelay :: Maybe DiffTime + -- ^ added before each MsgReplyTxs; txid replies are unaffected + , impairOmitProb :: Double + -- ^ per-body Bernoulli drop probability, in [0, 1] + , impairSeed :: Int + -- ^ seed for the per-peer StdGen used by 'omitBodies' + } deriving (Eq, Show) + +-- | The neutral impairment: no delay, no omission. Equivalent to running the +-- client unwrapped. +noImpairment :: Impairment +noImpairment = Impairment { impairBodyDelay = Nothing + , impairOmitProb = 0 + , impairSeed = 0 + } + +-- | Wrap a 'TxSubmissionClient' with the given 'Impairment'. Allocates a +-- per-peer 'StdGen' TVar only when the omission rate is non-zero. +applyImpairment :: (MonadDelay m, MonadSTM m) + => Impairment + -> TxSubmissionClient txid tx m a + -> m (TxSubmissionClient txid tx m a) +applyImpairment Impairment { impairBodyDelay, impairOmitProb, impairSeed } c0 = do + c1 <- if impairOmitProb > 0 + then do + genVar <- newTVarIO (mkStdGen impairSeed) + pure (omitBodies genVar impairOmitProb c0) + else pure c0 + pure $ case impairBodyDelay of + Just d -> delayBodies d c1 + Nothing -> c1 diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/MempoolWriter.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/MempoolWriter.hs new file mode 100644 index 00000000000..2dc5a722851 --- /dev/null +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/MempoolWriter.hs @@ -0,0 +1,47 @@ +module Test.Ouroboros.Network.TxSubmission.MempoolWriter (tests) where + +import Control.Concurrent.Class.MonadSTM (newTVarIO, readTVarIO) +import Control.Monad.IOSim (runSimOrThrow) + +import Ouroboros.Network.Protocol.TxSubmission2.Type (SizeInBytes (..)) +import Ouroboros.Network.TxSubmission.Inbound.V1 + (TxSubmissionMempoolWriter (..)) + +import Test.Ouroboros.Network.TxSubmission.Types + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCaseSteps, (@?=)) + + +tests :: TestTree +tests = testGroup "MempoolWriter" + [ testCaseSteps "getMempoolWriter records only valid duplicates" unit_getMempoolWriter_recordsOnlyValidDuplicates + ] + + +unit_getMempoolWriter_recordsOnlyValidDuplicates :: (String -> IO ()) -> IO () +unit_getMempoolWriter_recordsOnlyValidDuplicates step = do + step "Populate the inbound mempool with one valid tx and submit one invalid duplicate plus one valid duplicate" + let (accepted, rejected, duplicateTxIds) = + runSimOrThrow $ do + duplicateVar <- newTVarIO [] + mempool <- newMempool [mkTx 17 True] + let writer = getMempoolWriter duplicateVar mempool + result <- mempoolAddTxs writer [mkTx 17 False, mkTx 17 True] + duplicates <- readTVarIO duplicateVar + pure (fst result, snd result, duplicates) + + step "Assert both submissions are rejected as duplicates but only the valid duplicate is recorded for result accounting" + accepted @?= [] + rejected @?= [(17, DuplicateTx), (17, DuplicateTx)] + duplicateTxIds @?= [17] + where + mkTx :: TxId -> Bool -> Tx TxId + mkTx txid isValid = + Tx { + getTxId = txid, + getTxSize = SizeInBytes 1, + getTxAdvSize = SizeInBytes 1, + getTxValid = isValid, + getTxParent = Nothing + } diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs index 79041ec3bad..e320fe69a01 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs @@ -1,125 +1,116 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} - -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} module Test.Ouroboros.Network.TxSubmission.TxLogic ( tests , ArbTxDecisionPolicy (..) , PeerAddr + , ArbSharedTxState (..) + , ArbPeerTxLocalState (..) + , ReceiveDuplicateFixture + , PeerActionFixture + , FanoutFixture + , mkReceiveDuplicateFixture + , mkResolvedAckFixture + , mkForeignRejectedFixture + , mkFanoutFixture + , runReceiveDuplicateLoop + , runPeerActionLoop + , runFanoutLoop , sharedTxStateInvariant + , peerTxLocalStateInvariant + , peerTxInFlightInvariant + , combinedStateInvariant , InvariantStrength (..) - -- * Utils - , mkDecisionContext ) where -import Prelude hiding (seq) - -import Control.Exception (assert) -import Control.Monad.Class.MonadTime.SI (Time (..)) - -import Data.Foldable as Foldable (fold, foldl', toList) -import Data.List (intercalate, isPrefixOf, isSuffixOf, mapAccumR, nub, - stripPrefix) -import Data.Map.Merge.Strict qualified as Map -import Data.Map.Strict (Map) +import Control.DeepSeq (NFData (rnf)) +import Control.Exception (evaluate) +import Control.Monad.Class.MonadTime.SI (DiffTime, Time (..), addTime, diffTime) +import Data.Foldable (foldl', toList) +import Data.Function (on) +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet qualified as IntSet +import Data.List (elemIndex, mapAccumL, nub, nubBy, sortBy) import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe) -import Data.Monoid (Sum (..)) +import Data.Maybe (listToMaybe) import Data.Sequence.Strict qualified as StrictSeq -import Data.Set (Set) import Data.Set qualified as Set -import Data.Typeable -import System.Random (StdGen, mkStdGen) -import System.Random.SplitMix (SMGen) +import Data.Word (Word64) + +import NoThunks.Class (NoThunks, unsafeNoThunks) + -import NoThunks.Class import Ouroboros.Network.Protocol.TxSubmission2.Type -import Ouroboros.Network.TxSubmission.Inbound.V2.Decision (TxDecision (..)) -import Ouroboros.Network.TxSubmission.Inbound.V2.Decision qualified as TXS +import Ouroboros.Network.Tx (HasRawTxId (..), getRawTxId) import Ouroboros.Network.TxSubmission.Inbound.V2.Policy -import Ouroboros.Network.TxSubmission.Inbound.V2.State (PeerTxState (..), - SharedTxState (..)) -import Ouroboros.Network.TxSubmission.Inbound.V2.State qualified as TXS -import Ouroboros.Network.TxSubmission.Inbound.V2.Types qualified as TXS +import Ouroboros.Network.TxSubmission.Inbound.V2.State +import Ouroboros.Network.TxSubmission.Inbound.V2.Types import Test.Ouroboros.Network.TxSubmission.Types import Test.QuickCheck -import Test.QuickCheck.Function (apply) -import Test.QuickCheck.Gen (Gen (..)) -import Test.QuickCheck.Random (QCGen (..)) -#if !MIN_VERSION_QuickCheck(2,16,0) -import "quickcheck-monoids" Test.QuickCheck.Monoids -#endif -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (testProperty) -import Text.Pretty.Simple - +import Test.Tasty (TestTree, localOption, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCaseSteps, + (@?=)) +import Test.Tasty.QuickCheck (QuickCheckTests (..), testProperty) tests :: TestTree -tests = testGroup "AppV2" - [ testGroup "TxLogic" - [ testGroup "State" - [ testGroup "Arbitrary" - [ testGroup "ArbSharedTxState" - [ testProperty "generator" prop_SharedTxState_generator - , testProperty "shrinker" $ withMaxSuccess 10 - prop_SharedTxState_shrinker - , testProperty "nothunks" prop_SharedTxState_nothunks +tests = + testGroup "TxLogic" + [ localOption (QuickCheckTests 50) $ + testGroup "TriggerScenario meta-tests" + [ testProperty "generated scenario produces a valid initial state" + prop_TriggerScenario_validInitialState + , testProperty "shrink preserves validity" + prop_TriggerScenario_shrinkPreservesValidity + , testProperty "shrink does not grow the trigger list" + prop_TriggerScenario_shrinkSmaller + , testProperty "shrink does not contain the original value" + prop_TriggerScenario_shrinkExcludesOriginal ] - , testGroup "ArbReceivedTxIds" - [ testProperty "generator" prop_receivedTxIds_generator - ] - , testGroup "ArbCollectTxs" - [ testProperty "generator" prop_collectTxs_generator - , testProperty "shrinker" $ withMaxSuccess 10 - prop_collectTxs_shrinker - ] - ] - , testProperty "acknowledgeTxIds" prop_acknowledgeTxIds - , testProperty "receivedTxIdsImpl" prop_receivedTxIdsImpl - , testProperty "collectTxsImpl" prop_collectTxsImpl - , testProperty "splitAcknowledgedTxIds" prop_splitAcknowledgedTxIds - , 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 - ] - ] + , testProperty "nextPeerAction processes all multi-peer triggers" prop_nextPeerAction_processesAllTriggers + , testCaseSteps "peerScore decays linearly over time at scoreRate" unit_peerScore_decaysOverTime + , testCaseSteps "applyPeerRejections drains the existing score before adding the new rejection count" unit_applyPeerRejections_drainsThenAdds + , testProperty "handleReceivedTxIds classifies incoming txids" prop_handleReceivedTxIds + , testCaseSteps "handleReceivedTxIds tracks the advertise without mutating an existing entry" unit_handleReceivedTxIds_advertisesExistingEntry + , testProperty "handleReceivedTxs buffers requested bodies and releases omitted ones" prop_handleReceivedTxs + , testProperty "handleSubmittedTxs retains accepted and drops rejected" prop_handleSubmittedTxs_retainsAcceptedAndDropsRejected + , testProperty "nextPeerAction returns the current shared generation when idle" prop_nextPeerAction_returnsSharedGeneration + , testProperty "nextPeerAction respects the inflight size budget" prop_nextPeerAction_picksTxsRespectingBudget + , testProperty "nextPeerAction submits buffered owned txs before acking" prop_nextPeerAction_ownerSubmitsBuffered + , testProperty "nextPeerAction prunes expired retained txs" prop_nextPeerAction_prunesExpiredRetained + , testProperty "nextPeerAction keeps retained txs before expiry" prop_nextPeerAction_keepsRetained + , testProperty "nextPeerActionPipelined suppresses ack-only or request-only txid messages" prop_nextPeerActionPipelined_requiresAckAndReq + , testProperty "nextPeerActionPipelined emits a pipelined txid request when ack and request fire together" prop_nextPeerActionPipelined_requestsTxIds + , testProperty "nextPeerActionPipelined opens a second outstanding body batch" prop_nextPeerActionPipelined_secondBodyBatch + , testProperty "nextPeerActionPipelined does not open a third outstanding body batch" prop_nextPeerActionPipelined_noThirdBodyBatch + , testProperty "nextPeerAction's PeerDoNothing carries the earliest scheduled wake" prop_nextPeerAction_earliestWakeDelay + , testCaseSteps "nextPeerActionPipelined keeps one txid unacked while body replies are in flight" unit_nextPeerActionPipelined_keepsOneUnackedWithOutstandingBodyReply + , testCaseSteps "nextPeerAction skips blocked-available txs and requests later claimable ones" unit_nextPeerAction_skipsBlockedAvailableTxs + , testCaseSteps "nextPeerAction only acks the safe prefix before a blocked buffered tx" unit_nextPeerAction_acksSafePrefixBeforeBlockedBufferedTx + , testCaseSteps "nextPeerAction lets another peer claim a fresh tx when the first advertiser is full" unit_nextPeerAction_claimsFreshTxWhenFirstAdvertiserIsFull + , testCaseSteps "nextPeerAction claims a released tx from another advertiser" unit_nextPeerAction_claimsRejectedTxFromOtherAdvertiser + , testCaseSteps "nextPeerAction claims a tx once the score delay threshold has elapsed" unit_nextPeerAction_claimsAtScoreDelayThreshold + , testCaseSteps "nextPeerAction requests other work despite a blocked buffered tx" unit_nextPeerAction_requestsOtherWorkDespiteBlockedBufferedTx + , testProperty "nextPeerAction keeps non-owner txids unacked until resolved" prop_nextPeerAction_nonOwnerWaitsUntilResolved + , testProperty "nextPeerAction claims a claimable tx for the best idle advertiser" prop_nextPeerAction_claimsClaimableTx ] - ] +-- +-- NoThunks invariant checks +-- + +-- | Check that a value has no thunks in its fields. +checkNoThunks :: NoThunks a => String -> a -> Property +checkNoThunks name val = + val `seq` case unsafeNoThunks val of + Nothing -> property True + Just info -> counterexample + (name ++ " contains thunks: " ++ show info) + (property False) -- -- InboundState properties @@ -127,1495 +118,3085 @@ tests = testGroup "AppV2" type PeerAddr = Int +data ReceiveDuplicateFixture = ReceiveDuplicateFixture + { rdfPeerAddr :: !PeerAddr + , rdfRequestedTxIds :: !NumTxIdsToReq + , rdfTxidsAndSizes :: ![(TxId, SizeInBytes)] + , rdfPeerState :: !(PeerTxLocalState (Tx TxId)) + , rdfSharedState :: !(SharedTxState PeerAddr TxId) + } + +data PeerActionFixture = PeerActionFixture + { pafPeerAddr :: !PeerAddr + , pafPeerState :: !(PeerTxLocalState (Tx TxId)) + , pafSharedState :: !(SharedTxState PeerAddr TxId) + } + +data FanoutFixture = FanoutFixture + { ffPeers :: ![PeerAddr] + , ffRequestedTxIds :: !NumTxIdsToReq + , ffTxidsAndSizes :: ![(TxId, SizeInBytes)] + , ffInitialSharedState :: !(SharedTxState PeerAddr TxId) + } + +instance NFData ReceiveDuplicateFixture where + rnf ReceiveDuplicateFixture { rdfPeerAddr, rdfRequestedTxIds, rdfTxidsAndSizes + , rdfPeerState, rdfSharedState } = + rnf rdfPeerAddr + `seq` rnf rdfRequestedTxIds + `seq` rnf rdfTxidsAndSizes + `seq` rnf rdfPeerState + `seq` rnf rdfSharedState + +instance NFData PeerActionFixture where + rnf PeerActionFixture { pafPeerAddr, pafPeerState, pafSharedState } = + rnf pafPeerAddr + `seq` rnf pafPeerState + `seq` rnf pafSharedState + +instance NFData FanoutFixture where + rnf FanoutFixture { ffPeers, ffRequestedTxIds, ffTxidsAndSizes, ffInitialSharedState } = + rnf ffPeers + `seq` rnf ffRequestedTxIds + `seq` rnf ffTxidsAndSizes + `seq` rnf ffInitialSharedState + data InvariantStrength = WeakInvariant | StrongInvariant + deriving (Eq, Show) + +-- | 'PeerTxLocalState' invariant. +-- +-- Consistency constraints between the peer-local bookkeeping maps: +-- +-- * Every available or downloaded key is still tracked in the +-- unacknowledged queue. +-- * Every requested key is also available (a key can only be requested +-- while its advertised size is still known). +-- * Downloaded keys are disjoint from available and from requested +-- (a key moves out of available/requested exactly when its body +-- lands in downloaded). +-- * @peerRequestedTxs@ equals the union of all @requestedTxBatchSet@s +-- and @peerRequestedTxsSize@ equals the sum of all batch sizes. +-- * @peerAdvertisedTxKeys@ is a subset of the unacknowledged queue (a +-- peer can only advertise keys it has actually received and not yet +-- acked). +peerTxLocalStateInvariant + :: forall tx. + TxDecisionPolicy + -> PeerTxLocalState tx + -> Property +peerTxLocalStateInvariant TxDecisionPolicy { scoreMax } + PeerTxLocalState { + peerUnacknowledgedTxIds, + peerAvailableTxIds, + peerRequestedTxs, + peerRequestedTxBatches, + peerRequestedTxsSize, + peerDownloadedTxs, + peerScore + } = + conjoin + [ counterexample "requested keys are not all available" + (property (peerRequestedTxs `IntSet.isSubsetOf` availableKeys)) + , counterexample "available keys are not all in the unacknowledged queue" + (property (availableKeys `IntSet.isSubsetOf` unackKeys)) + , counterexample "downloaded keys are not all in the unacknowledged queue" + (property (downloadedKeys `IntSet.isSubsetOf` unackKeys)) + , counterexample "downloaded and available key sets overlap" + (IntSet.null (downloadedKeys `IntSet.intersection` availableKeys)) + , counterexample "downloaded and requested key sets overlap" + (IntSet.null (downloadedKeys `IntSet.intersection` peerRequestedTxs)) + , counterexample "peerRequestedTxs does not match the batch key-set union" + (peerRequestedTxs === batchKeyUnion) + , counterexample "peerRequestedTxsSize does not match the sum of batch sizes" + (peerRequestedTxsSize === batchSizeSum) + , counterexample ("peerScoreValue is negative: " ++ show scoreVal) + (property (scoreVal >= 0)) + , counterexample ("peerScoreValue exceeds scoreMax: " + ++ show scoreVal ++ " > " ++ show scoreMax) + (property (scoreVal <= scoreMax)) + ] + where + scoreVal = peerScoreValue peerScore + unackKeys = IntSet.fromList [ k | TxKey k <- toList peerUnacknowledgedTxIds ] + availableKeys = IntMap.keysSet peerAvailableTxIds + downloadedKeys = IntMap.keysSet peerDownloadedTxs + batchKeyUnion = + IntSet.unions (fmap requestedTxBatchSet (toList peerRequestedTxBatches)) + batchSizeSum = + sum (fmap requestedTxBatchSize (toList peerRequestedTxBatches)) + +-- | Per-peer 'PeerTxInFlight' invariant. +-- +-- A peer's attempting and submitting sets must be disjoint (a key is +-- in at most one phase per peer). Lease and submission stake imply +-- the peer is also tracking the key as advertised. +peerTxInFlightInvariant :: PeerTxInFlight -> Property +peerTxInFlightInvariant pif = + conjoin + [ counterexample "pifAttempting and pifSubmitting overlap" + (IntSet.null (pifAttempting pif `IntSet.intersection` pifSubmitting pif)) + , counterexample "pifLeased not contained in pifAttempting ∪ pifSubmitting" + (property (pifLeased pif + `IntSet.isSubsetOf` + (pifAttempting pif `IntSet.union` pifSubmitting pif))) + ] + +-- | Combined invariant over @SharedTxState@ and a snapshot of every +-- live peer's @(PeerTxLocalState, PeerTxInFlight)@. +-- +-- Runs the per-piece invariants ('peerTxLocalStateInvariant', +-- 'peerTxInFlightInvariant', 'sharedTxStateInvariant') and adds the +-- cross-state coherence constraints that need both shared and per-peer +-- views to express: +-- +-- * Every key in any peer's 'pifAdvertised' references an active +-- entry or a retained one (never falls out of both). +-- * Each entry's 'txAttempt' equals the number of peers in the map +-- whose 'pifAttempting' contains the key. +-- * Each entry's 'txInSubmission' is true iff some peer in the map +-- has the key in its 'pifSubmitting'. +-- * If an entry is 'TxLeased peer _' and that peer is in the map, +-- the peer's 'pifLeased' contains the key. Stale leases (peer's +-- 'pifLeased' has a key that the entry no longer leases to them) +-- are tolerated since theft via inflight-cap bumps does not +-- proactively scrub the loser's set. +-- +-- Single-peer call sites pass a @Map.singleton@; multi-peer scenarios +-- pass the full schedule snapshot so the cross-peer counter checks +-- are exercised. +combinedStateInvariant + :: forall peeraddr txid tx. + ( Ord peeraddr + , Ord txid + , HasRawTxId txid + , Show peeraddr + , Show txid + ) + => TxDecisionPolicy + -> InvariantStrength + -> Map.Map peeraddr (PeerTxLocalState tx, PeerTxInFlight) + -> SharedTxState peeraddr txid + -> Property +combinedStateInvariant policy strength peers sharedState = + let activeKeys = IntMap.keysSet (sharedTxTable sharedState) + retKeys = retainedKeysSet (sharedRetainedTxs sharedState) + liveKeys = activeKeys `IntSet.union` retKeys + in conjoin $ + [ counterexample ("PeerTxLocalState invariant violated for peer " + ++ show p) + (peerTxLocalStateInvariant policy ps) + | (p, (ps, _)) <- Map.toList peers ] + ++ [ counterexample ("PeerTxInFlight invariant violated for peer " + ++ show p) + (peerTxInFlightInvariant pif) + | (p, (_, pif)) <- Map.toList peers ] + ++ [ sharedTxStateInvariant strength sharedState ] + ++ [ counterexample ("peer " ++ show p + ++ " advertises keys that are neither active nor retained") + (property (pifAdvertised pif `IntSet.isSubsetOf` liveKeys)) + | (p, (_, pif)) <- Map.toList peers ] + ++ [ counterexample ("txAttempt mismatch for entry " ++ show k + ++ ": expected " ++ show expectedAttempt + ++ " (sum across peers' pifAttempting)" + ++ ", got " ++ show (txAttempt entry)) + (txAttempt entry === expectedAttempt) + | (k, entry) <- IntMap.toList (sharedTxTable sharedState) + , let expectedAttempt = + sum [ if IntSet.member k (pifAttempting pif) then 1 else 0 + | (_, (_, pif)) <- Map.toList peers ] + ] + ++ [ counterexample ("txInSubmission mismatch for entry " ++ show k + ++ ": expected " ++ show expectedSubmit) + (txInSubmission entry === expectedSubmit) + | (k, entry) <- IntMap.toList (sharedTxTable sharedState) + , let expectedSubmit = + any (\(_, (_, pif)) -> IntSet.member k (pifSubmitting pif)) + (Map.toList peers) + ] + ++ [ counterexample ("entry " ++ show k + ++ " is TxLeased to peer " ++ show owner + ++ " but the peer's pifLeased does not contain it") + (case Map.lookup owner peers of + Nothing -> property True + Just (_, ownerPif) -> property (IntSet.member k (pifLeased ownerPif))) + | (k, entry) <- IntMap.toList (sharedTxTable sharedState) + , TxLeased owner _ <- [txLease entry] + ] + -- | 'InboundState` invariant. -- sharedTxStateInvariant - :: forall peeraddr txid tx. - ( Ord txid + :: forall peeraddr txid. + ( Ord peeraddr + , Ord txid + , HasRawTxId txid + , Show peeraddr , Show txid - , Show tx ) => InvariantStrength - -> SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid -> Property -sharedTxStateInvariant invariantStrength - SharedTxState { - peerTxStates, - inflightTxs, - bufferedTxs, - referenceCounts, - timedTxs - } = - counterexample "bufferedTxs txid not a subset of unacknowledged txids" - ( - let unacknowledgedSet = - foldr (\PeerTxState { unacknowledgedTxIds } r -> - r <> Set.fromList (toList unacknowledgedTxIds)) - Set.empty txStates - timedSet = foldMap Set.fromList timedTxs - in case invariantStrength of - WeakInvariant -> - -- `submitTxToMempool` caches buffered `txs`, we check here that - -- they do not leak - counterexample ("unacknowledgedSet: " ++ show unacknowledgedSet) $ - counterexample ("bufferedTxsSet: " ++ show bufferedTxsSet) $ - counterexample ("timedTxsSet: " ++ show timedSet) $ - (bufferedTxsSet Set.\\ unacknowledgedSet) - `Set.isSubsetOf` - timedSet - - StrongInvariant -> property $ - -- the set of buffered txids must be a subset of sum of the sets of - -- unacknowledged txids - bufferedTxsSet - `Set.isSubsetOf` - unacknowledgedSet - ) - - .&&. counterexample "referenceCounts invariant violation" - ( - referenceCounts - === - -- fold unacknowledgedTxIds - Foldable.foldl' - (\m PeerTxState { unacknowledgedTxIds = unacked } -> - Foldable.foldl' - (flip $ - Map.alter (\case - Nothing -> Just $! 1 - Just cnt -> Just $! succ cnt) - ) - m - unacked - ) - -- fold timedTxs - (Foldable.foldl' - (Foldable.foldl' - (flip $ - Map.alter (\case - Nothing -> Just $! 1 - Just cnt -> Just $! succ cnt) - ) - ) - Map.empty - timedTxs - ) - txStates - ) +sharedTxStateInvariant strength SharedTxState { + sharedTxTable, + sharedRetainedTxs, + sharedTxIdToKey, + sharedKeyToTxId, + sharedNextTxKey + } = + conjoin $ + [ counterexample "sharedTxIdToKey/sharedKeyToTxId size mismatch" + (Map.size sharedTxIdToKey === IntMap.size sharedKeyToTxId) + , counterexample "active and retained tx sets overlap" + (IntSet.null (IntMap.keysSet sharedTxTable `IntSet.intersection` retainedKeysSet sharedRetainedTxs)) + , counterexample "tx-key maps disagree" + (property (keysRoundTripForward && keysRoundTripBackward)) + , counterexample "live tx keys missing from tx-key maps" + (liveKeys `IntSet.isSubsetOf` IntMap.keysSet sharedKeyToTxId) + , counterexample "sharedNextTxKey does not stay ahead of all live tx keys" + (property (all (< sharedNextTxKey) (IntSet.toList liveKeys))) + ] + ++ case strength of + -- Both strengths now run the per-entry well-formedness check. + -- "Self-evident liveness" (lease or txAttempt > 0 or + -- txInSubmission) is no longer a shared-state invariant: an + -- entry can sit TxClaimable with 'txAttempt = 0' while a live + -- peer's 'pifAdvertised' keeps it from being swept. The sweep + -- itself enforces global liveness; per-peer invariants live in + -- 'combinedStateInvariant'. + _ -> fmap checkTxEntry activeEntries + where + liveKeys = IntMap.keysSet sharedTxTable `IntSet.union` retainedKeysSet sharedRetainedTxs + activeEntries = IntMap.toList sharedTxTable + + keysRoundTripForward = + all (\(rawId, txKey) -> fmap getRawTxId (IntMap.lookup (unTxKey txKey) sharedKeyToTxId) == Just rawId) + (Map.toList sharedTxIdToKey) + + keysRoundTripBackward = + all (\(k, txid) -> Map.lookup (getRawTxId txid) sharedTxIdToKey == Just (TxKey k)) + (IntMap.toList sharedKeyToTxId) + + checkTxEntry (k, txEntry@TxEntry { txAttempt, txInSubmission }) = + counterexample ("bad active tx entry " ++ show k ++ ": " ++ show txEntry) $ + conjoin + [ counterexample "txAttempt is negative" + (property (txAttempt >= 0)) + , counterexample "txInSubmission without any peer in submission" + (property (not txInSubmission || txAttempt >= 0)) + ] - .&&. 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 -> Every - . counterexample (show ps) - . peerTxStateInvariant - $ ps - ) - peerTxStates) +newtype ArbTxDecisionPolicy = ArbTxDecisionPolicy TxDecisionPolicy + deriving (Eq, Show) - where - peerTxStateInvariant :: PeerTxState txid tx -> Property - peerTxStateInvariant PeerTxState { availableTxIds, - unacknowledgedTxIds, - unknownTxs, - requestedTxIdsInflight, - requestedTxsInflight, - requestedTxsInflightSize } = - - - counterexample ("unknownTxs is not a subset of unacknowledgedTxIds: " - ++ show (unknownTxs Set.\\ unacknowledgedTxIdsSet)) - (unknownTxs `Set.isSubsetOf` unacknowledgedTxIdsSet) - - .&&. counterexample ("availableTxs is not a subset of unacknowledgedTxIds: " - ++ show (availableTxIdsSet Set.\\ unacknowledgedTxIdsSet)) - (availableTxIdsSet `Set.isSubsetOf` unacknowledgedTxIdsSet) - - .&&. counterexample ("unacknowledged tx must be either available, unknown or buffered: " - ++ show (unacknowledgedTxIdsSet - Set.\\ availableTxIdsSet - Set.\\ unknownTxs - Set.\\ bufferedTxsSet - Set.\\ downloadedTxsSet)) - (unacknowledgedTxIdsSet - Set.\\ availableTxIdsSet - Set.\\ unknownTxs - Set.\\ downloadedTxsSet - `Set.isSubsetOf` - bufferedTxsSet - ) - - .&&. counterexample "requestedTxIdsInflight invariant violation" - (requestedTxIdsInflight >= 0) - - -- a requested tx is either available or buffered - .&&. counterexample ("requestedTxsInflight invariant violation: " - ++ show (requestedTxsInflight - Set.\\ availableTxIdsSet - Set.\\ bufferedTxsSet)) - (requestedTxsInflight Set.\\ availableTxIdsSet `Set.isSubsetOf` bufferedTxsSet) - - .&&. counterexample "requestedTxsInfightSize" - (requestedTxsInflightSize - === - fold (availableTxIds `Map.restrictKeys` requestedTxsInflight)) - - where - availableTxIdsSet :: Set txid - availableTxIdsSet = Map.keysSet availableTxIds - - unacknowledgedTxIdsSet :: Set txid - unacknowledgedTxIdsSet = Set.fromList (toList unacknowledgedTxIds) - - downloadedTxsSet :: Set txid - downloadedTxsSet = Set.unions $ map (Map.keysSet . downloadedTxs) txStates - - bufferedTxsSet = Map.keysSet bufferedTxs :: Set txid - liveSet = Map.keysSet referenceCounts :: Set txid - txStates = Map.elems peerTxStates :: [PeerTxState txid tx] +newtype ArbSharedTxState = ArbSharedTxState (SharedTxState PeerAddr TxId) + deriving Show --- --- Generate `InboundState` --- +newtype ArbPeerTxLocalState = ArbPeerTxLocalState (PeerTxLocalState (Tx TxId)) + deriving Show --- | PeerTxState generator. --- --- `mkArbPeerTxState` is the smart constructor. +-- | Tag classifying how @handleReceivedTxIds@ should resolve each incoming +-- txid. -- -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 +-- * 'TxIdNew' — fresh txid, hits the new-entry branch. +-- * 'TxIdRetained' — pre-seeded into 'sharedRetainedTxs', hits the retained +-- branch. +-- * 'TxIdMempool' — mempool-known and not previously in 'sharedTxTable', +-- hits the mempool branch with a @Nothing@ lookup. +-- * 'TxIdMempoolResolvesActive' — mempool-known and pre-seeded into +-- 'sharedTxTable' as advertised by some other peer, hits the mempool +-- branch with a @Just@ lookup and therefore triggers +-- 'removeAdvertisingPeersForResolvedTxExcept' + peer wake-up. Production +-- only hits this when a tx reached the mempool via the local +-- tx-submission interface after remote peers had already advertised the +-- txid, so it is deliberately rare in the generator. +data TxIdGroupTag + = TxIdNew + | TxIdRetained + | TxIdMempool + deriving (Eq, Ord, Show) + +instance Arbitrary TxIdGroupTag where + arbitrary = frequency + [ (12, pure TxIdNew) + , (4, pure TxIdRetained) + , (4, pure TxIdMempool) + ] -instance Arbitrary TxStatus where - arbitrary = oneof [ pure Available - , pure Inflight - , pure Unknown - ] +instance Arbitrary ArbTxDecisionPolicy where + arbitrary = + frequency + [ (1, pure (ArbTxDecisionPolicy defaultTxDecisionPolicy)) + , (9, do + interTxSpaceVal <- realToFrac <$> choose (0 :: Double, 1) + offset <- choose (0.01 :: Double, 10) + let inflightTimeoutVal = interTxSpaceVal + realToFrac offset + ArbTxDecisionPolicy <$> ( + TxDecisionPolicy . getSmall . getPositive + <$> arbitrary + <*> (getSmall . getPositive <$> arbitrary) + <*> (SizeInBytes . getPositive <$> arbitrary) + <*> choose (1, 10) + <*> (getSmall . getPositive <$> arbitrary) + <*> (realToFrac <$> choose (0 :: Double, 2)) + <*> choose (0, 1) + <*> choose (0, 1800) + <*> pure interTxSpaceVal + <*> pure inflightTimeoutVal)) + ] -data TxMask tx = TxAvailable tx TxStatus - -- ^ available txid with its size, the Bool indicates if it's - -- in-flight or not - | TxBuffered tx + shrink (ArbTxDecisionPolicy a) + | a == defaultTxDecisionPolicy = [] + | otherwise = nub $ + ArbTxDecisionPolicy defaultTxDecisionPolicy + : [ ArbTxDecisionPolicy a { maxNumTxIdsToRequest = NumTxIdsToReq x } + | (Positive (Small x)) <- shrink (Positive (Small (getNumTxIdsToReq (maxNumTxIdsToRequest a)))) + ] + ++ [ ArbTxDecisionPolicy a { maxUnacknowledgedTxIds = x } + | (Positive (Small x)) <- shrink (Positive (Small (maxUnacknowledgedTxIds a))) + ] + ++ [ ArbTxDecisionPolicy a { txsSizeInflightPerPeer = SizeInBytes s } + | Positive s <- shrink (Positive (getSizeInBytes (txsSizeInflightPerPeer a))) + ] + ++ [ ArbTxDecisionPolicy a { maxOutstandingTxBatchesPerPeer = x } + | x <- shrink (maxOutstandingTxBatchesPerPeer a), x >= 1 + ] + ++ [ ArbTxDecisionPolicy a { txInflightMultiplicity = x } + | Positive (Small x) <- shrink (Positive (Small (txInflightMultiplicity a))) + ] + ++ [ ArbTxDecisionPolicy a { bufferedTxsMinLifetime = realToFrac x } + | NonNegative x <- shrink (NonNegative (realToFrac (bufferedTxsMinLifetime a) :: Double)) + ] + ++ [ ArbTxDecisionPolicy a { scoreRate = x } + | NonNegative x <- shrink (NonNegative (scoreRate a)) + ] + ++ [ ArbTxDecisionPolicy a { scoreMax = x } + | NonNegative x <- shrink (NonNegative (scoreMax a)) + ] + ++ [ ArbTxDecisionPolicy a { interTxSpace = realToFrac x } + | NonNegative x <- shrink (NonNegative (realToFrac (interTxSpace a) :: Double)) + ] + ++ [ ArbTxDecisionPolicy a { inflightTimeout = realToFrac x } + | NonNegative x <- shrink (NonNegative (realToFrac (inflightTimeout a) :: Double)) + , realToFrac x > interTxSpace a + ] + +instance Arbitrary ArbPeerTxLocalState where + arbitrary = ArbPeerTxLocalState <$> genPeerTxLocalState + + shrink (ArbPeerTxLocalState peerState) + | peerState == emptyPeerTxLocalState = [] + | otherwise = + [ ArbPeerTxLocalState emptyPeerTxLocalState + , ArbPeerTxLocalState peerState + { peerRequestedTxs = IntSet.empty + , peerRequestedTxBatches = StrictSeq.empty + , peerRequestedTxsSize = 0 + , peerRequestedTxIds = 0 + , peerDownloadedTxs = IntMap.empty + } + ] -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 ArbSharedTxState where + arbitrary = ArbSharedTxState <$> genSharedTxState + shrink (ArbSharedTxState sharedState) + | sharedState == emptySharedTxState = [] + | otherwise = ArbSharedTxState <$> shrinkSharedTxState sharedState -instance Arbitrary tx => Arbitrary (TxMask tx) where - arbitrary = oneof [ TxAvailable - <$> arbitrary - <*> arbitrary - , TxBuffered <$> arbitrary - ] +-- +-- Peer score tests +-- - -- TODO: implement shrinker; this can be done by writing an inverse of - -- `mkArbPeerTxState` and shrinking the unacknowledged txs & mask map. +-- | 'currentPeerScore' decays the score linearly at 'scoreRate' per second. +unit_peerScore_decaysOverTime :: (String -> IO ()) -> Assertion +unit_peerScore_decaysOverTime step = do + step "After 50 seconds at scoreRate 0.1 a score of 10 should drain to 5" + currentPeerScore policy (Time 50) score0 @?= 5 + step "After 200 seconds the score should be fully decayed (clamped to 0)" + currentPeerScore policy (Time 200) score0 @?= 0 + step "Reading at the same instant as the last update returns the unchanged value" + currentPeerScore policy (Time 0) score0 @?= peerScoreValue score0 + where + policy = defaultTxDecisionPolicy + score0 = PeerScore { peerScoreValue = 10, peerScoreTs = Time 0 } + +-- | A new rejection drains the existing score at 'scoreRate' per second +-- since its last update before adding the rejection count. +unit_applyPeerRejections_drainsThenAdds :: (String -> IO ()) -> Assertion +unit_applyPeerRejections_drainsThenAdds step = do + step "Starting score 10 at Time 0; one rejection 50s later: 10 - (50 * 0.1) + 1 = 6" + fst (applyPeerRejections policy (Time 50) 1 peerState0) @?= 6 + where + policy = defaultTxDecisionPolicy + peerState0 = emptyPeerTxLocalState + { peerScore = PeerScore { peerScoreValue = 10 + , peerScoreTs = Time 0 } } +-- +-- handleReceivedTxIds +-- --- | Smart constructor for `ArbPeerTxState`. +-- | Verifies that 'handleReceivedTxIds' classifies each incoming txid: -- -mkArbPeerTxState :: Ord txid - => Fun txid Bool - -> Int -- ^ txids in-flight - -> [txid] - -> Map txid (TxMask (Tx txid)) - -> ArbPeerTxState txid (Tx txid) -mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMaskMap = - ArbPeerTxState - PeerTxState { unacknowledgedTxIds = StrictSeq.fromList unacked, - availableTxIds, - requestedTxIdsInflight, - requestedTxsInflight, - requestedTxsInflightSize, - unknownTxs, - score = 0, - scoreTs = Time 0, - downloadedTxs = Map.empty, - toMempoolTxs = Map.empty } - (Set.fromList $ Map.elems inflightMap) - bufferedMap - where - mempoolHasTx = apply mempoolHasTxFun - availableTxIds = Map.fromList - [ (txid, getTxAdvSize tx) | (txid, TxAvailable tx _) <- Map.assocs txMaskMap - , not (mempoolHasTx txid) - ] - unknownTxs = Set.fromList - [ txid | (txid, TxAvailable _ Unknown) <- Map.assocs txMaskMap - , not (mempoolHasTx txid) - ] - - requestedTxIdsInflight = fromIntegral txIdsInflight - requestedTxsInflightSize = foldMap getTxAdvSize inflightMap - requestedTxsInflight = Map.keysSet inflightMap - - -- exclude `txid`s which are already in the mempool, we never request such - -- `txid`s - -- - -- TODO: this should be lifted, we might have the same txid in-flight from - -- multiple peers, one will win the race and land in the mempool first - inflightMap = Map.fromList - [ (txid, tx) - | (txid, TxAvailable tx Inflight) <- Map.assocs txMaskMap - , not (mempoolHasTx txid) - ] +-- * 'TxIdNew' — interned and a fresh 'TxClaimable' entry is created; +-- the key joins 'peerAvailableTxIds' and 'pifAdvertised'. +-- * 'TxIdRetained' — already in 'sharedRetainedTxs'; no entry created +-- and the key is not added to 'pifAdvertised'. +-- * 'TxIdMempool' — interned, moved straight to 'sharedRetainedTxs' +-- and not added to 'pifAdvertised'. +-- +-- Pre-state is empty peer-local and an otherwise empty shared state with +-- the retained group seeded. Asserts the combined invariant before and +-- after, plus per-group inclusion / exclusion in each piece of state. +prop_handleReceivedTxIds + :: ArbTxDecisionPolicy + -> NonEmptyList (TxId, Positive Int, TxIdGroupTag) + -> Property +prop_handleReceivedTxIds (ArbTxDecisionPolicy policy) (NonEmpty taggedInput) = + let + -- Normalise: positive txids, non-zero sizes; dedupe by txid. + normalised :: [(TxId, SizeInBytes, TxIdGroupTag)] + normalised = + nubBy ((==) `on` (\(t,_,_) -> t)) + [ (abs txid + 1, mkSize sz, tag) + | (txid, sz, tag) <- taggedInput + ] - 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 } - ] + txidsAndSizes :: [(TxId, SizeInBytes)] + txidsAndSizes = [ (txid, sz) | (txid, sz, _) <- normalised ] + newGroup = [ (txid, sz) | (txid, sz, TxIdNew) <- normalised ] + retainedGroup = [ (txid, sz) | (txid, sz, TxIdRetained) <- normalised ] + mempoolGroup = [ (txid, sz) | (txid, sz, TxIdMempool) <- normalised ] -genArbPeerTxState - :: forall txid. - ( Arbitrary txid - , Ord txid - ) - => Fun txid Bool - -> Int -- ^ max txids inflight - -> Gen (ArbPeerTxState txid (Tx txid)) -genArbPeerTxState mempoolHasTxFun maxTxIdsInflight = do - -- unacknowledged sequence - unacked <- arbitrary - -- generate `Map txid (TxMask tx)` - txIdsInflight <- choose (0, maxTxIdsInflight) - txMap <- Map.fromList - <$> traverse (\txid -> (\a -> (txid, fixupTxMask txid a)) <$> arbitrary) - (nub unacked) - return $ mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMap - - -genSharedTxState - :: forall txid. - ( Arbitrary txid - , Ord txid - , Function txid - , CoArbitrary txid - ) - => Int -- ^ max txids inflight - -> Gen ( Fun txid Bool - , (PeerAddr, PeerTxState txid (Tx txid)) - , SharedTxState PeerAddr txid (Tx txid) - , Map PeerAddr (ArbPeerTxState txid (Tx txid)) - ) -genSharedTxState maxTxIdsInflight = do - _mempoolHasTxFun@(Fun (_, _, x) _) <- arbitrary :: Gen (Fun Bool Bool) - let mempoolHasTxFun = Fun (function (const False), False, x) (const False) - pss <- listOf1 (genArbPeerTxState mempoolHasTxFun maxTxIdsInflight) - seed <- arbitrary - - let pss' :: [(PeerAddr, ArbPeerTxState txid (Tx txid))] - pss' = [0..] `zip` pss - - peer <- choose (0, length pss - 1) - - let st :: SharedTxState PeerAddr txid (Tx txid) - st = fixupSharedTxState - (apply mempoolHasTxFun) - SharedTxState { - peerTxStates = Map.fromList - [ (peeraddr, arbPeerTxState) - | (peeraddr, ArbPeerTxState { arbPeerTxState }) - <- pss' - ], - inflightTxs = Foldable.foldl' (Map.unionWith (+)) Map.empty - [ Map.fromSet (const 1) (Set.map getTxId arbInflightSet) - | ArbPeerTxState { arbInflightSet } - <- pss - ], - bufferedTxs = fold - [ arbBufferedMap - | ArbPeerTxState { arbBufferedMap } - <- pss - ], - referenceCounts = Map.empty, - timedTxs = Map.empty, - inSubmissionToMempoolTxs - = Map.empty, - peerRng = mkStdGen seed - } - - return ( mempoolHasTxFun - , (peer, peerTxStates st Map.! peer) - , st - , Map.fromList pss' - ) - - --- | Make sure `SharedTxState` is well formed. --- -fixupSharedTxState - :: Ord txid - => (txid -> Bool) -- ^ mempoolHasTx - -> SharedTxState peeraddr txid tx - -> SharedTxState peeraddr txid tx -fixupSharedTxState _mempoolHasTx st@SharedTxState { peerTxStates } = - st { peerTxStates = peerTxStates', - inflightTxs = inflightTxs', - bufferedTxs = bufferedTxs', - referenceCounts = referenceCounts' - } - where - peerTxStates' = - Map.map (\ps@PeerTxState { availableTxIds, - requestedTxsInflight } -> - - let -- requested txs must not be buffered - requestedTxsInflight' = requestedTxsInflight - Set.\\ Map.keysSet bufferedTxs' - requestedTxsInflightSize' = fold $ availableTxIds - `Map.restrictKeys` - requestedTxsInflight' - - in ps { requestedTxsInflight = requestedTxsInflight', - requestedTxsInflightSize = requestedTxsInflightSize' } - ) - peerTxStates - - inflightTxs' = foldr (\PeerTxState { requestedTxsInflight } m -> - Map.unionWith (+) - (Map.fromSet (const 1) requestedTxsInflight) - m - ) - Map.empty - peerTxStates' - - bufferedTxs' = - bufferedTxs st - `Map.restrictKeys` - foldr (\PeerTxState {unacknowledgedTxIds = unacked } r -> - r <> Set.fromList (toList unacked)) - Set.empty (Map.elems peerTxStates) - - - referenceCounts' = - Foldable.foldl' - (\m PeerTxState { unacknowledgedTxIds } -> - Foldable.foldl' - (flip $ - Map.alter (\case - Nothing -> Just $! 1 - Just cnt -> Just $! succ cnt) - ) - m - unacknowledgedTxIds - ) - Map.empty - (Map.elems peerTxStates) - - -shrinkSharedTxState :: ( Arbitrary txid - , Ord txid - , Function txid - , Ord peeraddr - ) - => (txid -> Bool) - -> SharedTxState peeraddr txid (Tx txid) - -> [SharedTxState peeraddr txid (Tx txid)] -shrinkSharedTxState mempoolHasTx st@SharedTxState { peerTxStates, - inflightTxs, - bufferedTxs } = - [ st' - | peerTxStates' <- Map.fromList <$> shrinkList (\_ -> []) (Map.toList peerTxStates) - , not (Map.null peerTxStates') - , let st' = fixupSharedTxState mempoolHasTx st { peerTxStates = peerTxStates' } - , st' /= st - ] - ++ - [ fixupSharedTxState mempoolHasTx st { inflightTxs = inflightTxs' } - | inflightTxs' <- Map.fromList <$> shrinkList (\_ -> []) (Map.toList inflightTxs) - ] - ++ - [ st - | bufferedTxs' <- Map.fromList - <$> shrinkList (\_ -> []) (Map.assocs bufferedTxs) - , let minBuffered = - foldMap - (\PeerTxState { - unacknowledgedTxIds, - availableTxIds, - unknownTxs - } - -> - Set.fromList (toList unacknowledgedTxIds) - Set.\\ Map.keysSet availableTxIds - Set.\\ unknownTxs - ) - peerTxStates - bufferedTxs'' = bufferedTxs' - `Map.union` - (bufferedTxs `Map.restrictKeys` minBuffered) - st' = fixupSharedTxState mempoolHasTx st { bufferedTxs = bufferedTxs'' } - , st' /= st - ] + mempoolHasTx :: TxId -> Bool + mempoolHasTx txid = txid `Set.member` Set.fromList (fmap fst mempoolGroup) --- --- Arbitrary `SharaedTxState` instance --- + sharedState0 = seedRetainedTxids policy retainedGroup emptySharedTxState -data ArbSharedTxState = - ArbSharedTxState - (Fun TxId Bool) - (SharedTxState PeerAddr TxId (Tx TxId)) - deriving Show + requestedToReply = fromIntegral (length txidsAndSizes) + peerState0 = emptyPeerTxLocalState { peerRequestedTxIds = requestedToReply } + peerInFlight0 = emptyPeerTxInFlight -instance Arbitrary ArbSharedTxState where - arbitrary = do - Small maxTxIdsInflight <- arbitrary - (mempoolHasTx, _, sharedTxState, _) <- genSharedTxState maxTxIdsInflight - return $ ArbSharedTxState mempoolHasTx sharedTxState + (peerState', peerInFlight', sharedState') = + handleReceivedTxIds mempoolHasTx now policy + requestedToReply txidsAndSizes + peerState0 peerInFlight0 sharedState0 - shrink (ArbSharedTxState mempoolHasTx st) = - [ ArbSharedTxState mempoolHasTx st' - | st' <- shrinkSharedTxState (apply mempoolHasTx) st - ] + keyOf txid = unTxKey (lookupKeyOrFail txid sharedState') + expectedAdvertisedKeys = + IntSet.fromList [ keyOf txid | (txid, _) <- newGroup ] --- | 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 + expectedAvailableTxIds = + IntMap.fromList [ (keyOf txid, sz) | (txid, sz) <- newGroup ] + expectedUnacked = + [ lookupKeyOrFail txid sharedState' | (txid, _) <- txidsAndSizes ] -prop_SharedTxState_generator - :: ArbSharedTxState - -> Property -prop_SharedTxState_generator (ArbSharedTxState _ st) = sharedTxStateInvariant StrongInvariant st + retainUntil = addTime (bufferedTxsMinLifetime policy) now + checkNew (txid, _) = + let k = keyOf txid in + counterexample ("new tx " ++ show txid) $ conjoin + [ counterexample "missing TxClaimable entry" + (case IntMap.lookup k (sharedTxTable sharedState') of + Just txEntry -> conjoin + [ txLease txEntry === TxClaimable now + , txAttempt txEntry === 0 + , property (not (txInSubmission txEntry)) + ] + Nothing -> property False) + , counterexample "expected to be in retained" $ + property (not (retainedMember k (sharedRetainedTxs sharedState'))) + ] -prop_SharedTxState_shrinker - :: Fixed ArbSharedTxState - -> Property -prop_SharedTxState_shrinker = - property - . foldMap (\(ArbSharedTxState _ st) -> Every $ sharedTxStateInvariant StrongInvariant st) - . shrink - . getFixed + checkRetained (txid, _) = + let k = keyOf txid in + counterexample ("retained tx " ++ show txid) $ conjoin + [ counterexample "leaked into sharedTxTable" + (property (IntMap.notMember k (sharedTxTable sharedState'))) + , counterexample "missing from retained" + (property (retainedMember k (sharedRetainedTxs sharedState'))) + , counterexample "leaked into pifAdvertised" + (property (IntSet.notMember k (pifAdvertised peerInFlight'))) + ] + checkMempool (txid, _) = + let k = keyOf txid in + counterexample ("mempool tx " ++ show txid) $ conjoin + [ counterexample "leaked into sharedTxTable" + (property (IntMap.notMember k (sharedTxTable sharedState'))) + , counterexample "missing or wrong retainUntil" + (retainedLookup k (sharedRetainedTxs sharedState') === Just retainUntil) + , counterexample "leaked into pifAdvertised" + (property (IntSet.notMember k (pifAdvertised peerInFlight'))) + ] + in + classify (not (null newGroup)) "txids include new" $ + classify (not (null retainedGroup)) "txids include retained" $ + classify (not (null mempoolGroup)) "txids include mempool" $ + conjoin + [ counterexample "unacknowledged queue mismatch" + (toList (peerUnacknowledgedTxIds peerState') === expectedUnacked) + , counterexample "peerAvailableTxIds mismatch" + (peerAvailableTxIds peerState' === expectedAvailableTxIds) + , counterexample "pifAdvertised mismatch" + (pifAdvertised peerInFlight' === expectedAdvertisedKeys) + , counterexample "peerRequestedTxIds was not consumed" + (peerRequestedTxIds peerState' === 0) + , conjoin (fmap checkNew newGroup) + , conjoin (fmap checkRetained retainedGroup) + , conjoin (fmap checkMempool mempoolGroup) + , combinedStateInvariant policy WeakInvariant + (Map.singleton peerAddr (peerState', peerInFlight')) sharedState' + ] + where + peerAddr = 1 :: PeerAddr + +-- | When a peer advertises a txid whose entry already exists, the entry +-- itself is unchanged: the per-peer 'PeerTxInFlight' simply records the +-- new advertisement. The new model has no 'txAdvertiserCount' to bump. +unit_handleReceivedTxIds_advertisesExistingEntry :: (String -> IO ()) -> Assertion +unit_handleReceivedTxIds_advertisesExistingEntry step = do + step "Set up a sharedTxTable entry leased to peer 0" + let txid :: TxId + txid = 7 + existing = mkActiveSharedState [0] 0 [] [(txid, 256)] + peerAddr2 :: PeerAddr + peerAddr2 = 1 + entryBefore = lookupEntryOrFail (lookupKeyOrFail txid existing) existing + + step "Peer 1 advertises the same txid" + let (peerState', peerInFlight', sharedState') = + handleReceivedTxIds (const False) now defaultTxDecisionPolicy + 1 [(txid, 256)] + emptyPeerTxLocalState { peerRequestedTxIds = 1 } + emptyPeerTxInFlight + existing + + step "Entry in sharedTxTable is unchanged" + let entryAfter = lookupEntryOrFail (lookupKeyOrFail txid sharedState') sharedState' + entryAfter @?= entryBefore + + step "Peer 1 now tracks the txid as advertised + available" + let k = unTxKey (lookupKeyOrFail txid sharedState') + pifAdvertised peerInFlight' @?= IntSet.singleton k + IntMap.keys (peerAvailableTxIds peerState') @?= [k] + toList (peerUnacknowledgedTxIds peerState') @?= [TxKey k] + -- peerAddr2 is referenced to keep the variable in scope for clarity. + _ <- pure peerAddr2 + pure () -- --- `receivedTxIdsImpl` properties +-- handleReceivedTxs -- +-- | Verifies that 'handleReceivedTxs' buffers requested bodies and +-- releases omitted ones, decrementing 'txAttempt' for each. The +-- pre-state is built by manually claiming each requested key. +prop_handleReceivedTxs + :: ArbTxDecisionPolicy + -> NonEmptyList (TxId, Positive Int, Bool) + -> Property +prop_handleReceivedTxs (ArbTxDecisionPolicy policy) + (NonEmpty rawInput) = + let + normalised :: [(TxId, SizeInBytes, Bool)] + normalised = + nubBy ((==) `on` (\(t,_,_) -> t)) + [ (abs txid + 1, mkSize sz, inReply) + | (txid, sz, inReply) <- rawInput + ] -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 + txidsAndSizes :: [(TxId, SizeInBytes)] + txidsAndSizes = [ (txid, sz) | (txid, sz, _) <- normalised ] + + -- 1) Receive the txids on peer 1 to set up advertised + available. + sharedState0 = emptySharedTxState + requestedToReply = fromIntegral (length txidsAndSizes) + peerState0 = emptyPeerTxLocalState { peerRequestedTxIds = requestedToReply } + (peerState1, peerInFlight1, sharedState1) = + handleReceivedTxIds (const False) now policy + requestedToReply txidsAndSizes + peerState0 emptyPeerTxInFlight sharedState0 + + -- 2) Manually claim each key (simulate pickRequestTxs). + keys = [ lookupKeyOrFail txid sharedState1 | (txid, _) <- txidsAndSizes ] + leaseUntil = addTime (interTxSpace policy) now + + sharedState2 = sharedState1 { + sharedTxTable = + foldl' (\tbl k -> IntMap.adjust (claimEntry k) (unTxKey k) tbl) + (sharedTxTable sharedState1) keys, + sharedGeneration = sharedGeneration sharedState1 + 1 + } + claimEntry _ entry = + entry { + txLease = TxLeased peerAddr leaseUntil, + txAttempt = txAttempt entry + 1 + } -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 + requestedKeySet = IntSet.fromList (fmap unTxKey keys) + batch = mkRequestedTxBatch keys (sum (fmap snd txidsAndSizes)) + peerState2 = peerState1 { + peerRequestedTxs = requestedKeySet, + peerRequestedTxBatches = StrictSeq.singleton batch, + peerRequestedTxsSize = requestedTxBatchSize batch + } + peerInFlight2 = peerInFlight1 { + pifLeased = IntSet.union (pifLeased peerInFlight1) requestedKeySet, + pifAttempting = IntSet.union (pifAttempting peerInFlight1) requestedKeySet + } + + -- 3) Run handleReceivedTxs with only the in-reply subset. + txReply :: [(TxId, Tx TxId)] + txReply = [ (txid, mkTx txid sz) + | (txid, sz, inReply) <- normalised + , inReply + ] + expectedBuffered = IntSet.fromList + [ unTxKey (lookupKeyOrFail txid sharedState1) + | (txid, _, inReply) <- normalised, inReply ] - ++ - [ ArbReceivedTxIds - mempoolHasTxFun' txs peeraddr ps - (fixupSharedTxState (apply mempoolHasTxFun') st) - | mempoolHasTxFun' <- shrink mempoolHasTxFun + expectedOmitted = requestedKeySet `IntSet.difference` expectedBuffered + + (omittedCount, lateCount, peerState3, peerInFlight3, sharedState3) = + handleReceivedTxs (const False) now policy peerAddr txReply + peerState2 peerInFlight2 sharedState2 + in + classify (not (IntSet.null expectedBuffered)) "buffered subset" $ + classify (not (IntSet.null expectedOmitted)) "omitted subset" $ + conjoin + [ counterexample "lateCount should be zero (no retained / mempool branch hit)" + (lateCount === 0) + , counterexample "omittedCount mismatch" + (omittedCount === IntSet.size expectedOmitted) + , counterexample "buffered keys mismatch" + (IntMap.keysSet (peerDownloadedTxs peerState3) === expectedBuffered) + , counterexample "peerRequestedTxs not drained" + (peerRequestedTxs peerState3 === IntSet.empty) + , counterexample "request batch was not dequeued" + (peerRequestedTxBatches peerState3 === StrictSeq.empty) + , counterexample "pifLeased should retain only buffered keys" + (pifLeased peerInFlight3 === expectedBuffered) + , counterexample "pifAttempting should retain only buffered keys" + (pifAttempting peerInFlight3 === expectedBuffered) + , conjoin + [ counterexample + ("omitted entry " ++ show k ++ " should sit TxClaimable") $ + case IntMap.lookup k (sharedTxTable sharedState3) of + Just entry -> conjoin + [ case txLease entry of + TxClaimable _ -> property True + other -> counterexample (show other) (property False) + , counterexample "txAttempt not decremented" + (txAttempt entry === 0) + ] + Nothing -> counterexample "entry vanished" (property False) + | k <- IntSet.toList expectedOmitted + ] + , combinedStateInvariant policy WeakInvariant + (Map.singleton peerAddr (peerState3, peerInFlight3)) sharedState3 ] + where + peerAddr = 1 :: PeerAddr +-- +-- handleSubmittedTxs +-- -prop_receivedTxIds_generator - :: ArbReceivedTxIds +-- | Accepted txs move into 'sharedRetainedTxs'; rejected txs stay in +-- the active table with 'TxClaimable' lease and cleared +-- 'txInSubmission'; the peer's 'pifSubmitting' is fully cleared. +prop_handleSubmittedTxs_retainsAcceptedAndDropsRejected + :: ArbTxDecisionPolicy + -> NonEmptyList (TxId, Positive Int, Bool) -> Property -prop_receivedTxIds_generator (ArbReceivedTxIds _ someTxsToAck _peeraddr _ps st) = - label ("numToAck " ++ labelInt 100 10 (length someTxsToAck)) - . counterexample (show st) - $ sharedTxStateInvariant StrongInvariant st +prop_handleSubmittedTxs_retainsAcceptedAndDropsRejected + (ArbTxDecisionPolicy policy) + (NonEmpty rawInput) = + let + normalised :: [(TxId, SizeInBytes, Bool)] + normalised = + nubBy ((==) `on` (\(t,_,_) -> t)) + [ (abs txid + 1, mkSize sz, accept) + | (txid, sz, accept) <- rawInput + ] + txidsAndSizes = [ (txid, sz) | (txid, sz, _) <- normalised ] + + -- Pre-state: every key leased to peerAddr with txInSubmission set + -- and the key already counted in 'pifSubmitting'. + sharedState0 = mkActiveSharedState [peerAddr] peerAddr [] txidsAndSizes + keys = [ lookupKeyOrFail txid sharedState0 | (txid, _) <- txidsAndSizes ] + keySet = IntSet.fromList (fmap unTxKey keys) + + flipToSubmitting entry = + entry { txAttempt = 0, txInSubmission = True } + sharedState1 = sharedState0 { + sharedTxTable = + IntSet.foldl' (flip (IntMap.adjust flipToSubmitting)) + (sharedTxTable sharedState0) + keySet + } --- | This property verifies that `acknowledgeTxIds` acknowledges a prefix of --- unacknowledged txs, and that the `numTxIdsToAck` as well as `RefCoundDiff` --- are correct. --- --- It doesn't validate the returned `PeerTxState` holds it's properties as this --- needs to be done in the context of updated `SharedTxState`. This is verified --- by `prop_receivedTxIdsImpl`, `prop_collectTxsImpl` and --- `prop_makeDecisions_acknowledged`. --- -prop_acknowledgeTxIds :: ArbDecisionContextWithReceivedTxIds - -> Property -prop_acknowledgeTxIds (ArbDecisionContextWithReceivedTxIds policy st ps _ _ _) = - case TXS.acknowledgeTxIds policy st ps of - (numTxIdsToAck, txIdsToRequest, TXS.TxsToMempool txIdsTxs, TXS.RefCountDiff { TXS.txIdsToAck }, ps') | txIdsToRequest > 0 -> - counterexample "number of tx ids to ack must agree with RefCountDiff" - ( fromIntegral numTxIdsToAck - === - getSum (foldMap Sum txIdsToAck) - ) - - .&&. counterexample "acknowledged txs must form a prefix" - (let unacked = toList (unacknowledgedTxIds ps) - unacked' = toList (unacknowledgedTxIds ps') - in case unacked `stripSuffix` unacked' of - Nothing -> counterexample "acknowledged txs are not a prefix" False - Just txIdsToAck' -> - txIdsToAck - === - Map.fromListWith (+) ((,1) <$> txIdsToAck')) - - .&&. counterexample "acknowledged txs" - (let acked, txsToMempool :: Set TxId - acked = Set.fromList $ take (fromIntegral numTxIdsToAck) (toList $ unacknowledgedTxIds ps) - txsToMempool = Set.fromList $ map fst txIdsTxs - in counterexample ("numTxIdsToAck = " ++ show numTxIdsToAck) - (Set.isSubsetOf txsToMempool acked)) - .&&. counterexample "to mempool" - let dlTxs, txsToMempool, unacked' :: Set TxId - dlTxs = Map.keysSet $ downloadedTxs ps - txsToMempool = Set.fromList $ map fst txIdsTxs - unacked' = Set.fromList $ toList (unacknowledgedTxIds ps') - in counterexample ("txsToMempool " ++ show txsToMempool ++ - " not a subset of dlTxs " ++ show dlTxs) - (Set.isSubsetOf txsToMempool dlTxs) - .&&. counterexample ("txsToMempool" ++ show txsToMempool ++ - " not disjoint following decision from unacked " ++ show unacked') - (Set.null (Set.intersection unacked' txsToMempool)) - - _otherwise -> property True - where - stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] - stripSuffix as suffix = - reverse <$> reverse suffix `stripPrefix` reverse as + peerInFlight0 = emptyPeerTxInFlight { + pifLeased = keySet, + pifSubmitting = keySet, + pifAdvertised = keySet + } + peerState0 = emptyPeerTxLocalState { + peerUnacknowledgedTxIds = StrictSeq.fromList keys, + peerAvailableTxIds = + IntMap.fromList [(unTxKey (lookupKeyOrFail txid sharedState1), sz) + | (txid, sz) <- txidsAndSizes], + peerDownloadedTxs = + IntMap.fromList [(unTxKey (lookupKeyOrFail txid sharedState1), + mkTx txid sz) + | (txid, sz) <- txidsAndSizes] + } + accepted = [ lookupKeyOrFail txid sharedState1 + | (txid, _, True) <- normalised ] + rejected = [ lookupKeyOrFail txid sharedState1 + | (txid, _, False) <- normalised ] --- | 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 StrongInvariant 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 - ) + acceptedKeys = IntSet.fromList (fmap unTxKey accepted) + rejectedKeys = IntSet.fromList (fmap unTxKey rejected) - .&&. -- `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 + (peerState', peerInFlight', sharedState') = + handleSubmittedTxs now policy peerAddr accepted rejected + peerState0 peerInFlight0 sharedState1 - txidSeq = StrictSeq.fromList (getTxId <$> txs) - txidMap = Map.fromList [ (getTxId tx, getTxSize tx) | tx <- txs ] + retainUntil = addTime (bufferedTxsMinLifetime policy) now + checkAccepted k = + counterexample ("accepted " ++ show k) $ conjoin + [ counterexample "still in sharedTxTable" + (property (IntMap.notMember k (sharedTxTable sharedState'))) + , counterexample "missing or wrong retainUntil" + (retainedLookup k (sharedRetainedTxs sharedState') === Just retainUntil) + ] + checkRejected k = + counterexample ("rejected " ++ show k) $ + case IntMap.lookup k (sharedTxTable sharedState') of + Just entry -> conjoin + [ case txLease entry of + TxClaimable _ -> property True + other -> counterexample (show other) (property False) + , counterexample "txInSubmission still set" + (property (not (txInSubmission entry))) + ] + Nothing -> counterexample "entry vanished" (property False) + in + classify (not (null accepted)) "has accepted" $ + classify (not (null rejected)) "has rejected" $ + conjoin + [ counterexample "pifSubmitting still has keys" + (pifSubmitting peerInFlight' === IntSet.empty) + , counterexample "pifLeased not cleared for submitted keys" + (pifLeased peerInFlight' === IntSet.empty) + , counterexample "pifAdvertised not cleared for submitted keys" + (pifAdvertised peerInFlight' === IntSet.empty) + , counterexample "peerDownloadedTxs not cleared for submitted keys" + (IntMap.keysSet (peerDownloadedTxs peerState') === IntSet.empty) + , conjoin (fmap checkAccepted (IntSet.toList acceptedKeys)) + , conjoin (fmap checkRejected (IntSet.toList rejectedKeys)) + , combinedStateInvariant policy WeakInvariant + (Map.singleton peerAddr (peerState', peerInFlight')) sharedState' + ] + where + peerAddr = 1 :: PeerAddr --- | Verify that `SharedTxState` returned by `receivedTxIdsImpl` if evaluated --- to WHNF it doesn't contain any thunks. -- -prop_receivedTxIdsImpl_nothunks - :: ArbReceivedTxIds +-- nextPeerAction +-- + +-- | An idle peer whose shared state has no work returns +-- 'PeerDoNothing' carrying the current 'sharedGeneration'. +prop_nextPeerAction_returnsSharedGeneration + :: ArbTxDecisionPolicy + -> Word64 -> 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 +prop_nextPeerAction_returnsSharedGeneration (ArbTxDecisionPolicy policy0) gen = + let + -- A zero unack window forces 'pickRequestTxIdsAction' to return + -- 'Nothing', so the scheduler falls through to 'PeerDoNothing'. + policy = policy0 { maxUnacknowledgedTxIds = 0 + , maxNumTxIdsToRequest = 0 } + sharedState :: SharedTxState PeerAddr TxId + sharedState = emptySharedTxState { sharedGeneration = gen } + (action, _, _, _) = + nextPeerAction now policy peerAddr emptyPeerTxLocalState + emptyPeerTxInFlight sharedState + in + case action of + PeerDoNothing g _ -> g === gen + _ -> counterexample (show action) + (property False) where - txidSeq = StrictSeq.fromList (getTxId <$> txs) - txidMap = Map.fromList [ (getTxId tx, getTxSize tx) | tx <- txs ] + peerAddr = 1 :: PeerAddr + +-- | When advertised candidates exceed the per-peer size budget, +-- 'pickRequestTxs' picks a contiguous prefix of the unacked queue +-- whose total size fits the budget (with the soft single-tx allowance +-- documented in 'pickRequestTxsAction'). +prop_nextPeerAction_picksTxsRespectingBudget + :: ArbTxDecisionPolicy + -> NonEmptyList (TxId, Positive Int) + -> Property +prop_nextPeerAction_picksTxsRespectingBudget (ArbTxDecisionPolicy policy0) + (NonEmpty rawInput) = + let + -- Tighten the budget so the test exercises the truncation path. + policy = policy0 { txsSizeInflightPerPeer = SizeInBytes 4096 + , maxOutstandingTxBatchesPerPeer = 4 } + + txidsAndSizes :: [(TxId, SizeInBytes)] + txidsAndSizes = + nubBy ((==) `on` fst) + [ (abs txid + 1, SizeInBytes (1 + (fromIntegral n `mod` 2048))) + | (txid, Positive n) <- rawInput + ] + requestedToReply = fromIntegral (length txidsAndSizes) + peerState0 = emptyPeerTxLocalState { peerRequestedTxIds = requestedToReply } + (peerState1, peerInFlight1, sharedState1) = + handleReceivedTxIds (const False) now policy + requestedToReply txidsAndSizes + peerState0 emptyPeerTxInFlight emptySharedTxState + + (action, _peerState', peerInFlight', sharedState') = + nextPeerAction now policy peerAddr peerState1 peerInFlight1 sharedState1 + + keyOrder = [ unTxKey (lookupKeyOrFail txid sharedState1) + | (txid, _) <- txidsAndSizes ] + sizeOf k = + maybe 0 getSizeInBytes + (IntMap.lookup k (peerAvailableTxIds peerState1)) + + budget = getSizeInBytes (txsSizeInflightPerPeer policy) + isPrefix _ [] = True + isPrefix [] _ = False + isPrefix (x:xs) (y:ys) = x == y && isPrefix xs ys + in + case action of + PeerRequestTxs picked -> + let pickedKeys = fmap unTxKey picked + pickedSize = sum (fmap sizeOf pickedKeys) + -- The first picked tx may exceed the budget on its own + -- (soft budget); subsequent picks must keep the running + -- total at or below the budget. + tailSize = pickedSize - maybe 0 sizeOf (listToMaybe pickedKeys) + in conjoin + [ counterexample "picked is not a prefix of the unacked queue" + (property (pickedKeys `isPrefix` keyOrder)) + , counterexample + ("tail of picked exceeds budget: " ++ show pickedSize) + (property (tailSize <= budget)) + , counterexample "picked keys not added to pifLeased" + (property (IntSet.fromList pickedKeys + `IntSet.isSubsetOf` pifLeased peerInFlight')) + , counterexample "claimed entries should be TxLeased to peerAddr" + (conjoin + [ case IntMap.lookup k (sharedTxTable sharedState') of + Just entry -> case txLease entry of + TxLeased owner _ -> owner === peerAddr + other -> counterexample (show other) + (property False) + Nothing -> counterexample "missing entry" + (property False) + | k <- pickedKeys + ]) + ] + _ -> + -- If the candidates were empty (e.g. all sizes happened to be + -- the same and dedupe stripped them) the scheduler may pick + -- something else; just check the action type isn't junk. + counterexample (show action) (property True) + where + peerAddr = 1 :: PeerAddr + +-- | When the peer has buffered a downloaded body of which it owns the +-- lease, 'nextPeerAction' submits before requesting more bodies or +-- acking. +prop_nextPeerAction_ownerSubmitsBuffered + :: ArbTxDecisionPolicy + -> Positive Int + -> Property +prop_nextPeerAction_ownerSubmitsBuffered (ArbTxDecisionPolicy policy) + (Positive sizeBytes) = + let + txid :: TxId + txid = 1 + sz = SizeInBytes (1 + fromIntegral (sizeBytes `mod` 1024)) + + -- 1) Peer receives the txid (creates the entry). + (peerState1, peerInFlight1, sharedState1) = + handleReceivedTxIds (const False) now policy 1 [(txid, sz)] + (emptyPeerTxLocalState { peerRequestedTxIds = 1 }) + emptyPeerTxInFlight emptySharedTxState + + txKey = lookupKeyOrFail txid sharedState1 + keyInt = unTxKey txKey + leaseUntil = addTime (interTxSpace policy) now + + -- 2) Manually claim and buffer the body (simulating + -- pickRequestTxsAction + handleReceivedTxs's buffered branch). + sharedState2 = sharedState1 { + sharedTxTable = + IntMap.adjust + (\entry -> entry { + txLease = TxLeased peerAddr leaseUntil, + txAttempt = txAttempt entry + 1 + }) + keyInt (sharedTxTable sharedState1) + } + peerState2 = peerState1 { + peerDownloadedTxs = IntMap.singleton keyInt (mkTx txid sz) + } + peerInFlight2 = peerInFlight1 { + pifLeased = IntSet.insert keyInt (pifLeased peerInFlight1), + pifAttempting = IntSet.insert keyInt (pifAttempting peerInFlight1) + } + + (action, _, _, _) = + nextPeerAction now policy peerAddr peerState2 peerInFlight2 sharedState2 + in + case action of + PeerSubmitTxs ks -> ks === [txKey] + _ -> counterexample (show action) (property False) + where + peerAddr = 1 :: PeerAddr + +-- | After 'sweepSharedState' fires, retained entries past their +-- deadline are gone. This is a lightweight sanity check on the +-- retention sweep. +prop_nextPeerAction_prunesExpiredRetained + :: ArbTxDecisionPolicy + -> Positive Int + -> Property +prop_nextPeerAction_prunesExpiredRetained (ArbTxDecisionPolicy policy) + (Positive nTxids) = + let + n = 1 + (nTxids `mod` 5) + txidsAndSizes = + [ (t, SizeInBytes 64) | t <- [1 .. n] ] + + sharedState0 = seedRetainedTxids policy txidsAndSizes emptySharedTxState + expired = addTime (bufferedTxsMinLifetime policy + 1) now + sharedState' = sweepSharedState expired IntSet.empty sharedState0 + in + counterexample + ("retained set after sweep: " ++ show (retainedSize (sharedRetainedTxs sharedState'))) + (retainedSize (sharedRetainedTxs sharedState') === 0) + +-- | Before the retention deadline expires, retained entries survive a +-- sweep call. +prop_nextPeerAction_keepsRetained + :: ArbTxDecisionPolicy + -> Positive Int + -> Property +prop_nextPeerAction_keepsRetained (ArbTxDecisionPolicy policy) + (Positive nTxids) = + let + n = 1 + (nTxids `mod` 5) + txidsAndSizes = + [ (t, SizeInBytes 64) | t <- [1 .. n] ] + + sharedState0 = seedRetainedTxids policy txidsAndSizes emptySharedTxState + sharedState' = sweepSharedState now IntSet.empty sharedState0 + in + retainedSize (sharedRetainedTxs sharedState') === n -- --- `collectTxs` properties +-- nextPeerActionPipelined -- +-- | In pipelined mode 'pickRequestTxIdsAction' must return @Nothing@ +-- when either the ack count or the request count is zero (the wire +-- format would otherwise produce an ack-only or request-only +-- pipelined message, which is not allowed). +-- | When the peer has at least one ackable txid AND room to request +-- more, 'nextPeerActionPipelined' emits a 'PeerRequestTxIds' with both +-- counts non-zero. +prop_nextPeerActionPipelined_requestsTxIds + :: ArbTxDecisionPolicy + -> Property +prop_nextPeerActionPipelined_requestsTxIds (ArbTxDecisionPolicy policy0) = + let + policy = policy0 { maxUnacknowledgedTxIds = 8 + , maxNumTxIdsToRequest = 4 } + -- Pre-state: two ackable retained txids (so the keep-one-unacked + -- clamp on pipelined requests still leaves a non-zero ack) and an + -- outstanding pipelined req (peerRequestedTxIds = 1) so the wire + -- format treats the new request as pipelined. + txids = [(1, 64), (2, 64)] :: [(TxId, SizeInBytes)] + sharedState0 = seedRetainedTxids policy txids emptySharedTxState + keys = [ TxKey (unTxKey (lookupKeyOrFail txid sharedState0)) + | (txid, _) <- txids ] + peerState0 = emptyPeerTxLocalState { + peerUnacknowledgedTxIds = StrictSeq.fromList keys, + peerRequestedTxIds = 1 + } + (action, _, _, _) = + nextPeerActionPipelined now policy peerAddr peerState0 + emptyPeerTxInFlight sharedState0 + in + counterexample ("got: " ++ show action) $ + case action of + PeerRequestTxIds TxIdsPipelinedReq ack req -> + conjoin [ counterexample "ack should be non-zero" + (property (ack /= 0)) + , counterexample "req should be non-zero" + (property (req /= 0)) + ] + _ -> property False + where + peerAddr = 1 :: PeerAddr + +-- | The 'PeerDoNothing' wake-delay is the smallest of: earliest +-- claim-ready time among advertised txs, earliest stuck-bump time +-- among buffered txs, and earliest retention-expiry time. This test +-- focuses on the retention case: an idle peer with nothing else but a +-- single retained tx must wake at that retention deadline. +prop_nextPeerAction_earliestWakeDelay + :: ArbTxDecisionPolicy + -> Positive Int + -> Property +prop_nextPeerAction_earliestWakeDelay (ArbTxDecisionPolicy policy0) + (Positive offsetSec) = + let + -- Force the doNothing branch. + policy = policy0 { maxUnacknowledgedTxIds = 0 + , maxNumTxIdsToRequest = 0 + , bufferedTxsMinLifetime = realToFrac offsetSec } + txid :: TxId + txid = 1 + sharedState0 = seedRetainedTxids policy [(txid, 64)] emptySharedTxState + expectedWake = bufferedTxsMinLifetime policy + (action, _, _, _) = + nextPeerAction now policy peerAddr emptyPeerTxLocalState + emptyPeerTxInFlight sharedState0 + in + counterexample ("got: " ++ show action) $ + case action of + PeerDoNothing _ (Just delay) -> delay === expectedWake + _ -> property False + where + peerAddr = 1 :: PeerAddr + +-- | While a body reply is still in flight, the protocol requires the +-- peer to keep at least one txid unacked. Verifies that +-- 'pickRequestTxIdsAction' clamps the ack count accordingly when the +-- only ackable txid is the one that should stay unacked. +unit_nextPeerActionPipelined_keepsOneUnackedWithOutstandingBodyReply + :: (String -> IO ()) -> Assertion +unit_nextPeerActionPipelined_keepsOneUnackedWithOutstandingBodyReply step = do + step "Set up a peer with one retained (ackable) txid and an outstanding body batch" + let txid :: TxId + txid = 1 + policy = defaultTxDecisionPolicy + sharedState0 = seedRetainedTxids policy [(txid, 64)] emptySharedTxState + keyInt = unTxKey (lookupKeyOrFail txid sharedState0) + outstandingBatch = mkRequestedTxBatch [TxKey keyInt] 64 + peerState0 = emptyPeerTxLocalState { + peerUnacknowledgedTxIds = StrictSeq.singleton (TxKey keyInt), + peerRequestedTxs = IntSet.singleton keyInt, + peerRequestedTxBatches = StrictSeq.singleton outstandingBatch, + peerRequestedTxsSize = 64 + } + + step "Run nextPeerActionPipelined" + let (action, _, _, _) = + nextPeerActionPipelined now policy peerAddr peerState0 + emptyPeerTxInFlight sharedState0 + + step "Pipelined response must keep the txid unacked while the body batch is outstanding" + case action of + PeerRequestTxIds TxIdsPipelinedReq ack _ -> + ack @?= 0 + PeerDoNothing {} -> + -- Acceptable: not enough room to request anything. + pure () + other -> + assertFailure ("unexpected action: " ++ show other) + where + peerAddr = 1 :: PeerAddr -data ArbCollectTxs = - ArbCollectTxs (Fun TxId Bool) -- ^ mempoolHasTx - (Map TxId SizeInBytes) -- ^ requested txid's - (Map TxId (Tx TxId)) -- ^ received txs - PeerAddr -- ^ peeraddr - (PeerTxState TxId (Tx TxId)) - (SharedTxState PeerAddr TxId (Tx TxId)) - -- ^ 'InboundState' - deriving Show - - -instance Arbitrary ArbCollectTxs where - arbitrary = do - Small maxTxIdsInflight <- arbitrary - ( mempoolHasTxFun - , (peeraddr, ps@PeerTxState { availableTxIds, - requestedTxIdsInflight, - requestedTxsInflight, - requestedTxsInflightSize }) - , st - , _ - ) - <- genSharedTxState maxTxIdsInflight - requestedTxIds <- take (fromIntegral requestedTxIdsInflight) - <$> sublistOf (toList requestedTxsInflight) - - -- Limit the requested `txid`s to satisfy `requestedTxsInflightSize`. - let requestedTxIds' = fmap fst - $ takeWhile (\(_,s) -> s <= requestedTxsInflightSize) - $ zip requestedTxIds - (scanl1 (<>) [availableTxIds Map.! txid | txid <- requestedTxIds ]) - - receivedTx <- sublistOf requestedTxIds' - >>= traverse (\txid -> do - -- real size, which might be different from - -- the advertised size - size <- frequency [ (9, pure (availableTxIds Map.! txid)) - , (1, chooseEnum (0, maxTxSize)) - ] - - valid <- frequency [(4, pure True), (1, pure False)] - pure $ Tx { getTxId = txid, - getTxSize = size, - -- `availableTxIds` contains advertised sizes - getTxAdvSize = availableTxIds Map.! txid, - getTxValid = valid }) - - pure $ assert (foldMap getTxAdvSize receivedTx <= requestedTxsInflightSize) - $ ArbCollectTxs mempoolHasTxFun - (Map.fromList [ (txid, advSize) - | txid <- requestedTxIds' - , let advSize = availableTxIds Map.! txid - ]) - (Map.fromList [ (getTxId tx, tx) | tx <- receivedTx ]) - peeraddr - ps - st - - shrink (ArbCollectTxs mempoolHasTx requestedTxs receivedTxs peeraddr ps st) = - [ ArbCollectTxs mempoolHasTx - (Map.restrictKeys requestedTxs requestedTxs') - (receivedTxs `Map.restrictKeys` requestedTxs') - peeraddr ps st - | requestedTxs' <- Set.fromList <$> shrinkList (\_ -> []) (Map.keys requestedTxs) - ] - ++ - [ ArbCollectTxs mempoolHasTx - requestedTxs - (receivedTxs `Map.restrictKeys` receivedTxIds) - peeraddr ps st - | receivedTxIds <- Set.fromList <$> shrinkList (\_ -> []) (Map.keys receivedTxs) - ] - ++ - [ ArbCollectTxs mempoolHasTx - (requestedTxs - `Map.restrictKeys` unacked - `Map.restrictKeys` 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_nextPeerActionPipelined_requiresAckAndReq + :: ArbTxDecisionPolicy + -> Property +prop_nextPeerActionPipelined_requiresAckAndReq (ArbTxDecisionPolicy policy0) = + let + -- Cap to small windows so the property is easy to reason about. + policy = policy0 { maxUnacknowledgedTxIds = 4 + , maxNumTxIdsToRequest = 4 } + txid :: TxId + txid = 1 + -- Pre-state: peer has one unacked txid that is *not* ackable + -- (entry sits TxClaimable with no peer attempt and the peer is + -- still tracking it as advertised), AND there is already a + -- pipelined request outstanding so 'keepOneUnackedForPipelinedRequest' + -- forces num_acked = 0. + sharedState0 = mkActiveSharedState [peerAddr] peerAddr [] [(txid, 64)] + keyInt = unTxKey (lookupKeyOrFail txid sharedState0) + -- Strip the leaseholder so the entry is TxClaimable, attempt 0. + sharedState1 = sharedState0 { + sharedTxTable = + IntMap.adjust + (\entry -> entry { + txLease = TxClaimable now, + txAttempt = 0 + }) + keyInt (sharedTxTable sharedState0) + } + peerState0 = emptyPeerTxLocalState { + peerUnacknowledgedTxIds = StrictSeq.singleton (TxKey keyInt), + peerAvailableTxIds = IntMap.singleton keyInt 64, + peerRequestedTxIds = 1 -- pretend there's a pipelined req in flight + } + peerInFlight0 = emptyPeerTxInFlight { + pifAdvertised = IntSet.singleton keyInt + } + (action, _, _, _) = + nextPeerActionPipelined now policy peerAddr peerState0 + peerInFlight0 sharedState1 + in + counterexample ("got: " ++ show action) $ + case action of + PeerRequestTxIds {} -> property False + _ -> property True + where + peerAddr = 1 :: PeerAddr -prop_collectTxs_generator - :: ArbCollectTxs +-- | While a peer holds one outstanding body batch and there is room for +-- another, 'nextPeerActionPipelined' opens the second batch. +prop_nextPeerActionPipelined_secondBodyBatch + :: ArbTxDecisionPolicy -> 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 ("receivedTxs must be a subset of requestedTxIds " - ++ show (Map.keysSet receivedTxs Set.\\ requestedTxIdsSet)) - (Map.keysSet receivedTxs `Set.isSubsetOf` requestedTxIdsSet) - .&&. counterexample "peerTxState" - (Map.lookup peeraddr (peerTxStates st) === Just ps) - .&&. -- advertised sizes should agree with `getTxAdvSize of received txs. - property ( foldMap Every - $ Map.intersectionWith - (\advSize Tx {getTxId, getTxAdvSize} -> - counterexample (show getTxId) - $ advSize === getTxAdvSize) - requestedTxIds - receivedTxs - ) +prop_nextPeerActionPipelined_secondBodyBatch (ArbTxDecisionPolicy basePolicy) = + let + policy = basePolicy + { maxOutstandingTxBatchesPerPeer = max 2 (maxOutstandingTxBatchesPerPeer basePolicy) + , txsSizeInflightPerPeer = SizeInBytes 4096 + } + txSizeA, txSizeB :: SizeInBytes + txSizeA = SizeInBytes 100 + txSizeB = SizeInBytes 100 + keyA = TxKey 0 + keyB = TxKey 1 + kA = unTxKey keyA + kB = unTxKey keyB + leaseUntil = addTime (interTxSpace policy) now + sharedState = emptySharedTxState + { sharedTxTable = IntMap.fromList + [ (kA, TxEntry + { txLease = TxLeased peerAddr leaseUntil + , txAttempt = 1 + , txInSubmission = False + , currentMaxInflightMultiplicity = txInflightMultiplicity policy + }) + , (kB, TxEntry + { txLease = TxClaimable now + , txAttempt = 0 + , txInSubmission = False + , currentMaxInflightMultiplicity = txInflightMultiplicity policy + }) + ] + , sharedTxIdToKey = Map.fromList [(getRawTxId (1 :: TxId), keyA), (getRawTxId (2 :: TxId), keyB)] + , sharedKeyToTxId = IntMap.fromList [(kA, 1 :: TxId), (kB, 2 :: TxId)] + , sharedNextTxKey = 2 + } + peerState0 = emptyPeerTxLocalState + { peerUnacknowledgedTxIds = StrictSeq.fromList [keyA, keyB] + , peerAvailableTxIds = IntMap.fromList [(kA, txSizeA), (kB, txSizeB)] + , peerRequestedTxs = IntSet.singleton kA + , peerRequestedTxBatches = StrictSeq.singleton (mkRequestedTxBatch [keyA] txSizeA) + , peerRequestedTxsSize = txSizeA + } + peerInFlight0 = emptyPeerTxInFlight + { pifAdvertised = IntSet.fromList [kA, kB] + , pifLeased = IntSet.singleton kA + , pifAttempting = IntSet.singleton kA + } + + (action, _, peerInFlight', sharedState') = + nextPeerActionPipelined now policy peerAddr peerState0 + peerInFlight0 sharedState + in + counterexample ("got: " ++ show action) $ + case action of + PeerRequestTxs [picked] -> + conjoin + [ counterexample "expected to pick keyB" + (picked === keyB) + , counterexample "B not added to pifLeased" + (property (IntSet.member kB (pifLeased peerInFlight'))) + , counterexample "B not added to pifAttempting" + (property (IntSet.member kB (pifAttempting peerInFlight'))) + , counterexample "B not leased to peerAddr" + (case IntMap.lookup kB (sharedTxTable sharedState') of + Just entry -> case txLease entry of + TxLeased owner _ -> owner === peerAddr + _ -> property False + Nothing -> property False) + ] + _ -> property False where - requestedTxIdsSet = Map.keysSet requestedTxIds - requestedSize = fold (availableTxIds `Map.restrictKeys` requestedTxIdsSet) + peerAddr = 7 :: PeerAddr +-- | When the peer already holds 'maxOutstandingTxBatchesPerPeer' +-- outstanding body batches, 'nextPeerActionPipelined' refuses to open +-- another even with available candidates. +prop_nextPeerActionPipelined_noThirdBodyBatch + :: ArbTxDecisionPolicy + -> Property +prop_nextPeerActionPipelined_noThirdBodyBatch (ArbTxDecisionPolicy basePolicy) = + let + policy = basePolicy { maxOutstandingTxBatchesPerPeer = 2 } + txSize :: SizeInBytes + txSize = SizeInBytes 64 + keyA = TxKey 0 + keyB = TxKey 1 + keyC = TxKey 2 + kA = unTxKey keyA + kB = unTxKey keyB + kC = unTxKey keyC + leaseUntil = addTime (interTxSpace policy) now + inflightEntry = TxEntry + { txLease = TxLeased peerAddr leaseUntil + , txAttempt = 1 + , txInSubmission = False + , currentMaxInflightMultiplicity = txInflightMultiplicity policy + } + freshEntry = TxEntry + { txLease = TxClaimable now + , txAttempt = 0 + , txInSubmission = False + , currentMaxInflightMultiplicity = txInflightMultiplicity policy + } + sharedState = emptySharedTxState + { sharedTxTable = IntMap.fromList + [ (kA, inflightEntry) + , (kB, inflightEntry) + , (kC, freshEntry) + ] + , sharedTxIdToKey = Map.fromList + [ (getRawTxId (1 :: TxId), keyA) + , (getRawTxId (2 :: TxId), keyB) + , (getRawTxId (3 :: TxId), keyC) + ] + , sharedKeyToTxId = IntMap.fromList + [ (kA, 1 :: TxId), (kB, 2 :: TxId), (kC, 3 :: TxId) ] + , sharedNextTxKey = 3 + } + peerState0 = emptyPeerTxLocalState + { peerUnacknowledgedTxIds = StrictSeq.fromList [keyA, keyB, keyC] + , peerAvailableTxIds = IntMap.fromList + [(kA, txSize), (kB, txSize), (kC, txSize)] + , peerRequestedTxs = IntSet.fromList [kA, kB] + , peerRequestedTxBatches = StrictSeq.fromList + [ mkRequestedTxBatch [keyA] txSize + , mkRequestedTxBatch [keyB] txSize + ] + , peerRequestedTxsSize = txSize + txSize + } + peerInFlight0 = emptyPeerTxInFlight + { pifAdvertised = IntSet.fromList [kA, kB, kC] + , pifLeased = IntSet.fromList [kA, kB] + , pifAttempting = IntSet.fromList [kA, kB] + } -prop_collectTxs_shrinker - :: Fixed ArbCollectTxs - -- ^ disabled shrinking + (action, _, _, _) = + nextPeerActionPipelined now policy peerAddr peerState0 + peerInFlight0 sharedState + in + counterexample ("got: " ++ show action) $ + case action of + PeerRequestTxs {} -> property False + _ -> property True + where + peerAddr = 7 :: PeerAddr + +-- | A peer with two unacked txids — one whose entry is leased to +-- another peer (blocked) and one that's still claimable — must skip +-- the blocked one and fetch the claimable one. +unit_nextPeerAction_skipsBlockedAvailableTxs + :: (String -> IO ()) -> Assertion +unit_nextPeerAction_skipsBlockedAvailableTxs step = do + step "Set up two advertised txs: keyA leased to another peer with the cap full, keyB claimable" + let policy0 = defaultTxDecisionPolicy + policy = policy0 { txInflightMultiplicity = 1 } + peerAddr = 7 :: PeerAddr + otherPeer = 8 :: PeerAddr + keyA = TxKey 0 + keyB = TxKey 1 + kA = unTxKey keyA + kB = unTxKey keyB + sharedState = emptySharedTxState + { sharedTxTable = IntMap.fromList + [ (kA, TxEntry + { txLease = TxLeased otherPeer (addTime 10 now) + , txAttempt = 1 + , txInSubmission = False + , currentMaxInflightMultiplicity = txInflightMultiplicity policy + }) + , (kB, TxEntry + { txLease = TxClaimable now + , txAttempt = 0 + , txInSubmission = False + , currentMaxInflightMultiplicity = txInflightMultiplicity policy + }) + ] + , sharedTxIdToKey = Map.fromList + [(getRawTxId (1 :: TxId), keyA), (getRawTxId (2 :: TxId), keyB)] + , sharedKeyToTxId = IntMap.fromList [(kA, 1 :: TxId), (kB, 2 :: TxId)] + , sharedNextTxKey = 2 + } + peerState = emptyPeerTxLocalState + { peerUnacknowledgedTxIds = StrictSeq.fromList [keyA, keyB] + , peerAvailableTxIds = IntMap.fromList [(kA, 10), (kB, 11)] + } + peerInFlight = emptyPeerTxInFlight + { pifAdvertised = IntSet.fromList [kA, kB] + } + + step "Run nextPeerAction" + let (action, _, _, sharedState') = + nextPeerAction now policy peerAddr peerState peerInFlight sharedState + + step "The claimable tx is requested and leased; the blocked tx is skipped" + case action of + PeerRequestTxs picked -> + picked @?= [keyB] + other -> + assertFailure ("unexpected action: " ++ show other) + + case IntMap.lookup kB (sharedTxTable sharedState') of + Just entry -> case txLease entry of + TxLeased owner _ -> owner @?= peerAddr + TxClaimable _ -> assertFailure "keyB still TxClaimable" + Nothing -> assertFailure "keyB entry vanished" + +-- | When the peer's unacked queue mixes a retained-and-acked tx and a +-- buffered-but-blocked tx, only the safe prefix is acked; the blocked +-- tx remains unacked. +unit_nextPeerAction_acksSafePrefixBeforeBlockedBufferedTx + :: (String -> IO ()) -> Assertion +unit_nextPeerAction_acksSafePrefixBeforeBlockedBufferedTx step = do + step "Set up: tx 1 retained (ackable), tx 2 leased + buffered + already submitting via another peer" + let peerAddr = 7 :: PeerAddr + otherPeer = 8 :: PeerAddr + resolvedKey = TxKey 1 + blockedKey = TxKey 2 + kResolved = unTxKey resolvedKey + kBlocked = unTxKey blockedKey + blockedTx = mkTx 2 (mkSize (Positive 10)) + policy = defaultTxDecisionPolicy + blockedEntry = TxEntry + { txLease = TxLeased peerAddr (addTime 10 now) + , txAttempt = 1 + , txInSubmission = True + , currentMaxInflightMultiplicity = txInflightMultiplicity policy + } + sharedState = emptySharedTxState + { sharedTxTable = IntMap.singleton kBlocked blockedEntry + , sharedRetainedTxs = retainedSingleton kResolved (addTime 17 now) + , sharedTxIdToKey = Map.fromList + [(getRawTxId (1 :: TxId), resolvedKey), (getRawTxId (2 :: TxId), blockedKey)] + , sharedKeyToTxId = IntMap.fromList [(kResolved, 1 :: TxId), (kBlocked, 2 :: TxId)] + , sharedNextTxKey = 3 + } + peerState = emptyPeerTxLocalState + { peerUnacknowledgedTxIds = StrictSeq.fromList [resolvedKey, blockedKey] + , peerDownloadedTxs = IntMap.singleton kBlocked blockedTx + } + -- This peer holds the lease and is inside mempoolAddTxs; + -- another peer (otherPeer) is also "submitting" so submitting- + -- by-other is True from peerAddr's viewpoint. We model that by + -- otherPeer's pifSubmitting having the key. + peerInFlight = emptyPeerTxInFlight + { pifLeased = IntSet.singleton kBlocked + , pifSubmitting = IntSet.singleton kBlocked + } + + step "Run nextPeerAction (with the blocked tx already submitted by 'me')" + let (action, peerState', _, _) = + nextPeerAction now policy peerAddr peerState peerInFlight sharedState + + -- The pickSubmit walk finds the blocked tx still buffered + this + -- peer is the submitter (so 'txSubmittingByOther' is False), so + -- the test should fall through to a txid request that acks the + -- retained prefix only. + step "Only the retained prefix is acked; blocked tx remains unacked" + case action of + PeerRequestTxIds _ ack req -> do + ack @?= 1 + assertBool ("expected positive txIdsToReq, got " ++ show req) (req > 0) + toList (peerUnacknowledgedTxIds peerState') @?= [blockedKey] + PeerSubmitTxs ks -> + ks @?= [blockedKey] + other -> + assertFailure ("unexpected action: " ++ show other) + -- otherPeer is referenced only to express the multi-peer setup. + _ <- pure (otherPeer :: PeerAddr) + pure () + +-- | When peer A is at its inflight-size cap and a fresh txid arrives, +-- peer A cannot claim; once peer B advertises the same key, peer B can +-- claim and download. +unit_nextPeerAction_claimsFreshTxWhenFirstAdvertiserIsFull + :: (String -> IO ()) -> Assertion +unit_nextPeerAction_claimsFreshTxWhenFirstAdvertiserIsFull step = do + step "Receive a fresh txid from peer A while A is already at its inflight size limit" + let (peerAState1, peerAInFlight1, sharedState1) = + handleReceivedTxIds (const False) now defaultTxDecisionPolicy + requestedToReply [(txid, txSize)] + peerAState0 emptyPeerTxInFlight sharedState0 + txLease (lookupEntryOrFail key sharedState1) @?= TxClaimable now + + step "nextPeerAction for peer A: tx remains unclaimed because A is at the size cap" + let (peerAAction, _, _, _) = + nextPeerAction now defaultTxDecisionPolicy peerA + peerAState1 peerAInFlight1 sharedState1 + case peerAAction of + PeerDoNothing _ _ -> pure () + PeerRequestTxIds {} -> pure () + other -> assertFailure ("unexpected peer A action: " ++ show other) + + step "Peer B advertises the same txid" + let (peerBState1, peerBInFlight1, sharedState2) = + handleReceivedTxIds (const False) now defaultTxDecisionPolicy + requestedToReply [(txid, txSize)] + peerBState0 emptyPeerTxInFlight sharedState1 + + step "nextPeerAction for peer B: claims and requests the fresh tx" + let (peerBAction, peerBState2, peerBInFlight2, sharedState3) = + nextPeerAction now defaultTxDecisionPolicy peerB + peerBState1 peerBInFlight1 sharedState2 + case peerBAction of + PeerRequestTxs txKeys -> do + txKeys @?= [key] + peerRequestedTxs peerBState2 @?= IntSet.singleton k + IntSet.member k (pifLeased peerBInFlight2) @?= True + case IntMap.lookup k (sharedTxTable sharedState3) of + Just entry -> case txLease entry of + TxLeased owner _ -> owner @?= peerB + _ -> assertFailure "B's claim did not produce TxLeased B" + Nothing -> assertFailure "entry vanished after B's claim" + other -> assertFailure ("unexpected peer B action: " ++ show other) + where + peerA = 7 :: PeerAddr + peerB = 8 :: PeerAddr + txid :: TxId + txid = 1 + txSize = mkSize (Positive 10) + requestedToReply :: NumTxIdsToReq + requestedToReply = 1 + key = TxKey 0 + k = unTxKey key + sharedState0 = emptySharedTxState + peerAState0 = emptyPeerTxLocalState + { peerRequestedTxIds = requestedToReply + , peerRequestedTxsSize = txsSizeInflightPerPeer defaultTxDecisionPolicy + } + peerBState0 = emptyPeerTxLocalState + { peerRequestedTxIds = requestedToReply } + +-- | After peer A submits the body and the mempool rejects it, the +-- entry's lease releases back to 'TxClaimable' and peer B (still +-- advertising the key) is free to claim and re-attempt on its next +-- 'nextPeerAction' pass. +unit_nextPeerAction_claimsRejectedTxFromOtherAdvertiser + :: (String -> IO ()) -> Assertion +unit_nextPeerAction_claimsRejectedTxFromOtherAdvertiser step = do + step "Pre-state: tx leased to peer A, A is in mempoolAddTxs (post-markSubmittingTxs), B advertises the same key" + let txid :: TxId + txid = 4 + txKeyInt :: Int + txKeyInt = 0 + txSize :: SizeInBytes + txSize = 100 + txBody :: Tx TxId + txBody = mkTx txid txSize + peerA = 1 :: PeerAddr + peerB = 2 :: PeerAddr + sharedState0 :: SharedTxState PeerAddr TxId + sharedState0 = emptySharedTxState + { sharedTxIdToKey = Map.singleton (getRawTxId txid) (TxKey txKeyInt) + , sharedKeyToTxId = IntMap.singleton txKeyInt txid + , sharedNextTxKey = txKeyInt + 1 + , sharedTxTable = IntMap.singleton txKeyInt TxEntry + { txLease = TxLeased peerA (addTime 1 now) + , txAttempt = 0 + , txInSubmission = True + , currentMaxInflightMultiplicity = + txInflightMultiplicity defaultTxDecisionPolicy + } + } + peerAState0 = emptyPeerTxLocalState + { peerUnacknowledgedTxIds = StrictSeq.singleton (TxKey txKeyInt) + , peerDownloadedTxs = IntMap.singleton txKeyInt txBody + } + peerAInFlight0 = emptyPeerTxInFlight + { pifAdvertised = IntSet.singleton txKeyInt + , pifLeased = IntSet.singleton txKeyInt + , pifSubmitting = IntSet.singleton txKeyInt + } + peerBState0 = emptyPeerTxLocalState + { peerUnacknowledgedTxIds = StrictSeq.singleton (TxKey txKeyInt) + , peerAvailableTxIds = IntMap.singleton txKeyInt txSize + } + peerBInFlight0 = emptyPeerTxInFlight + { pifAdvertised = IntSet.singleton txKeyInt + } + + step "Peer A submits and the mempool rejects" + let (peerAState', peerAInFlight', sharedStateAfter) = + handleSubmittedTxs now defaultTxDecisionPolicy peerA + [] [TxKey txKeyInt] + peerAState0 peerAInFlight0 sharedState0 + + step "Lease released, attempt cleared, peer A's pif* cleared for the key" + case IntMap.lookup txKeyInt (sharedTxTable sharedStateAfter) of + Just entry -> do + txLease entry @?= TxClaimable now + txAttempt entry @?= 0 + txInSubmission entry @?= False + Nothing -> assertFailure "entry vanished after rejection" + peerDownloadedTxs peerAState' @?= IntMap.empty + pifLeased peerAInFlight' @?= IntSet.empty + pifSubmitting peerAInFlight' @?= IntSet.empty + pifAdvertised peerAInFlight' @?= IntSet.empty + + step "Peer B's nextPeerAction now claims the released tx" + let (peerBAction, peerBState', peerBInFlight', sharedStateFinal) = + nextPeerAction now defaultTxDecisionPolicy peerB + peerBState0 peerBInFlight0 sharedStateAfter + peerBAction @?= PeerRequestTxs [TxKey txKeyInt] + peerRequestedTxs peerBState' @?= IntSet.singleton txKeyInt + IntSet.member txKeyInt (pifLeased peerBInFlight') @?= True + case IntMap.lookup txKeyInt (sharedTxTable sharedStateFinal) of + Just entry -> case txLease entry of + TxLeased owner _ -> owner @?= peerB + _ -> assertFailure "B's claim did not produce TxLeased B" + Nothing -> assertFailure "entry vanished after B's claim" + +-- | A peer with a non-zero score waits its score-derived delay before +-- claiming a TxClaimable entry. Set up the entry to become claimable +-- exactly @peerScore / 20000@ seconds before @now@; the peer should +-- be allowed to claim at @now@. +unit_nextPeerAction_claimsAtScoreDelayThreshold + :: (String -> IO ()) -> Assertion +unit_nextPeerAction_claimsAtScoreDelayThreshold step = do + step "Set up: claimableAt = now - 1ms, peer score = 20 (1ms claim delay), so claim at now is just allowed" + let peerAddr = 7 :: PeerAddr + txid :: TxId + txid = 1 + txSize = mkSize (Positive 10) + key = TxKey 0 + k = unTxKey key + claimableAt = Time 99.999 -- now is Time 100 + sharedState = emptySharedTxState + { sharedTxIdToKey = Map.singleton (getRawTxId txid) key + , sharedKeyToTxId = IntMap.singleton k txid + , sharedNextTxKey = 1 + , sharedTxTable = IntMap.singleton k TxEntry + { txLease = TxClaimable claimableAt + , txAttempt = 0 + , txInSubmission = False + , currentMaxInflightMultiplicity = + txInflightMultiplicity defaultTxDecisionPolicy + } + } + peerState = emptyPeerTxLocalState + { peerUnacknowledgedTxIds = StrictSeq.singleton key + , peerAvailableTxIds = IntMap.singleton k txSize + , peerScore = PeerScore 20 now + } + peerInFlight = emptyPeerTxInFlight + { pifAdvertised = IntSet.singleton k + } + + step "Run nextPeerAction" + let (action, peerState', _, sharedState') = + nextPeerAction now defaultTxDecisionPolicy peerAddr + peerState peerInFlight sharedState + + step "Tx becomes claimable once the peerScore / 20000 ms threshold has elapsed" + case action of + PeerRequestTxs txKeys -> do + txKeys @?= [key] + peerRequestedTxs peerState' @?= IntSet.singleton k + case IntMap.lookup k (sharedTxTable sharedState') of + Just entry -> case txLease entry of + TxLeased owner _ -> owner @?= peerAddr + _ -> assertFailure "did not lease to peerAddr" + Nothing -> assertFailure "entry vanished after claim" + other -> assertFailure ("unexpected action: " ++ show other) + +-- | A peer that has buffered a tx blocked by another peer's submission +-- should still request body work for OTHER advertised txs that are +-- claimable. Without this, a single stuck submission would starve the +-- whole peer. +unit_nextPeerAction_requestsOtherWorkDespiteBlockedBufferedTx + :: (String -> IO ()) -> Assertion +unit_nextPeerAction_requestsOtherWorkDespiteBlockedBufferedTx step = do + step "Set up: blocked tx leased to me + buffered, but another peer is submitting it; second tx is claimable" + let peerAddr = 7 :: PeerAddr + submittingPeer = 8 :: PeerAddr + blockedTxid :: TxId + blockedTxid = 1 + claimableTxid :: TxId + claimableTxid = 2 + blockedSize = mkSize (Positive 10) + claimableSize = mkSize (Positive 11) + blockedKey = TxKey 1 + claimableKey = TxKey 2 + kBlocked = unTxKey blockedKey + kClaimable = unTxKey claimableKey + blockedTx = mkTx blockedTxid blockedSize + blockedEntry = TxEntry + { txLease = TxLeased peerAddr (addTime 10 now) + , txAttempt = 1 + , txInSubmission = True -- submittingPeer is in mempoolAddTxs + , currentMaxInflightMultiplicity = + txInflightMultiplicity defaultTxDecisionPolicy + } + sharedState = emptySharedTxState + { sharedTxTable = IntMap.fromList + [ (kBlocked, blockedEntry) + , (kClaimable, TxEntry + { txLease = TxClaimable now + , txAttempt = 0 + , txInSubmission = False + , currentMaxInflightMultiplicity = + txInflightMultiplicity defaultTxDecisionPolicy + }) + ] + , sharedTxIdToKey = Map.fromList + [ (getRawTxId blockedTxid, blockedKey) + , (getRawTxId claimableTxid, claimableKey) + ] + , sharedKeyToTxId = IntMap.fromList + [ (kBlocked, blockedTxid), (kClaimable, claimableTxid) ] + , sharedNextTxKey = 3 + } + peerState = emptyPeerTxLocalState + { peerUnacknowledgedTxIds = StrictSeq.fromList [blockedKey, claimableKey] + , peerAvailableTxIds = IntMap.fromList + [ (kBlocked, blockedSize), (kClaimable, claimableSize) ] + , peerDownloadedTxs = IntMap.singleton kBlocked blockedTx + } + -- This peer holds the lease on the blocked tx but didn't + -- submit it themselves; the submitting peer is someone else. + peerInFlight = emptyPeerTxInFlight + { pifAdvertised = IntSet.fromList [kBlocked, kClaimable] + , pifLeased = IntSet.singleton kBlocked + , pifAttempting = IntSet.singleton kBlocked + } + + step "Run nextPeerAction" + let (action, peerState', _, sharedState') = + nextPeerAction now defaultTxDecisionPolicy peerAddr + peerState peerInFlight sharedState + + step "Blocked tx stays buffered while the claimable tx is requested" + case action of + PeerRequestTxs picked -> do + picked @?= [claimableKey] + peerUnacknowledgedTxIds peerState' @?= peerUnacknowledgedTxIds peerState + peerRequestedTxs peerState' @?= IntSet.singleton kClaimable + peerDownloadedTxs peerState' @?= peerDownloadedTxs peerState + case IntMap.lookup kClaimable (sharedTxTable sharedState') of + Just entry -> case txLease entry of + TxLeased owner _ -> owner @?= peerAddr + _ -> assertFailure "claimable not leased to peerAddr" + Nothing -> assertFailure "claimable entry vanished" + other -> + assertFailure ("unexpected action: " ++ show other) + -- submittingPeer is referenced only for clarity of the test setup. + _ <- pure (submittingPeer :: PeerAddr) + pure () + +-- | A peer that is not the leaseholder and has not buffered the body +-- waits with the txid unacked until the tx resolves out of the active +-- table. After it resolves into 'sharedRetainedTxs' the same +-- 'nextPeerAction' call now ack-ifies the txid. +prop_nextPeerAction_nonOwnerWaitsUntilResolved + :: ArbTxDecisionPolicy + -> TxId -> Property -prop_collectTxs_shrinker (Fixed txs) = - property $ foldMap (\a@(ArbCollectTxs _ _ _ _ _ st) -> - Every . counterexample (show st) $ - f a =/= f txs - .&&. sharedTxStateInvariant StrongInvariant st - ) (shrink txs) +prop_nextPeerAction_nonOwnerWaitsUntilResolved (ArbTxDecisionPolicy policy) + txid0 = + let + txid = abs txid0 + 1 + key = TxKey 0 + k = unTxKey key + -- Unresolved: entry sits TxClaimable; another peer "has the body" + -- but in the new model that's reflected by txAttempt > 0 on the + -- entry; this peer's pif* are empty. Peer's peerAvailableTxIds is + -- empty so it can't claim either. + unresolvedSharedState :: SharedTxState PeerAddr TxId + unresolvedSharedState = emptySharedTxState + { sharedTxTable = IntMap.singleton k TxEntry + { txLease = TxClaimable now + , txAttempt = 0 + , txInSubmission = False + , currentMaxInflightMultiplicity = txInflightMultiplicity policy + } + , sharedTxIdToKey = Map.singleton (getRawTxId txid) key + , sharedKeyToTxId = IntMap.singleton k txid + , sharedNextTxKey = 1 + } + resolvedSharedState = unresolvedSharedState + { sharedTxTable = IntMap.empty + , sharedRetainedTxs = retainedSingleton k (addTime 17 now) + } + peerState0 = emptyPeerTxLocalState + { peerUnacknowledgedTxIds = StrictSeq.singleton key + , peerRequestedTxIds = 0 + } + peerInFlight0 = emptyPeerTxInFlight + { pifAdvertised = IntSet.singleton k + } + + (unresolvedAction, unresolvedPeerState', _, _) = + nextPeerAction now policy peerAddr peerState0 peerInFlight0 + unresolvedSharedState + (resolvedAction, resolvedPeerState', _, _) = + nextPeerAction now policy peerAddr peerState0 peerInFlight0 + resolvedSharedState + in + conjoin + [ counterexample "unresolved: must not ack the unresolved txid" $ + case unresolvedAction of + PeerDoNothing _ _ -> + peerUnacknowledgedTxIds unresolvedPeerState' + === peerUnacknowledgedTxIds peerState0 + PeerRequestTxIds _ ack _ -> + counterexample ("ack should be 0, got " ++ show ack) + (ack === 0) + other -> + counterexample ("unexpected unresolved action: " ++ show other) + (property False) + , counterexample "resolved: must ack the now-retained txid" $ + case resolvedAction of + PeerRequestTxIds _ ack _ -> + conjoin + [ ack === 1 + , peerUnacknowledgedTxIds resolvedPeerState' === StrictSeq.empty + ] + other -> + counterexample ("unexpected resolved action: " ++ show other) + (property False) + ] where - f (ArbCollectTxs _ reqSet recvMap peeraddr ps st) = (reqSet, recvMap, peeraddr, ps, st) + peerAddr = 1 :: PeerAddr + +-- | Roles for 'prop_nextPeerAction_claimsClaimableTx': 'Good' has no +-- score and can claim immediately; 'Bad' has a non-zero score that +-- pushes its claim past 'now'; 'Confounder' has no relevant local +-- state and is expected to do nothing on any 'nextPeerAction' call. +data PeerRole = Good | Bad | Confounder + deriving (Eq, Show) + +-- | Whether the lease starts as 'TxClaimable claimableAt' (a fresh +-- claimable lease) or as 'TxLeased oldOwner claimableAt' with +-- @claimableAt < now@ (a stale lease whose deadline already passed, +-- so any other advertiser whose 'peerClaimDelay' permits can claim). +data LeaseStart = ClaimableLease | ExpiredLease + deriving (Eq, Show) + +instance Arbitrary LeaseStart where + arbitrary = elements [ClaimableLease, ExpiredLease] + +-- | A scheduling order for the three peers. Generated as a permutation +-- of the three roles. +newtype PeerOrder = PeerOrder [PeerRole] + deriving Show +instance Arbitrary PeerOrder where + arbitrary = PeerOrder <$> shuffle [Good, Bad, Confounder] --- | Verify `collectTxsImpl` properties: +-- | Drives 'nextPeerAction' for three peers ('Good', 'Bad', +-- 'Confounder') in a generator-chosen order. Asserts: -- --- * 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 +-- * 'Good' (no score) claims the tx and ends up the leaseholder. +-- * 'Bad' (non-zero score) yields 'PeerDoNothing' with a wake delay +-- equal to the score-derived delay (offset by whether 'Bad' ran +-- before or after 'Good's claim). +-- * 'Confounder' (no relevant state) yields 'PeerDoNothing' with no +-- wake. +-- * The combined invariant holds for the full @(peerLocal, +-- peerInFlight)@ snapshot of all three peers after each action. +prop_nextPeerAction_claimsClaimableTx + :: ArbTxDecisionPolicy + -> Positive Int + -> Positive Int + -> Positive Int + -> TxId + -> Positive Int + -> Positive Int + -> Positive Int + -> PeerOrder + -> LeaseStart -> 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 (Map.size txidsRequested)) $ - label ("number of txids received " ++ labelInt 10 2 (Map.size txsReceived)) $ - label ("hasTxSizeError " ++ show hasTxSizeErr) $ - - case TXS.collectTxsImpl getTxSize peeraddr txidsRequested txsReceived st of - Right st' | not hasTxSizeErr -> - let ps' = peerTxStates st' Map.! peeraddr in - -- InboundState invariant - counterexample - ( "InboundState invariant violation:\n" ++ show st' ++ "\n" - ++ show ps' - ) - (sharedTxStateInvariant StrongInvariant 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 e | not hasTxSizeErr -> - counterexample "collectTxsImpl should return Right" $ - counterexample (show e) 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 +prop_nextPeerAction_claimsClaimableTx + (ArbTxDecisionPolicy arbPolicy) + (Positive good0) (Positive bad0) (Positive conf0) + txid0 txSize0 (Positive badScore0) (Positive tDecay0) (PeerOrder order) + leaseStart = + tabulate "order" [show order] + . tabulate "lease" [show leaseStart] + $ conjoin + [ counterexample ("Good must claim: " ++ show (lookupAction Good)) $ + case lookupAction Good of + Just (PeerRequestTxs txKeys, _, _) -> txKeys === [key] + _ -> property False + , counterexample ("Bad must yield with the score-delay derived wake: " + ++ show (lookupAction Bad)) $ + case lookupAction Bad of + Just (PeerDoNothing _ (Just delay), _, _) -> + let diff = abs (delay - expectedBadDelay) in + counterexample + ("delay = " ++ show delay + ++ ", expected = " ++ show expectedBadDelay + ++ ", diff = " ++ show diff) + (property (diff < 1e-9)) + other -> + counterexample ("got: " ++ show other) (property False) + , counterexample ("Confounder must do nothing with no scheduled wake: " + ++ show (lookupAction Confounder)) $ + case lookupAction Confounder of + Just (PeerDoNothing _ Nothing, _, _) -> property True + _ -> property False + , counterexample "Lease must end up at Good" $ + case IntMap.lookup k (sharedTxTable sharedStateFinal) of + Just entry -> case txLease entry of + TxLeased owner _ -> owner === goodPeer + _ -> property False + Nothing -> property False + ] where - hasTxSizeErr = any (\tx -> abs (getTxSize tx - getTxAdvSize tx) > TXS.const_MAX_TX_SIZE_DISCREPANCY) txsReceived + policy = arbPolicy + { scoreMax = max 200 (scoreMax arbPolicy) + , scoreRate = max 0.01 (min 1.0 (scoreRate arbPolicy)) + } - -- 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`?" + goodPeer = good0 + badPeer = bad0 + 1000 + confPeer = conf0 + 2000 + txid = abs txid0 + 1 + txSize = mkSize txSize0 + key = TxKey 0 + k = unTxKey key + + claimableAt = Time 99.999 + tDecaySec :: Double + tDecaySec = fromIntegral (1 + (tDecay0 - 1) `mod` 10 :: Int) + decayAmount :: Double + decayAmount = tDecaySec * scoreRate policy + decayedBadScore :: Double + decayedBadScore = fromIntegral (21 + (badScore0 - 1) `mod` 80 :: Int) + badInitialScore :: Double + badInitialScore = decayedBadScore + decayAmount + badPeerScore = PeerScore + { peerScoreValue = badInitialScore + , peerScoreTs = addTime (negate (realToFrac tDecaySec)) now + } + badRunsBeforeGood = case (elemIndex Bad order, elemIndex Good order) of + (Just bi, Just gi) -> bi < gi + _ -> False + badClaimDelay :: DiffTime + badClaimDelay = realToFrac (decayedBadScore / 20000) + expectedBadDelay :: DiffTime + expectedBadDelay + | badRunsBeforeGood = badClaimDelay - diffTime now claimableAt + | otherwise = badClaimDelay + interTxSpace policy + + -- Stale-lease holder; only present in shared state when + -- 'leaseStart = ExpiredLease'. 'nextPeerAction' is never called + -- for this peer; it exists only to set the @TxLeased@ owner with + -- @leaseUntil = claimableAt < now@. + oldOwner = good0 + bad0 + conf0 + 3000 + + sharedState0 = emptySharedTxState + { sharedTxIdToKey = Map.singleton (getRawTxId txid) key + , sharedKeyToTxId = IntMap.singleton k txid + , sharedNextTxKey = 1 + , sharedTxTable = IntMap.singleton k TxEntry + { txLease = case leaseStart of + ClaimableLease -> TxClaimable claimableAt + ExpiredLease -> TxLeased oldOwner claimableAt + , txAttempt = 0 + , txInSubmission = False + , currentMaxInflightMultiplicity = txInflightMultiplicity policy + } + } + + goodPeerState0 = emptyPeerTxLocalState + { peerUnacknowledgedTxIds = StrictSeq.singleton key + , peerAvailableTxIds = IntMap.singleton k txSize + } + goodInFlight0 = emptyPeerTxInFlight { pifAdvertised = IntSet.singleton k } + badPeerState0 = emptyPeerTxLocalState + { peerUnacknowledgedTxIds = StrictSeq.singleton key + , peerAvailableTxIds = IntMap.singleton k txSize + , peerScore = badPeerScore + } + badInFlight0 = emptyPeerTxInFlight { pifAdvertised = IntSet.singleton k } -deriving via OnlyCheckWhnfNamed "StdGen" StdGen instance NoThunks StdGen + confPeerState0 = emptyPeerTxLocalState + { peerRequestedTxIds = maxNumTxIdsToRequest policy + } + confInFlight0 = emptyPeerTxInFlight + + roleSetup Good = (goodPeer, goodPeerState0, goodInFlight0) + roleSetup Bad = (badPeer, badPeerState0, badInFlight0) + roleSetup Confounder = (confPeer, confPeerState0, confInFlight0) + + runOne :: (SharedTxState PeerAddr TxId, + [(PeerRole, PeerAction, PeerTxLocalState (Tx TxId), PeerTxInFlight)]) + -> PeerRole + -> (SharedTxState PeerAddr TxId, + [(PeerRole, PeerAction, PeerTxLocalState (Tx TxId), PeerTxInFlight)]) + runOne (ss, acc) role = + let (peer, ps0, pif0) = roleSetup role + (action, ps', pif', ss') = + nextPeerAction now policy peer ps0 pif0 ss + in (ss', (role, action, ps', pif') : acc) + + (sharedStateFinal, results) = foldl' runOne (sharedState0, []) order + + lookupAction :: PeerRole + -> Maybe (PeerAction, PeerTxLocalState (Tx TxId), PeerTxInFlight) + lookupAction role = + case [ (a, ps', pif') | (r, a, ps', pif') <- results, r == role ] of + [] -> Nothing + (x : _) -> Just x --- | Verify that `SharedTxState` returned by `collectTxsImpl` if evaluated to --- WHNF, it doesn't contain any thunks. -- -prop_collectTxsImpl_nothunks - :: ArbCollectTxs - -> Property -prop_collectTxsImpl_nothunks (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived peeraddr _ st) = - case TXS.collectTxsImpl getTxSize peeraddr txidsRequested txsReceived st of - Right st' -> case unsafeNoThunks $! st' of - Nothing -> property True - Just ctx -> counterexample (show ctx) False - Left _ -> property True - +-- TriggerScenario: multi-peer scheduler exercise +-- +-- Each 'ActionTrigger' on a peer's list describes one action that +-- should be choosable at the moment the test calls 'nextPeerAction'. +-- 'buildTriggerState' turns the per-peer list into a consistent +-- ('PeerTxLocalState', 'PeerTxInFlight', 'SharedTxState') triple. + +data ActionTrigger + = TSubmittable TxId (Positive Int) + -- ^ peer holds the lease, body buffered locally, ready to submit. + | TFetchable TxId (Positive Int) + -- ^ peer advertises the txid, claimable now. + | TAckable TxId + -- ^ in 'sharedRetainedTxs' + peer's unacked queue (resolved already). + | TFetchableLater (Positive Int) TxId (Positive Int) + -- ^ delay-in-seconds + txid + size: claimable only after the loop + -- has advanced 'time' by at least the delay. + deriving (Eq, Show) + +instance Arbitrary ActionTrigger where + arbitrary = oneof + [ TSubmittable <$> arbitrary <*> arbitrary + , TFetchable <$> arbitrary <*> arbitrary + , TAckable <$> arbitrary + , TFetchableLater <$> arbitrary <*> arbitrary <*> arbitrary + ] + shrink (TSubmittable t s) = + [ TFetchable t s, TAckable t ] + ++ [ TSubmittable t' s | t' <- take 1 (shrink t) ] + shrink (TFetchable t s) = + TAckable t : + [ TFetchable t' s | t' <- take 1 (shrink t) ] + shrink (TAckable t) = + [ TAckable t' | t' <- take 1 (shrink t) ] + shrink (TFetchableLater d t s) = + [ TFetchable t s, TAckable t ] + ++ [ TFetchableLater d' t s | d' <- take 1 (shrink d) ] + +triggerTxid :: ActionTrigger -> TxId +triggerTxid (TSubmittable t _) = t +triggerTxid (TFetchable t _) = t +triggerTxid (TAckable t) = t +triggerTxid (TFetchableLater _ t _) = t + +isTSubmittable :: ActionTrigger -> Bool +isTSubmittable TSubmittable{} = True +isTSubmittable _ = False + +isTAckable :: ActionTrigger -> Bool +isTAckable TAckable{} = True +isTAckable _ = False + +isTFetchableNow :: ActionTrigger -> Bool +isTFetchableNow TFetchable{} = True +isTFetchableNow _ = False + +isTFetchableLater :: ActionTrigger -> Bool +isTFetchableLater TFetchableLater{} = True +isTFetchableLater _ = False + +setTxid :: ActionTrigger -> TxId -> ActionTrigger +setTxid (TSubmittable _ s) t = TSubmittable t s +setTxid (TFetchable _ s) t = TFetchable t s +setTxid (TAckable _) t = TAckable t +setTxid (TFetchableLater d _ s) t = TFetchableLater d t s + +-- | Generator-time bias selector: 'ModeDisjoint' renumbers all +-- triggers so each peer's txid range is unique (no cross-peer overlap), +-- 'ModeShared' collapses txids into a small shared pool so cross-peer +-- overlap arises with high probability. +data OverlapMode = ModeDisjoint | ModeShared + deriving (Eq, Show) + +-- | A scenario is an overlap mode plus a per-peer trigger map. +data TriggerScenario = + TriggerScenario OverlapMode (Map.Map PeerAddr [ActionTrigger]) + deriving (Eq, Show) + +genPerPeerTriggers :: Gen [ActionTrigger] +genPerPeerTriggers = do + size <- frequency + [ (2, pure 1) + , (1, pure 0) + , (3, choose (2, 10)) + , (1, choose (11, 100)) + ] + genElem <- oneof + [ pure arbitrary + , pure (TFetchable <$> arbitrary <*> arbitrary) + , pure (TSubmittable <$> arbitrary <*> arbitrary) + , pure (TAckable <$> arbitrary) + , pure (TFetchableLater <$> arbitrary <*> arbitrary <*> arbitrary) + ] + vectorOf size genElem + +shrinkTriggerList :: [ActionTrigger] -> [[ActionTrigger]] +shrinkTriggerList ts = + let n = length ts in + [ take (n `div` 2) ts | n >= 2 ] + ++ [ drop (n `div` 2) ts | n >= 2 ] + ++ [ take i ts ++ drop (i + 1) ts | i <- [0 .. n - 1] ] + ++ [ take i ts ++ t' : drop (i + 1) ts + | i <- [0 .. n - 1] + , t' <- shrink (ts !! i) + ] + +renumberDisjoint :: [[ActionTrigger]] -> [[ActionTrigger]] +renumberDisjoint = snd . mapAccumL renumberOne 1 + where + renumberOne nextId triggers = + let n = length triggers in + (nextId + n, zipWith setTxid triggers [nextId .. nextId + n - 1]) -newtype ArbTxDecisionPolicy = ArbTxDecisionPolicy TxDecisionPolicy - deriving Show +collapseToPool :: Int -> [[ActionTrigger]] -> Gen [[ActionTrigger]] +collapseToPool poolSize = traverse (traverse remap) + where + remap trig = do + newId <- chooseInt (1, poolSize) + pure (setTxid trig newId) -instance Arbitrary ArbTxDecisionPolicy where - arbitrary = - ArbTxDecisionPolicy <$> ( - TxDecisionPolicy . getSmall . getPositive - <$> arbitrary - <*> (getSmall . getPositive <$> arbitrary) - <*> (SizeInBytes . getPositive <$> arbitrary) - <*> (getSmall . getPositive <$> arbitrary) - <*> (realToFrac <$> choose (0 :: Double, 2)) - <*> choose (0, 1) - <*> choose (0, 1800)) - - shrink (ArbTxDecisionPolicy a@TxDecisionPolicy { - maxNumTxIdsToRequest, - txsSizeInflightPerPeer, - txInflightMultiplicity }) = - [ ArbTxDecisionPolicy a { maxNumTxIdsToRequest = NumTxIdsToReq x } - | (Positive (Small x)) <- shrink (Positive (Small (getNumTxIdsToReq maxNumTxIdsToRequest))) +instance Arbitrary TriggerScenario where + arbitrary = do + nPeers <- frequency + [ (2, pure 1) + , (2, pure 2) + , (1, pure 3) ] - ++ - [ ArbTxDecisionPolicy a { txsSizeInflightPerPeer = SizeInBytes s } - | Positive s <- shrink (Positive (getSizeInBytes txsSizeInflightPerPeer)) + perPeer <- vectorOf nPeers genPerPeerTriggers + mode <- frequency + [ (2, pure ModeDisjoint) + , (3, pure ModeShared) ] - ++ - [ ArbTxDecisionPolicy a { txInflightMultiplicity = x } - | Positive (Small x) <- shrink (Positive (Small txInflightMultiplicity)) + remapped <- case mode of + ModeDisjoint -> pure (renumberDisjoint perPeer) + ModeShared -> + let totalT = sum (map length perPeer) + poolSz = max 1 (totalT `div` 2) in + collapseToPool poolSz perPeer + pure (TriggerScenario mode + (Map.fromList (zip [1 .. nPeers] remapped))) + shrink (TriggerScenario mode m) = + [ TriggerScenario mode (Map.delete p m) + | Map.size m > 1 + , p <- Map.keys m + ] + ++ [ TriggerScenario mode (Map.insert p ts' m) + | (p, ts) <- Map.toList m + , ts' <- shrinkTriggerList ts + ] + +-- | Strongest trigger category seen across all peers for a given txid. +data TxCategory = CatSubmit | CatFetch | CatAck + deriving (Eq, Show) + +categoryOf :: [ActionTrigger] -> TxCategory +categoryOf trigs + | any isTSubmittable trigs = CatSubmit + | any isTFetchableNow trigs || any isTFetchableLater trigs = CatFetch + | otherwise = CatAck + +hasActiveEntry :: ActionTrigger -> Bool +hasActiveEntry TAckable{} = False +hasActiveEntry _ = True + +-- | Build a consistent multi-peer state from a per-peer trigger map. +-- The state must already be normalised by 'normaliseScenario'. +buildTriggerState :: TxDecisionPolicy + -> Map.Map PeerAddr [ActionTrigger] + -> ( Map.Map PeerAddr (PeerTxLocalState (Tx TxId), PeerTxInFlight) + , SharedTxState PeerAddr TxId + ) +buildTriggerState policy perPeer = + (peerStates, sharedState0) + where + allTxids :: [TxId] + allTxids = nub + [ triggerTxid t + | (_, ts) <- Map.toAscList perPeer + , t <- ts ] + txidToKey :: Map.Map TxId Int + txidToKey = Map.fromList (zip allTxids [0..]) -prop_splitAcknowledgedTxIds - :: ArbDecisionContexts TxId - -> Property -prop_splitAcknowledgedTxIds - ArbDecisionContexts { - arbDecisionPolicy = policy@TxDecisionPolicy { maxNumTxIdsToRequest, - maxUnacknowledgedTxIds }, - arbSharedState = st - } - = - counterexample "ackedTxIds <> unackedTxIds ≠ unacknowledgedTxIds ps" - (ackedTxIds <> unackedTxIds === unacknowledgedTxIds ps) - .&&. counterexample "unackedAndRequested ≰ maxUnacknowledgedTxIds" - (unackedAndRequested <= maxUnacknowledgedTxIds) - .&&. counterexample "requestedTxIdsInflight ps ≰ maxNumTxIdsToRequest" - (requestedTxIdsInflight ps <= maxNumTxIdsToRequest) - .&&. counterexample "numTxIdsToReq ≰ maxNumTxIdsToRequest - requestedTxIdsInflight ps" - (numTxIdsToReq <= maxNumTxIdsToRequest - requestedTxIdsInflight ps) - .&&. counterexample "numTxIdsToReq ≰ maxUnacknowledgedTxIds - unackedAndRequested + fromIntegral numOfAckedTxIds" - (numTxIdsToReq <= maxUnacknowledgedTxIds - unackedAndRequested + fromIntegral numOfAckedTxIds) - where - ps = case Map.elems $ TXS.peerTxStates st of - a : _ -> a - [] -> error "generator invariant violation: empty peerTxStates map" - (numTxIdsToReq, ackedTxIds, unackedTxIds) - = TXS.splitAcknowledgedTxIds policy st ps - numOfAckedTxIds = StrictSeq.length ackedTxIds - numOfUnackedTxIds = StrictSeq.length unackedTxIds - unackedAndRequested = fromIntegral numOfUnackedTxIds + requestedTxIdsInflight ps + txidKey :: TxId -> Int + txidKey t = txidToKey Map.! t + triggersFor :: TxId -> [(PeerAddr, ActionTrigger)] + triggersFor txid = + [ (p, t) + | (p, ts) <- Map.toAscList perPeer + , t <- ts + , triggerTxid t == txid + ] -data ArbDecisionContexts txid = ArbDecisionContexts { - arbDecisionPolicy :: TxDecisionPolicy, + submittingPeer :: TxId -> Maybe PeerAddr + submittingPeer txid = listToMaybe + [ p | (p, t) <- triggersFor txid, isTSubmittable t ] + + laterDelay :: TxId -> Maybe Int + laterDelay txid = listToMaybe + [ d | (_, TFetchableLater (Positive d) _ _) <- triggersFor txid ] + + -- An entry's 'txAttempt' is exactly the number of TSubmittable + -- triggers for the txid; with 'dedupeAcrossPeers' that's at most 1. + -- All fetchable peers contribute via their per-peer 'pifAdvertised' + -- to keep the entry alive against the orphan sweep. + mkEntry :: TxId -> TxEntry PeerAddr + mkEntry txid = + let trigs = triggersFor txid + attemptCount = length [() | (_, t) <- trigs, isTSubmittable t] + lease = case submittingPeer txid of + Just p -> TxLeased p (addTime 10 now) + Nothing -> case laterDelay txid of + Just d -> TxClaimable (addTime (fromIntegral d) now) + Nothing -> TxClaimable now in + TxEntry + { txLease = lease + , txAttempt = attemptCount + , txInSubmission = False + , currentMaxInflightMultiplicity = txInflightMultiplicity policy + } - arbSharedState :: SharedTxState PeerAddr txid (Tx txid), + activeTxids = [ txid | txid <- allTxids + , categoryOf (map snd (triggersFor txid)) /= CatAck ] + retainedTxids = [ txid | txid <- allTxids + , categoryOf (map snd (triggersFor txid)) == CatAck ] + + retainedUntil = addTime 600 now + retainedEntries = [ (txidKey txid, retainedUntil) | txid <- retainedTxids ] + + mkPeerState :: PeerAddr -> [ActionTrigger] + -> (PeerTxLocalState (Tx TxId), PeerTxInFlight) + mkPeerState peeraddr ts = + let peerLocal = emptyPeerTxLocalState + { peerUnacknowledgedTxIds = StrictSeq.fromList + [ TxKey (txidKey (triggerTxid t)) | t <- ts ] + , peerDownloadedTxs = IntMap.fromList + [ (txidKey t', mkTx t' (mkSize s)) + | TSubmittable t' s <- ts + ] + , peerAvailableTxIds = IntMap.fromList $ + [ (txidKey t', mkSize s) | TFetchable t' s <- ts ] + ++ [ (txidKey t', mkSize s) | TFetchableLater _ t' s <- ts ] + } + advertised = IntSet.fromList + [ txidKey (triggerTxid t) | t <- ts, hasActiveEntry t ] + leasedHere = IntSet.fromList + [ txidKey t' | TSubmittable t' _ <- ts + , submittingPeer t' == Just peeraddr ] + attemptingHere = leasedHere + peerInFlight = emptyPeerTxInFlight + { pifAdvertised = advertised + , pifLeased = leasedHere + , pifAttempting = attemptingHere + } + in (peerLocal, peerInFlight) + + peerStates = Map.mapWithKey mkPeerState perPeer + + sharedState0 = emptySharedTxState + { sharedTxTable = IntMap.fromList + [ (txidKey txid, mkEntry txid) | txid <- activeTxids ] + , sharedTxIdToKey = Map.fromList + [ (getRawTxId txid, TxKey (txidKey txid)) | txid <- allTxids ] + , sharedKeyToTxId = IntMap.fromList + [ (txidKey txid, txid) | txid <- allTxids ] + , sharedNextTxKey = length allTxids + , sharedRetainedTxs = retainedFromList retainedEntries + } - arbMempoolHasTx :: Fun txid Bool - -- ^ needed just for shrinking - } +-- | Per-peer normalise: shift txids to >= 1, dedupe, reorder so +-- ackables come first, then submittables, then fetchables. +normaliseTriggers :: [ActionTrigger] -> [ActionTrigger] +normaliseTriggers = + orderTriggers + . nubBy ((==) `on` triggerTxid) + . map shiftTrigger + where + shiftTrigger (TSubmittable t s) = TSubmittable (abs t + 1) s + shiftTrigger (TFetchable t s) = TFetchable (abs t + 1) s + shiftTrigger (TAckable t) = TAckable (abs t + 1) + shiftTrigger (TFetchableLater d t s) = TFetchableLater d (abs t + 1) s + orderTriggers ts = + filter isTAckable ts + ++ filter isTSubmittable ts + ++ filter isTFetchableNow ts + ++ filter isTFetchableLater ts + +-- | Across peers, ensure each txid has 'TSubmittable' from at most one +-- peer (the lowest-numbered). +dedupeAcrossPeers :: Map.Map PeerAddr [ActionTrigger] + -> Map.Map PeerAddr [ActionTrigger] +dedupeAcrossPeers m = Map.mapWithKey (map . demote) m + where + primarySubmitter :: Map.Map TxId PeerAddr + primarySubmitter = Map.fromListWith min + [ (t, p) | (p, ts) <- Map.toList m, TSubmittable t _ <- ts ] + demote p (TSubmittable t s) + | Map.lookup t primarySubmitter /= Just p = TFetchable t s + demote _ trig = trig + +normaliseScenario :: Map.Map PeerAddr [ActionTrigger] + -> Map.Map PeerAddr [ActionTrigger] +normaliseScenario = dedupeAcrossPeers . Map.map normaliseTriggers + +-- | Policy used by the 'TriggerScenario' meta-tests. +metaPolicy :: TxDecisionPolicy +metaPolicy = defaultTxDecisionPolicy { txInflightMultiplicity = 2 } + +prop_TriggerScenario_validInitialState :: TriggerScenario -> Property +prop_TriggerScenario_validInitialState (TriggerScenario _ rawPerPeer) = + let perPeer = normaliseScenario rawPerPeer + (peerStates, ss0) = buildTriggerState metaPolicy perPeer in + combinedStateInvariant metaPolicy StrongInvariant peerStates ss0 + +prop_TriggerScenario_shrinkPreservesValidity :: TriggerScenario -> Property +prop_TriggerScenario_shrinkPreservesValidity ts = + conjoin + [ prop_TriggerScenario_validInitialState ts' + | ts' <- shrink ts + ] -instance Show txid => Show (ArbDecisionContexts txid) where - show ArbDecisionContexts { - arbDecisionPolicy, - arbSharedState = st, - arbMempoolHasTx - } - = - intercalate "\n\t" - [ "ArbDecisionContext" - , show arbDecisionPolicy - , show st - , show arbMempoolHasTx - ] +prop_TriggerScenario_shrinkSmaller :: TriggerScenario -> Property +prop_TriggerScenario_shrinkSmaller ts@(TriggerScenario _ rawM) = + let n = sum (map length (Map.elems rawM)) in + conjoin + [ counterexample ("shrink grew the trigger count: " ++ show ts') + $ sum (map length (Map.elems rawM')) <= n + | ts'@(TriggerScenario _ rawM') <- shrink ts + ] --- | 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 - - - --- | Fix-up `SharedTxState` so it satisfies `TxDecisionPolicy`. +prop_TriggerScenario_shrinkExcludesOriginal :: TriggerScenario -> Property +prop_TriggerScenario_shrinkExcludesOriginal ts = + counterexample "shrink contains the original value" + $ property (ts `notElem` shrink ts) + +-- | Drives 'nextPeerAction' for every peer in the scenario, advancing +-- the earliest-wake peer at each step. Asserts: -- -fixupSharedTxStateForPolicy - :: forall peeraddr txid tx. - Ord txid - => (txid -> Bool) -- ^ mempoolHasTx - -> TxDecisionPolicy - -> SharedTxState peeraddr txid tx - -> SharedTxState peeraddr txid tx -fixupSharedTxStateForPolicy - mempoolHasTx - policy@TxDecisionPolicy { - txsSizeInflightPerPeer, - txInflightMultiplicity - } - st@SharedTxState { peerTxStates } - = - fixupSharedTxState - mempoolHasTx - st { peerTxStates = snd . mapAccumR fn (0, Map.empty) $ peerTxStates } +-- 1. The loop terminates within the iteration budget. +-- 2. Every txid whose strongest cross-peer trigger category is +-- 'CatSubmit' or 'CatFetch' appears in the union of submitted keys +-- (since fetched bodies are deferred-delivered and then submitted). +-- 3. Every txid whose category is 'CatFetch' appears in the union of +-- requested keys. +-- 4. Every txid whose category is 'CatAck' appears in the union of +-- acked keys. +-- 5. 'combinedStateInvariant' holds on the initial state for every +-- peer and after the acting peer's update at every step. +prop_nextPeerAction_processesAllTriggers + :: ArbTxDecisionPolicy + -> TriggerScenario + -> Property +prop_nextPeerAction_processesAllTriggers + (ArbTxDecisionPolicy arbPolicy) (TriggerScenario mode rawPerPeer) = + tabulate "trigger count" [bucket totalTriggers] + . tabulate "peer count" [show nPeers] + . tabulate "iterations" [bucket iterations] + . tabulate "shared txids" [bucket sharedTxidCount] + . tabulate "overlap mode" [show mode] + $ conjoin + [ counterexample "loop must terminate within step budget" + $ property terminated + , counterexample "submitted set must equal CatSubmit txids" + $ allSubmitted === expectedSubmitted + , counterexample "requested set must equal CatFetch txids" + $ allRequested === expectedFetched + , counterexample + ("expected acks missing: " ++ show (IntSet.toList missingAcks)) + $ property (IntSet.null missingAcks) + , counterexample "initial combined invariant violated" + (combinedStateInvariant policy StrongInvariant peerStates0 sharedState0) + , conjoin + [ counterexample + ("invariant after step " ++ show n + ++ " (peer " ++ show p ++ ")") inv + | (n, p, inv) <- stateInvariants + ] + ] 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 - && 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 st' = fixupSharedTxStateForPolicy - (apply mempoolHasTx) policy st - - return $ ArbDecisionContexts { - arbDecisionPolicy = policy, - arbMempoolHasTx = mempoolHasTx, - arbSharedState = st' - } + perPeer = normaliseScenario rawPerPeer + totalTriggers = sum (map length (Map.elems perPeer)) + nPeers = Map.size perPeer + + txidPeerCounts :: Map.Map TxId Int + txidPeerCounts = Map.fromListWith (+) + [ (triggerTxid t, 1 :: Int) + | (_, ts) <- Map.toList perPeer + , t <- ts + ] + sharedTxidCount = length + [ () | (_, n) <- Map.toList txidPeerCounts, n >= 2 ] + + policy = arbPolicy + { txInflightMultiplicity = 2 + , txsSizeInflightPerPeer = + max_TX_SIZE * fromIntegral (max 1 totalTriggers) + , maxOutstandingTxBatchesPerPeer = max 1 totalTriggers + } - shrink a@ArbDecisionContexts { - arbDecisionPolicy = policy, - arbMempoolHasTx = mempoolHasTx, - arbSharedState = sharedState - } = - -- shrink shared state - [ a { arbSharedState = sharedState'' } - | sharedState' <- shrinkSharedTxState (apply mempoolHasTx) sharedState - , let sharedState'' = fixupSharedTxStateForPolicy - (apply mempoolHasTx) policy sharedState' - , sharedState'' /= sharedState + maxIters = 100 + 6 * totalTriggers * max 1 nPeers + + allTxids = nub + [ triggerTxid t | (_, ts) <- Map.toAscList perPeer, t <- ts ] + txidToKey = Map.fromList (zip allTxids [0..]) + txidKey t = txidToKey Map.! t + + triggersFor txid = + [ trig | (_, ts) <- Map.toAscList perPeer + , trig <- ts + , triggerTxid trig == txid ] + catFor txid = categoryOf (triggersFor txid) + + expectedSubmitted = IntSet.fromList + [ txidKey t | t <- allTxids + , let c = catFor t, c == CatSubmit || c == CatFetch ] + expectedFetched = IntSet.fromList + [ txidKey t | t <- allTxids, catFor t == CatFetch ] + expectedAcked = IntSet.fromList + [ txidKey t | t <- allTxids, catFor t == CatAck ] + + (peerStates0, sharedState0) = buildTriggerState policy perPeer + + -- Schedule entry: (next-wake-time, peerLocal, peerInFlight). + initialSchedule + :: Map.Map PeerAddr (Maybe Time, PeerTxLocalState (Tx TxId), PeerTxInFlight) + initialSchedule = Map.map (\(ps, pif) -> (Just now, ps, pif)) peerStates0 + + (allSubmitted, allRequested, allAcked, + stateInvariants, terminated, iterations) = + runLoop sharedState0 initialSchedule Map.empty + IntSet.empty IntSet.empty IntSet.empty + [] 0 now + + missingAcks = expectedAcked `IntSet.difference` allAcked + + pickEarliest schedule = + case sortBy (compare `on` snd) + [ (p, t) | (p, (Just t, _, _)) <- Map.toList schedule ] of + [] -> Nothing + (p, t) : _ -> + let (_, ps, pif) = schedule Map.! p in + Just (p, t, ps, pif) + + reactivateOthers acting time = + Map.mapWithKey $ \p (status, ps, pif) -> + if p == acting + then (status, ps, pif) + else case status of + Just t' | t' <= time -> (Just t', ps, pif) + _ -> (Just time, ps, pif) + + mkBody :: SharedTxState PeerAddr TxId + -> PeerTxLocalState (Tx TxId) + -> TxKey + -> (TxId, Tx TxId) + mkBody ss ps (TxKey k) = + let txid = sharedKeyToTxId ss IntMap.! k + size = peerAvailableTxIds ps IntMap.! k in + (txid, mkTx txid size) + + runLoop ss schedule pending subs reqs acks invs i lastTime + | i >= maxIters = + (subs, reqs, acks, reverse invs, False, i) + | otherwise = + case pickEarliest schedule of + Nothing -> + (subs, reqs, acks, reverse invs, True, i) + Just (p, time, ps, pif) -> + let lastTime' = max lastTime time + + -- Snapshot of every peer's @(peerLocal, peerInFlight)@ + -- with @p@'s entry overridden to the supplied pair. + peerSnapshot pSnap psSnap pifSnap = + Map.insert pSnap (psSnap, pifSnap) + (Map.map (\(_, ps_, pif_) -> (ps_, pif_)) schedule) + + -- Drain p's pending body deliveries before its action. + (psPre, pifPre, ssPre, pendingPre, drainInvs, stepDrain) = + case Map.lookup p pending of + Nothing -> (ps, pif, ss, pending, [], i) + Just deliveries -> + let (_, _, ps2, pif2, ss2) = + handleReceivedTxs (const False) time policy p + deliveries ps pif ss + stepD = i + 1 + drainInv = conjoin + [ combinedStateInvariant policy + StrongInvariant + (peerSnapshot p ps2 pif2) + ss2 + , checkNoThunks + ("peerState after drain (peer " + ++ show p ++ ", step " ++ show stepD ++ ")") + ps2 + , checkNoThunks + ("sharedState after drain (peer " + ++ show p ++ ", step " ++ show stepD ++ ")") + ss2 + ] in + ( ps2, pif2, ss2, Map.delete p pending + , [(stepD, p, drainInv)], stepD ) + + (action, ps', pif', ss') = + nextPeerAction time policy p psPre pifPre ssPre + oldUnacked = peerUnacknowledgedTxIds psPre + newUnacked = peerUnacknowledgedTxIds ps' + numAcked = StrictSeq.length oldUnacked + - StrictSeq.length newUnacked + ackedNow = IntSet.fromList $ map unTxKey + $ toList (StrictSeq.take numAcked oldUnacked) + step = stepDrain + 1 + inv = conjoin + [ combinedStateInvariant policy StrongInvariant + (peerSnapshot p ps' pif') ss' + , checkNoThunks + ("peerState' (peer " ++ show p + ++ ", step " ++ show step ++ ")") + ps' + , checkNoThunks + ("sharedState' (peer " ++ show p + ++ ", step " ++ show step ++ ")") + ss' + ] in + case action of + PeerDoNothing _ Nothing -> + let schedule' = Map.insert p (Nothing, ps', pif') schedule in + runLoop ss' schedule' pendingPre subs reqs acks + ((step, p, inv) : drainInvs ++ invs) step lastTime' + PeerDoNothing _ (Just delay) -> + let nextWake = addTime (max delay 0.001) time + schedule' = Map.insert p (Just nextWake, ps', pif') schedule in + runLoop ss' schedule' pendingPre subs reqs acks + ((step, p, inv) : drainInvs ++ invs) step lastTime' + PeerSubmitTxs ks -> + let (ps'', pif'', ss'') = + handleSubmittedTxs time policy p ks [] ps' pif' ss' + postInv = conjoin + [ combinedStateInvariant policy StrongInvariant + (peerSnapshot p ps'' pif'') ss'' + , checkNoThunks + ("peerState'' (peer " ++ show p + ++ ", step " ++ show step ++ ")") + ps'' + , checkNoThunks + ("sharedState'' (peer " ++ show p + ++ ", step " ++ show step ++ ")") + ss'' + ] + others' = reactivateOthers p time schedule + schedule' = Map.insert p (Just time, ps'', pif'') others' + subs' = IntSet.union subs + (IntSet.fromList (unTxKey <$> ks)) in + runLoop ss'' schedule' pendingPre subs' reqs acks + ( (step, p, postInv) : (step, p, inv) + : drainInvs ++ invs ) step lastTime' + PeerRequestTxs ks -> + let bodies = [ mkBody ssPre psPre k | k <- ks ] + pending' = Map.insert p bodies pendingPre + others' = reactivateOthers p time schedule + schedule' = Map.insert p (Just time, ps', pif') others' + reqs' = IntSet.union reqs + (IntSet.fromList (unTxKey <$> ks)) in + runLoop ss' schedule' pending' subs reqs' acks + ((step, p, inv) : drainInvs ++ invs) step lastTime' + PeerRequestTxIds{} -> + let others' = reactivateOthers p time schedule + schedule' = Map.insert p (Just time, ps', pif') others' + acks' = IntSet.union acks ackedNow in + runLoop ss' schedule' pendingPre subs reqs acks' + ((step, p, inv) : drainInvs ++ invs) step lastTime' + +-- Generate a self-consistent local peer view of requested, available, and downloaded txs. +genPeerTxLocalState :: Gen (PeerTxLocalState (Tx TxId)) +genPeerTxLocalState = sized $ \n -> do + let maxKeys = min 12 (n + 2) + + numKeys <- chooseInt (0, maxKeys) + peerRequestedTxIds <- fromIntegral <$> chooseInt (0, min 8 (n + 1)) + peerUnacknowledgedTxIds <- StrictSeq.fromList <$> shuffle [ TxKey key | key <- [0 .. numKeys - 1] ] + + downloadedKeys <- sublistOf (toList peerUnacknowledgedTxIds) + let downloadedSet = + IntSet.fromList [ unTxKey key | key <- downloadedKeys ] + remainingKeys = + [ key + | key <- toList peerUnacknowledgedTxIds + , not (IntSet.member (unTxKey key) downloadedSet) ] + requestedKeys <- sublistOf remainingKeys + let requestedSet = + IntSet.fromList [ unTxKey key | key <- requestedKeys ] + availableExtraCandidates = + [ key + | key <- remainingKeys + , not (IntSet.member (unTxKey key) requestedSet) + ] + availableExtraKeys <- sublistOf availableExtraCandidates --- | Construct decision context in a deterministic way. For micro benchmarks. --- --- It is based on QuickCheck's `arbitrary` instance for `ArbDecisionContexts. --- -mkDecisionContext :: SMGen - -- ^ pseudo random generator - -> Int - -- ^ size - -> (TxDecisionPolicy, SharedTxState PeerAddr TxId (Tx TxId)) -mkDecisionContext stdgen size = - case unGen gen (QCGen stdgen) size of - ArbDecisionContexts { arbDecisionPolicy = policy, - arbSharedState = sharedState - } -> (policy, sharedState) + let availableKeys = requestedKeys <> availableExtraKeys + peerAvailableTxIds <- + IntMap.fromList <$> mapM genAvailableTx availableKeys + + let requestedKeysOrdered = + [ key + | key <- toList peerUnacknowledgedTxIds + , IntSet.member (unTxKey key) requestedSet + ] + (peerRequestedTxBatches, peerRequestedTxsSize) <- + genRequestedTxBatches peerAvailableTxIds requestedKeysOrdered + + peerDownloadedTxs <- + IntMap.fromList <$> mapM genDownloadedTx downloadedKeys + + peerScoreTs <- genSmallTime + -- Generated peer states default to a zero score. + let peerScoreValue = 0 + pure PeerTxLocalState { + peerPhase = PeerIdle, + peerUnacknowledgedTxIds, + peerAvailableTxIds, + peerRequestedTxs = requestedSet, + peerRequestedTxBatches, + peerRequestedTxsSize, + peerRequestedTxIds, + peerDownloadedTxs, + peerDownloadStartTime = Nothing, + peerScore = PeerScore peerScoreValue peerScoreTs + } where - gen :: Gen (ArbDecisionContexts TxId) - gen = arbitrary + genAvailableTx key = do + txSize <- genPositiveSize + pure (unTxKey key, txSize) + genDownloadedTx key = do + txSize <- genPositiveSize + pure (unTxKey key, mkTx (txIdForKey key) txSize) -prop_ArbDecisionContexts_generator - :: ArbDecisionContexts TxId - -> Property -prop_ArbDecisionContexts_generator - ArbDecisionContexts { arbSharedState = st } - = - -- whenFail (pPrint a) $ - sharedTxStateInvariant StrongInvariant st - - -prop_ArbDecisionContexts_shrinker - :: ArbDecisionContexts TxId - -> Every -prop_ArbDecisionContexts_shrinker - ctx - = - foldMap (\a -> - Every - . counterexample (show a) - . sharedTxStateInvariant StrongInvariant - . arbSharedState - $ a) - $ shrink ctx - - --- | Verify that `makeDecisions` preserves the `SharedTxState` invariant. +-- Generate a shared tx state with distinct active and retained entries. -- -prop_makeDecisions_sharedstate - :: ArbDecisionContexts TxId - -> Property -prop_makeDecisions_sharedstate - ArbDecisionContexts { arbDecisionPolicy = policy, - arbSharedState = sharedTxState } = - let (sharedState, decisions) = TXS.makeDecisions policy sharedTxState (peerTxStates sharedTxState) - in counterexample (show sharedState) - $ counterexample (show decisions) - $ sharedTxStateInvariant StrongInvariant sharedState +-- Per-peer state is no longer carried in 'SharedTxState'; tests that +-- exercise multi-peer behaviour pair this generator with a separate +-- 'PeerTxLocalState' for the peer under test. +genSharedTxState :: Gen (SharedTxState PeerAddr TxId) +genSharedTxState = sized $ \n -> do + let maxPeers = min 6 (n + 1) + maxActiveTxs = min 8 (n + 2) + maxRetainedTxs = min 6 (n + 2) + numPeers <- chooseInt (1, max 1 maxPeers) + peeraddrs <- genDistinctPositiveInts numPeers --- | 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, - arbSharedState = sharedTxState - } - = - let (sharedState', decisions) = TXS.makeDecisions policy sharedTxState (peerTxStates sharedTxState) - - inflightSet :: Set TxId - inflightSet = foldMap (Map.keysSet . txdTxsToRequest) decisions - - inflightSize :: Map PeerAddr SizeInBytes - inflightSize = Map.foldrWithKey - (\peer TxDecision { txdTxsToRequest } m -> - Map.insert peer - (foldMap (\txid -> fromMaybe 0 $ Map.lookup peer (peerTxStates sharedTxState) - >>= Map.lookup txid . availableTxIds) - (Map.keysSet txdTxsToRequest)) - m - ) Map.empty decisions - - bufferedSet :: Set TxId - bufferedSet = Map.keysSet (bufferedTxs sharedTxState) - 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 ( Every - . 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 sharedTxState) of - Nothing -> 0 - Just PeerTxState { requestedTxsInflightSize = a } -> a - in Just ( Every - . 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 _ -> - Every $ - counterexample ("peer missing in peerTxStates " ++ show peeraddr) - False)) - (Map.mapMissing (\_ _ -> Every True)) - (Map.zipWithMatched (\peeraddr a b -> Every - . counterexample (show peeraddr) - $ a `Set.isSubsetOf` b)) - -- map of requested txs - (Map.fromList [ (peeraddr, Map.keysSet txids) - | (peeraddr, TxDecision { txdTxsToRequest = txids }) - <- Map.assocs decisions - ]) - -- map of available txs - (Map.map (Map.keysSet . availableTxIds) - (peerTxStates sharedTxState))) - - --- | Verify that `makeTxDecisions` obeys `TxDecisionPolicy`. --- -prop_makeDecisions_policy - :: ArbDecisionContexts TxId - -> Property -prop_makeDecisions_policy - ArbDecisionContexts { - arbDecisionPolicy = policy@TxDecisionPolicy { txsSizeInflightPerPeer, - txInflightMultiplicity }, - arbSharedState = sharedTxState - } = - let (sharedState', _decisions) = TXS.makeDecisions policy sharedTxState (peerTxStates sharedTxState) - txsSizeInflightPerPeerEff = txsSizeInflightPerPeer + maxTxSize - in - -- 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 Every $ counterexample (show (inflight, txsSizeInflightPerPeerEff)) $ - inflight - <= - txsSizeInflightPerPeerEff - ) - (peerTxStates sharedState') - ) + numActiveTxs <- chooseInt (0, maxActiveTxs) + numRetainedTxs <- chooseInt (0, maxRetainedTxs) - .&&. - ( - -- none of the multiplicities should go above the - -- `txInflightMultiplicity` - let inflight = inflightTxs sharedState' - in - counterexample ("multiplicities violation: " ++ show inflight) - . foldMap (Every . (<= txInflightMultiplicity)) - $ inflight - ) + txids <- genDistinctPositiveInts (numActiveTxs + numRetainedTxs) + let (activeTxIds, retainedTxIds) = splitAt numActiveTxs txids + activeEntries <- mapM (genActiveTxEntry peeraddrs) activeTxIds + retainedEntries <- mapM genRetainedEntry retainedTxIds + sharedGeneration <- genSmallWord64 --- | Verify that `makeDecisions` and `acknowledgeTxIds` are compatible. --- -prop_makeDecisions_acknowledged - :: ArbDecisionContexts TxId - -> Property -prop_makeDecisions_acknowledged - ArbDecisionContexts { arbDecisionPolicy = policy, - arbSharedState = sharedTxState - } = - whenFail (pPrintOpt CheckColorTty defaultOutputOptionsDarkBg { outputOptionsCompact = True } sharedTxState) $ - let (_, decisions) = TXS.makeDecisions policy sharedTxState (peerTxStates sharedTxState) - - ackFromDecisions :: Map PeerAddr NumTxIdsToAck - ackFromDecisions = Map.fromList - [ (peer, txdTxIdsToAcknowledge) - | (peer, TxDecision { txdTxIdsToAcknowledge }) - <- Map.assocs decisions - ] - - ackFromState :: Map PeerAddr NumTxIdsToAck - ackFromState = - Map.map (\ps -> case TXS.acknowledgeTxIds policy sharedTxState ps of - (a, _, _, _, _) -> a) - . peerTxStates - $ sharedTxState - - in counterexample (show (ackFromDecisions, ackFromState)) - . fold - $ Map.merge - -- it is an error if `ackFromDecisions` contains a result which is - -- missing in `ackFromState` - (Map.mapMissing (\addr num -> Every $ 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 -> Every (d === 0))) - -- if both entries exists they must be equal - (Map.zipWithMatched (\_ a b -> Every (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, - arbSharedState = sharedTxState - } - = - let (sharedTxState', decisions') - = TXS.makeDecisions policy - sharedTxState - (peerTxStates sharedTxState) - (sharedTxState'', decisions'') - = TXS.makeDecisions policy - sharedTxState' - (peerTxStates sharedTxState') - in counterexample ("decisions': " ++ show decisions') - . counterexample ("state': " ++ show sharedTxState') - . counterexample ("decisions'': " ++ show decisions'') - . counterexample ("state'': " ++ show sharedTxState'') - $ null decisions'' - - -data ArbDecisionContextWithReceivedTxIds = ArbDecisionContextWithReceivedTxIds { - adcrDecisionPolicy :: TxDecisionPolicy, - adcrSharedState :: SharedTxState 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 + pure $ buildSharedTxState activeEntries retainedEntries sharedGeneration + where + genRetainedEntry txid = do + retainUntil <- genSharedExpiryTime + pure (txid, retainUntil) + +-- Generate one active tx entry using a mix of leased and claimable shapes. +genActiveTxEntry :: [PeerAddr] -> TxId -> Gen (TxId, TxEntry PeerAddr) +genActiveTxEntry peeraddrs txid = do + txEntry <- frequency + [ (5, genLeasedTxEntry peeraddrs) + , (3, genClaimableTxEntry) + ] + pure (txid, txEntry) + +-- Generate a leased entry where the owner may also be in submission. +genLeasedTxEntry :: [PeerAddr] -> Gen (TxEntry PeerAddr) +genLeasedTxEntry peeraddrs = do + owner <- elements peeraddrs + txLease <- TxLeased owner <$> genSharedExpiryTime + inSub <- frequency [(2, pure False), (1, pure True)] + pure TxEntry { + txLease, + txAttempt = if inSub then 0 else 1, + txInSubmission = inSub, + currentMaxInflightMultiplicity = + txInflightMultiplicity defaultTxDecisionPolicy } - 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 - - downTxsNum <- choose (0, length txIdsToAck') - let downloadedTxs = Foldable.foldl' pruneTx Map.empty $ take downTxsNum $ Map.toList (bufferedTxs st') - ps'' = ps' { downloadedTxs = downloadedTxs } - - return ArbDecisionContextWithReceivedTxIds { - adcrDecisionPolicy = policy, - adcrSharedState = st', - adcrPeerTxState = ps'', - adcrMempoolHasTx = mempoolHasTx, - adcrTxsToAck = txIdsToAck', - adcrPeerAddr = peeraddr - } - where - pruneTx :: Map TxId tx -> (TxId, Maybe tx) -> Map TxId tx - pruneTx m (_, Nothing) = m - pruneTx m (txid, Just tx) = Map.insert txid tx m - - shrink ArbDecisionContextWithReceivedTxIds { - adcrDecisionPolicy = policy, - adcrSharedState = st, - adcrPeerTxState = ps, - adcrMempoolHasTx = mempoolHasTx, - adcrTxsToAck = txIdsToAck, - adcrPeerAddr = peeraddr - } - = - [ ArbDecisionContextWithReceivedTxIds { - adcrDecisionPolicy = policy', - adcrSharedState = st', - adcrPeerTxState = ps, - adcrMempoolHasTx = mempoolHasTx', - adcrTxsToAck = txIdsToAck', - adcrPeerAddr = peeraddr - } - | ArbDecisionContexts { - arbDecisionPolicy = policy', - arbSharedState = st', - arbMempoolHasTx = mempoolHasTx' - } - <- shrink ArbDecisionContexts { - arbDecisionPolicy = policy, - arbSharedState = st, - arbMempoolHasTx = mempoolHasTx - } - , peeraddr `Map.member` peerTxStates st' - , let txIdsToAck' = take ( fromIntegral - . TXS.requestedTxIdsInflight - $ peerTxStates st' Map.! peeraddr - ) - txIdsToAck - ] +-- Generate a claimable entry with no in-flight attempt. +genClaimableTxEntry :: Gen (TxEntry PeerAddr) +genClaimableTxEntry = do + claimableAt <- genSharedExpiryTime + pure TxEntry { + txLease = TxClaimable claimableAt, + txAttempt = 0, + txInSubmission = False, + currentMaxInflightMultiplicity = + txInflightMultiplicity defaultTxDecisionPolicy + } --- | `filterActivePeers` should not change decisions made by `makeDecisions` --- -prop_filterActivePeers_not_limitting_decisions - :: ArbDecisionContexts TxId - -> Property -prop_filterActivePeers_not_limitting_decisions - ArbDecisionContexts { - arbDecisionPolicy = policy, - arbSharedState = st +-- Rebuild a shared state from tx-centric fixtures while preserving interned keys. +buildSharedTxState + :: [(TxId, TxEntry PeerAddr)] + -> [(TxId, Time)] + -> Word64 + -> SharedTxState PeerAddr TxId +buildSharedTxState activeEntries retainedEntries sharedGeneration = + baseState { + sharedTxTable = + IntMap.fromList + [ (unTxKey (lookupKeyOrFail txid baseState), txEntry) + | (txid, txEntry) <- activeEntries + ], + sharedRetainedTxs = + retainedFromList + [ (unTxKey (lookupKeyOrFail txid baseState), retainUntil) + | (txid, retainUntil) <- retainedEntries + ], + sharedGeneration } - = - counterexample (unlines - ["decisions: " ++ show decisions - ," " ++ show decisionPeers - ,"active decisions: " ++ show decisionsOfActivePeers - ," " ++ show activePeers]) $ - - counterexample ("active peers does not restrict the total number of valid decisions available" - ++ show (decisionsOfActivePeers Map.\\ decisions) - ) - (Map.keysSet decisionsOfActivePeers `Set.isSubsetOf` Map.keysSet decisions) where - activePeersMap = TXS.filterActivePeers policy st - activePeers = Map.keysSet activePeersMap - (_, decisionsOfActivePeers) - = TXS.makeDecisions policy st activePeersMap + baseState = + mkSharedState (fmap fst activeEntries <> fmap fst retainedEntries) + +-- Shrink shared state by dropping active or retained txs. +shrinkSharedTxState + :: SharedTxState PeerAddr TxId + -> [SharedTxState PeerAddr TxId] +shrinkSharedTxState sharedState = + nub $ + [ emptySharedTxState + , buildSharedTxState [] retainedEntries 0 + , buildSharedTxState activeEntries [] 0 + ] ++ + [ buildSharedTxState activeEntries' retainedEntries 0 + | activeEntries' <- smallerActiveEntries + ] ++ + [ buildSharedTxState activeEntries retainedEntries' 0 + | retainedEntries' <- smallerRetainedEntries + ] + where + activeEntries = + [ (resolveTxKey sharedState (TxKey k), txEntry) + | (k, txEntry) <- IntMap.toList (sharedTxTable sharedState) + ] + retainedEntries = + [ (resolveTxKey sharedState (TxKey k), retainUntil) + | (k, retainUntil) <- retainedToList (sharedRetainedTxs sharedState) + ] + smallerActiveEntries = + take 6 + [ activeEntries' + | activeEntries' <- shrinkList (const []) activeEntries + , length activeEntries' < length activeEntries + ] + smallerRetainedEntries = + take 6 + [ retainedEntries' + | retainedEntries' <- shrinkList (const []) retainedEntries + , length retainedEntries' < length retainedEntries + ] - (_, decisions) = TXS.makeDecisions policy st (peerTxStates st) - decisionPeers = Map.keysSet decisions +-- Partition requested keys into a small number of contiguous request batches. +genRequestedTxBatches + :: IntMap.IntMap SizeInBytes + -> [TxKey] + -> Gen (StrictSeq.StrictSeq RequestedTxBatch, SizeInBytes) +genRequestedTxBatches _ [] = + pure (StrictSeq.empty, 0) +genRequestedTxBatches peerAvailableTxIds requestedKeys = do + batchCount <- chooseInt (1, min 3 (length requestedKeys)) + batchLengths <- genPositivePartition (length requestedKeys) batchCount + let batches = + [ mkRequestedTxBatch keys (sum [ lookupAvailableTxSize key | key <- keys ]) + | keys <- splitByLengths batchLengths requestedKeys + ] + peerRequestedTxsSize = + sum [ requestedTxBatchSize batch | batch <- batches ] + pure (StrictSeq.fromList batches, peerRequestedTxsSize) + where + lookupAvailableTxSize key = + case IntMap.lookup (unTxKey key) peerAvailableTxIds of + Just txSize -> txSize + Nothing -> error "TxLogic.genRequestedTxBatches: missing requested tx size" + +-- Split a positive total into a fixed number of positive parts. +genPositivePartition :: Int -> Int -> Gen [Int] +genPositivePartition totalCount 1 = + pure [totalCount] +genPositivePartition totalCount parts = do + n <- chooseInt (1, totalCount - parts + 1) + (n :) <$> genPositivePartition (totalCount - n) (parts - 1) + +-- Split a list according to a list of chunk lengths. +splitByLengths :: [Int] -> [a] -> [[a]] +splitByLengths [] [] = [] +splitByLengths [] _ = [] +splitByLengths (n : ns) xs = + let (prefix, suffix) = splitAt n xs in + prefix : splitByLengths ns suffix + +-- Generate distinct positive ints from a bounded shuffled range. +genDistinctPositiveInts :: Int -> Gen [Int] +genDistinctPositiveInts count + | count <= 0 = pure [] + | otherwise = take count <$> shuffle [1 .. max count (count * 4 + 5)] + +-- Generate expiry times near the shared test reference time. +genSharedExpiryTime :: Gen Time +genSharedExpiryTime = + Time . fromIntegral <$> chooseInt (80, 120) + +-- Generate a positive tx size +genPositiveSize :: Gen SizeInBytes +genPositiveSize = + fromIntegral <$> chooseInt (1, fromIntegral $ getSizeInBytes max_TX_SIZE) + +-- Generate a small test timestamp. +genSmallTime :: Gen Time +genSmallTime = + Time . fromIntegral <$> chooseInt (0, 1000) + +-- Generate a small test generation counter. +genSmallWord64 :: Gen Word64 +genSmallWord64 = + fromIntegral <$> chooseInt (0, 1000) + +-- Recover the fixture txid associated with an interned key. +txIdForKey :: TxKey -> TxId +txIdForKey (TxKey key) = key + 1 + +-- Fixed reference time used by deterministic test fixtures. +now :: Time +now = Time 100 + +-- Convert a positive QuickCheck value into a bounded non-zero tx size. +mkSize :: Positive Int -> SizeInBytes +mkSize (Positive n) = fromIntegral ((n `mod` 65535) + 1) + +-- Render a count into a coarse bucket label for QuickCheck's 'tabulate'. +bucket :: Int -> String +bucket n + | n <= 0 = "0" + | n == 1 = "1" + | n <= 5 = "2-5" + | n <= 10 = "6-10" + | n <= 25 = "11-25" + | n <= 100 = "26-100" + | otherwise = "100+" + +-- Build a valid test transaction with matching body and advertised size. +mkTx :: TxId -> SizeInBytes -> Tx TxId +mkTx txid txSize = Tx + { getTxId = txid + , getTxSize = txSize + , getTxAdvSize = txSize + , getTxValid = True + , getTxParent = Nothing + } +-- Intern a list of txids into an otherwise empty shared state. +mkSharedState :: [TxId] -> SharedTxState PeerAddr TxId +mkSharedState txids = snd (internTxIds txids emptySharedTxState) --- 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. +-- Construct a requested batch together with its cached key set. +mkRequestedTxBatch :: [TxKey] -> SizeInBytes -> RequestedTxBatch +mkRequestedTxBatch keys requestedTxBatchSize = RequestedTxBatch + { requestedTxBatchSet = IntSet.fromList (map unTxKey keys) + , requestedTxBatchSize + } --- --- Auxiliary functions --- +-- Look up an interned key and fail fast in test setup code. +lookupKeyOrFail :: TxId -> SharedTxState PeerAddr TxId -> TxKey +lookupKeyOrFail txid st = + case lookupTxKey txid st of + Just txKey -> txKey + Nothing -> error "TxLogic.lookupKeyOrFail: missing tx key" + +-- Look up an active tx entry and fail fast in test setup code. +lookupEntryOrFail :: TxKey -> SharedTxState PeerAddr TxId -> TxEntry PeerAddr +lookupEntryOrFail (TxKey k) st = + case IntMap.lookup k (sharedTxTable st) of + Just txEntry -> txEntry + Nothing -> error "TxLogic.lookupEntryOrFail: missing tx entry" + +-- Intern the given txids into the shared state and seed each into +-- sharedRetainedTxs. +seedRetainedTxids + :: TxDecisionPolicy + -> [(TxId, SizeInBytes)] + -> SharedTxState PeerAddr TxId + -> SharedTxState PeerAddr TxId +seedRetainedTxids policy entries st0 = + stInterned { + sharedRetainedTxs = + foldl' (\r k -> retainedInsertMax k retainUntil r) + (sharedRetainedTxs stInterned) + retainedKeys + } + where + retainUntil = addTime (bufferedTxsMinLifetime policy) now + (_, stInterned) = internTxIds (fmap fst entries) st0 + retainedKeys = [ unTxKey (lookupKeyOrFail txid stInterned) + | (txid, _) <- entries + ] + +mkReceiveDuplicateFixture :: Int -> Int -> ReceiveDuplicateFixture +mkReceiveDuplicateFixture existingAdvertisers txidCount = + ReceiveDuplicateFixture + { rdfPeerAddr = targetPeer + , rdfRequestedTxIds = fromIntegral txidCount + , rdfTxidsAndSizes = txidsAndSizes + , rdfPeerState = + emptyPeerTxLocalState { + peerRequestedTxIds = fromIntegral txidCount + } + , rdfSharedState = + mkActiveSharedState allPeers ownerPeer existingPeers txidsAndSizes + } + where + ownerPeer = 0 + targetPeer = existingAdvertisers + existingPeers = [1 .. existingAdvertisers - 1] + allPeers = ownerPeer : targetPeer : existingPeers + txidsAndSizes = mkTxidsAndSizes txidCount + +-- Prebuild an ack-only workload after all advertised txs have resolved into +-- retained entries. +mkResolvedAckFixture :: Int -> Int -> PeerActionFixture +mkResolvedAckFixture advertiserCount txidCount = + PeerActionFixture + { pafPeerAddr = targetPeer + , pafPeerState = + emptyPeerTxLocalState { + peerUnacknowledgedTxIds = StrictSeq.fromList txKeys + } + , pafSharedState = sharedState + } + where + ownerPeer = 0 + targetPeer = 1 + otherPeers = [2 .. advertiserCount - 1] + allPeers = [0 .. advertiserCount - 1] + txidsAndSizes = mkTxidsAndSizes txidCount + sharedState0 = + mkActiveSharedState allPeers ownerPeer (targetPeer : otherPeers) txidsAndSizes + sharedState = retainAllActiveTxs sharedState0 + txKeys = fmap (`lookupKeyOrFail` sharedState0) (fmap fst txidsAndSizes) + +-- | Compatibility alias for the previous benchmark helper name. +mkForeignRejectedFixture :: Int -> Int -> PeerActionFixture +mkForeignRejectedFixture = mkResolvedAckFixture + +mkFanoutFixture :: Int -> Int -> FanoutFixture +mkFanoutFixture peerCount txidCount = + FanoutFixture + { ffPeers = peers + , ffRequestedTxIds = fromIntegral txidCount + , ffTxidsAndSizes = txidsAndSizes + , ffInitialSharedState = + mkActiveSharedState allPeers ownerPeer [] txidsAndSizes + } + where + ownerPeer = 0 + peers = [1 .. peerCount] + allPeers = ownerPeer : peers + txidsAndSizes = mkTxidsAndSizes txidCount + +runReceiveDuplicateLoop :: Int -> ReceiveDuplicateFixture -> IO () +runReceiveDuplicateLoop iterations ReceiveDuplicateFixture + { rdfRequestedTxIds + , rdfTxidsAndSizes + , rdfPeerState + , rdfSharedState + } = + go iterations + where + go 0 = pure () + go n = do + let result = + handleReceivedTxIds + (const False) + now + defaultTxDecisionPolicy + rdfRequestedTxIds + rdfTxidsAndSizes + rdfPeerState + emptyPeerTxInFlight + rdfSharedState + _ <- evaluate (rnf result) + go (n - 1) + +runPeerActionLoop :: Int -> PeerActionFixture -> IO () +runPeerActionLoop iterations PeerActionFixture + { pafPeerAddr + , pafPeerState + , pafSharedState + } = + go iterations + where + go 0 = pure () + go n = do + let result = + nextPeerAction now defaultTxDecisionPolicy pafPeerAddr + pafPeerState emptyPeerTxInFlight pafSharedState + _ <- evaluate (rnf result) + go (n - 1) + +runFanoutLoop :: Int -> FanoutFixture -> IO () +runFanoutLoop iterations FanoutFixture + { ffPeers + , ffRequestedTxIds + , ffTxidsAndSizes + , ffInitialSharedState + } = + go iterations + where + go 0 = pure () + go n = do + _ <- evaluate (rnf roundResult) + go (n - 1) + + roundResult = + let (!peerStatesRev, !sharedStateAfterReceive) = + foldl' receiveOne ([], ffInitialSharedState) ffPeers + !sharedStateResolved = retainAllActiveTxs sharedStateAfterReceive + (!ackResultsRev, !sharedStateAfterAck) = + foldl' acknowledgeOne ([], sharedStateResolved) (reverse peerStatesRev) + in (reverse peerStatesRev, reverse ackResultsRev, sharedStateAfterAck) + + receiveOne + :: ([(PeerAddr, PeerTxLocalState (Tx TxId), PeerTxInFlight)], SharedTxState PeerAddr TxId) + -> PeerAddr + -> ([(PeerAddr, PeerTxLocalState (Tx TxId), PeerTxInFlight)], SharedTxState PeerAddr TxId) + receiveOne (!peerStatesAcc, !sharedStateAcc) peeraddr = + let peerState0 = + emptyPeerTxLocalState { + peerRequestedTxIds = ffRequestedTxIds + } + !(peerState', peerInFlight', sharedStateAcc') = + handleReceivedTxIds + (const False) + now + defaultTxDecisionPolicy + ffRequestedTxIds + ffTxidsAndSizes + peerState0 + emptyPeerTxInFlight + sharedStateAcc + in ((peeraddr, peerState', peerInFlight') : peerStatesAcc, sharedStateAcc') + + acknowledgeOne + :: ([(PeerAddr, PeerAction, PeerTxLocalState (Tx TxId))], SharedTxState PeerAddr TxId) + -> (PeerAddr, PeerTxLocalState (Tx TxId), PeerTxInFlight) + -> ([(PeerAddr, PeerAction, PeerTxLocalState (Tx TxId))], SharedTxState PeerAddr TxId) + acknowledgeOne (!ackResultsAcc, !sharedStateAcc) (peeraddr, peerState0, peerInFlight0) = + let !(peerAction, peerState', _peerInFlight', sharedStateAcc') = + nextPeerAction now defaultTxDecisionPolicy peeraddr + peerState0 peerInFlight0 sharedStateAcc + in ( (peeraddr, peerAction, peerState') : ackResultsAcc + , sharedStateAcc' + ) + +mkTxidsAndSizes :: Int -> [(TxId, SizeInBytes)] +mkTxidsAndSizes count = + [ (txid, fromIntegral (128 + txid)) + | txid <- [1 .. count] + ] + +mkActiveSharedState + :: [PeerAddr] + -> PeerAddr + -> [PeerAddr] + -> [(TxId, SizeInBytes)] + -> SharedTxState PeerAddr TxId +mkActiveSharedState _allPeers ownerPeer _resolvedAdvertisers txidsAndSizes = + sharedState1 { + sharedTxTable = + IntMap.fromList + [ (unTxKey txKey, mkEntry txKey) + | (txid, _txSize) <- txidsAndSizes + , let txKey = lookupKeyOrFail txid sharedState1 + ] + } + where + sharedState0 = emptySharedTxState + sharedState1 = snd (internTxIds (fmap fst txidsAndSizes) sharedState0) + + mkEntry _txKey = TxEntry + { txLease = TxLeased ownerPeer (addTime 10 now) + , txAttempt = 1 + , txInSubmission = False + , currentMaxInflightMultiplicity = + txInflightMultiplicity defaultTxDecisionPolicy + } + +-- Resolve all active txs into retained entries so non-owner peers may safely +-- acknowledge their txids. +retainAllActiveTxs :: SharedTxState PeerAddr TxId -> SharedTxState PeerAddr TxId +retainAllActiveTxs st@SharedTxState { sharedTxTable, sharedRetainedTxs, sharedGeneration } = + st { + sharedTxTable = IntMap.empty, + sharedRetainedTxs = IntMap.foldlWithKey' retainOne sharedRetainedTxs sharedTxTable, + sharedGeneration = sharedGeneration + 1 + } + where + retainUntil = addTime (bufferedTxsMinLifetime defaultTxDecisionPolicy) now -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 ++ ")" + retainOne retainedAcc k _ = + retainedInsertMax k retainUntil retainedAcc diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Types.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Types.hs index 3692779c74f..daf22597c05 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Types.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Types.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveAnyClass #-} @@ -17,6 +18,7 @@ module Test.Ouroboros.Network.TxSubmission.Types , readMempool , getMempoolReader , getMempoolWriter + , InvalidTx (..) , maxTxSize , LargeNonEmptyList (..) , SimResults (..) @@ -31,6 +33,7 @@ import Prelude hiding (seq) import NoThunks.Class import Control.Concurrent.Class.MonadSTM +import Control.Concurrent.Class.MonadSTM.Strict qualified as StrictSTM import Control.DeepSeq import Control.Exception (SomeException (..)) import Control.Monad.Class.MonadAsync @@ -47,7 +50,13 @@ import Codec.CBOR.Decoding qualified as CBOR import Codec.CBOR.Encoding qualified as CBOR import Codec.CBOR.Read qualified as CBOR +import Data.Bits (shiftR) import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Short qualified as SBS +import Data.Either (partitionEithers) +import Data.List qualified as List +import Data.Sequence qualified as Seq +import Data.Set qualified as Set import Data.Typeable (Typeable) import GHC.Generics (Generic) @@ -55,6 +64,7 @@ import Network.TypedProtocol.Codec import Ouroboros.Network.Protocol.TxSubmission2.Codec import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.Tx (HasRawTxId (..), RawTxId (..)) import Ouroboros.Network.TxSubmission.Inbound.V1 import Ouroboros.Network.TxSubmission.Mempool.Reader import Ouroboros.Network.TxSubmission.Mempool.Simple (Mempool) @@ -72,7 +82,12 @@ data Tx txid = Tx { -- | 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, + -- | Optional parent dependency: this tx may only be accepted into a + -- mempool once its parent is already present (either from an earlier + -- batch or earlier in the same batch). 'Nothing' means no dependency. + -- Used by chain-aware tests to model transaction chains. + getTxParent :: !(Maybe txid) } deriving (Eq, Ord, Show, Generic, NFData) @@ -95,6 +110,9 @@ instance Arbitrary txid => Arbitrary (Tx txid) where <*> frequency [ (3, pure True) , (1, pure False) ] + <*> pure Nothing + -- ^ Generic Arbitrary produces standalone txs with no parent. + -- Chain-aware generators construct parents explicitly. -- maximal tx size maxTxSize :: SizeInBytes @@ -102,6 +120,9 @@ maxTxSize = 65536 type TxId = Int +instance HasRawTxId Int where + getRawTxId n = RawTxId (SBS.pack [ fromIntegral (n `shiftR` (i * 8)) | i <- [7, 6 .. 0] ]) + emptyMempool :: MonadSTM m => m (Mempool m txid (Tx txid)) emptyMempool = Mempool.empty @@ -122,7 +143,7 @@ getMempoolReader :: forall txid m. getMempoolReader = Mempool.getReader getTxId getTxAdvSize -data InvalidTx = InvalidTx | DuplicateTx +data InvalidTx = InvalidTx | DuplicateTx | MissingParent deriving (Eq, Show) getMempoolWriter :: forall txid m. @@ -137,18 +158,90 @@ getMempoolWriter :: forall txid m. => TVar m [txid] -> Mempool m txid (Tx txid) -> TxSubmissionMempoolWriter txid (Tx txid) Integer m InvalidTx -getMempoolWriter duplicateVar = - Mempool.getWriter DuplicateTx - getTxId - (\_ txs -> return - [ if getTxValid tx - then Right tx - else Left (getTxId tx, InvalidTx) - | tx <- txs - ] - ) - (\t -> atomically $ modifyTVar' duplicateVar - (map fst (filter ((== DuplicateTx) . snd) t) <>)) +getMempoolWriter duplicateVar (Mempool.Mempool mempoolVar) = + TxSubmissionMempoolWriter { + txId = getTxId, + mempoolAddTxs = \txs -> do + (acceptedTxs, rejectedTxs, duplicateValidTxIds) <- atomically $ do + Mempool.MempoolSeq { Mempool.mempoolSet, Mempool.mempoolSeq, Mempool.nextIdx } <- + StrictSTM.readTVar mempoolVar + + let (duplicateTxs, txsToValidate) = + List.partition (\tx -> getTxId tx `Set.member` mempoolSet) txs + duplicateRejectedTxs = + [ (getTxId tx, DuplicateTx) + | tx <- duplicateTxs + ] + duplicateValidTxIds = + [ getTxId tx + | tx <- duplicateTxs + , getTxValid tx + ] + (invalidRejectedTxs, validTxs) = + partitionEithers + [ if getTxValid tx + then Right tx + else Left (getTxId tx, InvalidTx) + | tx <- txsToValidate + ] + + (delta, mempoolSeq', nextIdx', acceptedTxs, duplicateValidTxIds', missingParentIds) = + List.foldl' + (\(set, seq, idx, accepted, duplicates, missing) tx -> + let txid = getTxId tx in + if txid `Set.member` set + then ( set + , seq + , idx + , accepted + , txid : duplicates + , missing + ) + else case getTxParent tx of + Just p + | not (p `Set.member` set) + && not (p `Set.member` mempoolSet) -> + -- Parent is not in the mempool and has not + -- been accepted earlier in this batch. + ( set + , seq + , idx + , accepted + , duplicates + , txid : missing + ) + _ -> + ( Set.insert txid set + , seq Seq.|> Mempool.WithIndex idx tx + , succ idx + , txid : accepted + , duplicates + , missing + ) + ) + (Set.empty, mempoolSeq, nextIdx, [], [], []) + validTxs + + StrictSTM.writeTVar + mempoolVar + Mempool.MempoolSeq { + Mempool.mempoolSet = mempoolSet `Set.union` delta, + Mempool.mempoolSeq = mempoolSeq', + Mempool.nextIdx = nextIdx' + } + + pure + ( acceptedTxs + , invalidRejectedTxs + ++ duplicateRejectedTxs + ++ [ (txid, DuplicateTx) | txid <- duplicateValidTxIds' ] + ++ [ (txid, MissingParent) | txid <- missingParentIds ] + , duplicateValidTxIds ++ duplicateValidTxIds' + ) + + atomically $ modifyTVar' duplicateVar (duplicateValidTxIds <>) + pure (acceptedTxs, rejectedTxs) + } txSubmissionCodec2 :: MonadST m @@ -158,12 +251,13 @@ txSubmissionCodec2 = codecTxSubmission2 CBOR.encodeInt CBOR.decodeInt encodeTx decodeTx where - encodeTx Tx {getTxId, getTxSize, getTxAdvSize, getTxValid} = - CBOR.encodeListLen 4 + encodeTx Tx {getTxId, getTxSize, getTxAdvSize, getTxValid, getTxParent} = + CBOR.encodeListLen 5 <> CBOR.encodeInt getTxId <> CBOR.encodeWord32 (getSizeInBytes getTxSize) <> CBOR.encodeWord32 (getSizeInBytes getTxAdvSize) <> CBOR.encodeBool getTxValid + <> encodeMaybeInt getTxParent decodeTx = do _ <- CBOR.decodeListLen @@ -171,6 +265,17 @@ txSubmissionCodec2 = <*> (SizeInBytes <$> CBOR.decodeWord32) <*> (SizeInBytes <$> CBOR.decodeWord32) <*> CBOR.decodeBool + <*> decodeMaybeInt + + encodeMaybeInt Nothing = CBOR.encodeListLen 0 + encodeMaybeInt (Just i) = CBOR.encodeListLen 1 <> CBOR.encodeInt i + + decodeMaybeInt = do + n <- CBOR.decodeListLen + case n of + 0 -> pure Nothing + 1 -> Just <$> CBOR.decodeInt + _ -> fail "decodeMaybeInt: unexpected list length" newtype LargeNonEmptyList a = LargeNonEmpty { getLargeNonEmpty :: [a] } diff --git a/ouroboros-network/tracing/Ouroboros/Network/Tracing/TxSubmission.hs b/ouroboros-network/tracing/Ouroboros/Network/Tracing/TxSubmission.hs index d0465d13579..5bdbf5e7362 100644 --- a/ouroboros-network/tracing/Ouroboros/Network/Tracing/TxSubmission.hs +++ b/ouroboros-network/tracing/Ouroboros/Network/Tracing/TxSubmission.hs @@ -4,11 +4,9 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Network.Tracing.TxSubmission () where -import Control.Arrow -import Control.Monad.Class.MonadTime.SI import Data.Aeson +import Data.IntMap.Strict qualified as IntMap import Data.Map.Strict qualified as Map -import Data.Set qualified as Set import Cardano.Logging import Ouroboros.Network.TxSubmission.Inbound.V2.Types @@ -17,65 +15,100 @@ instance (Show txid, Show peeraddr) => LogFormatting (TraceTxLogic peeraddr txid forMachine dtal (TraceSharedTxState label SharedTxState {..}) = mconcat $ [ "kind" .= String "TraceSharedTxState" , "label" .= label - , "inflightTxs" .= (fmap (first show) . Map.toList $ inflightTxs) - , "bufferedTxs" .= (fmap show . Set.toList . Map.keysSet $ bufferedTxs) - , "timedTxs" .= (fmap (\(Time t, txids) -> (t, fmap show txids)) . Map.toList $ timedTxs) - , "inSubmissionToMempoolTxs" .= (fmap (first show) . Map.toList $ inSubmissionToMempoolTxs) + , "sharedGeneration" .= sharedGeneration + , "activeTxCount" .= IntMap.size sharedTxTable + , "retainedTxCount" .= retainedSize sharedRetainedTxs + , "internedTxCount" .= Map.size sharedTxIdToKey + , "leasedTxCount" .= leasedTxCount + , "claimableTxCount" .= claimableTxCount + , "totalAttemptCount" .= totalAttemptCount + , "submittingTxCount" .= submittingTxCount ] ++ more where + activeEntries = IntMap.elems sharedTxTable + + leasedTxCount = + length [ () | TxEntry { txLease = TxLeased _ _ } <- activeEntries ] + + claimableTxCount = + length [ () | TxEntry { txLease = TxClaimable _ } <- activeEntries ] + + totalAttemptCount = + sum [ txAttempt entry | entry <- activeEntries ] + + submittingTxCount = + length [ () | TxEntry { txInSubmission = True } <- activeEntries ] + + renderTxId txKey = + maybe "" show (IntMap.lookup txKey sharedKeyToTxId) + more = case dtal of DMaximum -> - [ "peerTxStates" .= (fmap (first show) . Map.toList $ inflightTxs) - , "referenceCounts" .= (fmap (first show) . Map.toList $ referenceCounts) + [ "sharedTxTable" .= [ (renderTxId txKey, show txEntry) + | (txKey, txEntry) <- IntMap.toList sharedTxTable + ] + , "sharedRetainedTxs" .= [ (renderTxId txKey, show retainUntil) + | (txKey, retainUntil) <- retainedToList sharedRetainedTxs + ] + , "internedTxIds" .= fmap show (Map.keys sharedTxIdToKey) ] _otherwise -> [] - forMachine dtal (TraceTxDecisions decisionMap) = - ("kind" .= String "TraceTxDecisions") - <> case dtal of - DMaximum -> "decisions" .= - let g (TxsToMempool txs) = map (show . fst) txs - f TxDecision {..} = - [( fromIntegral txdTxIdsToAcknowledge :: Int, fromIntegral txdTxIdsToRequest :: Int - , map (first show) . Map.toList $ txdTxsToRequest, g txdTxsToMempool)] - in map (\(peer, decision) -> (show peer, f decision)) . Map.toList $ decisionMap - _otherwise -> - let f TxDecision {..} = txdTxIdsToAcknowledge == 0 && txdTxIdsToRequest == 0 && - Map.null txdTxsToRequest - in "decision-count" .= Map.size (Map.filter (not . f) decisionMap) - instance MetaTrace (TraceTxLogic peeraddr txid tx) where namespaceFor TraceSharedTxState {} = Namespace [] ["TraceSharedTxState"] - namespaceFor TraceTxDecisions {} = - Namespace [] ["TraceTxDecisions"] severityFor _ _ = Just Debug documentFor (Namespace [] ["TraceSharedTxState"]) = - Just "Internal bookkeeping of tx-submission shared state for determining fetch decisions" + Just "Internal bookkeeping of tx-submission shared state for peer coordination" documentFor _ = Nothing allNamespaces = [ - Namespace [] ["TraceSharedTxState"], - Namespace [] ["TraceTxDecisions"] + Namespace [] ["TraceSharedTxState"] ] instance LogFormatting TxSubmissionCounters where forMachine _dtal TxSubmissionCounters {..} = mconcat [ "kind" .= String "TxSubmissionCounters" - , "numOfOutstandingTxIds" .= numOfOutstandingTxIds - , "numOfBufferedTxs" .= numOfBufferedTxs - , "numOfInSubmissionToMempoolTxs" .= numOfInSubmissionToMempoolTxs - , "numOfTxIdsInflight" .= numOfTxIdsInflight + , "txIdMessagesSent" .= txIdMessagesSent + , "txIdsRequested" .= txIdsRequested + , "txIdRepliesReceived" .= txIdRepliesReceived + , "txIdsReceived" .= txIdsReceived + , "txMessagesSent" .= txMessagesSent + , "txsRequested" .= txsRequested + , "txRepliesReceived" .= txRepliesReceived + , "txsReceived" .= txsReceived + , "txsOmitted" .= txsOmitted + , "lateBodies" .= lateBodies + , "txsAccepted" .= txsAccepted + , "txsRejected" .= txsRejected + , "txIdBlockingReqsSent" .= txIdBlockingReqsSent + , "txIdPipelinedReqsSent" .= txIdPipelinedReqsSent + , "txIdBlockingWaitMs" .= txIdBlockingWaitMs + , "txPipelineWaitMs" .= txPipelineWaitMs + , "txSubmissionWaitMs" .= txSubmissionWaitMs ] asMetrics TxSubmissionCounters {..} = - [ IntM "txSubmission.numOfOutstandingTxIds" (fromIntegral numOfOutstandingTxIds) - , IntM "txSubmission.numOfBufferedTxs" (fromIntegral numOfBufferedTxs) - , IntM "txSubmission.numOfInSubmissionToMempoolTxs" (fromIntegral numOfInSubmissionToMempoolTxs) - , IntM "txSubmission.numOfTxIdsInflight" (fromIntegral numOfTxIdsInflight) + [ IntM "txSubmission.txIdMessagesSent" (fromIntegral txIdMessagesSent) + , IntM "txSubmission.txIdsRequested" (fromIntegral txIdsRequested) + , IntM "txSubmission.txIdRepliesReceived" (fromIntegral txIdRepliesReceived) + , IntM "txSubmission.txIdsReceived" (fromIntegral txIdsReceived) + , IntM "txSubmission.txMessagesSent" (fromIntegral txMessagesSent) + , IntM "txSubmission.txsRequested" (fromIntegral txsRequested) + , IntM "txSubmission.txRepliesReceived" (fromIntegral txRepliesReceived) + , IntM "txSubmission.txsReceived" (fromIntegral txsReceived) + , IntM "txSubmission.txsOmitted" (fromIntegral txsOmitted) + , IntM "txSubmission.lateBodies" (fromIntegral lateBodies) + , IntM "txSubmission.txsAccepted" (fromIntegral txsAccepted) + , IntM "txSubmission.txsRejected" (fromIntegral txsRejected) + , IntM "txSubmission.txIdBlockingReqsSent" (fromIntegral txIdBlockingReqsSent) + , IntM "txSubmission.txIdPipelinedReqsSent" (fromIntegral txIdPipelinedReqsSent) + , IntM "txSubmission.txIdBlockingWaitMs" (fromIntegral txIdBlockingWaitMs) + , IntM "txSubmission.txPipelineWaitMs" (fromIntegral txPipelineWaitMs) + , IntM "txSubmission.txSubmissionWaitMs" (fromIntegral txSubmissionWaitMs) ] instance MetaTrace TxSubmissionCounters where @@ -86,10 +119,23 @@ instance MetaTrace TxSubmissionCounters where documentFor _ = Nothing metricsDocFor (Namespace [] ["Counters"]) = - [ ("txSubmission.numOfOutstandingTxIds", "txid's which are not yet downloaded") - , ("txSubmission.numOfBufferedTxs", "tx's which have been recently successfully applied to the mempool") - , ("txSubmission.numOfInSubmissionToMempoolTxs", "number of all tx's which are enqueued to the mempool") - , ("txSubmission.numOfTxIdsInflight", "number of all in-flight txid's") + [ ("txSubmission.txIdMessagesSent", "number of txid request messages sent") + , ("txSubmission.txIdsRequested", "number of txids requested from remote peers") + , ("txSubmission.txIdRepliesReceived", "number of txid reply messages received") + , ("txSubmission.txIdsReceived", "number of txids received in reply batches") + , ("txSubmission.txMessagesSent", "number of tx body request messages sent") + , ("txSubmission.txsRequested", "number of tx bodies requested from remote peers") + , ("txSubmission.txRepliesReceived", "number of tx body reply messages received") + , ("txSubmission.txsReceived", "number of tx bodies received") + , ("txSubmission.txsOmitted", "number of requested tx bodies omitted from replies") + , ("txSubmission.lateBodies", "number of tx bodies received after local resolution") + , ("txSubmission.txsAccepted", "number of tx bodies resolved into the mempool") + , ("txSubmission.txsRejected", "number of tx bodies rejected by the mempool") + , ("txSubmission.txIdBlockingReqsSent", "number of blocking txid request messages sent") + , ("txSubmission.txIdPipelinedReqsSent", "number of pipelined txid request messages sent") + , ("txSubmission.txIdBlockingWaitMs", "cumulative milliseconds spent waiting for blocking txid replies (idle state proxy)") + , ("txSubmission.txPipelineWaitMs", "cumulative milliseconds the pipeline was active from first body request until full drain (loading state proxy)") + , ("txSubmission.txSubmissionWaitMs", "cumulative milliseconds spent in mempoolAddTxs; high values indicate mempool backpressure") ] metricsDocFor _ = [] diff --git a/ouroboros-network/tracing/Ouroboros/Network/Tracing/TxSubmission/Inbound.hs b/ouroboros-network/tracing/Ouroboros/Network/Tracing/TxSubmission/Inbound.hs index 147412c28e3..c666d3cc7d0 100644 --- a/ouroboros-network/tracing/Ouroboros/Network/Tracing/TxSubmission/Inbound.hs +++ b/ouroboros-network/tracing/Ouroboros/Network/Tracing/TxSubmission/Inbound.hs @@ -73,11 +73,14 @@ instance (Show txid, Show tx) , "error" .= Text.pack (show e) ] - forMachine _dtal (TraceTxInboundDecision decision) = - mconcat [ - "kind" .= String "TraceTxInboundDecision" - , "decision" .= Text.pack (show decision) + forMachine dtal (TraceTxInboundRequestTxs txids) = + mconcat + [ "kind" .= String "TraceTxInboundRequestTxs" + , "count" .= toJSON (length txids) ] + <> case dtal of + DDetailed -> "txIds" .= Text.pack (show txids) + _otherwise -> mempty asMetrics (TraceTxSubmissionCollected txids) = [CounterM "submissions.submitted" (Just (length txids))] @@ -106,8 +109,8 @@ instance MetaTrace (TraceTxSubmissionInbound txid tx) where Namespace [] ["RejectedFromMempool"] namespaceFor TraceTxInboundError {} = Namespace [] ["Error"] - namespaceFor TraceTxInboundDecision {} = - Namespace [] ["Decision"] + namespaceFor TraceTxInboundRequestTxs {} = + Namespace [] ["RequestTxs"] severityFor (Namespace _ ["Collected"]) _ = Just Debug severityFor (Namespace _ ["Processed"]) _ = Just Debug @@ -117,7 +120,7 @@ instance MetaTrace (TraceTxSubmissionInbound txid tx) where severityFor (Namespace _ ["AddedToMempool"]) _ = Just Debug severityFor (Namespace _ ["RejectedFromMempool"]) _ = Just Debug severityFor (Namespace _ ["Error"]) _ = Just Debug - severityFor (Namespace _ ["Decision"]) _ = Just Debug + severityFor (Namespace _ ["RequestTxs"]) _ = Just Debug severityFor _ _ = Nothing @@ -151,8 +154,8 @@ instance MetaTrace (TraceTxSubmissionInbound txid tx) where "Transactions rejected from mempool and processing time" documentFor (Namespace _ ["Error"]) = Just "Protocol violation causing connection reset" - documentFor (Namespace _ ["Decision"]) = Just - "Decision to advance the protocol" + documentFor (Namespace _ ["RequestTxs"]) = Just + "Transactions requested from the remote peer" documentFor _ = Nothing allNamespaces = [ @@ -164,5 +167,5 @@ instance MetaTrace (TraceTxSubmissionInbound txid tx) where , Namespace [] ["AddedToMempool"] , Namespace [] ["RejectedFromMempool"] , Namespace [] ["Error"] - , Namespace [] ["Decision"] + , Namespace [] ["RequestTxs"] ]