{-# 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
  , combinedStateInvariantStep
  , sharedGenerationBumpInvariant
  ) where

import Control.DeepSeq (NFData (rnf))
import Control.Exception (evaluate)
import Control.Monad.Class.MonadTime.SI (DiffTime, Time (..), addTime, diffTime)
import Data.Foldable (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.List as List (foldl')
import Data.Map.Strict qualified as Map
import Data.Maybe (listToMaybe)
import Data.Sequence.Strict qualified as StrictSeq
import Data.Set qualified as Set
import Data.Word (Word64)

import NoThunks.Class (NoThunks, unsafeNoThunks)



import Ouroboros.Network.Protocol.TxSubmission2.Type
import Ouroboros.Network.Tx (HasRawTxId (..), getRawTxId)
import Ouroboros.Network.TxSubmission.Inbound.V2.Policy
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.Tasty (TestTree, localOption, testGroup)
import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase,
           testCaseSteps, (@?=))
import Test.Tasty.QuickCheck (QuickCheckTests (..), testProperty)

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup TestName
"TxLogic"
    [ QuickCheckTests -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Int -> QuickCheckTests
QuickCheckTests Int
50) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
        TestName -> [TestTree] -> TestTree
testGroup TestName
"TriggerScenario meta-tests"
          [ TestName -> (TriggerScenario -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"generated scenario produces a valid initial state"
                         TriggerScenario -> Property
prop_TriggerScenario_validInitialState
          , TestName -> (TriggerScenario -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink preserves validity"
                         TriggerScenario -> Property
prop_TriggerScenario_shrinkPreservesValidity
          , TestName -> (TriggerScenario -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink does not grow the trigger list"
                         TriggerScenario -> Property
prop_TriggerScenario_shrinkSmaller
          , TestName -> (TriggerScenario -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink does not contain the original value"
                         TriggerScenario -> Property
prop_TriggerScenario_shrinkExcludesOriginal
          ]
    , TestName -> [TestTree] -> TestTree
testGroup TestName
"TxDecisionPolicy meta-tests"
          [ TestName -> (ArbTxDecisionPolicy -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"generator produces sane policies"
                         ArbTxDecisionPolicy -> Property
prop_ArbTxDecisionPolicy_generatesSane
          , TestName -> (ArbTxDecisionPolicy -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrinker produces sane policies"
                         ArbTxDecisionPolicy -> Property
prop_ArbTxDecisionPolicy_shrinkSane
          ]
    , TestName
-> (ArbTxDecisionPolicy -> TriggerScenario -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"nextPeerAction processes all multi-peer triggers" ArbTxDecisionPolicy -> TriggerScenario -> Property
prop_nextPeerAction_processesAllTriggers
    , TestName -> ((TestName -> IO ()) -> IO ()) -> TestTree
testCaseSteps TestName
"peerScore decays linearly over time at scoreRate" (TestName -> IO ()) -> IO ()
unit_peerScore_decaysOverTime
    , TestName -> ((TestName -> IO ()) -> IO ()) -> TestTree
testCaseSteps TestName
"applyPeerEvents drains the existing score before adding the new rejection count" (TestName -> IO ()) -> IO ()
unit_applyPeerEvents_drainsThenAdds
    , TestName
-> (ArbTxDecisionPolicy
    -> NonEmptyList (Int, Positive Int, TxIdGroupTag) -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"handleReceivedTxIds classifies incoming txids" ArbTxDecisionPolicy
-> NonEmptyList (Int, Positive Int, TxIdGroupTag) -> Property
prop_handleReceivedTxIds
    , TestName -> ((TestName -> IO ()) -> IO ()) -> TestTree
testCaseSteps TestName
"handleReceivedTxIds tracks the advertise without mutating an existing entry" (TestName -> IO ()) -> IO ()
unit_handleReceivedTxIds_advertisesExistingEntry
    , TestName
-> (ArbTxDecisionPolicy
    -> NonEmptyList (Int, Positive Int, Bool) -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"handleReceivedTxs buffers requested bodies and releases omitted ones" ArbTxDecisionPolicy
-> NonEmptyList (Int, Positive Int, Bool) -> Property
prop_handleReceivedTxs
    , TestName
-> (ArbTxDecisionPolicy
    -> NonEmptyList (Int, Positive Int, Bool) -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"handleSubmittedTxs retains accepted and drops rejected" ArbTxDecisionPolicy
-> NonEmptyList (Int, Positive Int, Bool) -> Property
prop_handleSubmittedTxs_retainsAcceptedAndDropsRejected
    , TestName -> (ArbTxDecisionPolicy -> Word64 -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"nextPeerAction returns the current shared generation when idle" ArbTxDecisionPolicy -> Word64 -> Property
prop_nextPeerAction_returnsSharedGeneration
    , TestName
-> (ArbTxDecisionPolicy
    -> NonEmptyList (Int, Positive Int) -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"nextPeerAction respects the inflight size budget" ArbTxDecisionPolicy -> NonEmptyList (Int, Positive Int) -> Property
prop_nextPeerAction_picksTxsRespectingBudget
    , TestName
-> (ArbTxDecisionPolicy -> Positive Int -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"nextPeerAction submits buffered owned txs before acking" ArbTxDecisionPolicy -> Positive Int -> Property
prop_nextPeerAction_ownerSubmitsBuffered
    , TestName -> IO () -> TestTree
testCase     TestName
"nextPeerAction claims a duplicated advertised txid only once" IO ()
unit_nextPeerAction_dedupsBodyRequestOnDuplicateTxIds
    , TestName -> IO () -> TestTree
testCase     TestName
"nextPeerAction submits a duplicated buffered txid only once"  IO ()
unit_nextPeerAction_dedupsSubmitOnDuplicateTxIds
    , TestName -> IO () -> TestTree
testCase     TestName
"nextPeerAction clears in-flight tracking when an orphaned body is pruned" IO ()
unit_nextPeerAction_clearsInFlightForPrunedBody
    , TestName
-> (ArbTxDecisionPolicy -> Positive Int -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"nextPeerAction prunes expired retained txs" ArbTxDecisionPolicy -> Positive Int -> Property
prop_nextPeerAction_prunesExpiredRetained
    , TestName
-> (ArbTxDecisionPolicy -> Positive Int -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"nextPeerAction keeps retained txs before expiry" ArbTxDecisionPolicy -> Positive Int -> Property
prop_nextPeerAction_keepsRetained
    , TestName -> (ArbTxDecisionPolicy -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"nextPeerActionPipelined allows request-only (ack=0) when the queue is non-empty" ArbTxDecisionPolicy -> Property
prop_nextPeerActionPipelined_allowsRequestOnly
    , TestName -> ((TestName -> IO ()) -> IO ()) -> TestTree
testCaseSteps TestName
"nextPeerActionPipelined rejects pure-ack (ack=N, req=0) messages" (TestName -> IO ()) -> IO ()
unit_nextPeerActionPipelined_rejectsPureAck
    , TestName -> (ArbTxDecisionPolicy -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"nextPeerActionPipelined emits a pipelined txid request when ack and request fire together" ArbTxDecisionPolicy -> Property
prop_nextPeerActionPipelined_requestsTxIds
    , TestName -> (ArbTxDecisionPolicy -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"nextPeerActionPipelined opens a second outstanding body batch" ArbTxDecisionPolicy -> Property
prop_nextPeerActionPipelined_secondBodyBatch
    , TestName -> (ArbTxDecisionPolicy -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"nextPeerActionPipelined does not open a third outstanding body batch" ArbTxDecisionPolicy -> Property
prop_nextPeerActionPipelined_noThirdBodyBatch
    , TestName -> ((TestName -> IO ()) -> IO ()) -> TestTree
testCaseSteps TestName
"nextPeerActionPipelined keeps one txid unacked while body replies are in flight" (TestName -> IO ()) -> IO ()
unit_nextPeerActionPipelined_keepsOneUnackedWithOutstandingBodyReply
    , TestName -> ((TestName -> IO ()) -> IO ()) -> TestTree
testCaseSteps TestName
"nextPeerAction skips blocked-available txs and requests later claimable ones" (TestName -> IO ()) -> IO ()
unit_nextPeerAction_skipsBlockedAvailableTxs
    , TestName -> ((TestName -> IO ()) -> IO ()) -> TestTree
testCaseSteps TestName
"nextPeerAction only acks the safe prefix before a blocked buffered tx" (TestName -> IO ()) -> IO ()
unit_nextPeerAction_acksSafePrefixBeforeBlockedBufferedTx
    , TestName -> ((TestName -> IO ()) -> IO ()) -> TestTree
testCaseSteps TestName
"nextPeerAction lets another peer claim a fresh tx when the first advertiser is full" (TestName -> IO ()) -> IO ()
unit_nextPeerAction_claimsFreshTxWhenFirstAdvertiserIsFull
    , TestName -> ((TestName -> IO ()) -> IO ()) -> TestTree
testCaseSteps TestName
"nextPeerAction claims a released tx from another advertiser" (TestName -> IO ()) -> IO ()
unit_nextPeerAction_claimsRejectedTxFromOtherAdvertiser
    , TestName -> ((TestName -> IO ()) -> IO ()) -> TestTree
testCaseSteps TestName
"nextPeerAction claims a tx once the score delay threshold has elapsed" (TestName -> IO ()) -> IO ()
unit_nextPeerAction_claimsAtScoreDelayThreshold
    , TestName -> ((TestName -> IO ()) -> IO ()) -> TestTree
testCaseSteps TestName
"nextPeerAction requests other work despite a blocked buffered tx" (TestName -> IO ()) -> IO ()
unit_nextPeerAction_requestsOtherWorkDespiteBlockedBufferedTx
    , TestName -> ((TestName -> IO ()) -> IO ()) -> TestTree
testCaseSteps TestName
"nextPeerAction submits buffered bodies across a resolved-elsewhere gap" (TestName -> IO ()) -> IO ()
unit_nextPeerAction_submitsBufferedAcrossResolvedGap
    , TestName -> (ArbTxDecisionPolicy -> Int -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"nextPeerAction keeps non-owner txids unacked until resolved" ArbTxDecisionPolicy -> Int -> Property
prop_nextPeerAction_nonOwnerWaitsUntilResolved
    , TestName
-> (ArbTxDecisionPolicy
    -> Positive Int
    -> Positive Int
    -> Positive Int
    -> Int
    -> Positive Int
    -> Positive Int
    -> Positive Int
    -> PeerOrder
    -> LeaseStart
    -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"nextPeerAction claims a claimable tx for the best idle advertiser" ArbTxDecisionPolicy
-> Positive Int
-> Positive Int
-> Positive Int
-> Int
-> Positive Int
-> Positive Int
-> Positive Int
-> PeerOrder
-> LeaseStart
-> Property
prop_nextPeerAction_claimsClaimableTx
    ]

-- | The 'ArbTxDecisionPolicy' generator only produces policies that pass
-- 'saneTxDecisionPolicy'.
prop_ArbTxDecisionPolicy_generatesSane :: ArbTxDecisionPolicy -> Property
prop_ArbTxDecisionPolicy_generatesSane :: ArbTxDecisionPolicy -> Property
prop_ArbTxDecisionPolicy_generatesSane (ArbTxDecisionPolicy TxDecisionPolicy
p) =
    TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TxDecisionPolicy -> TestName
forall a. Show a => a -> TestName
show TxDecisionPolicy
p) (TxDecisionPolicy -> Bool
saneTxDecisionPolicy TxDecisionPolicy
p)

-- | Shrinking an 'ArbTxDecisionPolicy' only yields policies that pass
-- 'saneTxDecisionPolicy'.
prop_ArbTxDecisionPolicy_shrinkSane :: ArbTxDecisionPolicy -> Property
prop_ArbTxDecisionPolicy_shrinkSane :: ArbTxDecisionPolicy -> Property
prop_ArbTxDecisionPolicy_shrinkSane ArbTxDecisionPolicy
arb =
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
      [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TxDecisionPolicy -> TestName
forall a. Show a => a -> TestName
show TxDecisionPolicy
p) (TxDecisionPolicy -> Bool
saneTxDecisionPolicy TxDecisionPolicy
p)
      | ArbTxDecisionPolicy TxDecisionPolicy
p <- ArbTxDecisionPolicy -> [ArbTxDecisionPolicy]
forall a. Arbitrary a => a -> [a]
shrink ArbTxDecisionPolicy
arb
      ]

--
-- NoThunks invariant checks
--

-- | Check that a value has no thunks in its fields.
checkNoThunks :: NoThunks a => String -> a -> Property
checkNoThunks :: forall a. NoThunks a => TestName -> a -> Property
checkNoThunks TestName
name a
val =
    a
val a -> Property -> Property
forall a b. a -> b -> b
`seq` case a -> Maybe ThunkInfo
forall a. NoThunks a => a -> Maybe ThunkInfo
unsafeNoThunks a
val of
      Maybe ThunkInfo
Nothing   -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
      Just ThunkInfo
info -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
                     (TestName
name TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" contains thunks: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ ThunkInfo -> TestName
forall a. Show a => a -> TestName
show ThunkInfo
info)
                     Bool
False

--
-- InboundState properties
--

type PeerAddr = Int

data ReceiveDuplicateFixture = ReceiveDuplicateFixture
  { ReceiveDuplicateFixture -> Int
rdfPeerAddr       :: !PeerAddr
  , ReceiveDuplicateFixture -> NumTxIdsToReq
rdfRequestedTxIds :: !NumTxIdsToReq
  , ReceiveDuplicateFixture -> [(Int, SizeInBytes)]
rdfTxidsAndSizes  :: ![(TxId, SizeInBytes)]
  , ReceiveDuplicateFixture -> PeerTxLocalState (Tx Int)
rdfPeerState      :: !(PeerTxLocalState (Tx TxId))
  , ReceiveDuplicateFixture -> SharedTxState Int Int
rdfSharedState    :: !(SharedTxState PeerAddr TxId)
  }

data PeerActionFixture = PeerActionFixture
  { PeerActionFixture -> Int
pafPeerAddr    :: !PeerAddr
  , PeerActionFixture -> PeerTxLocalState (Tx Int)
pafPeerState   :: !(PeerTxLocalState (Tx TxId))
  , PeerActionFixture -> SharedTxState Int Int
pafSharedState :: !(SharedTxState PeerAddr TxId)
  }

data FanoutFixture = FanoutFixture
  { FanoutFixture -> [Int]
ffPeers              :: ![PeerAddr]
  , FanoutFixture -> NumTxIdsToReq
ffRequestedTxIds     :: !NumTxIdsToReq
  , FanoutFixture -> [(Int, SizeInBytes)]
ffTxidsAndSizes      :: ![(TxId, SizeInBytes)]
  , FanoutFixture -> SharedTxState Int Int
ffInitialSharedState :: !(SharedTxState PeerAddr TxId)
  }

instance NFData ReceiveDuplicateFixture where
  rnf :: ReceiveDuplicateFixture -> ()
rnf ReceiveDuplicateFixture { Int
rdfPeerAddr :: ReceiveDuplicateFixture -> Int
rdfPeerAddr :: Int
rdfPeerAddr, NumTxIdsToReq
rdfRequestedTxIds :: ReceiveDuplicateFixture -> NumTxIdsToReq
rdfRequestedTxIds :: NumTxIdsToReq
rdfRequestedTxIds, [(Int, SizeInBytes)]
rdfTxidsAndSizes :: ReceiveDuplicateFixture -> [(Int, SizeInBytes)]
rdfTxidsAndSizes :: [(Int, SizeInBytes)]
rdfTxidsAndSizes
                              , PeerTxLocalState (Tx Int)
rdfPeerState :: ReceiveDuplicateFixture -> PeerTxLocalState (Tx Int)
rdfPeerState :: PeerTxLocalState (Tx Int)
rdfPeerState, SharedTxState Int Int
rdfSharedState :: ReceiveDuplicateFixture -> SharedTxState Int Int
rdfSharedState :: SharedTxState Int Int
rdfSharedState } =
       Int -> ()
forall a. NFData a => a -> ()
rnf Int
rdfPeerAddr
    () -> () -> ()
forall a b. a -> b -> b
`seq` NumTxIdsToReq -> ()
forall a. NFData a => a -> ()
rnf NumTxIdsToReq
rdfRequestedTxIds
    () -> () -> ()
forall a b. a -> b -> b
`seq` [(Int, SizeInBytes)] -> ()
forall a. NFData a => a -> ()
rnf [(Int, SizeInBytes)]
rdfTxidsAndSizes
    () -> () -> ()
forall a b. a -> b -> b
`seq` PeerTxLocalState (Tx Int) -> ()
forall a. NFData a => a -> ()
rnf PeerTxLocalState (Tx Int)
rdfPeerState
    () -> () -> ()
forall a b. a -> b -> b
`seq` SharedTxState Int Int -> ()
forall a. NFData a => a -> ()
rnf SharedTxState Int Int
rdfSharedState

instance NFData PeerActionFixture where
  rnf :: PeerActionFixture -> ()
rnf PeerActionFixture { Int
pafPeerAddr :: PeerActionFixture -> Int
pafPeerAddr :: Int
pafPeerAddr, PeerTxLocalState (Tx Int)
pafPeerState :: PeerActionFixture -> PeerTxLocalState (Tx Int)
pafPeerState :: PeerTxLocalState (Tx Int)
pafPeerState, SharedTxState Int Int
pafSharedState :: PeerActionFixture -> SharedTxState Int Int
pafSharedState :: SharedTxState Int Int
pafSharedState } =
       Int -> ()
forall a. NFData a => a -> ()
rnf Int
pafPeerAddr
    () -> () -> ()
forall a b. a -> b -> b
`seq` PeerTxLocalState (Tx Int) -> ()
forall a. NFData a => a -> ()
rnf PeerTxLocalState (Tx Int)
pafPeerState
    () -> () -> ()
forall a b. a -> b -> b
`seq` SharedTxState Int Int -> ()
forall a. NFData a => a -> ()
rnf SharedTxState Int Int
pafSharedState

instance NFData FanoutFixture where
  rnf :: FanoutFixture -> ()
rnf FanoutFixture { [Int]
ffPeers :: FanoutFixture -> [Int]
ffPeers :: [Int]
ffPeers, NumTxIdsToReq
ffRequestedTxIds :: FanoutFixture -> NumTxIdsToReq
ffRequestedTxIds :: NumTxIdsToReq
ffRequestedTxIds, [(Int, SizeInBytes)]
ffTxidsAndSizes :: FanoutFixture -> [(Int, SizeInBytes)]
ffTxidsAndSizes :: [(Int, SizeInBytes)]
ffTxidsAndSizes, SharedTxState Int Int
ffInitialSharedState :: FanoutFixture -> SharedTxState Int Int
ffInitialSharedState :: SharedTxState Int Int
ffInitialSharedState } =
       [Int] -> ()
forall a. NFData a => a -> ()
rnf [Int]
ffPeers
    () -> () -> ()
forall a b. a -> b -> b
`seq` NumTxIdsToReq -> ()
forall a. NFData a => a -> ()
rnf NumTxIdsToReq
ffRequestedTxIds
    () -> () -> ()
forall a b. a -> b -> b
`seq` [(Int, SizeInBytes)] -> ()
forall a. NFData a => a -> ()
rnf [(Int, SizeInBytes)]
ffTxidsAndSizes
    () -> () -> ()
forall a b. a -> b -> b
`seq` SharedTxState Int Int -> ()
forall a. NFData a => a -> ()
rnf SharedTxState Int Int
ffInitialSharedState

-- | '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.
     NoThunks tx
  => TxDecisionPolicy
  -> PeerTxLocalState tx
  -> Property
peerTxLocalStateInvariant :: forall tx.
NoThunks tx =>
TxDecisionPolicy -> PeerTxLocalState tx -> Property
peerTxLocalStateInvariant TxDecisionPolicy { Double
scoreMax :: Double
scoreMax :: TxDecisionPolicy -> Double
scoreMax }
                          ps :: PeerTxLocalState tx
ps@PeerTxLocalState {
                            StrictSeq TxKey
peerUnacknowledgedTxIds :: StrictSeq TxKey
peerUnacknowledgedTxIds :: forall tx. PeerTxLocalState tx -> StrictSeq TxKey
peerUnacknowledgedTxIds,
                            IntMap SizeInBytes
peerAvailableTxIds :: IntMap SizeInBytes
peerAvailableTxIds :: forall tx. PeerTxLocalState tx -> IntMap SizeInBytes
peerAvailableTxIds,
                            IntSet
peerRequestedTxs :: IntSet
peerRequestedTxs :: forall tx. PeerTxLocalState tx -> IntSet
peerRequestedTxs,
                            StrictSeq RequestedTxBatch
peerRequestedTxBatches :: StrictSeq RequestedTxBatch
peerRequestedTxBatches :: forall tx. PeerTxLocalState tx -> StrictSeq RequestedTxBatch
peerRequestedTxBatches,
                            SizeInBytes
peerRequestedTxsSize :: SizeInBytes
peerRequestedTxsSize :: forall tx. PeerTxLocalState tx -> SizeInBytes
peerRequestedTxsSize,
                            IntMap tx
peerDownloadedTxs :: IntMap tx
peerDownloadedTxs :: forall tx. PeerTxLocalState tx -> IntMap tx
peerDownloadedTxs,
                            PeerScore
peerScore :: PeerScore
peerScore :: forall tx. PeerTxLocalState tx -> PeerScore
peerScore
                          } =
  [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
    [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"requested keys are not all available"
        (IntSet
peerRequestedTxs IntSet -> IntSet -> Bool
`IntSet.isSubsetOf` IntSet
availableKeys)
    , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"available keys are not all in the unacknowledged queue"
        (IntSet
availableKeys IntSet -> IntSet -> Bool
`IntSet.isSubsetOf` IntSet
unackKeys)
    , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"downloaded keys are not all in the unacknowledged queue"
        (IntSet
downloadedKeys IntSet -> IntSet -> Bool
`IntSet.isSubsetOf` IntSet
unackKeys)
    , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"downloaded and available key sets overlap"
        (IntSet -> Bool
IntSet.null (IntSet
downloadedKeys IntSet -> IntSet -> IntSet
`IntSet.intersection` IntSet
availableKeys))
    , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"downloaded and requested key sets overlap"
        (IntSet -> Bool
IntSet.null (IntSet
downloadedKeys IntSet -> IntSet -> IntSet
`IntSet.intersection` IntSet
peerRequestedTxs))
    , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"peerRequestedTxs does not match the batch key-set union"
        (IntSet
peerRequestedTxs IntSet -> IntSet -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== IntSet
batchKeyUnion)
    , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"peerRequestedTxsSize does not match the sum of batch sizes"
        (SizeInBytes
peerRequestedTxsSize SizeInBytes -> SizeInBytes -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== SizeInBytes
batchSizeSum)
    , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"peerScoreValue is negative: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Double -> TestName
forall a. Show a => a -> TestName
show Double
scoreVal)
        (Double
scoreVal Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0)
    , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"peerScoreValue exceeds scoreMax: "
                      TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Double -> TestName
forall a. Show a => a -> TestName
show Double
scoreVal TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" > " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Double -> TestName
forall a. Show a => a -> TestName
show Double
scoreMax)
        (Double
scoreVal Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
scoreMax)
    , TestName -> PeerTxLocalState tx -> Property
forall a. NoThunks a => TestName -> a -> Property
checkNoThunks TestName
"PeerTxLocalState" PeerTxLocalState tx
ps
    ]
  where
    scoreVal :: Double
scoreVal       = PeerScore -> Double
peerScoreValue PeerScore
peerScore
    unackKeys :: IntSet
unackKeys      = [Int] -> IntSet
IntSet.fromList [ Int
k | TxKey Int
k <- StrictSeq TxKey -> [TxKey]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq TxKey
peerUnacknowledgedTxIds ]
    availableKeys :: IntSet
availableKeys  = IntMap SizeInBytes -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet IntMap SizeInBytes
peerAvailableTxIds
    downloadedKeys :: IntSet
downloadedKeys = IntMap tx -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet IntMap tx
peerDownloadedTxs
    batchKeyUnion :: IntSet
batchKeyUnion  =
      [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions ((RequestedTxBatch -> IntSet) -> [RequestedTxBatch] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RequestedTxBatch -> IntSet
requestedTxBatchSet (StrictSeq RequestedTxBatch -> [RequestedTxBatch]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq RequestedTxBatch
peerRequestedTxBatches))
    batchSizeSum :: SizeInBytes
batchSizeSum   =
      [SizeInBytes] -> SizeInBytes
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((RequestedTxBatch -> SizeInBytes)
-> [RequestedTxBatch] -> [SizeInBytes]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RequestedTxBatch -> SizeInBytes
requestedTxBatchSize (StrictSeq RequestedTxBatch -> [RequestedTxBatch]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq RequestedTxBatch
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); 'pifLeased' is a subset of their
-- union; and 'pifAdvertised' is a subset of 'pifAcksPending' (every
-- advertised key is still pending an ack).
peerTxInFlightInvariant :: PeerTxInFlight -> Property
peerTxInFlightInvariant :: PeerTxInFlight -> Property
peerTxInFlightInvariant PeerTxInFlight
pif =
  [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
    [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"pifAttempting and pifSubmitting overlap"
        (IntSet -> Bool
IntSet.null (PeerTxInFlight -> IntSet
pifAttempting PeerTxInFlight
pif IntSet -> IntSet -> IntSet
`IntSet.intersection` PeerTxInFlight -> IntSet
pifSubmitting PeerTxInFlight
pif))
    , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"pifLeased not contained in pifAttempting `union` pifSubmitting"
        (PeerTxInFlight -> IntSet
pifLeased PeerTxInFlight
pif
           IntSet -> IntSet -> Bool
`IntSet.isSubsetOf`
           (PeerTxInFlight -> IntSet
pifAttempting PeerTxInFlight
pif IntSet -> IntSet -> IntSet
`IntSet.union` PeerTxInFlight -> IntSet
pifSubmitting PeerTxInFlight
pif))
    , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"pifAdvertised not contained in pifAcksPending"
        (PeerTxInFlight -> IntSet
pifAdvertised PeerTxInFlight
pif IntSet -> IntSet -> Bool
`IntSet.isSubsetOf` PeerTxInFlight -> IntSet
pifAcksPending PeerTxInFlight
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.
--   * Each peer's 'pifAcksPending' is a subset of the keys in its
--     'peerUnacknowledgedTxIds' queue.
--
-- 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
     , NoThunks tx
     )
  => TxDecisionPolicy
  -> Map.Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
  -> SharedTxState peeraddr txid
  -> Property
combinedStateInvariant :: forall peeraddr txid tx.
(Ord peeraddr, Ord txid, HasRawTxId txid, Show peeraddr, Show txid,
 NoThunks tx) =>
TxDecisionPolicy
-> Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> SharedTxState peeraddr txid
-> Property
combinedStateInvariant TxDecisionPolicy
policy Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
peers SharedTxState peeraddr txid
sharedState =
  let activeKeys :: IntSet
activeKeys = IntMap (TxEntry peeraddr) -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet (SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState peeraddr txid
sharedState)
      retKeys :: IntSet
retKeys    = RetainedTxs -> IntSet
retainedKeysSet (SharedTxState peeraddr txid -> RetainedTxs
forall peeraddr txid. SharedTxState peeraddr txid -> RetainedTxs
sharedRetainedTxs SharedTxState peeraddr txid
sharedState)
      liveKeys :: IntSet
liveKeys   = IntSet
activeKeys IntSet -> IntSet -> IntSet
`IntSet.union` IntSet
retKeys
  in [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$
       [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"PeerTxLocalState invariant violated for peer "
                          TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ peeraddr -> TestName
forall a. Show a => a -> TestName
show peeraddr
p)
           (TxDecisionPolicy -> PeerTxLocalState tx -> Property
forall tx.
NoThunks tx =>
TxDecisionPolicy -> PeerTxLocalState tx -> Property
peerTxLocalStateInvariant TxDecisionPolicy
policy PeerTxLocalState tx
ps)
       | (peeraddr
p, (PeerTxLocalState tx
ps, PeerTxInFlight
_)) <- Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> [(peeraddr, (PeerTxLocalState tx, PeerTxInFlight))]
forall k a. Map k a -> [(k, a)]
Map.toList Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
peers ]
    [Property] -> [Property] -> [Property]
forall a. [a] -> [a] -> [a]
++ [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"PeerTxInFlight invariant violated for peer "
                           TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ peeraddr -> TestName
forall a. Show a => a -> TestName
show peeraddr
p)
           (PeerTxInFlight -> Property
peerTxInFlightInvariant PeerTxInFlight
pif)
       | (peeraddr
p, (PeerTxLocalState tx
_, PeerTxInFlight
pif)) <- Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> [(peeraddr, (PeerTxLocalState tx, PeerTxInFlight))]
forall k a. Map k a -> [(k, a)]
Map.toList Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
peers ]
    [Property] -> [Property] -> [Property]
forall a. [a] -> [a] -> [a]
++ [ SharedTxState peeraddr txid -> Property
forall peeraddr txid.
(Ord peeraddr, Ord txid, HasRawTxId txid, Show peeraddr,
 Show txid) =>
SharedTxState peeraddr txid -> Property
sharedTxStateInvariant SharedTxState peeraddr txid
sharedState ]
    [Property] -> [Property] -> [Property]
forall a. [a] -> [a] -> [a]
++ [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"peer " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ peeraddr -> TestName
forall a. Show a => a -> TestName
show peeraddr
p
                          TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" advertises keys that are neither active nor retained")
           (PeerTxInFlight -> IntSet
pifAdvertised PeerTxInFlight
pif IntSet -> IntSet -> Bool
`IntSet.isSubsetOf` IntSet
liveKeys)
       | (peeraddr
p, (PeerTxLocalState tx
_, PeerTxInFlight
pif)) <- Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> [(peeraddr, (PeerTxLocalState tx, PeerTxInFlight))]
forall k a. Map k a -> [(k, a)]
Map.toList Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
peers ]
    [Property] -> [Property] -> [Property]
forall a. [a] -> [a] -> [a]
++ [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"txAttempt mismatch for entry " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
k
                          TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
": expected " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
expectedAttempt
                          TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" (sum across peers' pifAttempting)"
                          TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
", got " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show (TxEntry peeraddr -> Int
forall peeraddr. TxEntry peeraddr -> Int
txAttempt TxEntry peeraddr
entry))
           (TxEntry peeraddr -> Int
forall peeraddr. TxEntry peeraddr -> Int
txAttempt TxEntry peeraddr
entry Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
expectedAttempt)
       | (Int
k, TxEntry peeraddr
entry) <- IntMap (TxEntry peeraddr) -> [(Int, TxEntry peeraddr)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList (SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState peeraddr txid
sharedState)
       , let expectedAttempt :: Int
expectedAttempt =
               [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ if Int -> IntSet -> Bool
IntSet.member Int
k (PeerTxInFlight -> IntSet
pifAttempting PeerTxInFlight
pif) then Int
1 else Int
0
                   | (peeraddr
_, (PeerTxLocalState tx
_, PeerTxInFlight
pif)) <- Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> [(peeraddr, (PeerTxLocalState tx, PeerTxInFlight))]
forall k a. Map k a -> [(k, a)]
Map.toList Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
peers ]
       ]
    [Property] -> [Property] -> [Property]
forall a. [a] -> [a] -> [a]
++ [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"txInSubmission mismatch for entry " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
k
                          TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
": expected " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Bool -> TestName
forall a. Show a => a -> TestName
show Bool
expectedSubmit)
           (TxEntry peeraddr -> Bool
forall peeraddr. TxEntry peeraddr -> Bool
txInSubmission TxEntry peeraddr
entry Bool -> Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Bool
expectedSubmit)
       | (Int
k, TxEntry peeraddr
entry) <- IntMap (TxEntry peeraddr) -> [(Int, TxEntry peeraddr)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList (SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState peeraddr txid
sharedState)
       , let expectedSubmit :: Bool
expectedSubmit =
               ((peeraddr, (PeerTxLocalState tx, PeerTxInFlight)) -> Bool)
-> [(peeraddr, (PeerTxLocalState tx, PeerTxInFlight))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(peeraddr
_, (PeerTxLocalState tx
_, PeerTxInFlight
pif)) -> Int -> IntSet -> Bool
IntSet.member Int
k (PeerTxInFlight -> IntSet
pifSubmitting PeerTxInFlight
pif))
                   (Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> [(peeraddr, (PeerTxLocalState tx, PeerTxInFlight))]
forall k a. Map k a -> [(k, a)]
Map.toList Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
peers)
       ]
    [Property] -> [Property] -> [Property]
forall a. [a] -> [a] -> [a]
++ [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"entry " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
k
                          TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" is TxLeased to peer " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ peeraddr -> TestName
forall a. Show a => a -> TestName
show peeraddr
owner
                          TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" but the peer's pifLeased does not contain it")
           (case peeraddr
-> Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> Maybe (PeerTxLocalState tx, PeerTxInFlight)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup peeraddr
owner Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
peers of
              Maybe (PeerTxLocalState tx, PeerTxInFlight)
Nothing            -> Bool
True
              Just (PeerTxLocalState tx
_, PeerTxInFlight
ownerPif) -> Int -> IntSet -> Bool
IntSet.member Int
k (PeerTxInFlight -> IntSet
pifLeased PeerTxInFlight
ownerPif))
       | (Int
k, TxEntry peeraddr
entry) <- IntMap (TxEntry peeraddr) -> [(Int, TxEntry peeraddr)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList (SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState peeraddr txid
sharedState)
       , TxLeased peeraddr
owner Time
_ <- [TxEntry peeraddr -> TxLease peeraddr
forall peeraddr. TxEntry peeraddr -> TxLease peeraddr
txLease TxEntry peeraddr
entry]
       ]
    [Property] -> [Property] -> [Property]
forall a. [a] -> [a] -> [a]
++ [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"peer " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ peeraddr -> TestName
forall a. Show a => a -> TestName
show peeraddr
p
                          TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" has pifAcksPending keys not in its unacknowledged queue")
           (PeerTxInFlight -> IntSet
pifAcksPending PeerTxInFlight
pif IntSet -> IntSet -> Bool
`IntSet.isSubsetOf` IntSet
unackKeys)
       | (peeraddr
p, (PeerTxLocalState tx
ps, PeerTxInFlight
pif)) <- Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> [(peeraddr, (PeerTxLocalState tx, PeerTxInFlight))]
forall k a. Map k a -> [(k, a)]
Map.toList Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
peers
       , let unackKeys :: IntSet
unackKeys = [Int] -> IntSet
IntSet.fromList
                           [ Int
k | TxKey Int
k <- StrictSeq TxKey -> [TxKey]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (PeerTxLocalState tx -> StrictSeq TxKey
forall tx. PeerTxLocalState tx -> StrictSeq TxKey
peerUnacknowledgedTxIds PeerTxLocalState tx
ps) ]
       ]

-- | Cross-step invariant on shared state: any change to fields other
-- than the two counters ('sharedGeneration' and 'sharedRevision') must
-- advance at least one of them.
--
-- 'writeSharedStateIfChanged' (Registry.hs) treats the pair as a dirty
-- bit: a pure transition whose new state matches the old on both
-- counters is silently dropped at commit time.  Forgetting to bump
-- either counter in a transition that mutates shared state therefore
-- loses the update in production while still passing the structural
-- single-state 'sharedTxStateInvariant'.
--
-- The check is one-directional: a counter may also bump when no other
-- field changed (e.g. 'handleReceivedTxs' bumps unconditionally).
-- Spurious bumps only cost wake-ups and are not asserted against.
sharedGenerationBumpInvariant
  :: (Eq peeraddr, Eq txid, HasRawTxId txid)
  => SharedTxState peeraddr txid  -- ^ before
  -> SharedTxState peeraddr txid  -- ^ after
  -> Property
sharedGenerationBumpInvariant :: forall peeraddr txid.
(Eq peeraddr, Eq txid, HasRawTxId txid) =>
SharedTxState peeraddr txid
-> SharedTxState peeraddr txid -> Property
sharedGenerationBumpInvariant SharedTxState peeraddr txid
before SharedTxState peeraddr txid
after =
  [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
    [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
        (TestName
"sharedGeneration decreased: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Word64 -> TestName
forall a. Show a => a -> TestName
show Word64
g0 TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" -> " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Word64 -> TestName
forall a. Show a => a -> TestName
show Word64
g1)
        (Word64
g1 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
g0)
    , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
        (TestName
"sharedRevision decreased: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Word64 -> TestName
forall a. Show a => a -> TestName
show Word64
r0 TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" -> " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Word64 -> TestName
forall a. Show a => a -> TestName
show Word64
r1)
        (Word64
r1 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
r0)
    , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
        (TestName
"neither counter bumped despite state change "
          TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
"(generation " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Word64 -> TestName
forall a. Show a => a -> TestName
show Word64
g0 TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" -> " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Word64 -> TestName
forall a. Show a => a -> TestName
show Word64
g1
          TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
", revision " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Word64 -> TestName
forall a. Show a => a -> TestName
show Word64
r0 TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" -> " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Word64 -> TestName
forall a. Show a => a -> TestName
show Word64
r1 TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
")")
        (Bool -> Bool
not Bool
otherFieldsChanged Bool -> Bool -> Bool
|| Word64
g1 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
g0 Bool -> Bool -> Bool
|| Word64
r1 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
r0)
    ]
  where
    g0 :: Word64
g0 = SharedTxState peeraddr txid -> Word64
forall peeraddr txid. SharedTxState peeraddr txid -> Word64
sharedGeneration SharedTxState peeraddr txid
before
    g1 :: Word64
g1 = SharedTxState peeraddr txid -> Word64
forall peeraddr txid. SharedTxState peeraddr txid -> Word64
sharedGeneration SharedTxState peeraddr txid
after
    r0 :: Word64
r0 = SharedTxState peeraddr txid -> Word64
forall peeraddr txid. SharedTxState peeraddr txid -> Word64
sharedRevision   SharedTxState peeraddr txid
before
    r1 :: Word64
r1 = SharedTxState peeraddr txid -> Word64
forall peeraddr txid. SharedTxState peeraddr txid -> Word64
sharedRevision   SharedTxState peeraddr txid
after
    -- Align both counters so the derived Eq picks up only the other-field
    -- differences.  Using a record update means any new field added to
    -- 'SharedTxState' is automatically included in the comparison.
    otherFieldsChanged :: Bool
otherFieldsChanged =
      SharedTxState peeraddr txid
before { sharedGeneration = g1, sharedRevision = r1 } SharedTxState peeraddr txid -> SharedTxState peeraddr txid -> Bool
forall a. Eq a => a -> a -> Bool
/= SharedTxState peeraddr txid
after

-- | Step-level variant of 'combinedStateInvariant': runs the standard
-- invariant on the after-state and adds the 'sharedGeneration' bump
-- check across the step.  Use at any call site where a pure transition
-- produces both a before and an after state.
combinedStateInvariantStep
  :: forall peeraddr txid tx.
     ( Ord peeraddr
     , Ord txid
     , HasRawTxId txid
     , Show peeraddr
     , Show txid
     , NoThunks tx
     )
  => TxDecisionPolicy
  -> Map.Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
  -> SharedTxState peeraddr txid  -- ^ before
  -> SharedTxState peeraddr txid  -- ^ after
  -> Property
combinedStateInvariantStep :: forall peeraddr txid tx.
(Ord peeraddr, Ord txid, HasRawTxId txid, Show peeraddr, Show txid,
 NoThunks tx) =>
TxDecisionPolicy
-> Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> SharedTxState peeraddr txid
-> SharedTxState peeraddr txid
-> Property
combinedStateInvariantStep TxDecisionPolicy
policy Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
peers SharedTxState peeraddr txid
before SharedTxState peeraddr txid
after =
  [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
    [ TxDecisionPolicy
-> Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> SharedTxState peeraddr txid
-> Property
forall peeraddr txid tx.
(Ord peeraddr, Ord txid, HasRawTxId txid, Show peeraddr, Show txid,
 NoThunks tx) =>
TxDecisionPolicy
-> Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> SharedTxState peeraddr txid
-> Property
combinedStateInvariant TxDecisionPolicy
policy Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
peers SharedTxState peeraddr txid
after
    , SharedTxState peeraddr txid
-> SharedTxState peeraddr txid -> Property
forall peeraddr txid.
(Eq peeraddr, Eq txid, HasRawTxId txid) =>
SharedTxState peeraddr txid
-> SharedTxState peeraddr txid -> Property
sharedGenerationBumpInvariant SharedTxState peeraddr txid
before SharedTxState peeraddr txid
after
    ]


-- | 'InboundState` invariant.
--
sharedTxStateInvariant
  :: forall peeraddr txid.
     ( Ord peeraddr
     , Ord txid
     , HasRawTxId txid
     , Show peeraddr
     , Show txid
     )
  => SharedTxState peeraddr txid
  -> Property
sharedTxStateInvariant :: forall peeraddr txid.
(Ord peeraddr, Ord txid, HasRawTxId txid, Show peeraddr,
 Show txid) =>
SharedTxState peeraddr txid -> Property
sharedTxStateInvariant SharedTxState {
                          IntMap (TxEntry peeraddr)
sharedTxTable :: forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable :: IntMap (TxEntry peeraddr)
sharedTxTable,
                          RetainedTxs
sharedRetainedTxs :: forall peeraddr txid. SharedTxState peeraddr txid -> RetainedTxs
sharedRetainedTxs :: RetainedTxs
sharedRetainedTxs,
                          Map (RawTxId txid) TxKey
sharedTxIdToKey :: Map (RawTxId txid) TxKey
sharedTxIdToKey :: forall peeraddr txid.
SharedTxState peeraddr txid -> Map (RawTxId txid) TxKey
sharedTxIdToKey,
                          IntMap txid
sharedKeyToTxId :: IntMap txid
sharedKeyToTxId :: forall peeraddr txid. SharedTxState peeraddr txid -> IntMap txid
sharedKeyToTxId,
                          Int
sharedNextTxKey :: Int
sharedNextTxKey :: forall peeraddr txid. SharedTxState peeraddr txid -> Int
sharedNextTxKey
                        } =
  [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$
    [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"sharedTxIdToKey/sharedKeyToTxId size mismatch"
        (Map (RawTxId txid) TxKey -> Int
forall k a. Map k a -> Int
Map.size Map (RawTxId txid) TxKey
sharedTxIdToKey Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== IntMap txid -> Int
forall a. IntMap a -> Int
IntMap.size IntMap txid
sharedKeyToTxId)
    , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"active and retained tx sets overlap"
        (IntSet -> Bool
IntSet.null (IntMap (TxEntry peeraddr) -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet IntMap (TxEntry peeraddr)
sharedTxTable IntSet -> IntSet -> IntSet
`IntSet.intersection` RetainedTxs -> IntSet
retainedKeysSet RetainedTxs
sharedRetainedTxs))
    , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"tx-key maps disagree"
        (Bool
keysRoundTripForward Bool -> Bool -> Bool
&& Bool
keysRoundTripBackward)
    , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"live tx keys missing from tx-key maps"
        (IntSet
liveKeys IntSet -> IntSet -> Bool
`IntSet.isSubsetOf` IntMap txid -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet IntMap txid
sharedKeyToTxId)
    , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"sharedNextTxKey does not stay ahead of all live tx keys"
        ((Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
sharedNextTxKey) (IntSet -> [Int]
IntSet.toList IntSet
liveKeys))
    ]
    [Property] -> [Property] -> [Property]
forall a. [a] -> [a] -> [a]
++ ((Int, TxEntry peeraddr) -> Property)
-> [(Int, TxEntry peeraddr)] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, TxEntry peeraddr) -> Property
forall {a} {peeraddr}.
(Show a, Show peeraddr) =>
(a, TxEntry peeraddr) -> Property
checkTxEntry [(Int, TxEntry peeraddr)]
activeEntries
  where
    liveKeys :: IntSet
liveKeys = IntMap (TxEntry peeraddr) -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet IntMap (TxEntry peeraddr)
sharedTxTable IntSet -> IntSet -> IntSet
`IntSet.union` RetainedTxs -> IntSet
retainedKeysSet RetainedTxs
sharedRetainedTxs
    activeEntries :: [(Int, TxEntry peeraddr)]
activeEntries = IntMap (TxEntry peeraddr) -> [(Int, TxEntry peeraddr)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap (TxEntry peeraddr)
sharedTxTable

    keysRoundTripForward :: Bool
keysRoundTripForward =
      ((RawTxId txid, TxKey) -> Bool) -> [(RawTxId txid, TxKey)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(RawTxId txid
rawId, TxKey
txKey) -> (txid -> RawTxId txid) -> Maybe txid -> Maybe (RawTxId txid)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap txid -> RawTxId txid
forall txid. HasRawTxId txid => txid -> RawTxId txid
getRawTxId (Int -> IntMap txid -> Maybe txid
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (TxKey -> Int
unTxKey TxKey
txKey) IntMap txid
sharedKeyToTxId) Maybe (RawTxId txid) -> Maybe (RawTxId txid) -> Bool
forall a. Eq a => a -> a -> Bool
== RawTxId txid -> Maybe (RawTxId txid)
forall a. a -> Maybe a
Just RawTxId txid
rawId)
          (Map (RawTxId txid) TxKey -> [(RawTxId txid, TxKey)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (RawTxId txid) TxKey
sharedTxIdToKey)

    keysRoundTripBackward :: Bool
keysRoundTripBackward =
      ((Int, txid) -> Bool) -> [(Int, txid)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Int
k, txid
txid) -> RawTxId txid -> Map (RawTxId txid) TxKey -> Maybe TxKey
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (txid -> RawTxId txid
forall txid. HasRawTxId txid => txid -> RawTxId txid
getRawTxId txid
txid) Map (RawTxId txid) TxKey
sharedTxIdToKey Maybe TxKey -> Maybe TxKey -> Bool
forall a. Eq a => a -> a -> Bool
== TxKey -> Maybe TxKey
forall a. a -> Maybe a
Just (Int -> TxKey
TxKey Int
k))
          (IntMap txid -> [(Int, txid)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap txid
sharedKeyToTxId)

    checkTxEntry :: (a, TxEntry peeraddr) -> Property
checkTxEntry (a
k, txEntry :: TxEntry peeraddr
txEntry@TxEntry { Int
txAttempt :: forall peeraddr. TxEntry peeraddr -> Int
txAttempt :: Int
txAttempt, Bool
txInSubmission :: forall peeraddr. TxEntry peeraddr -> Bool
txInSubmission :: Bool
txInSubmission }) =
      TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"bad active tx entry " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ a -> TestName
forall a. Show a => a -> TestName
show a
k TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
": " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TxEntry peeraddr -> TestName
forall a. Show a => a -> TestName
show TxEntry peeraddr
txEntry) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
          [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"txAttempt is negative"
              (Int
txAttempt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0)
          , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"txInSubmission without any peer in submission"
              (Bool -> Bool
not Bool
txInSubmission Bool -> Bool -> Bool
|| Int
txAttempt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0)
          ]

newtype ArbTxDecisionPolicy = ArbTxDecisionPolicy TxDecisionPolicy
  deriving (ArbTxDecisionPolicy -> ArbTxDecisionPolicy -> Bool
(ArbTxDecisionPolicy -> ArbTxDecisionPolicy -> Bool)
-> (ArbTxDecisionPolicy -> ArbTxDecisionPolicy -> Bool)
-> Eq ArbTxDecisionPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArbTxDecisionPolicy -> ArbTxDecisionPolicy -> Bool
== :: ArbTxDecisionPolicy -> ArbTxDecisionPolicy -> Bool
$c/= :: ArbTxDecisionPolicy -> ArbTxDecisionPolicy -> Bool
/= :: ArbTxDecisionPolicy -> ArbTxDecisionPolicy -> Bool
Eq, Int -> ArbTxDecisionPolicy -> TestName -> TestName
[ArbTxDecisionPolicy] -> TestName -> TestName
ArbTxDecisionPolicy -> TestName
(Int -> ArbTxDecisionPolicy -> TestName -> TestName)
-> (ArbTxDecisionPolicy -> TestName)
-> ([ArbTxDecisionPolicy] -> TestName -> TestName)
-> Show ArbTxDecisionPolicy
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> ArbTxDecisionPolicy -> TestName -> TestName
showsPrec :: Int -> ArbTxDecisionPolicy -> TestName -> TestName
$cshow :: ArbTxDecisionPolicy -> TestName
show :: ArbTxDecisionPolicy -> TestName
$cshowList :: [ArbTxDecisionPolicy] -> TestName -> TestName
showList :: [ArbTxDecisionPolicy] -> TestName -> TestName
Show)

newtype ArbSharedTxState = ArbSharedTxState (SharedTxState PeerAddr TxId)
  deriving Int -> ArbSharedTxState -> TestName -> TestName
[ArbSharedTxState] -> TestName -> TestName
ArbSharedTxState -> TestName
(Int -> ArbSharedTxState -> TestName -> TestName)
-> (ArbSharedTxState -> TestName)
-> ([ArbSharedTxState] -> TestName -> TestName)
-> Show ArbSharedTxState
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> ArbSharedTxState -> TestName -> TestName
showsPrec :: Int -> ArbSharedTxState -> TestName -> TestName
$cshow :: ArbSharedTxState -> TestName
show :: ArbSharedTxState -> TestName
$cshowList :: [ArbSharedTxState] -> TestName -> TestName
showList :: [ArbSharedTxState] -> TestName -> TestName
Show

newtype ArbPeerTxLocalState = ArbPeerTxLocalState (PeerTxLocalState (Tx TxId))
  deriving Int -> ArbPeerTxLocalState -> TestName -> TestName
[ArbPeerTxLocalState] -> TestName -> TestName
ArbPeerTxLocalState -> TestName
(Int -> ArbPeerTxLocalState -> TestName -> TestName)
-> (ArbPeerTxLocalState -> TestName)
-> ([ArbPeerTxLocalState] -> TestName -> TestName)
-> Show ArbPeerTxLocalState
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> ArbPeerTxLocalState -> TestName -> TestName
showsPrec :: Int -> ArbPeerTxLocalState -> TestName -> TestName
$cshow :: ArbPeerTxLocalState -> TestName
show :: ArbPeerTxLocalState -> TestName
$cshowList :: [ArbPeerTxLocalState] -> TestName -> TestName
showList :: [ArbPeerTxLocalState] -> TestName -> TestName
Show

-- | Tag classifying how @handleReceivedTxIds@ should resolve each incoming
-- txid.
--
-- * '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 (TxIdGroupTag -> TxIdGroupTag -> Bool
(TxIdGroupTag -> TxIdGroupTag -> Bool)
-> (TxIdGroupTag -> TxIdGroupTag -> Bool) -> Eq TxIdGroupTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TxIdGroupTag -> TxIdGroupTag -> Bool
== :: TxIdGroupTag -> TxIdGroupTag -> Bool
$c/= :: TxIdGroupTag -> TxIdGroupTag -> Bool
/= :: TxIdGroupTag -> TxIdGroupTag -> Bool
Eq, Eq TxIdGroupTag
Eq TxIdGroupTag =>
(TxIdGroupTag -> TxIdGroupTag -> Ordering)
-> (TxIdGroupTag -> TxIdGroupTag -> Bool)
-> (TxIdGroupTag -> TxIdGroupTag -> Bool)
-> (TxIdGroupTag -> TxIdGroupTag -> Bool)
-> (TxIdGroupTag -> TxIdGroupTag -> Bool)
-> (TxIdGroupTag -> TxIdGroupTag -> TxIdGroupTag)
-> (TxIdGroupTag -> TxIdGroupTag -> TxIdGroupTag)
-> Ord TxIdGroupTag
TxIdGroupTag -> TxIdGroupTag -> Bool
TxIdGroupTag -> TxIdGroupTag -> Ordering
TxIdGroupTag -> TxIdGroupTag -> TxIdGroupTag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TxIdGroupTag -> TxIdGroupTag -> Ordering
compare :: TxIdGroupTag -> TxIdGroupTag -> Ordering
$c< :: TxIdGroupTag -> TxIdGroupTag -> Bool
< :: TxIdGroupTag -> TxIdGroupTag -> Bool
$c<= :: TxIdGroupTag -> TxIdGroupTag -> Bool
<= :: TxIdGroupTag -> TxIdGroupTag -> Bool
$c> :: TxIdGroupTag -> TxIdGroupTag -> Bool
> :: TxIdGroupTag -> TxIdGroupTag -> Bool
$c>= :: TxIdGroupTag -> TxIdGroupTag -> Bool
>= :: TxIdGroupTag -> TxIdGroupTag -> Bool
$cmax :: TxIdGroupTag -> TxIdGroupTag -> TxIdGroupTag
max :: TxIdGroupTag -> TxIdGroupTag -> TxIdGroupTag
$cmin :: TxIdGroupTag -> TxIdGroupTag -> TxIdGroupTag
min :: TxIdGroupTag -> TxIdGroupTag -> TxIdGroupTag
Ord, Int -> TxIdGroupTag -> TestName -> TestName
[TxIdGroupTag] -> TestName -> TestName
TxIdGroupTag -> TestName
(Int -> TxIdGroupTag -> TestName -> TestName)
-> (TxIdGroupTag -> TestName)
-> ([TxIdGroupTag] -> TestName -> TestName)
-> Show TxIdGroupTag
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> TxIdGroupTag -> TestName -> TestName
showsPrec :: Int -> TxIdGroupTag -> TestName -> TestName
$cshow :: TxIdGroupTag -> TestName
show :: TxIdGroupTag -> TestName
$cshowList :: [TxIdGroupTag] -> TestName -> TestName
showList :: [TxIdGroupTag] -> TestName -> TestName
Show)

instance Arbitrary TxIdGroupTag where
  arbitrary :: Gen TxIdGroupTag
arbitrary = [(Int, Gen TxIdGroupTag)] -> Gen TxIdGroupTag
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
12, TxIdGroupTag -> Gen TxIdGroupTag
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxIdGroupTag
TxIdNew)
    , (Int
4,  TxIdGroupTag -> Gen TxIdGroupTag
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxIdGroupTag
TxIdRetained)
    , (Int
4,  TxIdGroupTag -> Gen TxIdGroupTag
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxIdGroupTag
TxIdMempool)
    ]

instance Arbitrary ArbTxDecisionPolicy where
    arbitrary :: Gen ArbTxDecisionPolicy
arbitrary =
      [(Int, Gen ArbTxDecisionPolicy)] -> Gen ArbTxDecisionPolicy
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
        [ (Int
1, ArbTxDecisionPolicy -> Gen ArbTxDecisionPolicy
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxDecisionPolicy -> ArbTxDecisionPolicy
ArbTxDecisionPolicy TxDecisionPolicy
defaultTxDecisionPolicy))
        , (Int
9, do
            interTxSpaceVal <- Double -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> DiffTime) -> Gen Double -> Gen DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double, Double) -> Gen Double
forall a. Random a => (a, a) -> Gen a
choose (Double
0 :: Double, Double
1)
            offset          <- choose (0.01 :: Double, 10)
            let inflightTimeoutVal = DiffTime
interTxSpaceVal DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ Double -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
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)
                <*> choose (0, 5)
                <*> pure interTxSpaceVal
                <*> pure inflightTimeoutVal
                <*> (realToFrac <$> choose (0.1, 1 :: Double))
                <*> pure False))
        ]

    shrink :: ArbTxDecisionPolicy -> [ArbTxDecisionPolicy]
shrink (ArbTxDecisionPolicy TxDecisionPolicy
a)
      | TxDecisionPolicy
a TxDecisionPolicy -> TxDecisionPolicy -> Bool
forall a. Eq a => a -> a -> Bool
== TxDecisionPolicy
defaultTxDecisionPolicy = []
      | Bool
otherwise = [ArbTxDecisionPolicy] -> [ArbTxDecisionPolicy]
forall a. Eq a => [a] -> [a]
nub ([ArbTxDecisionPolicy] -> [ArbTxDecisionPolicy])
-> [ArbTxDecisionPolicy] -> [ArbTxDecisionPolicy]
forall a b. (a -> b) -> a -> b
$
          TxDecisionPolicy -> ArbTxDecisionPolicy
ArbTxDecisionPolicy TxDecisionPolicy
defaultTxDecisionPolicy
        ArbTxDecisionPolicy
-> [ArbTxDecisionPolicy] -> [ArbTxDecisionPolicy]
forall a. a -> [a] -> [a]
: [ TxDecisionPolicy -> ArbTxDecisionPolicy
ArbTxDecisionPolicy TxDecisionPolicy
a { maxNumTxIdsToRequest = NumTxIdsToReq x }
          | (Positive (Small Word16
x)) <- Positive (Small Word16) -> [Positive (Small Word16)]
forall a. Arbitrary a => a -> [a]
shrink (Small Word16 -> Positive (Small Word16)
forall a. a -> Positive a
Positive (Word16 -> Small Word16
forall a. a -> Small a
Small (NumTxIdsToReq -> Word16
getNumTxIdsToReq (TxDecisionPolicy -> NumTxIdsToReq
maxNumTxIdsToRequest TxDecisionPolicy
a))))
          ]
        [ArbTxDecisionPolicy]
-> [ArbTxDecisionPolicy] -> [ArbTxDecisionPolicy]
forall a. [a] -> [a] -> [a]
++ [ TxDecisionPolicy -> ArbTxDecisionPolicy
ArbTxDecisionPolicy TxDecisionPolicy
a { maxUnacknowledgedTxIds = x }
           | (Positive (Small NumTxIdsToReq
x)) <- Positive (Small NumTxIdsToReq) -> [Positive (Small NumTxIdsToReq)]
forall a. Arbitrary a => a -> [a]
shrink (Small NumTxIdsToReq -> Positive (Small NumTxIdsToReq)
forall a. a -> Positive a
Positive (NumTxIdsToReq -> Small NumTxIdsToReq
forall a. a -> Small a
Small (TxDecisionPolicy -> NumTxIdsToReq
maxUnacknowledgedTxIds TxDecisionPolicy
a)))
           ]
        [ArbTxDecisionPolicy]
-> [ArbTxDecisionPolicy] -> [ArbTxDecisionPolicy]
forall a. [a] -> [a] -> [a]
++ [ TxDecisionPolicy -> ArbTxDecisionPolicy
ArbTxDecisionPolicy TxDecisionPolicy
a { txsSizeInflightPerPeer = SizeInBytes s }
           | Positive Word32
s <- Positive Word32 -> [Positive Word32]
forall a. Arbitrary a => a -> [a]
shrink (Word32 -> Positive Word32
forall a. a -> Positive a
Positive (SizeInBytes -> Word32
getSizeInBytes (TxDecisionPolicy -> SizeInBytes
txsSizeInflightPerPeer TxDecisionPolicy
a)))
           ]
        [ArbTxDecisionPolicy]
-> [ArbTxDecisionPolicy] -> [ArbTxDecisionPolicy]
forall a. [a] -> [a] -> [a]
++ [ TxDecisionPolicy -> ArbTxDecisionPolicy
ArbTxDecisionPolicy TxDecisionPolicy
a { maxOutstandingTxBatchesPerPeer = x }
           | Int
x <- Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink (TxDecisionPolicy -> Int
maxOutstandingTxBatchesPerPeer TxDecisionPolicy
a), Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
           ]
        [ArbTxDecisionPolicy]
-> [ArbTxDecisionPolicy] -> [ArbTxDecisionPolicy]
forall a. [a] -> [a] -> [a]
++ [ TxDecisionPolicy -> ArbTxDecisionPolicy
ArbTxDecisionPolicy TxDecisionPolicy
a { txInflightMultiplicity = x }
           | Positive (Small Int
x) <- Positive (Small Int) -> [Positive (Small Int)]
forall a. Arbitrary a => a -> [a]
shrink (Small Int -> Positive (Small Int)
forall a. a -> Positive a
Positive (Int -> Small Int
forall a. a -> Small a
Small (TxDecisionPolicy -> Int
txInflightMultiplicity TxDecisionPolicy
a)))
           ]
        [ArbTxDecisionPolicy]
-> [ArbTxDecisionPolicy] -> [ArbTxDecisionPolicy]
forall a. [a] -> [a] -> [a]
++ [ TxDecisionPolicy -> ArbTxDecisionPolicy
ArbTxDecisionPolicy TxDecisionPolicy
a { bufferedTxsMinLifetime = realToFrac x }
           | NonNegative Double
x <- NonNegative Double -> [NonNegative Double]
forall a. Arbitrary a => a -> [a]
shrink (Double -> NonNegative Double
forall a. a -> NonNegative a
NonNegative (DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (TxDecisionPolicy -> DiffTime
bufferedTxsMinLifetime TxDecisionPolicy
a) :: Double))
           ]
        [ArbTxDecisionPolicy]
-> [ArbTxDecisionPolicy] -> [ArbTxDecisionPolicy]
forall a. [a] -> [a] -> [a]
++ [ TxDecisionPolicy -> ArbTxDecisionPolicy
ArbTxDecisionPolicy TxDecisionPolicy
a { scoreRate = x }
           | NonNegative Double
x <- NonNegative Double -> [NonNegative Double]
forall a. Arbitrary a => a -> [a]
shrink (Double -> NonNegative Double
forall a. a -> NonNegative a
NonNegative (TxDecisionPolicy -> Double
scoreRate TxDecisionPolicy
a))
           ]
        [ArbTxDecisionPolicy]
-> [ArbTxDecisionPolicy] -> [ArbTxDecisionPolicy]
forall a. [a] -> [a] -> [a]
++ [ TxDecisionPolicy -> ArbTxDecisionPolicy
ArbTxDecisionPolicy TxDecisionPolicy
a { scoreMax = x }
           | NonNegative Double
x <- NonNegative Double -> [NonNegative Double]
forall a. Arbitrary a => a -> [a]
shrink (Double -> NonNegative Double
forall a. a -> NonNegative a
NonNegative (TxDecisionPolicy -> Double
scoreMax TxDecisionPolicy
a))
           ]
        [ArbTxDecisionPolicy]
-> [ArbTxDecisionPolicy] -> [ArbTxDecisionPolicy]
forall a. [a] -> [a] -> [a]
++ [ TxDecisionPolicy -> ArbTxDecisionPolicy
ArbTxDecisionPolicy TxDecisionPolicy
a { scoreAcceptDecrement = x }
           | NonNegative Double
x <- NonNegative Double -> [NonNegative Double]
forall a. Arbitrary a => a -> [a]
shrink (Double -> NonNegative Double
forall a. a -> NonNegative a
NonNegative (TxDecisionPolicy -> Double
scoreAcceptDecrement TxDecisionPolicy
a))
           ]
        [ArbTxDecisionPolicy]
-> [ArbTxDecisionPolicy] -> [ArbTxDecisionPolicy]
forall a. [a] -> [a] -> [a]
++ [ TxDecisionPolicy -> ArbTxDecisionPolicy
ArbTxDecisionPolicy TxDecisionPolicy
a { interTxSpace = realToFrac x }
           | NonNegative Double
x <- NonNegative Double -> [NonNegative Double]
forall a. Arbitrary a => a -> [a]
shrink (Double -> NonNegative Double
forall a. a -> NonNegative a
NonNegative (DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (TxDecisionPolicy -> DiffTime
interTxSpace TxDecisionPolicy
a) :: Double))
           ]
        [ArbTxDecisionPolicy]
-> [ArbTxDecisionPolicy] -> [ArbTxDecisionPolicy]
forall a. [a] -> [a] -> [a]
++ [ TxDecisionPolicy -> ArbTxDecisionPolicy
ArbTxDecisionPolicy TxDecisionPolicy
a { inflightTimeout = realToFrac x }
           | NonNegative Double
x <- NonNegative Double -> [NonNegative Double]
forall a. Arbitrary a => a -> [a]
shrink (Double -> NonNegative Double
forall a. a -> NonNegative a
NonNegative (DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (TxDecisionPolicy -> DiffTime
inflightTimeout TxDecisionPolicy
a) :: Double))
           , Double -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
x DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> TxDecisionPolicy -> DiffTime
interTxSpace TxDecisionPolicy
a
           ]

instance Arbitrary ArbPeerTxLocalState where
  arbitrary :: Gen ArbPeerTxLocalState
arbitrary = PeerTxLocalState (Tx Int) -> ArbPeerTxLocalState
ArbPeerTxLocalState (PeerTxLocalState (Tx Int) -> ArbPeerTxLocalState)
-> Gen (PeerTxLocalState (Tx Int)) -> Gen ArbPeerTxLocalState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (PeerTxLocalState (Tx Int))
genPeerTxLocalState

  shrink :: ArbPeerTxLocalState -> [ArbPeerTxLocalState]
shrink (ArbPeerTxLocalState PeerTxLocalState (Tx Int)
peerState)
    | PeerTxLocalState (Tx Int)
peerState PeerTxLocalState (Tx Int) -> PeerTxLocalState (Tx Int) -> Bool
forall a. Eq a => a -> a -> Bool
== PeerTxLocalState (Tx Int)
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState = []
    | Bool
otherwise =
        [ PeerTxLocalState (Tx Int) -> ArbPeerTxLocalState
ArbPeerTxLocalState PeerTxLocalState (Tx Int)
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState
        , PeerTxLocalState (Tx Int) -> ArbPeerTxLocalState
ArbPeerTxLocalState PeerTxLocalState (Tx Int)
peerState
            { peerRequestedTxs = IntSet.empty
            , peerRequestedTxBatches = StrictSeq.empty
            , peerRequestedTxsSize = 0
            , peerRequestedTxIds = 0
            , peerDownloadedTxs = IntMap.empty
            }
        ]

instance Arbitrary ArbSharedTxState where
  arbitrary :: Gen ArbSharedTxState
arbitrary = SharedTxState Int Int -> ArbSharedTxState
ArbSharedTxState (SharedTxState Int Int -> ArbSharedTxState)
-> Gen (SharedTxState Int Int) -> Gen ArbSharedTxState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (SharedTxState Int Int)
genSharedTxState

  shrink :: ArbSharedTxState -> [ArbSharedTxState]
shrink (ArbSharedTxState SharedTxState Int Int
sharedState)
    | SharedTxState Int Int
sharedState SharedTxState Int Int -> SharedTxState Int Int -> Bool
forall a. Eq a => a -> a -> Bool
== SharedTxState Int Int
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState = []
    | Bool
otherwise = SharedTxState Int Int -> ArbSharedTxState
ArbSharedTxState (SharedTxState Int Int -> ArbSharedTxState)
-> [SharedTxState Int Int] -> [ArbSharedTxState]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SharedTxState Int Int -> [SharedTxState Int Int]
shrinkSharedTxState SharedTxState Int Int
sharedState

--
-- Peer score tests
--

-- | 'currentPeerScore' decays the score linearly at 'scoreRate' per second.
unit_peerScore_decaysOverTime :: (String -> IO ()) -> Assertion
unit_peerScore_decaysOverTime :: (TestName -> IO ()) -> IO ()
unit_peerScore_decaysOverTime TestName -> IO ()
step = do
    TestName -> IO ()
step TestName
"After 50 seconds at scoreRate 0.1 a score of 10 should drain to 5"
    TxDecisionPolicy -> Time -> PeerScore -> Double
currentPeerScore TxDecisionPolicy
policy (DiffTime -> Time
Time DiffTime
50) PeerScore
score0 Double -> Double -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Double
5
    TestName -> IO ()
step TestName
"After 200 seconds the score should be fully decayed (clamped to 0)"
    TxDecisionPolicy -> Time -> PeerScore -> Double
currentPeerScore TxDecisionPolicy
policy (DiffTime -> Time
Time DiffTime
200) PeerScore
score0 Double -> Double -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Double
0
    TestName -> IO ()
step TestName
"Reading at the same instant as the last update returns the unchanged value"
    TxDecisionPolicy -> Time -> PeerScore -> Double
currentPeerScore TxDecisionPolicy
policy (DiffTime -> Time
Time DiffTime
0) PeerScore
score0 Double -> Double -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= PeerScore -> Double
peerScoreValue PeerScore
score0
  where
    -- Pin scoreRate to a value that makes the test arithmetic obvious;
    -- the production default may be tuned without affecting this
    -- formula-level invariant.
    policy :: TxDecisionPolicy
policy = TxDecisionPolicy
defaultTxDecisionPolicy { scoreRate = 0.1 }
    score0 :: PeerScore
score0 = PeerScore { peerScoreValue :: Double
peerScoreValue = Double
10, peerScoreTs :: Time
peerScoreTs = DiffTime -> Time
Time DiffTime
0 }

-- | A new rejection drains the existing score at 'scoreRate' per second
-- since its last update before adding the rejection count.
unit_applyPeerEvents_drainsThenAdds :: (String -> IO ()) -> Assertion
unit_applyPeerEvents_drainsThenAdds :: (TestName -> IO ()) -> IO ()
unit_applyPeerEvents_drainsThenAdds TestName -> IO ()
step = do
    TestName -> IO ()
step TestName
"Starting score 10 at Time 0; one rejection 50s later: 10 - (50 * 0.1) + 1 = 6"
    (Double, PeerTxLocalState (ZonkAny 109)) -> Double
forall a b. (a, b) -> a
fst (TxDecisionPolicy
-> Time
-> Int
-> Int
-> PeerTxLocalState (ZonkAny 109)
-> (Double, PeerTxLocalState (ZonkAny 109))
forall tx.
TxDecisionPolicy
-> Time
-> Int
-> Int
-> PeerTxLocalState tx
-> (Double, PeerTxLocalState tx)
applyPeerEvents TxDecisionPolicy
policy (DiffTime -> Time
Time DiffTime
50) Int
0 Int
1 PeerTxLocalState (ZonkAny 109)
forall tx. PeerTxLocalState tx
peerState0) Double -> Double -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Double
6
  where
    -- See 'unit_peerScore_decaysOverTime' for why the test pins
    -- scoreRate explicitly.
    policy :: TxDecisionPolicy
policy     = TxDecisionPolicy
defaultTxDecisionPolicy { scoreRate = 0.1 }
    peerState0 :: PeerTxLocalState tx
peerState0 = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState
                   { peerScore = PeerScore { peerScoreValue = 10
                                           , peerScoreTs    = Time 0 } }

--
-- handleReceivedTxIds
--

-- | Verifies that 'handleReceivedTxIds' classifies each incoming 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
-> NonEmptyList (Int, Positive Int, TxIdGroupTag) -> Property
prop_handleReceivedTxIds (ArbTxDecisionPolicy TxDecisionPolicy
policy) (NonEmpty [(Int, Positive Int, TxIdGroupTag)]
taggedInput) =
  let
    -- Normalise: positive txids, non-zero sizes; dedupe by txid.
    normalised :: [(TxId, SizeInBytes, TxIdGroupTag)]
    normalised :: [(Int, SizeInBytes, TxIdGroupTag)]
normalised =
      ((Int, SizeInBytes, TxIdGroupTag)
 -> (Int, SizeInBytes, TxIdGroupTag) -> Bool)
-> [(Int, SizeInBytes, TxIdGroupTag)]
-> [(Int, SizeInBytes, TxIdGroupTag)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int -> Int -> Bool)
-> ((Int, SizeInBytes, TxIdGroupTag) -> Int)
-> (Int, SizeInBytes, TxIdGroupTag)
-> (Int, SizeInBytes, TxIdGroupTag)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\(Int
t,SizeInBytes
_,TxIdGroupTag
_) -> Int
t))
        [ (Int -> Int
forall a. Num a => a -> a
abs Int
txid Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Positive Int -> SizeInBytes
mkSize Positive Int
sz, TxIdGroupTag
tag)
        | (Int
txid, Positive Int
sz, TxIdGroupTag
tag) <- [(Int, Positive Int, TxIdGroupTag)]
taggedInput
        ]

    txidsAndSizes :: [(TxId, SizeInBytes)]
    txidsAndSizes :: [(Int, SizeInBytes)]
txidsAndSizes = [ (Int
txid, SizeInBytes
sz) | (Int
txid, SizeInBytes
sz, TxIdGroupTag
_) <- [(Int, SizeInBytes, TxIdGroupTag)]
normalised ]

    newGroup :: [(Int, SizeInBytes)]
newGroup      = [ (Int
txid, SizeInBytes
sz) | (Int
txid, SizeInBytes
sz, TxIdGroupTag
TxIdNew)      <- [(Int, SizeInBytes, TxIdGroupTag)]
normalised ]
    retainedGroup :: [(Int, SizeInBytes)]
retainedGroup = [ (Int
txid, SizeInBytes
sz) | (Int
txid, SizeInBytes
sz, TxIdGroupTag
TxIdRetained) <- [(Int, SizeInBytes, TxIdGroupTag)]
normalised ]
    mempoolGroup :: [(Int, SizeInBytes)]
mempoolGroup  = [ (Int
txid, SizeInBytes
sz) | (Int
txid, SizeInBytes
sz, TxIdGroupTag
TxIdMempool)  <- [(Int, SizeInBytes, TxIdGroupTag)]
normalised ]

    mempoolHasTx :: TxId -> Bool
    mempoolHasTx :: Int -> Bool
mempoolHasTx Int
txid = Int
txid Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (((Int, SizeInBytes) -> Int) -> [(Int, SizeInBytes)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, SizeInBytes) -> Int
forall a b. (a, b) -> a
fst [(Int, SizeInBytes)]
mempoolGroup)

    sharedState0 :: SharedTxState Int Int
sharedState0 = TxDecisionPolicy
-> [(Int, SizeInBytes)]
-> SharedTxState Int Int
-> SharedTxState Int Int
seedRetainedTxids TxDecisionPolicy
policy [(Int, SizeInBytes)]
retainedGroup SharedTxState Int Int
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState

    requestedToReply :: NumTxIdsToReq
requestedToReply = Int -> NumTxIdsToReq
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(Int, SizeInBytes)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, SizeInBytes)]
txidsAndSizes)
    peerState0 :: PeerTxLocalState (Tx TxId)
    peerState0 :: PeerTxLocalState (Tx Int)
peerState0   = PeerTxLocalState (Tx Int)
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState { peerRequestedTxIds = requestedToReply }
    peerInFlight0 :: PeerTxInFlight
peerInFlight0 = PeerTxInFlight
emptyPeerTxInFlight

    (PeerTxLocalState (Tx Int)
peerState', PeerTxInFlight
peerInFlight', SharedTxState Int Int
sharedState') =
      (Int -> Bool)
-> Time
-> TxDecisionPolicy
-> NumTxIdsToReq
-> [(Int, SizeInBytes)]
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
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 Int -> Bool
mempoolHasTx Time
now TxDecisionPolicy
policy
                          NumTxIdsToReq
requestedToReply [(Int, SizeInBytes)]
txidsAndSizes
                          PeerTxLocalState (Tx Int)
peerState0 PeerTxInFlight
peerInFlight0 SharedTxState Int Int
sharedState0

    keyOf :: Int -> Int
keyOf Int
txid = TxKey -> Int
unTxKey (Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
sharedState')

    expectedAdvertisedKeys :: IntSet
expectedAdvertisedKeys =
      [Int] -> IntSet
IntSet.fromList [ Int -> Int
keyOf Int
txid | (Int
txid, SizeInBytes
_) <- [(Int, SizeInBytes)]
newGroup ]

    expectedAvailableTxIds :: IntMap SizeInBytes
expectedAvailableTxIds =
      [(Int, SizeInBytes)] -> IntMap SizeInBytes
forall a. [(Int, a)] -> IntMap a
IntMap.fromList [ (Int -> Int
keyOf Int
txid, SizeInBytes
sz) | (Int
txid, SizeInBytes
sz) <- [(Int, SizeInBytes)]
newGroup ]

    expectedUnacked :: [TxKey]
expectedUnacked =
      [ Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
sharedState' | (Int
txid, SizeInBytes
_) <- [(Int, SizeInBytes)]
txidsAndSizes ]

    retainUntil :: Time
retainUntil = DiffTime -> Time -> Time
addTime (TxDecisionPolicy -> DiffTime
bufferedTxsMinLifetime TxDecisionPolicy
policy) Time
now

    checkNew :: (Int, b) -> Property
checkNew (Int
txid, b
_) =
      let k :: Int
k = Int -> Int
keyOf Int
txid in
      TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"new tx " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
txid) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
        [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"missing TxClaimable entry"
            (case Int -> IntMap (TxEntry Int) -> Maybe (TxEntry Int)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedState') of
               Just TxEntry Int
txEntry -> [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
                 [ TxEntry Int -> TxLease Int
forall peeraddr. TxEntry peeraddr -> TxLease peeraddr
txLease TxEntry Int
txEntry TxLease Int -> TxLease Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Time -> TxLease Int
forall peeraddr. Time -> TxLease peeraddr
TxClaimable Time
now
                 , TxEntry Int -> Int
forall peeraddr. TxEntry peeraddr -> Int
txAttempt TxEntry Int
txEntry Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
0
                 , Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Bool
not (TxEntry Int -> Bool
forall peeraddr. TxEntry peeraddr -> Bool
txInSubmission TxEntry Int
txEntry))
                 ]
               Maybe (TxEntry Int)
Nothing -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False)
        , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"expected to be in retained" (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
            Bool -> Bool
not (Int -> RetainedTxs -> Bool
retainedMember Int
k (SharedTxState Int Int -> RetainedTxs
forall peeraddr txid. SharedTxState peeraddr txid -> RetainedTxs
sharedRetainedTxs SharedTxState Int Int
sharedState'))
        ]

    checkRetained :: (Int, b) -> Property
checkRetained (Int
txid, b
_) =
      let k :: Int
k = Int -> Int
keyOf Int
txid in
      TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"retained tx " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
txid) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
        [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"leaked into sharedTxTable"
            (Int -> IntMap (TxEntry Int) -> Bool
forall a. Int -> IntMap a -> Bool
IntMap.notMember Int
k (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedState'))
        , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"missing from retained"
            (Int -> RetainedTxs -> Bool
retainedMember Int
k (SharedTxState Int Int -> RetainedTxs
forall peeraddr txid. SharedTxState peeraddr txid -> RetainedTxs
sharedRetainedTxs SharedTxState Int Int
sharedState'))
        , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"leaked into pifAdvertised"
            (Int -> IntSet -> Bool
IntSet.notMember Int
k (PeerTxInFlight -> IntSet
pifAdvertised PeerTxInFlight
peerInFlight'))
        ]

    checkMempool :: (Int, b) -> Property
checkMempool (Int
txid, b
_) =
      let k :: Int
k = Int -> Int
keyOf Int
txid in
      TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"mempool tx " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
txid) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
        [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"leaked into sharedTxTable"
            (Int -> IntMap (TxEntry Int) -> Bool
forall a. Int -> IntMap a -> Bool
IntMap.notMember Int
k (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedState'))
        , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"missing or wrong retainUntil"
            (Int -> RetainedTxs -> Maybe Time
retainedLookup Int
k (SharedTxState Int Int -> RetainedTxs
forall peeraddr txid. SharedTxState peeraddr txid -> RetainedTxs
sharedRetainedTxs SharedTxState Int Int
sharedState') Maybe Time -> Maybe Time -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Time -> Maybe Time
forall a. a -> Maybe a
Just Time
retainUntil)
        , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"leaked into pifAdvertised"
            (Int -> IntSet -> Bool
IntSet.notMember Int
k (PeerTxInFlight -> IntSet
pifAdvertised PeerTxInFlight
peerInFlight'))
        ]
  in
    Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Bool -> Bool
not ([(Int, SizeInBytes)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, SizeInBytes)]
newGroup))      TestName
"txids include new"      (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Bool -> Bool
not ([(Int, SizeInBytes)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, SizeInBytes)]
retainedGroup)) TestName
"txids include retained" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Bool -> Bool
not ([(Int, SizeInBytes)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, SizeInBytes)]
mempoolGroup))  TestName
"txids include mempool"  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
      [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"unacknowledged queue mismatch"
          (StrictSeq TxKey -> [TxKey]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (PeerTxLocalState (Tx Int) -> StrictSeq TxKey
forall tx. PeerTxLocalState tx -> StrictSeq TxKey
peerUnacknowledgedTxIds PeerTxLocalState (Tx Int)
peerState') [TxKey] -> [TxKey] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [TxKey]
expectedUnacked)
      , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"peerAvailableTxIds mismatch"
          (PeerTxLocalState (Tx Int) -> IntMap SizeInBytes
forall tx. PeerTxLocalState tx -> IntMap SizeInBytes
peerAvailableTxIds PeerTxLocalState (Tx Int)
peerState' IntMap SizeInBytes -> IntMap SizeInBytes -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== IntMap SizeInBytes
expectedAvailableTxIds)
      , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"pifAdvertised mismatch"
          (PeerTxInFlight -> IntSet
pifAdvertised PeerTxInFlight
peerInFlight' IntSet -> IntSet -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== IntSet
expectedAdvertisedKeys)
      , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"peerRequestedTxIds was not consumed"
          (PeerTxLocalState (Tx Int) -> NumTxIdsToReq
forall tx. PeerTxLocalState tx -> NumTxIdsToReq
peerRequestedTxIds PeerTxLocalState (Tx Int)
peerState' NumTxIdsToReq -> NumTxIdsToReq -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== NumTxIdsToReq
0)
      , [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin (((Int, SizeInBytes) -> Property)
-> [(Int, SizeInBytes)] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, SizeInBytes) -> Property
forall {b}. (Int, b) -> Property
checkNew [(Int, SizeInBytes)]
newGroup)
      , [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin (((Int, SizeInBytes) -> Property)
-> [(Int, SizeInBytes)] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, SizeInBytes) -> Property
forall {b}. (Int, b) -> Property
checkRetained [(Int, SizeInBytes)]
retainedGroup)
      , [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin (((Int, SizeInBytes) -> Property)
-> [(Int, SizeInBytes)] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, SizeInBytes) -> Property
forall {b}. (Int, b) -> Property
checkMempool [(Int, SizeInBytes)]
mempoolGroup)
      , TxDecisionPolicy
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
-> SharedTxState Int Int
-> SharedTxState Int Int
-> Property
forall peeraddr txid tx.
(Ord peeraddr, Ord txid, HasRawTxId txid, Show peeraddr, Show txid,
 NoThunks tx) =>
TxDecisionPolicy
-> Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> SharedTxState peeraddr txid
-> SharedTxState peeraddr txid
-> Property
combinedStateInvariantStep TxDecisionPolicy
policy
          (Int
-> (PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
forall k a. k -> a -> Map k a
Map.singleton Int
peerAddr (PeerTxLocalState (Tx Int)
peerState', PeerTxInFlight
peerInFlight'))
          SharedTxState Int Int
sharedState0 SharedTxState Int Int
sharedState'
      ]
  where
    peerAddr :: Int
peerAddr = Int
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 :: (TestName -> IO ()) -> IO ()
unit_handleReceivedTxIds_advertisesExistingEntry TestName -> IO ()
step = do
    TestName -> IO ()
step TestName
"Set up a sharedTxTable entry leased to peer 0"
    let txid :: TxId
        txid :: Int
txid = Int
7
        existing :: SharedTxState Int Int
existing = [Int]
-> Int -> [Int] -> [(Int, SizeInBytes)] -> SharedTxState Int Int
mkActiveSharedState [Int
0] Int
0 [] [(Int
txid, SizeInBytes
256)]
        peerAddr2 :: PeerAddr
        peerAddr2 :: Int
peerAddr2 = Int
1
        entryBefore :: TxEntry Int
entryBefore = TxKey -> SharedTxState Int Int -> TxEntry Int
lookupEntryOrFail (Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
existing) SharedTxState Int Int
existing

    TestName -> IO ()
step TestName
"Peer 1 advertises the same txid"
    let (PeerTxLocalState tx
peerState', PeerTxInFlight
peerInFlight', SharedTxState Int Int
sharedState') =
          (Int -> Bool)
-> Time
-> TxDecisionPolicy
-> NumTxIdsToReq
-> [(Int, SizeInBytes)]
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerTxLocalState tx, PeerTxInFlight, SharedTxState Int Int)
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 (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False) Time
now TxDecisionPolicy
defaultTxDecisionPolicy
                              NumTxIdsToReq
1 [(Int
txid, SizeInBytes
256)]
                              PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState { peerRequestedTxIds = 1 }
                              PeerTxInFlight
emptyPeerTxInFlight
                              SharedTxState Int Int
existing

    TestName -> IO ()
step TestName
"Entry in sharedTxTable is unchanged"
    let entryAfter :: TxEntry Int
entryAfter = TxKey -> SharedTxState Int Int -> TxEntry Int
lookupEntryOrFail (Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
sharedState') SharedTxState Int Int
sharedState'
    TxEntry Int
entryAfter TxEntry Int -> TxEntry Int -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= TxEntry Int
entryBefore

    TestName -> IO ()
step TestName
"Peer 1 now tracks the txid as advertised + available"
    let k :: Int
k = TxKey -> Int
unTxKey (Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
sharedState')
    PeerTxInFlight -> IntSet
pifAdvertised PeerTxInFlight
peerInFlight' IntSet -> IntSet -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int -> IntSet
IntSet.singleton Int
k
    IntMap SizeInBytes -> [Int]
forall a. IntMap a -> [Int]
IntMap.keys (PeerTxLocalState (ZonkAny 107) -> IntMap SizeInBytes
forall tx. PeerTxLocalState tx -> IntMap SizeInBytes
peerAvailableTxIds PeerTxLocalState (ZonkAny 107)
forall tx. PeerTxLocalState tx
peerState') [Int] -> [Int] -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= [Int
k]
    StrictSeq TxKey -> [TxKey]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (PeerTxLocalState (ZonkAny 108) -> StrictSeq TxKey
forall tx. PeerTxLocalState tx -> StrictSeq TxKey
peerUnacknowledgedTxIds PeerTxLocalState (ZonkAny 108)
forall tx. PeerTxLocalState tx
peerState') [TxKey] -> [TxKey] -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= [Int -> TxKey
TxKey Int
k]
    -- peerAddr2 is referenced to keep the variable in scope for clarity.
    _ <- Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
peerAddr2
    pure ()

--
-- 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
-> NonEmptyList (Int, Positive Int, Bool) -> Property
prop_handleReceivedTxs (ArbTxDecisionPolicy TxDecisionPolicy
policy)
                       (NonEmpty [(Int, Positive Int, Bool)]
rawInput) =
  let
    normalised :: [(TxId, SizeInBytes, Bool)]
    normalised :: [(Int, SizeInBytes, Bool)]
normalised =
      ((Int, SizeInBytes, Bool) -> (Int, SizeInBytes, Bool) -> Bool)
-> [(Int, SizeInBytes, Bool)] -> [(Int, SizeInBytes, Bool)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int -> Int -> Bool)
-> ((Int, SizeInBytes, Bool) -> Int)
-> (Int, SizeInBytes, Bool)
-> (Int, SizeInBytes, Bool)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\(Int
t,SizeInBytes
_,Bool
_) -> Int
t))
        [ (Int -> Int
forall a. Num a => a -> a
abs Int
txid Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Positive Int -> SizeInBytes
mkSize Positive Int
sz, Bool
inReply)
        | (Int
txid, Positive Int
sz, Bool
inReply) <- [(Int, Positive Int, Bool)]
rawInput
        ]

    txidsAndSizes :: [(TxId, SizeInBytes)]
    txidsAndSizes :: [(Int, SizeInBytes)]
txidsAndSizes = [ (Int
txid, SizeInBytes
sz) | (Int
txid, SizeInBytes
sz, Bool
_) <- [(Int, SizeInBytes, Bool)]
normalised ]

    -- 1) Receive the txids on peer 1 to set up advertised + available.
    sharedState0 :: SharedTxState peeraddr txid
sharedState0 = SharedTxState peeraddr txid
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState
    requestedToReply :: NumTxIdsToReq
requestedToReply = Int -> NumTxIdsToReq
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(Int, SizeInBytes)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, SizeInBytes)]
txidsAndSizes)
    peerState0 :: PeerTxLocalState tx
peerState0   = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState { peerRequestedTxIds = requestedToReply }
    (PeerTxLocalState tx
peerState1, PeerTxInFlight
peerInFlight1, SharedTxState peeraddr Int
sharedState1) =
      (Int -> Bool)
-> Time
-> TxDecisionPolicy
-> NumTxIdsToReq
-> [(Int, SizeInBytes)]
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr Int
-> (PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr Int)
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 (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False) Time
now TxDecisionPolicy
policy
                          NumTxIdsToReq
requestedToReply [(Int, SizeInBytes)]
txidsAndSizes
                          PeerTxLocalState tx
forall tx. PeerTxLocalState tx
peerState0 PeerTxInFlight
emptyPeerTxInFlight SharedTxState peeraddr Int
forall peeraddr txid. SharedTxState peeraddr txid
sharedState0

    -- 2) Manually claim each key (simulate pickRequestTxs).
    keys :: [TxKey]
keys = [ Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1 | (Int
txid, SizeInBytes
_) <- [(Int, SizeInBytes)]
txidsAndSizes ]
    leaseUntil :: Time
leaseUntil = DiffTime -> Time -> Time
addTime (TxDecisionPolicy -> DiffTime
interTxSpace TxDecisionPolicy
policy) Time
now

    sharedState2 :: SharedTxState Int Int
sharedState2 = SharedTxState (ZonkAny 115) Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1 {
        sharedTxTable =
          List.foldl' (\IntMap (TxEntry Int)
tbl TxKey
k -> (TxEntry Int -> TxEntry Int)
-> Int -> IntMap (TxEntry Int) -> IntMap (TxEntry Int)
forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IntMap.adjust (TxKey -> TxEntry Int -> TxEntry Int
forall {p} {peeraddr}. p -> TxEntry peeraddr -> TxEntry Int
claimEntry TxKey
k) (TxKey -> Int
unTxKey TxKey
k) IntMap (TxEntry Int)
tbl)
                      (sharedTxTable sharedState1) keys,
        sharedGeneration = sharedGeneration sharedState1 + 1
      }
    claimEntry :: p -> TxEntry peeraddr -> TxEntry Int
claimEntry p
_ TxEntry peeraddr
entry =
      TxEntry peeraddr
entry {
        txLease = TxLeased peerAddr leaseUntil,
        txAttempt = txAttempt entry + 1
      }

    requestedKeySet :: IntSet
requestedKeySet = [Int] -> IntSet
IntSet.fromList ((TxKey -> Int) -> [TxKey] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxKey -> Int
unTxKey [TxKey]
keys)
    batch :: RequestedTxBatch
batch = [TxKey] -> SizeInBytes -> RequestedTxBatch
mkRequestedTxBatch [TxKey]
keys ([SizeInBytes] -> SizeInBytes
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((Int, SizeInBytes) -> SizeInBytes)
-> [(Int, SizeInBytes)] -> [SizeInBytes]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, SizeInBytes) -> SizeInBytes
forall a b. (a, b) -> b
snd [(Int, SizeInBytes)]
txidsAndSizes))
    peerState2 :: PeerTxLocalState tx
peerState2 = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
peerState1 {
        peerRequestedTxs = requestedKeySet,
        peerRequestedTxBatches = StrictSeq.singleton batch,
        peerRequestedTxsSize = requestedTxBatchSize batch
      }
    peerInFlight2 :: PeerTxInFlight
peerInFlight2 = PeerTxInFlight
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 :: [(Int, Tx Int)]
txReply = [ (Int
txid, Int -> SizeInBytes -> Tx Int
mkTx Int
txid SizeInBytes
sz)
              | (Int
txid, SizeInBytes
sz, Bool
inReply) <- [(Int, SizeInBytes, Bool)]
normalised
              , Bool
inReply
              ]
    expectedBuffered :: IntSet
expectedBuffered = [Int] -> IntSet
IntSet.fromList
      [ TxKey -> Int
unTxKey (Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1)
      | (Int
txid, SizeInBytes
_, Bool
inReply) <- [(Int, SizeInBytes, Bool)]
normalised, Bool
inReply
      ]
    expectedOmitted :: IntSet
expectedOmitted = IntSet
requestedKeySet IntSet -> IntSet -> IntSet
`IntSet.difference` IntSet
expectedBuffered

    (Int
omittedCount, Int
lateCount, PeerTxLocalState (Tx Int)
peerState3, PeerTxInFlight
peerInFlight3, SharedTxState Int Int
sharedState3) =
      (Int -> Bool)
-> Time
-> TxDecisionPolicy
-> Int
-> [(Int, Tx Int)]
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (Int, Int, PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr txid tx.
(HasCallStack, Eq peeraddr, Show 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 (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False) Time
now TxDecisionPolicy
policy Int
peerAddr [(Int, Tx Int)]
txReply
                        PeerTxLocalState (Tx Int)
forall tx. PeerTxLocalState tx
peerState2 PeerTxInFlight
peerInFlight2 SharedTxState Int Int
sharedState2
  in
    Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Bool -> Bool
not (IntSet -> Bool
IntSet.null IntSet
expectedBuffered)) TestName
"buffered subset"  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Bool -> Bool
not (IntSet -> Bool
IntSet.null IntSet
expectedOmitted))  TestName
"omitted subset"   (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
      [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"lateCount should be zero (no retained / mempool branch hit)"
          (Int
lateCount Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
0)
      , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"omittedCount mismatch"
          (Int
omittedCount Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== IntSet -> Int
IntSet.size IntSet
expectedOmitted)
      , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"buffered keys mismatch"
          (IntMap (Tx Int) -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet (PeerTxLocalState (Tx Int) -> IntMap (Tx Int)
forall tx. PeerTxLocalState tx -> IntMap tx
peerDownloadedTxs PeerTxLocalState (Tx Int)
peerState3) IntSet -> IntSet -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== IntSet
expectedBuffered)
      , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"peerRequestedTxs not drained"
          (PeerTxLocalState (Tx Int) -> IntSet
forall tx. PeerTxLocalState tx -> IntSet
peerRequestedTxs PeerTxLocalState (Tx Int)
peerState3 IntSet -> IntSet -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== IntSet
IntSet.empty)
      , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"request batch was not dequeued"
          (PeerTxLocalState (Tx Int) -> StrictSeq RequestedTxBatch
forall tx. PeerTxLocalState tx -> StrictSeq RequestedTxBatch
peerRequestedTxBatches PeerTxLocalState (Tx Int)
peerState3 StrictSeq RequestedTxBatch
-> StrictSeq RequestedTxBatch -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== StrictSeq RequestedTxBatch
forall a. StrictSeq a
StrictSeq.empty)
      , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"pifLeased should retain only buffered keys"
          (PeerTxInFlight -> IntSet
pifLeased PeerTxInFlight
peerInFlight3 IntSet -> IntSet -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== IntSet
expectedBuffered)
      , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"pifAttempting should retain only buffered keys"
          (PeerTxInFlight -> IntSet
pifAttempting PeerTxInFlight
peerInFlight3 IntSet -> IntSet -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== IntSet
expectedBuffered)
      , [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
          [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
              (TestName
"omitted entry " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
k TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" should sit TxClaimable") (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            case Int -> IntMap (TxEntry Int) -> Maybe (TxEntry Int)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedState3) of
              Just TxEntry Int
entry -> [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
                [ case TxEntry Int -> TxLease Int
forall peeraddr. TxEntry peeraddr -> TxLease peeraddr
txLease TxEntry Int
entry of
                    TxClaimable Time
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
                    TxLease Int
other         -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TxLease Int -> TestName
forall a. Show a => a -> TestName
show TxLease Int
other) Bool
False
                , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"txAttempt not decremented"
                    (TxEntry Int -> Int
forall peeraddr. TxEntry peeraddr -> Int
txAttempt TxEntry Int
entry Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
0)
                ]
              Maybe (TxEntry Int)
Nothing -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"entry vanished" Bool
False
          | Int
k <- IntSet -> [Int]
IntSet.toList IntSet
expectedOmitted
          ]
      , TxDecisionPolicy
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
-> SharedTxState Int Int
-> SharedTxState Int Int
-> Property
forall peeraddr txid tx.
(Ord peeraddr, Ord txid, HasRawTxId txid, Show peeraddr, Show txid,
 NoThunks tx) =>
TxDecisionPolicy
-> Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> SharedTxState peeraddr txid
-> SharedTxState peeraddr txid
-> Property
combinedStateInvariantStep TxDecisionPolicy
policy
          (Int
-> (PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
forall k a. k -> a -> Map k a
Map.singleton Int
peerAddr (PeerTxLocalState (Tx Int)
peerState3, PeerTxInFlight
peerInFlight3))
          SharedTxState Int Int
sharedState2 SharedTxState Int Int
sharedState3
      ]
  where
    peerAddr :: Int
peerAddr = Int
1 :: PeerAddr

--
-- handleSubmittedTxs
--

-- | 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_handleSubmittedTxs_retainsAcceptedAndDropsRejected :: ArbTxDecisionPolicy
-> NonEmptyList (Int, Positive Int, Bool) -> Property
prop_handleSubmittedTxs_retainsAcceptedAndDropsRejected
    (ArbTxDecisionPolicy TxDecisionPolicy
policy)
    (NonEmpty [(Int, Positive Int, Bool)]
rawInput) =
  let
    normalised :: [(TxId, SizeInBytes, Bool)]
    normalised :: [(Int, SizeInBytes, Bool)]
normalised =
      ((Int, SizeInBytes, Bool) -> (Int, SizeInBytes, Bool) -> Bool)
-> [(Int, SizeInBytes, Bool)] -> [(Int, SizeInBytes, Bool)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int -> Int -> Bool)
-> ((Int, SizeInBytes, Bool) -> Int)
-> (Int, SizeInBytes, Bool)
-> (Int, SizeInBytes, Bool)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\(Int
t,SizeInBytes
_,Bool
_) -> Int
t))
        [ (Int -> Int
forall a. Num a => a -> a
abs Int
txid Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Positive Int -> SizeInBytes
mkSize Positive Int
sz, Bool
accept)
        | (Int
txid, Positive Int
sz, Bool
accept) <- [(Int, Positive Int, Bool)]
rawInput
        ]

    txidsAndSizes :: [(Int, SizeInBytes)]
txidsAndSizes = [ (Int
txid, SizeInBytes
sz) | (Int
txid, SizeInBytes
sz, Bool
_) <- [(Int, SizeInBytes, Bool)]
normalised ]

    -- Pre-state: every key leased to peerAddr with txInSubmission set
    -- and the key already counted in 'pifSubmitting'.
    sharedState0 :: SharedTxState Int Int
sharedState0 = [Int]
-> Int -> [Int] -> [(Int, SizeInBytes)] -> SharedTxState Int Int
mkActiveSharedState [Int
peerAddr] Int
peerAddr [] [(Int, SizeInBytes)]
txidsAndSizes
    keys :: [TxKey]
keys = [ Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
sharedState0 | (Int
txid, SizeInBytes
_) <- [(Int, SizeInBytes)]
txidsAndSizes ]
    keySet :: IntSet
keySet = [Int] -> IntSet
IntSet.fromList ((TxKey -> Int) -> [TxKey] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxKey -> Int
unTxKey [TxKey]
keys)

    flipToSubmitting :: TxEntry peeraddr -> TxEntry peeraddr
flipToSubmitting TxEntry peeraddr
entry =
      TxEntry peeraddr
entry { txAttempt = 0, txInSubmission = True }
    sharedState1 :: SharedTxState Int Int
sharedState1 = SharedTxState Int Int
sharedState0 {
        sharedTxTable =
          IntSet.foldl' (flip (IntMap.adjust flipToSubmitting))
                        (sharedTxTable sharedState0)
                        keySet
      }

    peerInFlight0 :: PeerTxInFlight
peerInFlight0 = PeerTxInFlight
emptyPeerTxInFlight {
        pifLeased     = keySet,
        pifSubmitting = keySet,
        pifAdvertised = keySet
      }
    peerState0 :: PeerTxLocalState (Tx Int)
peerState0 = PeerTxLocalState (ZonkAny 116)
forall tx. PeerTxLocalState tx
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 :: [TxKey]
accepted = [ Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
sharedState1
               | (Int
txid, SizeInBytes
_, Bool
True)  <- [(Int, SizeInBytes, Bool)]
normalised ]
    rejected :: [TxKey]
rejected = [ Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
sharedState1
               | (Int
txid, SizeInBytes
_, Bool
False) <- [(Int, SizeInBytes, Bool)]
normalised ]

    acceptedKeys :: IntSet
acceptedKeys = [Int] -> IntSet
IntSet.fromList ((TxKey -> Int) -> [TxKey] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxKey -> Int
unTxKey [TxKey]
accepted)
    rejectedKeys :: IntSet
rejectedKeys = [Int] -> IntSet
IntSet.fromList ((TxKey -> Int) -> [TxKey] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxKey -> Int
unTxKey [TxKey]
rejected)

    (PeerTxLocalState (Tx Int)
peerState', PeerTxInFlight
peerInFlight', SharedTxState Int Int
sharedState') =
      Time
-> TxDecisionPolicy
-> Int
-> [TxKey]
-> [TxKey]
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Eq peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> [TxKey]
-> [TxKey]
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
handleSubmittedTxs Time
now TxDecisionPolicy
policy Int
peerAddr [TxKey]
accepted [TxKey]
rejected
                         PeerTxLocalState (Tx Int)
peerState0 PeerTxInFlight
peerInFlight0 SharedTxState Int Int
sharedState1

    -- Mirror the production pipeline in 'submitBufferedTxs': after
    -- 'handleSubmittedTxs', the V2 harness runs 'applyPeerEvents' on
    -- the resulting peer state.  Running 'peerTxLocalStateInvariant'
    -- on the output guards both its fast path
    -- (rejectedCount == 0 && score == 0) and its slow path against
    -- future strictness regressions via the invariant's embedded
    -- 'checkNoThunks'.
    (Double
_, PeerTxLocalState (Tx Int)
peerStateAfterEvents) =
      TxDecisionPolicy
-> Time
-> Int
-> Int
-> PeerTxLocalState (Tx Int)
-> (Double, PeerTxLocalState (Tx Int))
forall tx.
TxDecisionPolicy
-> Time
-> Int
-> Int
-> PeerTxLocalState tx
-> (Double, PeerTxLocalState tx)
applyPeerEvents TxDecisionPolicy
policy Time
now ([TxKey] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxKey]
accepted) ([TxKey] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxKey]
rejected) PeerTxLocalState (Tx Int)
peerState'

    retainUntil :: Time
retainUntil = DiffTime -> Time -> Time
addTime (TxDecisionPolicy -> DiffTime
bufferedTxsMinLifetime TxDecisionPolicy
policy) Time
now

    checkAccepted :: Int -> Property
checkAccepted Int
k =
      TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"accepted " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
k) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
        [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"still in sharedTxTable"
            (Int -> IntMap (TxEntry Int) -> Bool
forall a. Int -> IntMap a -> Bool
IntMap.notMember Int
k (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedState'))
        , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"missing or wrong retainUntil"
            (Int -> RetainedTxs -> Maybe Time
retainedLookup Int
k (SharedTxState Int Int -> RetainedTxs
forall peeraddr txid. SharedTxState peeraddr txid -> RetainedTxs
sharedRetainedTxs SharedTxState Int Int
sharedState') Maybe Time -> Maybe Time -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Time -> Maybe Time
forall a. a -> Maybe a
Just Time
retainUntil)
        ]
    checkRejected :: Int -> Property
checkRejected Int
k =
      TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"rejected " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
k) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        case Int -> IntMap (TxEntry Int) -> Maybe (TxEntry Int)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedState') of
          Just TxEntry Int
entry -> [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
            [ case TxEntry Int -> TxLease Int
forall peeraddr. TxEntry peeraddr -> TxLease peeraddr
txLease TxEntry Int
entry of
                TxClaimable Time
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
                TxLease Int
other         -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TxLease Int -> TestName
forall a. Show a => a -> TestName
show TxLease Int
other) Bool
False
            , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"txInSubmission still set"
                (Bool -> Bool
not (TxEntry Int -> Bool
forall peeraddr. TxEntry peeraddr -> Bool
txInSubmission TxEntry Int
entry))
            ]
          Maybe (TxEntry Int)
Nothing -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"entry vanished" Bool
False
  in
    Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Bool -> Bool
not ([TxKey] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxKey]
accepted)) TestName
"has accepted" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Bool -> Bool
not ([TxKey] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxKey]
rejected)) TestName
"has rejected" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
      [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"pifSubmitting still has keys"
          (PeerTxInFlight -> IntSet
pifSubmitting PeerTxInFlight
peerInFlight' IntSet -> IntSet -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== IntSet
IntSet.empty)
      , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"pifLeased not cleared for submitted keys"
          (PeerTxInFlight -> IntSet
pifLeased PeerTxInFlight
peerInFlight' IntSet -> IntSet -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== IntSet
IntSet.empty)
      , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"pifAdvertised not cleared for submitted keys"
          (PeerTxInFlight -> IntSet
pifAdvertised PeerTxInFlight
peerInFlight' IntSet -> IntSet -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== IntSet
IntSet.empty)
      , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"peerDownloadedTxs not cleared for submitted keys"
          (IntMap (Tx Int) -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet (PeerTxLocalState (Tx Int) -> IntMap (Tx Int)
forall tx. PeerTxLocalState tx -> IntMap tx
peerDownloadedTxs PeerTxLocalState (Tx Int)
peerState') IntSet -> IntSet -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== IntSet
IntSet.empty)
      , [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ((Int -> Property) -> [Int] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Property
checkAccepted (IntSet -> [Int]
IntSet.toList IntSet
acceptedKeys))
      , [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ((Int -> Property) -> [Int] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Property
checkRejected (IntSet -> [Int]
IntSet.toList IntSet
rejectedKeys))
      , TxDecisionPolicy
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
-> SharedTxState Int Int
-> SharedTxState Int Int
-> Property
forall peeraddr txid tx.
(Ord peeraddr, Ord txid, HasRawTxId txid, Show peeraddr, Show txid,
 NoThunks tx) =>
TxDecisionPolicy
-> Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> SharedTxState peeraddr txid
-> SharedTxState peeraddr txid
-> Property
combinedStateInvariantStep TxDecisionPolicy
policy
          (Int
-> (PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
forall k a. k -> a -> Map k a
Map.singleton Int
peerAddr (PeerTxLocalState (Tx Int)
peerState', PeerTxInFlight
peerInFlight'))
          SharedTxState Int Int
sharedState1 SharedTxState Int Int
sharedState'
      , TxDecisionPolicy -> PeerTxLocalState (Tx Int) -> Property
forall tx.
NoThunks tx =>
TxDecisionPolicy -> PeerTxLocalState tx -> Property
peerTxLocalStateInvariant TxDecisionPolicy
policy PeerTxLocalState (Tx Int)
peerStateAfterEvents
      ]
  where
    peerAddr :: Int
peerAddr = Int
1 :: PeerAddr

--
-- nextPeerAction
--

-- | An idle peer whose shared state has no work returns
-- 'PeerDoNothing' carrying the current 'sharedGeneration'.
prop_nextPeerAction_returnsSharedGeneration
  :: ArbTxDecisionPolicy
  -> Word64
  -> Property
prop_nextPeerAction_returnsSharedGeneration :: ArbTxDecisionPolicy -> Word64 -> Property
prop_nextPeerAction_returnsSharedGeneration (ArbTxDecisionPolicy TxDecisionPolicy
policy0) Word64
gen =
  let
    -- A zero unack window forces 'pickRequestTxIdsAction' to return
    -- 'Nothing', so the scheduler falls through to 'PeerDoNothing'.
    policy :: TxDecisionPolicy
policy = TxDecisionPolicy
policy0 { maxUnacknowledgedTxIds = 0
                     , maxNumTxIdsToRequest   = 0 }
    sharedState :: SharedTxState PeerAddr TxId
    sharedState :: SharedTxState Int Int
sharedState = SharedTxState Int Int
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState { sharedGeneration = gen }
    (PeerAction
action, PeerTxLocalState (ZonkAny 104)
_, PeerTxInFlight
_, SharedTxState Int Int
_) =
      Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (ZonkAny 104)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (ZonkAny 104), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState (ZonkAny 104)
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState
                     PeerTxInFlight
emptyPeerTxInFlight SharedTxState Int Int
sharedState
  in
    case PeerAction
action of
      PeerDoNothing Word64
g Maybe DiffTime
_ -> Word64
g Word64 -> Word64 -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Word64
gen
      PeerAction
_                 -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
action)
                                          Bool
False
  where
    peerAddr :: Int
peerAddr = Int
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 -> NonEmptyList (Int, Positive Int) -> Property
prop_nextPeerAction_picksTxsRespectingBudget (ArbTxDecisionPolicy TxDecisionPolicy
policy0)
                                             (NonEmpty [(Int, Positive Int)]
rawInput) =
  let
    -- Tighten the budget so the test exercises the truncation path.
    policy :: TxDecisionPolicy
policy = TxDecisionPolicy
policy0 { txsSizeInflightPerPeer = SizeInBytes 4096
                     , maxOutstandingTxBatchesPerPeer = 4 }

    txidsAndSizes :: [(TxId, SizeInBytes)]
    txidsAndSizes :: [(Int, SizeInBytes)]
txidsAndSizes =
      ((Int, SizeInBytes) -> (Int, SizeInBytes) -> Bool)
-> [(Int, SizeInBytes)] -> [(Int, SizeInBytes)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int -> Int -> Bool)
-> ((Int, SizeInBytes) -> Int)
-> (Int, SizeInBytes)
-> (Int, SizeInBytes)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, SizeInBytes) -> Int
forall a b. (a, b) -> a
fst)
        [ (Int -> Int
forall a. Num a => a -> a
abs Int
txid Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Word32 -> SizeInBytes
SizeInBytes (Word32
1 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`mod` Word32
2048)))
        | (Int
txid, Positive Int
n) <- [(Int, Positive Int)]
rawInput
        ]

    requestedToReply :: NumTxIdsToReq
requestedToReply = Int -> NumTxIdsToReq
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(Int, SizeInBytes)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, SizeInBytes)]
txidsAndSizes)
    peerState0 :: PeerTxLocalState tx
peerState0   = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState { peerRequestedTxIds = requestedToReply }
    (PeerTxLocalState tx
peerState1, PeerTxInFlight
peerInFlight1, SharedTxState peeraddr Int
sharedState1) =
      (Int -> Bool)
-> Time
-> TxDecisionPolicy
-> NumTxIdsToReq
-> [(Int, SizeInBytes)]
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr Int
-> (PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr Int)
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 (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False) Time
now TxDecisionPolicy
policy
                          NumTxIdsToReq
requestedToReply [(Int, SizeInBytes)]
txidsAndSizes
                          PeerTxLocalState tx
forall tx. PeerTxLocalState tx
peerState0 PeerTxInFlight
emptyPeerTxInFlight SharedTxState peeraddr Int
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState

    (PeerAction
action, PeerTxLocalState tx
_peerState', PeerTxInFlight
peerInFlight', SharedTxState Int Int
sharedState') =
      Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState tx
forall tx. PeerTxLocalState tx
peerState1 PeerTxInFlight
peerInFlight1 SharedTxState Int Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1

    keyOrder :: [Int]
keyOrder = [ TxKey -> Int
unTxKey (Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1)
               | (Int
txid, SizeInBytes
_) <- [(Int, SizeInBytes)]
txidsAndSizes ]
    sizeOf :: Int -> Word32
sizeOf Int
k =
      Word32 -> (SizeInBytes -> Word32) -> Maybe SizeInBytes -> Word32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word32
0 SizeInBytes -> Word32
getSizeInBytes
        (Int -> IntMap SizeInBytes -> Maybe SizeInBytes
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k (PeerTxLocalState (ZonkAny 100) -> IntMap SizeInBytes
forall tx. PeerTxLocalState tx -> IntMap SizeInBytes
peerAvailableTxIds PeerTxLocalState (ZonkAny 100)
forall tx. PeerTxLocalState tx
peerState1))

    budget :: Word32
budget = SizeInBytes -> Word32
getSizeInBytes (TxDecisionPolicy -> SizeInBytes
txsSizeInflightPerPeer TxDecisionPolicy
policy)
    isPrefix :: [a] -> [a] -> Bool
isPrefix [a]
_ []          = Bool
True
    isPrefix [] [a]
_          = Bool
False
    isPrefix (a
x:[a]
xs) (a
y:[a]
ys) = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y Bool -> Bool -> Bool
&& [a] -> [a] -> Bool
isPrefix [a]
xs [a]
ys
  in
    case PeerAction
action of
      PeerRequestTxs [TxKey]
picked ->
        let pickedKeys :: [Int]
pickedKeys = (TxKey -> Int) -> [TxKey] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxKey -> Int
unTxKey [TxKey]
picked
            pickedSize :: Word32
pickedSize = [Word32] -> Word32
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Int -> Word32) -> [Int] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Word32
sizeOf [Int]
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 :: Word32
tailSize = Word32
pickedSize Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32 -> (Int -> Word32) -> Maybe Int -> Word32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word32
0 Int -> Word32
sizeOf ([Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe [Int]
pickedKeys)
        in [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
             [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"picked is not a prefix of the unacked queue"
                 ([Int]
pickedKeys [Int] -> [Int] -> Bool
forall {a}. Eq a => [a] -> [a] -> Bool
`isPrefix` [Int]
keyOrder)
             , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
                 (TestName
"tail of picked exceeds budget: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Word32 -> TestName
forall a. Show a => a -> TestName
show Word32
pickedSize)
                 (Word32
tailSize Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word32
budget)
             , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"picked keys not added to pifLeased"
                 ([Int] -> IntSet
IntSet.fromList [Int]
pickedKeys
                    IntSet -> IntSet -> Bool
`IntSet.isSubsetOf` PeerTxInFlight -> IntSet
pifLeased PeerTxInFlight
peerInFlight')
             , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"claimed entries should be TxLeased to peerAddr"
                 ([Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
                   [ case Int -> IntMap (TxEntry Int) -> Maybe (TxEntry Int)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedState') of
                       Just TxEntry Int
entry -> case TxEntry Int -> TxLease Int
forall peeraddr. TxEntry peeraddr -> TxLease peeraddr
txLease TxEntry Int
entry of
                         TxLeased Int
owner Time
_ -> Int
owner Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
peerAddr
                         TxLease Int
other            -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TxLease Int -> TestName
forall a. Show a => a -> TestName
show TxLease Int
other)
                                                            Bool
False
                       Maybe (TxEntry Int)
Nothing -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"missing entry"
                                                 Bool
False
                   | Int
k <- [Int]
pickedKeys
                   ])
             ]
      PeerAction
_ ->
        -- 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.
        TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
action) Bool
True
  where
    peerAddr :: Int
peerAddr = Int
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 -> Positive Int -> Property
prop_nextPeerAction_ownerSubmitsBuffered (ArbTxDecisionPolicy TxDecisionPolicy
policy)
                                         (Positive Int
sizeBytes) =
  let
    txid :: TxId
    txid :: Int
txid = Int
1
    sz :: SizeInBytes
sz   = Word32 -> SizeInBytes
SizeInBytes (Word32
1 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
sizeBytes Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
1024))

    -- 1) Peer receives the txid (creates the entry).
    (PeerTxLocalState tx
peerState1, PeerTxInFlight
peerInFlight1, SharedTxState peeraddr Int
sharedState1) =
      (Int -> Bool)
-> Time
-> TxDecisionPolicy
-> NumTxIdsToReq
-> [(Int, SizeInBytes)]
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr Int
-> (PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr Int)
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 (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False) Time
now TxDecisionPolicy
policy NumTxIdsToReq
1 [(Int
txid, SizeInBytes
sz)]
                          (PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState { peerRequestedTxIds = 1 })
                          PeerTxInFlight
emptyPeerTxInFlight SharedTxState peeraddr Int
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState

    txKey :: TxKey
txKey   = Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1
    keyInt :: Int
keyInt  = TxKey -> Int
unTxKey TxKey
txKey
    leaseUntil :: Time
leaseUntil = DiffTime -> Time -> Time
addTime (TxDecisionPolicy -> DiffTime
interTxSpace TxDecisionPolicy
policy) Time
now

    -- 2) Manually claim and buffer the body (simulating
    -- pickRequestTxsAction + handleReceivedTxs's buffered branch).
    sharedState2 :: SharedTxState Int Int
sharedState2 = SharedTxState (ZonkAny 94) Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1 {
        sharedTxTable =
          IntMap.adjust
            (\TxEntry Int
entry -> TxEntry Int
entry {
                 txLease = TxLeased peerAddr leaseUntil,
                 txAttempt = txAttempt entry + 1
               })
            keyInt (sharedTxTable sharedState1)
      }
    peerState2 :: PeerTxLocalState (Tx Int)
peerState2 = PeerTxLocalState (ZonkAny 95)
forall tx. PeerTxLocalState tx
peerState1 {
        peerDownloadedTxs = IntMap.singleton keyInt (mkTx txid sz)
      }
    peerInFlight2 :: PeerTxInFlight
peerInFlight2 = PeerTxInFlight
peerInFlight1 {
        pifLeased     = IntSet.insert keyInt (pifLeased peerInFlight1),
        pifAttempting = IntSet.insert keyInt (pifAttempting peerInFlight1)
      }

    (PeerAction
action, PeerTxLocalState (Tx Int)
_, PeerTxInFlight
_, SharedTxState Int Int
_) =
      Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState (Tx Int)
peerState2 PeerTxInFlight
peerInFlight2 SharedTxState Int Int
sharedState2
  in
    case PeerAction
action of
      PeerSubmitTxs [TxKey]
ks -> [TxKey]
ks [TxKey] -> [TxKey] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [TxKey
txKey]
      PeerAction
_                -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
action) Bool
False
  where
    peerAddr :: Int
peerAddr = Int
1 :: PeerAddr

-- | A sender may legitimately re-advertise an unacked txid (e.g. fork
-- switch on the sender re-adds the tx to its mempool under a new idx;
-- the outbound side tracks by idx, not by hash).  When the same key
-- appears more than once in 'peerUnacknowledgedTxIds',
-- 'nextPeerAction' must still claim and request the body only once
-- per scheduler invocation, with 'txAttempt' incremented by exactly
-- one and 'peerRequestedTxsSize' charged for a single tx body.
unit_nextPeerAction_dedupsBodyRequestOnDuplicateTxIds :: Assertion
unit_nextPeerAction_dedupsBodyRequestOnDuplicateTxIds :: IO ()
unit_nextPeerAction_dedupsBodyRequestOnDuplicateTxIds = do
    let n :: Int
n  = Int
3
        sz :: SizeInBytes
sz = Word32 -> SizeInBytes
SizeInBytes Word32
512
        txid :: TxId
        txid :: Int
txid = Int
1

        -- Widen the unack window so N copies fit; pin the size budget
        -- to two tx bodies so the test catches the inflated-size bug
        -- (a per-occurrence charge would block the second occurrence).
        policy :: TxDecisionPolicy
policy = TxDecisionPolicy
defaultTxDecisionPolicy
          { maxUnacknowledgedTxIds         = NumTxIdsToReq (fromIntegral (n + 1))
          , maxNumTxIdsToRequest           = NumTxIdsToReq (fromIntegral (n + 1))
          , txsSizeInflightPerPeer         = SizeInBytes (getSizeInBytes sz * 2)
          , maxOutstandingTxBatchesPerPeer = 4
          }

        duplicated :: [(Int, SizeInBytes)]
duplicated       = Int -> (Int, SizeInBytes) -> [(Int, SizeInBytes)]
forall a. Int -> a -> [a]
replicate Int
n (Int
txid, SizeInBytes
sz)
        requestedToReply :: NumTxIdsToReq
requestedToReply = Int -> NumTxIdsToReq
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n

        -- Simulate the wire delivering N copies of the same txid in one
        -- 'MsgReplyTxIds' batch.
        (PeerTxLocalState tx
peerState1, PeerTxInFlight
peerInFlight1, SharedTxState peeraddr Int
sharedState1) =
          (Int -> Bool)
-> Time
-> TxDecisionPolicy
-> NumTxIdsToReq
-> [(Int, SizeInBytes)]
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr Int
-> (PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr Int)
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 (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False) Time
now TxDecisionPolicy
policy
                              NumTxIdsToReq
requestedToReply [(Int, SizeInBytes)]
duplicated
                              (PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState { peerRequestedTxIds = requestedToReply })
                              PeerTxInFlight
emptyPeerTxInFlight SharedTxState peeraddr Int
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState

        txKey :: TxKey
txKey  = Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1
        keyInt :: Int
keyInt = TxKey -> Int
unTxKey TxKey
txKey

        (PeerAction
action, PeerTxLocalState tx
peerState', PeerTxInFlight
peerInFlight', SharedTxState Int Int
sharedState') =
          Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState tx
forall tx. PeerTxLocalState tx
peerState1 PeerTxInFlight
peerInFlight1 SharedTxState Int Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1

    -- The queue must keep all N duplicates so the ack-by-count
    -- handshake stays in lockstep with the sender.
    StrictSeq TxKey -> Int
forall a. StrictSeq a -> Int
StrictSeq.length (PeerTxLocalState (ZonkAny 86) -> StrictSeq TxKey
forall tx. PeerTxLocalState tx -> StrictSeq TxKey
peerUnacknowledgedTxIds PeerTxLocalState (ZonkAny 86)
forall tx. PeerTxLocalState tx
peerState1) Int -> Int -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int
n

    case PeerAction
action of
      PeerRequestTxs [TxKey]
picked -> do
        [TxKey]
picked [TxKey] -> [TxKey] -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= [TxKey
txKey]
        HasCallStack => TestName -> Bool -> IO ()
TestName -> Bool -> IO ()
assertBool TestName
"pifLeased must contain the key"
          (Int -> IntSet -> Bool
IntSet.member Int
keyInt (PeerTxInFlight -> IntSet
pifLeased PeerTxInFlight
peerInFlight'))
        case Int -> IntMap (TxEntry Int) -> Maybe (TxEntry Int)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
keyInt (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedState') of
          Just TxEntry Int
e  -> TxEntry Int -> Int
forall peeraddr. TxEntry peeraddr -> Int
txAttempt TxEntry Int
e Int -> Int -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int
1
          Maybe (TxEntry Int)
Nothing -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure TestName
"missing entry after request"
        PeerTxLocalState (ZonkAny 87) -> SizeInBytes
forall tx. PeerTxLocalState tx -> SizeInBytes
peerRequestedTxsSize PeerTxLocalState (ZonkAny 87)
forall tx. PeerTxLocalState tx
peerState' SizeInBytes -> SizeInBytes -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= SizeInBytes
sz
        StrictSeq RequestedTxBatch -> Int
forall a. StrictSeq a -> Int
StrictSeq.length (PeerTxLocalState (ZonkAny 88) -> StrictSeq RequestedTxBatch
forall tx. PeerTxLocalState tx -> StrictSeq RequestedTxBatch
peerRequestedTxBatches PeerTxLocalState (ZonkAny 88)
forall tx. PeerTxLocalState tx
peerState') Int -> Int -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int
1
        PeerTxLocalState (ZonkAny 89) -> IntSet
forall tx. PeerTxLocalState tx -> IntSet
peerRequestedTxs PeerTxLocalState (ZonkAny 89)
forall tx. PeerTxLocalState tx
peerState' IntSet -> IntSet -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int -> IntSet
IntSet.singleton Int
keyInt
      PeerAction
_ ->
        TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure (TestName
"expected PeerRequestTxs, got: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
action)
  where
    peerAddr :: Int
peerAddr = Int
1 :: PeerAddr

-- | When the same key appears more than once in
-- 'peerUnacknowledgedTxIds' and we have its body buffered,
-- 'nextPeerAction' must submit the key only once.  Otherwise the
-- mempool would receive duplicate copies, and a mempool that
-- deduplicates internally would have its duplicate-rejected entries
-- misclassified as accepted by 'classifySubmittedTxs' in V2.
unit_nextPeerAction_dedupsSubmitOnDuplicateTxIds :: Assertion
unit_nextPeerAction_dedupsSubmitOnDuplicateTxIds :: IO ()
unit_nextPeerAction_dedupsSubmitOnDuplicateTxIds = do
    let n :: Int
n  = Int
3
        sz :: SizeInBytes
sz = Word32 -> SizeInBytes
SizeInBytes Word32
512
        txid :: TxId
        txid :: Int
txid = Int
1

        policy :: TxDecisionPolicy
policy = TxDecisionPolicy
defaultTxDecisionPolicy
          { maxUnacknowledgedTxIds = NumTxIdsToReq (fromIntegral (n + 1))
          , maxNumTxIdsToRequest   = NumTxIdsToReq (fromIntegral (n + 1))
          }

        duplicated :: [(Int, SizeInBytes)]
duplicated       = Int -> (Int, SizeInBytes) -> [(Int, SizeInBytes)]
forall a. Int -> a -> [a]
replicate Int
n (Int
txid, SizeInBytes
sz)
        requestedToReply :: NumTxIdsToReq
requestedToReply = Int -> NumTxIdsToReq
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n

        (PeerTxLocalState tx
peerState1, PeerTxInFlight
peerInFlight1, SharedTxState peeraddr Int
sharedState1) =
          (Int -> Bool)
-> Time
-> TxDecisionPolicy
-> NumTxIdsToReq
-> [(Int, SizeInBytes)]
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr Int
-> (PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr Int)
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 (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False) Time
now TxDecisionPolicy
policy
                              NumTxIdsToReq
requestedToReply [(Int, SizeInBytes)]
duplicated
                              (PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState { peerRequestedTxIds = requestedToReply })
                              PeerTxInFlight
emptyPeerTxInFlight SharedTxState peeraddr Int
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState

        txKey :: TxKey
txKey      = Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1
        keyInt :: Int
keyInt     = TxKey -> Int
unTxKey TxKey
txKey
        leaseUntil :: Time
leaseUntil = DiffTime -> Time -> Time
addTime (TxDecisionPolicy -> DiffTime
interTxSpace TxDecisionPolicy
policy) Time
now

        -- Manually claim the lease and buffer the body, simulating a
        -- completed body fetch.  The buffered body covers every
        -- duplicate in the queue since they all share the same key.
        sharedState2 :: SharedTxState Int Int
sharedState2 = SharedTxState (ZonkAny 77) Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1 {
            sharedTxTable =
              IntMap.adjust
                (\TxEntry Int
entry -> TxEntry Int
entry {
                     txLease   = TxLeased peerAddr leaseUntil,
                     txAttempt = txAttempt entry + 1
                   })
                keyInt (sharedTxTable sharedState1)
          }
        peerState2 :: PeerTxLocalState (Tx Int)
peerState2 = PeerTxLocalState (ZonkAny 78)
forall tx. PeerTxLocalState tx
peerState1 {
            peerDownloadedTxs = IntMap.singleton keyInt (mkTx txid sz)
          }
        peerInFlight2 :: PeerTxInFlight
peerInFlight2 = PeerTxInFlight
peerInFlight1 {
            pifLeased     = IntSet.insert keyInt (pifLeased peerInFlight1),
            pifAttempting = IntSet.insert keyInt (pifAttempting peerInFlight1)
          }

        (PeerAction
action, PeerTxLocalState (Tx Int)
_, PeerTxInFlight
_, SharedTxState Int Int
_) =
          Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState (Tx Int)
peerState2 PeerTxInFlight
peerInFlight2 SharedTxState Int Int
sharedState2

    StrictSeq TxKey -> Int
forall a. StrictSeq a -> Int
StrictSeq.length (PeerTxLocalState (Tx Int) -> StrictSeq TxKey
forall tx. PeerTxLocalState tx -> StrictSeq TxKey
peerUnacknowledgedTxIds PeerTxLocalState (Tx Int)
peerState2) Int -> Int -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int
n
    case PeerAction
action of
      PeerSubmitTxs [TxKey]
ks -> [TxKey]
ks [TxKey] -> [TxKey] -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= [TxKey
txKey]
      PeerAction
_ -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure (TestName
"expected PeerSubmitTxs, got: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
action)
  where
    peerAddr :: Int
peerAddr = Int
1 :: PeerAddr

-- | When another peer resolves a tx into the mempool while this peer
-- still has its body buffered, the scheduler's 'mkPeerActionContext'
-- drops the orphaned body from 'peerDownloadedTxs' (it can no longer
-- be submitted: there is no active 'sharedTxTable' entry to mark
-- 'txInSubmission' on).  The matching 'pifLeased' / 'pifAttempting'
-- entries must also be cleared, otherwise:
--
-- * 'txSelectable' wrongly vetoes a re-claim on re-advertisement via
--   'txPeerHasAttempt' (the same 'TxKey' is returned when the txid is
--   re-interned), so this peer becomes silently unproductive for that
--   txid; and
-- * on bracket exit, 'scrubFromPeerInFlight.decAttempt' decrements
--   'txAttempt' on a freshly re-interned entry that this peer never
--   claimed, corrupting another peer's accounting.
unit_nextPeerAction_clearsInFlightForPrunedBody :: Assertion
unit_nextPeerAction_clearsInFlightForPrunedBody :: IO ()
unit_nextPeerAction_clearsInFlightForPrunedBody = do
    let sz :: SizeInBytes
sz = Word32 -> SizeInBytes
SizeInBytes Word32
512
        txid :: TxId
        txid :: Int
txid = Int
1
        policy :: TxDecisionPolicy
policy = TxDecisionPolicy
defaultTxDecisionPolicy

        -- Peer A receives the txid advertisement.
        (PeerTxLocalState tx
peerState1, PeerTxInFlight
peerInFlight1, SharedTxState peeraddr Int
sharedState1) =
          (Int -> Bool)
-> Time
-> TxDecisionPolicy
-> NumTxIdsToReq
-> [(Int, SizeInBytes)]
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr Int
-> (PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr Int)
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 (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False) Time
now TxDecisionPolicy
policy NumTxIdsToReq
1 [(Int
txid, SizeInBytes
sz)]
                              (PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState { peerRequestedTxIds = 1 })
                              PeerTxInFlight
emptyPeerTxInFlight SharedTxState peeraddr Int
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState

        txKey :: TxKey
txKey      = Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1
        keyInt :: Int
keyInt     = TxKey -> Int
unTxKey TxKey
txKey
        leaseUntil :: Time
leaseUntil = DiffTime -> Time -> Time
addTime (TxDecisionPolicy -> DiffTime
interTxSpace TxDecisionPolicy
policy) Time
now

        -- Peer A has claimed the lease and buffered the downloaded body.
        sharedState2 :: SharedTxState Int Int
sharedState2 = SharedTxState (ZonkAny 71) Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1 {
            sharedTxTable =
              IntMap.adjust
                (\TxEntry Int
entry -> TxEntry Int
entry {
                     txLease   = TxLeased peerAddr leaseUntil,
                     txAttempt = txAttempt entry + 1
                   })
                keyInt (sharedTxTable sharedState1)
          }
        peerState2 :: PeerTxLocalState (Tx Int)
peerState2 = PeerTxLocalState (ZonkAny 72)
forall tx. PeerTxLocalState tx
peerState1 {
            peerDownloadedTxs = IntMap.singleton keyInt (mkTx txid sz)
          }
        peerInFlight2 :: PeerTxInFlight
peerInFlight2 = PeerTxInFlight
peerInFlight1 {
            pifLeased     = IntSet.insert keyInt (pifLeased peerInFlight1),
            pifAttempting = IntSet.insert keyInt (pifAttempting peerInFlight1)
          }

        -- Simulate a sibling advertiser submitting the same tx to the
        -- mempool.  The active entry moves to 'sharedRetainedTxs'; peer
        -- A's local body buffer is now orphaned.
        retainUntil :: Time
retainUntil = DiffTime -> Time -> Time
addTime (TxDecisionPolicy -> DiffTime
bufferedTxsMinLifetime TxDecisionPolicy
policy) Time
now
        sharedState3 :: SharedTxState Int Int
sharedState3 = SharedTxState Int Int
sharedState2 {
            sharedTxTable     = IntMap.delete keyInt (sharedTxTable sharedState2),
            sharedRetainedTxs =
              retainedInsertMax keyInt retainUntil (sharedRetainedTxs sharedState2),
            sharedGeneration  = sharedGeneration sharedState2 + 1
          }

        (PeerAction
_action, PeerTxLocalState (Tx Int)
peerState', PeerTxInFlight
peerInFlight', SharedTxState Int Int
_sharedState') =
          Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState (Tx Int)
peerState2 PeerTxInFlight
peerInFlight2 SharedTxState Int Int
sharedState3

    -- The orphaned body is pruned from the local buffer.
    HasCallStack => TestName -> Bool -> IO ()
TestName -> Bool -> IO ()
assertBool TestName
"peerDownloadedTxs must drop the orphaned body"
      (Int -> IntMap (Tx Int) -> Bool
forall a. Int -> IntMap a -> Bool
IntMap.notMember Int
keyInt (PeerTxLocalState (Tx Int) -> IntMap (Tx Int)
forall tx. PeerTxLocalState tx -> IntMap tx
peerDownloadedTxs PeerTxLocalState (Tx Int)
peerState'))
    -- The matching in-flight tracking entries must be cleared in lockstep.
    HasCallStack => TestName -> Bool -> IO ()
TestName -> Bool -> IO ()
assertBool TestName
"pifLeased must drop the orphaned key"
      (Int -> IntSet -> Bool
IntSet.notMember Int
keyInt (PeerTxInFlight -> IntSet
pifLeased PeerTxInFlight
peerInFlight'))
    HasCallStack => TestName -> Bool -> IO ()
TestName -> Bool -> IO ()
assertBool TestName
"pifAttempting must drop the orphaned key"
      (Int -> IntSet -> Bool
IntSet.notMember Int
keyInt (PeerTxInFlight -> IntSet
pifAttempting PeerTxInFlight
peerInFlight'))
  where
    peerAddr :: Int
peerAddr = Int
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 -> Positive Int -> Property
prop_nextPeerAction_prunesExpiredRetained (ArbTxDecisionPolicy TxDecisionPolicy
policy)
                                          (Positive Int
nTxids) =
  let
    n :: Int
n = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
nTxids Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
5)
    txidsAndSizes :: [(Int, SizeInBytes)]
txidsAndSizes =
      [ (Int
t, Word32 -> SizeInBytes
SizeInBytes Word32
64) | Int
t <- [Int
1 .. Int
n] ]

    sharedState0 :: SharedTxState Int Int
sharedState0 = TxDecisionPolicy
-> [(Int, SizeInBytes)]
-> SharedTxState Int Int
-> SharedTxState Int Int
seedRetainedTxids TxDecisionPolicy
policy [(Int, SizeInBytes)]
txidsAndSizes SharedTxState Int Int
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState
    expired :: Time
expired      = DiffTime -> Time -> Time
addTime (TxDecisionPolicy -> DiffTime
bufferedTxsMinLifetime TxDecisionPolicy
policy DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
1) Time
now
    sharedState' :: SharedTxState Int Int
sharedState' = Time -> IntSet -> SharedTxState Int Int -> SharedTxState Int Int
forall txid peeraddr.
HasRawTxId txid =>
Time
-> IntSet
-> SharedTxState peeraddr txid
-> SharedTxState peeraddr txid
sweepSharedState Time
expired IntSet
IntSet.empty SharedTxState Int Int
sharedState0
  in
    TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
      (TestName
"retained set after sweep: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show (RetainedTxs -> Int
retainedSize (SharedTxState Int Int -> RetainedTxs
forall peeraddr txid. SharedTxState peeraddr txid -> RetainedTxs
sharedRetainedTxs SharedTxState Int Int
sharedState')))
      (RetainedTxs -> Int
retainedSize (SharedTxState Int Int -> RetainedTxs
forall peeraddr txid. SharedTxState peeraddr txid -> RetainedTxs
sharedRetainedTxs SharedTxState Int Int
sharedState') Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
0)

-- | Before the retention deadline expires, retained entries survive a
-- sweep call.
prop_nextPeerAction_keepsRetained
  :: ArbTxDecisionPolicy
  -> Positive Int
  -> Property
prop_nextPeerAction_keepsRetained :: ArbTxDecisionPolicy -> Positive Int -> Property
prop_nextPeerAction_keepsRetained (ArbTxDecisionPolicy TxDecisionPolicy
policy)
                                  (Positive Int
nTxids) =
  let
    n :: Int
n = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
nTxids Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
5)
    txidsAndSizes :: [(Int, SizeInBytes)]
txidsAndSizes =
      [ (Int
t, Word32 -> SizeInBytes
SizeInBytes Word32
64) | Int
t <- [Int
1 .. Int
n] ]

    sharedState0 :: SharedTxState Int Int
sharedState0 = TxDecisionPolicy
-> [(Int, SizeInBytes)]
-> SharedTxState Int Int
-> SharedTxState Int Int
seedRetainedTxids TxDecisionPolicy
policy [(Int, SizeInBytes)]
txidsAndSizes SharedTxState Int Int
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState
    sharedState' :: SharedTxState Int Int
sharedState' = Time -> IntSet -> SharedTxState Int Int -> SharedTxState Int Int
forall txid peeraddr.
HasRawTxId txid =>
Time
-> IntSet
-> SharedTxState peeraddr txid
-> SharedTxState peeraddr txid
sweepSharedState Time
now IntSet
IntSet.empty SharedTxState Int Int
sharedState0
  in
    RetainedTxs -> Int
retainedSize (SharedTxState Int Int -> RetainedTxs
forall peeraddr txid. SharedTxState peeraddr txid -> RetainedTxs
sharedRetainedTxs SharedTxState Int Int
sharedState') Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
n

--
-- 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 -> Property
prop_nextPeerActionPipelined_requestsTxIds (ArbTxDecisionPolicy TxDecisionPolicy
policy0) =
  let
    policy :: TxDecisionPolicy
policy = TxDecisionPolicy
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 :: [(Int, SizeInBytes)]
txids = [(Int
1, SizeInBytes
64), (Int
2, SizeInBytes
64)] :: [(TxId, SizeInBytes)]
    sharedState0 :: SharedTxState Int Int
sharedState0 = TxDecisionPolicy
-> [(Int, SizeInBytes)]
-> SharedTxState Int Int
-> SharedTxState Int Int
seedRetainedTxids TxDecisionPolicy
policy [(Int, SizeInBytes)]
txids SharedTxState Int Int
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState
    keys :: [TxKey]
keys = [ Int -> TxKey
TxKey (TxKey -> Int
unTxKey (Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
sharedState0))
           | (Int
txid, SizeInBytes
_) <- [(Int, SizeInBytes)]
txids ]
    peerState0 :: PeerTxLocalState tx
peerState0 = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState {
        peerUnacknowledgedTxIds = StrictSeq.fromList keys,
        peerRequestedTxIds      = 1
      }
    (PeerAction
action, PeerTxLocalState (ZonkAny 66)
_, PeerTxInFlight
_, SharedTxState Int Int
_) =
      Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (ZonkAny 66)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (ZonkAny 66), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerActionPipelined Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState (ZonkAny 66)
forall tx. PeerTxLocalState tx
peerState0
                              PeerTxInFlight
emptyPeerTxInFlight SharedTxState Int Int
sharedState0
  in
    TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"got: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
action) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      case PeerAction
action of
        PeerRequestTxIds NumTxIdsToAck
ack NumTxIdsToReq
req ->
          [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"ack should be non-zero"
                      (NumTxIdsToAck
ack NumTxIdsToAck -> NumTxIdsToAck -> Bool
forall a. Eq a => a -> a -> Bool
/= NumTxIdsToAck
0)
                  , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"req should be non-zero"
                      (NumTxIdsToReq
req NumTxIdsToReq -> NumTxIdsToReq -> Bool
forall a. Eq a => a -> a -> Bool
/= NumTxIdsToReq
0)
                  ]
        PeerAction
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
  where
    peerAddr :: Int
peerAddr = Int
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 :: (TestName -> IO ()) -> IO ()
unit_nextPeerActionPipelined_keepsOneUnackedWithOutstandingBodyReply TestName -> IO ()
step = do
    TestName -> IO ()
step TestName
"Set up a peer with one retained (ackable) txid and an outstanding body batch"
    let txid :: TxId
        txid :: Int
txid = Int
1
        policy :: TxDecisionPolicy
policy = TxDecisionPolicy
defaultTxDecisionPolicy
        sharedState0 :: SharedTxState Int Int
sharedState0 = TxDecisionPolicy
-> [(Int, SizeInBytes)]
-> SharedTxState Int Int
-> SharedTxState Int Int
seedRetainedTxids TxDecisionPolicy
policy [(Int
txid, SizeInBytes
64)] SharedTxState Int Int
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState
        keyInt :: Int
keyInt = TxKey -> Int
unTxKey (Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
sharedState0)
        outstandingBatch :: RequestedTxBatch
outstandingBatch = [TxKey] -> SizeInBytes -> RequestedTxBatch
mkRequestedTxBatch [Int -> TxKey
TxKey Int
keyInt] SizeInBytes
64
        peerState0 :: PeerTxLocalState tx
peerState0 = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState {
            peerUnacknowledgedTxIds = StrictSeq.singleton (TxKey keyInt),
            peerRequestedTxs        = IntSet.singleton keyInt,
            peerRequestedTxBatches  = StrictSeq.singleton outstandingBatch,
            peerRequestedTxsSize    = 64
          }

    TestName -> IO ()
step TestName
"Run nextPeerActionPipelined"
    let (PeerAction
action, PeerTxLocalState (ZonkAny 65)
_, PeerTxInFlight
_, SharedTxState Int Int
_) =
          Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (ZonkAny 65)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (ZonkAny 65), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerActionPipelined Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState (ZonkAny 65)
forall tx. PeerTxLocalState tx
peerState0
                                  PeerTxInFlight
emptyPeerTxInFlight SharedTxState Int Int
sharedState0

    TestName -> IO ()
step TestName
"Pipelined response must keep the txid unacked while the body batch is outstanding"
    case PeerAction
action of
      PeerRequestTxIds NumTxIdsToAck
ack NumTxIdsToReq
_ ->
        NumTxIdsToAck
ack NumTxIdsToAck -> NumTxIdsToAck -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= NumTxIdsToAck
0
      PeerDoNothing {} ->
        -- Acceptable: not enough room to request anything.
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      PeerAction
other ->
        TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure (TestName
"unexpected action: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
other)
  where
    peerAddr :: Int
peerAddr = Int
1 :: PeerAddr

-- | When the peer has an unacked txid that is *not* ackable (so the
-- ack prefix is empty) but the unack window still has room, the
-- pipelined picker emits a request-only message ('ack=0, req=N').
-- Filling the window without acking is spec-compliant and matches V1's
-- behaviour.
prop_nextPeerActionPipelined_allowsRequestOnly
  :: ArbTxDecisionPolicy
  -> Property
prop_nextPeerActionPipelined_allowsRequestOnly :: ArbTxDecisionPolicy -> Property
prop_nextPeerActionPipelined_allowsRequestOnly (ArbTxDecisionPolicy TxDecisionPolicy
policy0) =
  let
    -- Cap to small windows so the property is easy to reason about.
    policy :: TxDecisionPolicy
policy = TxDecisionPolicy
policy0 { maxUnacknowledgedTxIds = 4
                     , maxNumTxIdsToRequest   = 4 }
    txid :: TxId
    txid :: Int
txid = Int
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 :: SharedTxState Int Int
sharedState0 = [Int]
-> Int -> [Int] -> [(Int, SizeInBytes)] -> SharedTxState Int Int
mkActiveSharedState [Int
peerAddr] Int
peerAddr [] [(Int
txid, SizeInBytes
64)]
    keyInt :: Int
keyInt = TxKey -> Int
unTxKey (Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
sharedState0)
    -- Strip the leaseholder so the entry is TxClaimable, attempt 0.
    sharedState1 :: SharedTxState Int Int
sharedState1 = SharedTxState Int Int
sharedState0 {
        sharedTxTable =
          IntMap.adjust
            (\TxEntry Int
entry -> TxEntry Int
entry {
                 txLease   = TxClaimable now,
                 txAttempt = 0
               })
            keyInt (sharedTxTable sharedState0)
      }
    -- Leave 'peerAvailableTxIds' empty so 'pickRequestTxsAction' finds no
    -- body candidate and the scheduler falls through to the txid picker.
    peerState0 :: PeerTxLocalState tx
peerState0 = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState {
        peerUnacknowledgedTxIds = StrictSeq.singleton (TxKey keyInt),
        peerRequestedTxIds = 1  -- pretend there's a pipelined req in flight
      }
    peerInFlight0 :: PeerTxInFlight
peerInFlight0 = PeerTxInFlight
emptyPeerTxInFlight {
        pifAdvertised = IntSet.singleton keyInt
      }

    (PeerAction
action, PeerTxLocalState (ZonkAny 64)
_, PeerTxInFlight
_, SharedTxState Int Int
_) =
      Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (ZonkAny 64)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (ZonkAny 64), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerActionPipelined Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState (ZonkAny 64)
forall tx. PeerTxLocalState tx
peerState0
                              PeerTxInFlight
peerInFlight0 SharedTxState Int Int
sharedState1
  in
    TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"got: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
action) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      case PeerAction
action of
        PeerRequestTxIds NumTxIdsToAck
ack NumTxIdsToReq
req ->
          [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"ack should be zero (nothing ackable)"
                      (NumTxIdsToAck
ack NumTxIdsToAck -> NumTxIdsToAck -> Bool
forall a. Eq a => a -> a -> Bool
== NumTxIdsToAck
0)
                  , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"req should be non-zero (window has room)"
                      (NumTxIdsToReq
req NumTxIdsToReq -> NumTxIdsToReq -> Bool
forall a. Eq a => a -> a -> Bool
/= NumTxIdsToReq
0)
                  ]
        PeerAction
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
  where
    peerAddr :: Int
peerAddr = Int
1 :: PeerAddr

-- | Pure-ack pipelined messages (ack=N, req=0) burn a pipeline slot for
-- an empty reply and shrink the txid window without growing it.  The
-- pipelined picker must defer such acks until they can be bundled with
-- a request.
unit_nextPeerActionPipelined_rejectsPureAck
  :: (String -> IO ()) -> Assertion
unit_nextPeerActionPipelined_rejectsPureAck :: (TestName -> IO ()) -> IO ()
unit_nextPeerActionPipelined_rejectsPureAck TestName -> IO ()
step = do
    TestName -> IO ()
step TestName
"Set up: two retained (ackable) txids in the unacked queue, request cap saturated"
    -- Make the per-message request cap small so we can saturate it with
    -- 'peerRequestedTxIds' and force the request count to zero.
    let policy :: TxDecisionPolicy
policy = TxDecisionPolicy
defaultTxDecisionPolicy { maxUnacknowledgedTxIds = 8
                                         , maxNumTxIdsToRequest   = 2 }
        txids :: [(Int, SizeInBytes)]
txids = [(Int
1, SizeInBytes
64), (Int
2, SizeInBytes
64)] :: [(TxId, SizeInBytes)]
        sharedState0 :: SharedTxState Int Int
sharedState0 = TxDecisionPolicy
-> [(Int, SizeInBytes)]
-> SharedTxState Int Int
-> SharedTxState Int Int
seedRetainedTxids TxDecisionPolicy
policy [(Int, SizeInBytes)]
txids SharedTxState Int Int
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState
        keys :: [TxKey]
keys = [ Int -> TxKey
TxKey (TxKey -> Int
unTxKey (Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
sharedState0))
               | (Int
txid, SizeInBytes
_) <- [(Int, SizeInBytes)]
txids ]
        -- 'peerRequestedTxIds' equals 'maxNumTxIdsToRequest' so the
        -- request cap is saturated and 'txIdsToRequest' evaluates to 0.
        -- Two ackable txids in the queue with the keep-one-unacked clamp
        -- means the ack count would be 1 - i.e. ack=1, req=0.
        peerState0 :: PeerTxLocalState tx
peerState0 = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState {
            peerUnacknowledgedTxIds = StrictSeq.fromList keys,
            peerRequestedTxIds      = 2
          }

    TestName -> IO ()
step TestName
"Run nextPeerActionPipelined"
    let (PeerAction
action, PeerTxLocalState (ZonkAny 63)
_, PeerTxInFlight
_, SharedTxState Int Int
_) =
          Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (ZonkAny 63)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (ZonkAny 63), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerActionPipelined Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState (ZonkAny 63)
forall tx. PeerTxLocalState tx
peerState0
                                  PeerTxInFlight
emptyPeerTxInFlight SharedTxState Int Int
sharedState0

    TestName -> IO ()
step TestName
"Pure-ack pipelined message must not be emitted"
    case PeerAction
action of
      PeerRequestTxIds {} ->
        TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure (TestName
"unexpected pure-ack request: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
action)
      PeerAction
_ ->
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    peerAddr :: Int
peerAddr = Int
1 :: PeerAddr

-- | 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_nextPeerActionPipelined_secondBodyBatch :: ArbTxDecisionPolicy -> Property
prop_nextPeerActionPipelined_secondBodyBatch (ArbTxDecisionPolicy TxDecisionPolicy
basePolicy) =
  let
    policy :: TxDecisionPolicy
policy = TxDecisionPolicy
basePolicy
      { maxOutstandingTxBatchesPerPeer = max 2 (maxOutstandingTxBatchesPerPeer basePolicy)
      , txsSizeInflightPerPeer = SizeInBytes 4096
      }
    txSizeA, txSizeB :: SizeInBytes
    txSizeA :: SizeInBytes
txSizeA = Word32 -> SizeInBytes
SizeInBytes Word32
100
    txSizeB :: SizeInBytes
txSizeB = Word32 -> SizeInBytes
SizeInBytes Word32
100
    keyA :: TxKey
keyA = Int -> TxKey
TxKey Int
0
    keyB :: TxKey
keyB = Int -> TxKey
TxKey Int
1
    kA :: Int
kA = TxKey -> Int
unTxKey TxKey
keyA
    kB :: Int
kB = TxKey -> Int
unTxKey TxKey
keyB
    leaseUntil :: Time
leaseUntil = DiffTime -> Time -> Time
addTime (TxDecisionPolicy -> DiffTime
interTxSpace TxDecisionPolicy
policy) Time
now
    sharedState :: SharedTxState Int Int
sharedState = SharedTxState (ZonkAny 61) (ZonkAny 60)
forall peeraddr txid. SharedTxState peeraddr txid
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 :: PeerTxLocalState tx
peerState0 = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
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 :: PeerTxInFlight
peerInFlight0 = PeerTxInFlight
emptyPeerTxInFlight
      { pifAdvertised = IntSet.fromList [kA, kB]
      , pifLeased     = IntSet.singleton kA
      , pifAttempting = IntSet.singleton kA
      }

    (PeerAction
action, PeerTxLocalState (ZonkAny 62)
_, PeerTxInFlight
peerInFlight', SharedTxState Int Int
sharedState') =
      Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (ZonkAny 62)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (ZonkAny 62), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerActionPipelined Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState (ZonkAny 62)
forall tx. PeerTxLocalState tx
peerState0
                              PeerTxInFlight
peerInFlight0 SharedTxState Int Int
sharedState
  in
    TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"got: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
action) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      case PeerAction
action of
        PeerRequestTxs [TxKey
picked] ->
          [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
            [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"expected to pick keyB"
                (TxKey
picked TxKey -> TxKey -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TxKey
keyB)
            , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"B not added to pifLeased"
                (Int -> IntSet -> Bool
IntSet.member Int
kB (PeerTxInFlight -> IntSet
pifLeased PeerTxInFlight
peerInFlight'))
            , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"B not added to pifAttempting"
                (Int -> IntSet -> Bool
IntSet.member Int
kB (PeerTxInFlight -> IntSet
pifAttempting PeerTxInFlight
peerInFlight'))
            , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"B not leased to peerAddr"
                (case Int -> IntMap (TxEntry Int) -> Maybe (TxEntry Int)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
kB (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedState') of
                   Just TxEntry Int
entry -> case TxEntry Int -> TxLease Int
forall peeraddr. TxEntry peeraddr -> TxLease peeraddr
txLease TxEntry Int
entry of
                     TxLeased Int
owner Time
_ -> Int
owner Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
peerAddr
                     TxLease Int
_                -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
                   Maybe (TxEntry Int)
Nothing -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False)
            ]
        PeerAction
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
  where
    peerAddr :: Int
peerAddr = Int
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 -> Property
prop_nextPeerActionPipelined_noThirdBodyBatch (ArbTxDecisionPolicy TxDecisionPolicy
basePolicy) =
  let
    policy :: TxDecisionPolicy
policy = TxDecisionPolicy
basePolicy { maxOutstandingTxBatchesPerPeer = 2 }
    txSize :: SizeInBytes
    txSize :: SizeInBytes
txSize = Word32 -> SizeInBytes
SizeInBytes Word32
64
    keyA :: TxKey
keyA = Int -> TxKey
TxKey Int
0
    keyB :: TxKey
keyB = Int -> TxKey
TxKey Int
1
    keyC :: TxKey
keyC = Int -> TxKey
TxKey Int
2
    kA :: Int
kA = TxKey -> Int
unTxKey TxKey
keyA
    kB :: Int
kB = TxKey -> Int
unTxKey TxKey
keyB
    kC :: Int
kC = TxKey -> Int
unTxKey TxKey
keyC
    leaseUntil :: Time
leaseUntil = DiffTime -> Time -> Time
addTime (TxDecisionPolicy -> DiffTime
interTxSpace TxDecisionPolicy
policy) Time
now
    inflightEntry :: TxEntry Int
inflightEntry = TxEntry
      { txLease :: TxLease Int
txLease = Int -> Time -> TxLease Int
forall peeraddr. peeraddr -> Time -> TxLease peeraddr
TxLeased Int
peerAddr Time
leaseUntil
      , txAttempt :: Int
txAttempt = Int
1
      , txInSubmission :: Bool
txInSubmission = Bool
False
      , currentMaxInflightMultiplicity :: Int
currentMaxInflightMultiplicity = TxDecisionPolicy -> Int
txInflightMultiplicity TxDecisionPolicy
policy
      }
    freshEntry :: TxEntry peeraddr
freshEntry = TxEntry
      { txLease :: TxLease peeraddr
txLease = Time -> TxLease peeraddr
forall peeraddr. Time -> TxLease peeraddr
TxClaimable Time
now
      , txAttempt :: Int
txAttempt = Int
0
      , txInSubmission :: Bool
txInSubmission = Bool
False
      , currentMaxInflightMultiplicity :: Int
currentMaxInflightMultiplicity = TxDecisionPolicy -> Int
txInflightMultiplicity TxDecisionPolicy
policy
      }
    sharedState :: SharedTxState Int Int
sharedState = SharedTxState (ZonkAny 58) (ZonkAny 57)
forall peeraddr txid. SharedTxState peeraddr txid
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 :: PeerTxLocalState tx
peerState0 = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
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 :: PeerTxInFlight
peerInFlight0 = PeerTxInFlight
emptyPeerTxInFlight
      { pifAdvertised = IntSet.fromList [kA, kB, kC]
      , pifLeased     = IntSet.fromList [kA, kB]
      , pifAttempting = IntSet.fromList [kA, kB]
      }

    (PeerAction
action, PeerTxLocalState (ZonkAny 59)
_, PeerTxInFlight
_, SharedTxState Int Int
_) =
      Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (ZonkAny 59)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (ZonkAny 59), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerActionPipelined Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState (ZonkAny 59)
forall tx. PeerTxLocalState tx
peerState0
                              PeerTxInFlight
peerInFlight0 SharedTxState Int Int
sharedState
  in
    TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"got: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
action) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
      case PeerAction
action of
        PeerRequestTxs {} -> Bool
False
        PeerAction
_                 -> Bool
True
  where
    peerAddr :: Int
peerAddr = Int
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 :: (TestName -> IO ()) -> IO ()
unit_nextPeerAction_skipsBlockedAvailableTxs TestName -> IO ()
step = do
    TestName -> IO ()
step TestName
"Set up two advertised txs: keyA leased to another peer with the cap full, keyB claimable"
    let policy0 :: TxDecisionPolicy
policy0     = TxDecisionPolicy
defaultTxDecisionPolicy
        policy :: TxDecisionPolicy
policy      = TxDecisionPolicy
policy0 { txInflightMultiplicity = 1 }
        peerAddr :: Int
peerAddr    = Int
7  :: PeerAddr
        otherPeer :: Int
otherPeer   = Int
8  :: PeerAddr
        keyA :: TxKey
keyA        = Int -> TxKey
TxKey Int
0
        keyB :: TxKey
keyB        = Int -> TxKey
TxKey Int
1
        kA :: Int
kA          = TxKey -> Int
unTxKey TxKey
keyA
        kB :: Int
kB          = TxKey -> Int
unTxKey TxKey
keyB
        sharedState :: SharedTxState Int Int
sharedState = SharedTxState (ZonkAny 55) (ZonkAny 54)
forall peeraddr txid. SharedTxState peeraddr txid
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 :: PeerTxLocalState tx
peerState = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState
          { peerUnacknowledgedTxIds = StrictSeq.fromList [keyA, keyB]
          , peerAvailableTxIds = IntMap.fromList [(kA, 10), (kB, 11)]
          }
        peerInFlight :: PeerTxInFlight
peerInFlight = PeerTxInFlight
emptyPeerTxInFlight
          { pifAdvertised = IntSet.fromList [kA, kB]
          }

    TestName -> IO ()
step TestName
"Run nextPeerAction"
    let (PeerAction
action, PeerTxLocalState (ZonkAny 56)
_, PeerTxInFlight
_, SharedTxState Int Int
sharedState') =
          Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (ZonkAny 56)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (ZonkAny 56), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState (ZonkAny 56)
forall tx. PeerTxLocalState tx
peerState PeerTxInFlight
peerInFlight SharedTxState Int Int
sharedState

    TestName -> IO ()
step TestName
"The claimable tx is requested and leased; the blocked tx is skipped"
    case PeerAction
action of
      PeerRequestTxs [TxKey]
picked ->
        [TxKey]
picked [TxKey] -> [TxKey] -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= [TxKey
keyB]
      PeerAction
other ->
        TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure (TestName
"unexpected action: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
other)

    case Int -> IntMap (TxEntry Int) -> Maybe (TxEntry Int)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
kB (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedState') of
      Just TxEntry Int
entry -> case TxEntry Int -> TxLease Int
forall peeraddr. TxEntry peeraddr -> TxLease peeraddr
txLease TxEntry Int
entry of
        TxLeased Int
owner Time
_ -> Int
owner Int -> Int -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int
peerAddr
        TxClaimable Time
_    -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure TestName
"keyB still TxClaimable"
      Maybe (TxEntry Int)
Nothing -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure TestName
"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 :: (TestName -> IO ()) -> IO ()
unit_nextPeerAction_acksSafePrefixBeforeBlockedBufferedTx TestName -> IO ()
step = do
    TestName -> IO ()
step TestName
"Set up: tx 1 retained (ackable), tx 2 leased + buffered + already submitting via another peer"
    let peerAddr :: Int
peerAddr  = Int
7 :: PeerAddr
        resolvedKey :: TxKey
resolvedKey = Int -> TxKey
TxKey Int
1
        blockedKey :: TxKey
blockedKey  = Int -> TxKey
TxKey Int
2
        kResolved :: Int
kResolved   = TxKey -> Int
unTxKey TxKey
resolvedKey
        kBlocked :: Int
kBlocked    = TxKey -> Int
unTxKey TxKey
blockedKey
        blockedTx :: Tx Int
blockedTx   = Int -> SizeInBytes -> Tx Int
mkTx Int
2 (Positive Int -> SizeInBytes
mkSize (Int -> Positive Int
forall a. a -> Positive a
Positive Int
10))
        policy :: TxDecisionPolicy
policy      = TxDecisionPolicy
defaultTxDecisionPolicy
        blockedEntry :: TxEntry Int
blockedEntry = TxEntry
          { txLease :: TxLease Int
txLease = Int -> Time -> TxLease Int
forall peeraddr. peeraddr -> Time -> TxLease peeraddr
TxLeased Int
peerAddr (DiffTime -> Time -> Time
addTime DiffTime
10 Time
now)
          , txAttempt :: Int
txAttempt = Int
1
          , txInSubmission :: Bool
txInSubmission = Bool
True
          , currentMaxInflightMultiplicity :: Int
currentMaxInflightMultiplicity = TxDecisionPolicy -> Int
txInflightMultiplicity TxDecisionPolicy
policy
          }
        sharedState :: SharedTxState Int Int
sharedState = SharedTxState (ZonkAny 53) (ZonkAny 52)
forall peeraddr txid. SharedTxState peeraddr txid
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 :: PeerTxLocalState (Tx Int)
peerState = PeerTxLocalState (ZonkAny 51)
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState
          { peerUnacknowledgedTxIds = StrictSeq.fromList [resolvedKey, blockedKey]
          , peerDownloadedTxs = IntMap.singleton kBlocked blockedTx
          }
        -- Another peer (not in this single-peer snapshot) is mid-submission,
        -- so the entry's 'txInSubmission' flag is set.  peerAddr holds the
        -- lease and has the body buffered, but must skip submitting while
        -- the flag is set; it can still ack the safe retained prefix.
        peerInFlight :: PeerTxInFlight
peerInFlight = PeerTxInFlight
emptyPeerTxInFlight
          { pifLeased     = IntSet.singleton kBlocked
          , pifAttempting = IntSet.singleton kBlocked
          }

    TestName -> IO ()
step TestName
"Run nextPeerAction (with the blocked tx in submission by another peer)"
    let (PeerAction
action, PeerTxLocalState (Tx Int)
peerState', PeerTxInFlight
_, SharedTxState Int Int
_) =
          Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState (Tx Int)
peerState PeerTxInFlight
peerInFlight SharedTxState Int Int
sharedState

    -- 'pickBufferedTxsToSubmit' finds the blocked tx buffered but in
    -- submission ('txInSubmission' set), so it skips it; the walk falls
    -- through to a txid request that acks the retained prefix only.
    TestName -> IO ()
step TestName
"Only the retained prefix is acked; blocked tx remains unacked"
    case PeerAction
action of
      PeerRequestTxIds NumTxIdsToAck
ack NumTxIdsToReq
req -> do
        NumTxIdsToAck
ack NumTxIdsToAck -> NumTxIdsToAck -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= NumTxIdsToAck
1
        HasCallStack => TestName -> Bool -> IO ()
TestName -> Bool -> IO ()
assertBool (TestName
"expected positive txIdsToReq, got " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ NumTxIdsToReq -> TestName
forall a. Show a => a -> TestName
show NumTxIdsToReq
req) (NumTxIdsToReq
req NumTxIdsToReq -> NumTxIdsToReq -> Bool
forall a. Ord a => a -> a -> Bool
> NumTxIdsToReq
0)
        StrictSeq TxKey -> [TxKey]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (PeerTxLocalState (Tx Int) -> StrictSeq TxKey
forall tx. PeerTxLocalState tx -> StrictSeq TxKey
peerUnacknowledgedTxIds PeerTxLocalState (Tx Int)
peerState') [TxKey] -> [TxKey] -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= [TxKey
blockedKey]
      PeerAction
other ->
        TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure (TestName
"unexpected action: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
other)

-- | When a peer's unack queue has a buffered body, then a
-- resolved-elsewhere gap (the txid has no entry in 'sharedTxTable'),
-- then another buffered body, 'pickBufferedTxsToSubmit' must skip the
-- gap and emit both buffered bodies in one 'PeerSubmitTxs' batch.
--
-- Regression guard for the Nothing-vs-Just distinction in
-- 'pickBufferedTxsToSubmit': collapsing the 'Nothing' branch into
-- "stop" leaves the second buffered body unsubmitted, breaking
-- progress when an intermediate txid was resolved by another peer.
unit_nextPeerAction_submitsBufferedAcrossResolvedGap
  :: (String -> IO ()) -> Assertion
unit_nextPeerAction_submitsBufferedAcrossResolvedGap :: (TestName -> IO ()) -> IO ()
unit_nextPeerAction_submitsBufferedAcrossResolvedGap TestName -> IO ()
step = do
    TestName -> IO ()
step TestName
"Set up: 3 unack txids, bodies buffered for 1st and 3rd; 2nd resolved elsewhere"
    let peerAddr :: Int
peerAddr  = Int
7 :: PeerAddr
        key1 :: TxKey
key1      = Int -> TxKey
TxKey Int
1
        key2 :: TxKey
key2      = Int -> TxKey
TxKey Int
2
        key3 :: TxKey
key3      = Int -> TxKey
TxKey Int
3
        k1 :: Int
k1        = TxKey -> Int
unTxKey TxKey
key1
        k3 :: Int
k3        = TxKey -> Int
unTxKey TxKey
key3
        body1 :: Tx Int
body1     = Int -> SizeInBytes -> Tx Int
mkTx Int
1 (Positive Int -> SizeInBytes
mkSize (Int -> Positive Int
forall a. a -> Positive a
Positive Int
10))
        body3 :: Tx Int
body3     = Int -> SizeInBytes -> Tx Int
mkTx Int
3 (Positive Int -> SizeInBytes
mkSize (Int -> Positive Int
forall a. a -> Positive a
Positive Int
10))
        policy :: TxDecisionPolicy
policy    = TxDecisionPolicy
defaultTxDecisionPolicy
        leaseTime :: Time
leaseTime = DiffTime -> Time -> Time
addTime DiffTime
10 Time
now
        entry :: TxEntry Int
entry     = TxEntry
          { txLease :: TxLease Int
txLease                        = Int -> Time -> TxLease Int
forall peeraddr. peeraddr -> Time -> TxLease peeraddr
TxLeased Int
peerAddr Time
leaseTime
          , txAttempt :: Int
txAttempt                      = Int
1
          , txInSubmission :: Bool
txInSubmission                 = Bool
False
          , currentMaxInflightMultiplicity :: Int
currentMaxInflightMultiplicity = TxDecisionPolicy -> Int
txInflightMultiplicity TxDecisionPolicy
policy
          }
        sharedState :: SharedTxState Int Int
sharedState = SharedTxState (ZonkAny 50) (ZonkAny 49)
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState
          { sharedTxTable   = IntMap.fromList [(k1, entry), (k3, entry)]
          , sharedTxIdToKey = Map.fromList
              [ (getRawTxId (1 :: TxId), key1)
              , (getRawTxId (2 :: TxId), key2)
              , (getRawTxId (3 :: TxId), key3)
              ]
          , sharedKeyToTxId = IntMap.fromList
              [(k1, 1 :: TxId), (unTxKey key2, 2), (k3, 3)]
          , sharedNextTxKey = 4
          }
        peerState :: PeerTxLocalState (Tx Int)
peerState = PeerTxLocalState (ZonkAny 48)
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState
          { peerUnacknowledgedTxIds = StrictSeq.fromList [key1, key2, key3]
          , peerDownloadedTxs       = IntMap.fromList [(k1, body1), (k3, body3)]
          }
        peerInFlight :: PeerTxInFlight
peerInFlight = PeerTxInFlight
emptyPeerTxInFlight
          { pifLeased     = IntSet.fromList [k1, k3]
          , pifAttempting = IntSet.fromList [k1, k3]
          }

    TestName -> IO ()
step TestName
"Run nextPeerAction"
    let (PeerAction
action, PeerTxLocalState (Tx Int)
_, PeerTxInFlight
_, SharedTxState Int Int
_) =
          Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState (Tx Int)
peerState PeerTxInFlight
peerInFlight SharedTxState Int Int
sharedState

    TestName -> IO ()
step TestName
"Both buffered bodies submitted in one batch"
    case PeerAction
action of
      PeerSubmitTxs [TxKey]
ks -> [TxKey]
ks [TxKey] -> [TxKey] -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= [TxKey
key1, TxKey
key3]
      PeerAction
other            -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure (TestName
"unexpected action: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
other)

-- | 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 :: (TestName -> IO ()) -> IO ()
unit_nextPeerAction_claimsFreshTxWhenFirstAdvertiserIsFull TestName -> IO ()
step = do
    TestName -> IO ()
step TestName
"Receive a fresh txid from peer A while A is already at its inflight size limit"
    let (PeerTxLocalState tx
peerAState1, PeerTxInFlight
peerAInFlight1, SharedTxState peeraddr Int
sharedState1) =
          (Int -> Bool)
-> Time
-> TxDecisionPolicy
-> NumTxIdsToReq
-> [(Int, SizeInBytes)]
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr Int
-> (PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr Int)
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 (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False) Time
now TxDecisionPolicy
defaultTxDecisionPolicy
            NumTxIdsToReq
requestedToReply [(Int
txid, SizeInBytes
txSize)]
            PeerTxLocalState tx
forall tx. PeerTxLocalState tx
peerAState0 PeerTxInFlight
emptyPeerTxInFlight SharedTxState peeraddr Int
forall peeraddr txid. SharedTxState peeraddr txid
sharedState0
    TxEntry Int -> TxLease Int
forall peeraddr. TxEntry peeraddr -> TxLease peeraddr
txLease (TxKey -> SharedTxState Int Int -> TxEntry Int
lookupEntryOrFail TxKey
key SharedTxState Int Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1) TxLease Int -> TxLease Int -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Time -> TxLease Int
forall peeraddr. Time -> TxLease peeraddr
TxClaimable Time
now

    TestName -> IO ()
step TestName
"nextPeerAction for peer A: tx remains unclaimed because A is at the size cap"
    let (PeerAction
peerAAction, PeerTxLocalState (ZonkAny 39)
_, PeerTxInFlight
_, SharedTxState Int Int
_) =
          Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (ZonkAny 39)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (ZonkAny 39), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
defaultTxDecisionPolicy Int
peerA
            PeerTxLocalState (ZonkAny 39)
forall tx. PeerTxLocalState tx
peerAState1 PeerTxInFlight
peerAInFlight1 SharedTxState Int Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1
    case PeerAction
peerAAction of
      PeerDoNothing Word64
_ Maybe DiffTime
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      PeerRequestTxIds {} -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      PeerAction
other -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure (TestName
"unexpected peer A action: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
other)

    TestName -> IO ()
step TestName
"Peer B advertises the same txid"
    let (PeerTxLocalState tx
peerBState1, PeerTxInFlight
peerBInFlight1, SharedTxState peeraddr Int
sharedState2) =
          (Int -> Bool)
-> Time
-> TxDecisionPolicy
-> NumTxIdsToReq
-> [(Int, SizeInBytes)]
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr Int
-> (PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr Int)
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 (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False) Time
now TxDecisionPolicy
defaultTxDecisionPolicy
            NumTxIdsToReq
requestedToReply [(Int
txid, SizeInBytes
txSize)]
            PeerTxLocalState tx
forall tx. PeerTxLocalState tx
peerBState0 PeerTxInFlight
emptyPeerTxInFlight SharedTxState peeraddr Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1

    TestName -> IO ()
step TestName
"nextPeerAction for peer B: claims and requests the fresh tx"
    let (PeerAction
peerBAction, PeerTxLocalState tx
peerBState2, PeerTxInFlight
peerBInFlight2, SharedTxState Int Int
sharedState3) =
          Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
defaultTxDecisionPolicy Int
peerB
            PeerTxLocalState tx
forall tx. PeerTxLocalState tx
peerBState1 PeerTxInFlight
peerBInFlight1 SharedTxState Int Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState2
    case PeerAction
peerBAction of
      PeerRequestTxs [TxKey]
txKeys -> do
        [TxKey]
txKeys [TxKey] -> [TxKey] -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= [TxKey
key]
        PeerTxLocalState (ZonkAny 47) -> IntSet
forall tx. PeerTxLocalState tx -> IntSet
peerRequestedTxs PeerTxLocalState (ZonkAny 47)
forall tx. PeerTxLocalState tx
peerBState2 IntSet -> IntSet -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int -> IntSet
IntSet.singleton Int
k
        Int -> IntSet -> Bool
IntSet.member Int
k (PeerTxInFlight -> IntSet
pifLeased PeerTxInFlight
peerBInFlight2) Bool -> Bool -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Bool
True
        case Int -> IntMap (TxEntry Int) -> Maybe (TxEntry Int)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedState3) of
          Just TxEntry Int
entry -> case TxEntry Int -> TxLease Int
forall peeraddr. TxEntry peeraddr -> TxLease peeraddr
txLease TxEntry Int
entry of
            TxLeased Int
owner Time
_ -> Int
owner Int -> Int -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int
peerB
            TxLease Int
_                -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure TestName
"B's claim did not produce TxLeased B"
          Maybe (TxEntry Int)
Nothing -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure TestName
"entry vanished after B's claim"
      PeerAction
other -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure (TestName
"unexpected peer B action: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
other)
  where
    peerA :: Int
peerA = Int
7 :: PeerAddr
    peerB :: Int
peerB = Int
8 :: PeerAddr
    txid :: TxId
    txid :: Int
txid = Int
1
    txSize :: SizeInBytes
txSize = Positive Int -> SizeInBytes
mkSize (Int -> Positive Int
forall a. a -> Positive a
Positive Int
10)
    requestedToReply :: NumTxIdsToReq
    requestedToReply :: NumTxIdsToReq
requestedToReply = NumTxIdsToReq
1
    key :: TxKey
key = Int -> TxKey
TxKey Int
0
    k :: Int
k   = TxKey -> Int
unTxKey TxKey
key
    sharedState0 :: SharedTxState peeraddr txid
sharedState0 = SharedTxState peeraddr txid
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState
    peerAState0 :: PeerTxLocalState tx
peerAState0 = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState
      { peerRequestedTxIds = requestedToReply
      , peerRequestedTxsSize = txsSizeInflightPerPeer defaultTxDecisionPolicy
      }
    peerBState0 :: PeerTxLocalState tx
peerBState0 = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
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 :: (TestName -> IO ()) -> IO ()
unit_nextPeerAction_claimsRejectedTxFromOtherAdvertiser TestName -> IO ()
step = do
    TestName -> IO ()
step TestName
"Pre-state: tx leased to peer A, A is in mempoolAddTxs (post-markSubmittingTxs), B advertises the same key"
    let txid :: TxId
        txid :: Int
txid = Int
4
        txKeyInt :: Int
        txKeyInt :: Int
txKeyInt = Int
0
        txSize :: SizeInBytes
        txSize :: SizeInBytes
txSize = SizeInBytes
100
        txBody :: Tx TxId
        txBody :: Tx Int
txBody = Int -> SizeInBytes -> Tx Int
mkTx Int
txid SizeInBytes
txSize
        peerA :: Int
peerA = Int
1 :: PeerAddr
        peerB :: Int
peerB = Int
2 :: PeerAddr
        sharedState0 :: SharedTxState PeerAddr TxId
        sharedState0 :: SharedTxState Int Int
sharedState0 = SharedTxState (ZonkAny 30) (ZonkAny 29)
forall peeraddr txid. SharedTxState peeraddr txid
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 :: PeerTxLocalState (Tx Int)
peerAState0 = PeerTxLocalState (ZonkAny 28)
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState
          { peerUnacknowledgedTxIds = StrictSeq.singleton (TxKey txKeyInt)
          , peerDownloadedTxs       = IntMap.singleton txKeyInt txBody
          }
        peerAInFlight0 :: PeerTxInFlight
peerAInFlight0 = PeerTxInFlight
emptyPeerTxInFlight
          { pifAdvertised = IntSet.singleton txKeyInt
          , pifLeased     = IntSet.singleton txKeyInt
          , pifSubmitting = IntSet.singleton txKeyInt
          }
        peerBState0 :: PeerTxLocalState tx
peerBState0 = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState
          { peerUnacknowledgedTxIds = StrictSeq.singleton (TxKey txKeyInt)
          , peerAvailableTxIds      = IntMap.singleton txKeyInt txSize
          }
        peerBInFlight0 :: PeerTxInFlight
peerBInFlight0 = PeerTxInFlight
emptyPeerTxInFlight
          { pifAdvertised = IntSet.singleton txKeyInt
          }

    TestName -> IO ()
step TestName
"Peer A submits and the mempool rejects"
    let (PeerTxLocalState (Tx Int)
peerAState', PeerTxInFlight
peerAInFlight', SharedTxState Int Int
sharedStateAfter) =
          Time
-> TxDecisionPolicy
-> Int
-> [TxKey]
-> [TxKey]
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Eq peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> [TxKey]
-> [TxKey]
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
handleSubmittedTxs Time
now TxDecisionPolicy
defaultTxDecisionPolicy Int
peerA
            [] [Int -> TxKey
TxKey Int
txKeyInt]
            PeerTxLocalState (Tx Int)
peerAState0 PeerTxInFlight
peerAInFlight0 SharedTxState Int Int
sharedState0

    TestName -> IO ()
step TestName
"Lease released, attempt cleared, peer A's pif* cleared for the key"
    case Int -> IntMap (TxEntry Int) -> Maybe (TxEntry Int)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
txKeyInt (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedStateAfter) of
      Just TxEntry Int
entry -> do
        TxEntry Int -> TxLease Int
forall peeraddr. TxEntry peeraddr -> TxLease peeraddr
txLease TxEntry Int
entry         TxLease Int -> TxLease Int -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Time -> TxLease Int
forall peeraddr. Time -> TxLease peeraddr
TxClaimable Time
now
        TxEntry Int -> Int
forall peeraddr. TxEntry peeraddr -> Int
txAttempt TxEntry Int
entry       Int -> Int -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int
0
        TxEntry Int -> Bool
forall peeraddr. TxEntry peeraddr -> Bool
txInSubmission TxEntry Int
entry  Bool -> Bool -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Bool
False
      Maybe (TxEntry Int)
Nothing -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure TestName
"entry vanished after rejection"
    PeerTxLocalState (Tx Int) -> IntMap (Tx Int)
forall tx. PeerTxLocalState tx -> IntMap tx
peerDownloadedTxs PeerTxLocalState (Tx Int)
peerAState' IntMap (Tx Int) -> IntMap (Tx Int) -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= IntMap (Tx Int)
forall a. IntMap a
IntMap.empty
    PeerTxInFlight -> IntSet
pifLeased     PeerTxInFlight
peerAInFlight'  IntSet -> IntSet -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= IntSet
IntSet.empty
    PeerTxInFlight -> IntSet
pifSubmitting PeerTxInFlight
peerAInFlight'  IntSet -> IntSet -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= IntSet
IntSet.empty
    PeerTxInFlight -> IntSet
pifAdvertised PeerTxInFlight
peerAInFlight'  IntSet -> IntSet -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= IntSet
IntSet.empty

    TestName -> IO ()
step TestName
"Peer B's nextPeerAction now claims the released tx"
    let (PeerAction
peerBAction, PeerTxLocalState tx
peerBState', PeerTxInFlight
peerBInFlight', SharedTxState Int Int
sharedStateFinal) =
          Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
defaultTxDecisionPolicy Int
peerB
            PeerTxLocalState tx
forall tx. PeerTxLocalState tx
peerBState0 PeerTxInFlight
peerBInFlight0 SharedTxState Int Int
sharedStateAfter
    PeerAction
peerBAction PeerAction -> PeerAction -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= [TxKey] -> PeerAction
PeerRequestTxs [Int -> TxKey
TxKey Int
txKeyInt]
    PeerTxLocalState (ZonkAny 34) -> IntSet
forall tx. PeerTxLocalState tx -> IntSet
peerRequestedTxs PeerTxLocalState (ZonkAny 34)
forall tx. PeerTxLocalState tx
peerBState' IntSet -> IntSet -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int -> IntSet
IntSet.singleton Int
txKeyInt
    Int -> IntSet -> Bool
IntSet.member Int
txKeyInt (PeerTxInFlight -> IntSet
pifLeased PeerTxInFlight
peerBInFlight') Bool -> Bool -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Bool
True
    case Int -> IntMap (TxEntry Int) -> Maybe (TxEntry Int)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
txKeyInt (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedStateFinal) of
      Just TxEntry Int
entry -> case TxEntry Int -> TxLease Int
forall peeraddr. TxEntry peeraddr -> TxLease peeraddr
txLease TxEntry Int
entry of
        TxLeased Int
owner Time
_ -> Int
owner Int -> Int -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int
peerB
        TxLease Int
_                -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure TestName
"B's claim did not produce TxLeased B"
      Maybe (TxEntry Int)
Nothing -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure TestName
"entry vanished after B's claim"

-- | A peer with a non-zero score waits its score-derived delay before
-- claiming a TxClaimable entry.  With any non-zero score the floor is
-- 10 ms (see 'peerClaimDelay'); set up the entry to become claimable
-- exactly 10 ms before @now@ so the claim is just allowed.
unit_nextPeerAction_claimsAtScoreDelayThreshold
  :: (String -> IO ()) -> Assertion
unit_nextPeerAction_claimsAtScoreDelayThreshold :: (TestName -> IO ()) -> IO ()
unit_nextPeerAction_claimsAtScoreDelayThreshold TestName -> IO ()
step = do
    TestName -> IO ()
step TestName
"Set up: claimableAt = now - 10ms, peer score = 20 (10ms floor claim delay), so claim at now is just allowed"
    let peerAddr :: Int
peerAddr = Int
7 :: PeerAddr
        txid :: TxId
        txid :: Int
txid = Int
1
        txSize :: SizeInBytes
txSize = Positive Int -> SizeInBytes
mkSize (Int -> Positive Int
forall a. a -> Positive a
Positive Int
10)
        key :: TxKey
key = Int -> TxKey
TxKey Int
0
        k :: Int
k   = TxKey -> Int
unTxKey TxKey
key
        claimableAt :: Time
claimableAt = DiffTime -> Time
Time DiffTime
99.990  -- now is Time 100; 10 ms in the past
        sharedState :: SharedTxState peeraddr Int
sharedState = SharedTxState (ZonkAny 24) (ZonkAny 23)
forall peeraddr txid. SharedTxState peeraddr txid
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 :: PeerTxLocalState tx
peerState = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState
          { peerUnacknowledgedTxIds = StrictSeq.singleton key
          , peerAvailableTxIds = IntMap.singleton k txSize
          , peerScore = PeerScore 20 now
          }
        peerInFlight :: PeerTxInFlight
peerInFlight = PeerTxInFlight
emptyPeerTxInFlight
          { pifAdvertised = IntSet.singleton k
          }

    TestName -> IO ()
step TestName
"Run nextPeerAction"
    let (PeerAction
action, PeerTxLocalState tx
peerState', PeerTxInFlight
_, SharedTxState Int Int
sharedState') =
          Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
defaultTxDecisionPolicy Int
peerAddr
            PeerTxLocalState tx
forall tx. PeerTxLocalState tx
peerState PeerTxInFlight
peerInFlight SharedTxState Int Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState

    TestName -> IO ()
step TestName
"Tx becomes claimable once the score-derived 10ms floor has elapsed"
    case PeerAction
action of
      PeerRequestTxs [TxKey]
txKeys -> do
        [TxKey]
txKeys [TxKey] -> [TxKey] -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= [TxKey
key]
        PeerTxLocalState (ZonkAny 27) -> IntSet
forall tx. PeerTxLocalState tx -> IntSet
peerRequestedTxs PeerTxLocalState (ZonkAny 27)
forall tx. PeerTxLocalState tx
peerState' IntSet -> IntSet -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int -> IntSet
IntSet.singleton Int
k
        case Int -> IntMap (TxEntry Int) -> Maybe (TxEntry Int)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedState') of
          Just TxEntry Int
entry -> case TxEntry Int -> TxLease Int
forall peeraddr. TxEntry peeraddr -> TxLease peeraddr
txLease TxEntry Int
entry of
            TxLeased Int
owner Time
_ -> Int
owner Int -> Int -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int
peerAddr
            TxLease Int
_                -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure TestName
"did not lease to peerAddr"
          Maybe (TxEntry Int)
Nothing -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure TestName
"entry vanished after claim"
      PeerAction
other -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure (TestName
"unexpected action: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
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 :: (TestName -> IO ()) -> IO ()
unit_nextPeerAction_requestsOtherWorkDespiteBlockedBufferedTx TestName -> IO ()
step = do
    TestName -> IO ()
step TestName
"Set up: blocked tx leased to me + buffered, but another peer is submitting it; second tx is claimable"
    let peerAddr :: Int
peerAddr       = Int
7 :: PeerAddr
        submittingPeer :: Int
submittingPeer = Int
8 :: PeerAddr
        blockedTxid :: TxId
        blockedTxid :: Int
blockedTxid = Int
1
        claimableTxid :: TxId
        claimableTxid :: Int
claimableTxid = Int
2
        blockedSize :: SizeInBytes
blockedSize   = Positive Int -> SizeInBytes
mkSize (Int -> Positive Int
forall a. a -> Positive a
Positive Int
10)
        claimableSize :: SizeInBytes
claimableSize = Positive Int -> SizeInBytes
mkSize (Int -> Positive Int
forall a. a -> Positive a
Positive Int
11)
        blockedKey :: TxKey
blockedKey   = Int -> TxKey
TxKey Int
1
        claimableKey :: TxKey
claimableKey = Int -> TxKey
TxKey Int
2
        kBlocked :: Int
kBlocked     = TxKey -> Int
unTxKey TxKey
blockedKey
        kClaimable :: Int
kClaimable   = TxKey -> Int
unTxKey TxKey
claimableKey
        blockedTx :: Tx Int
blockedTx    = Int -> SizeInBytes -> Tx Int
mkTx Int
blockedTxid SizeInBytes
blockedSize
        blockedEntry :: TxEntry Int
blockedEntry = TxEntry
          { txLease :: TxLease Int
txLease = Int -> Time -> TxLease Int
forall peeraddr. peeraddr -> Time -> TxLease peeraddr
TxLeased Int
peerAddr (DiffTime -> Time -> Time
addTime DiffTime
10 Time
now)
          , txAttempt :: Int
txAttempt = Int
1
          , txInSubmission :: Bool
txInSubmission = Bool
True   -- submittingPeer is in mempoolAddTxs
          , currentMaxInflightMultiplicity :: Int
currentMaxInflightMultiplicity =
              TxDecisionPolicy -> Int
txInflightMultiplicity TxDecisionPolicy
defaultTxDecisionPolicy
          }
        sharedState :: SharedTxState Int Int
sharedState = SharedTxState (ZonkAny 22) (ZonkAny 21)
forall peeraddr txid. SharedTxState peeraddr txid
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 :: PeerTxLocalState (Tx Int)
peerState = PeerTxLocalState (ZonkAny 20)
forall tx. PeerTxLocalState tx
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 :: PeerTxInFlight
peerInFlight = PeerTxInFlight
emptyPeerTxInFlight
          { pifAdvertised = IntSet.fromList [kBlocked, kClaimable]
          , pifLeased     = IntSet.singleton kBlocked
          , pifAttempting = IntSet.singleton kBlocked
          }

    TestName -> IO ()
step TestName
"Run nextPeerAction"
    let (PeerAction
action, PeerTxLocalState (Tx Int)
peerState', PeerTxInFlight
_, SharedTxState Int Int
sharedState') =
          Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
defaultTxDecisionPolicy Int
peerAddr
            PeerTxLocalState (Tx Int)
peerState PeerTxInFlight
peerInFlight SharedTxState Int Int
sharedState

    TestName -> IO ()
step TestName
"Blocked tx stays buffered while the claimable tx is requested"
    case PeerAction
action of
      PeerRequestTxs [TxKey]
picked -> do
        [TxKey]
picked [TxKey] -> [TxKey] -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= [TxKey
claimableKey]
        PeerTxLocalState (Tx Int) -> StrictSeq TxKey
forall tx. PeerTxLocalState tx -> StrictSeq TxKey
peerUnacknowledgedTxIds PeerTxLocalState (Tx Int)
peerState' StrictSeq TxKey -> StrictSeq TxKey -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= PeerTxLocalState (Tx Int) -> StrictSeq TxKey
forall tx. PeerTxLocalState tx -> StrictSeq TxKey
peerUnacknowledgedTxIds PeerTxLocalState (Tx Int)
peerState
        PeerTxLocalState (Tx Int) -> IntSet
forall tx. PeerTxLocalState tx -> IntSet
peerRequestedTxs PeerTxLocalState (Tx Int)
peerState' IntSet -> IntSet -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int -> IntSet
IntSet.singleton Int
kClaimable
        PeerTxLocalState (Tx Int) -> IntMap (Tx Int)
forall tx. PeerTxLocalState tx -> IntMap tx
peerDownloadedTxs PeerTxLocalState (Tx Int)
peerState' IntMap (Tx Int) -> IntMap (Tx Int) -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= PeerTxLocalState (Tx Int) -> IntMap (Tx Int)
forall tx. PeerTxLocalState tx -> IntMap tx
peerDownloadedTxs PeerTxLocalState (Tx Int)
peerState
        case Int -> IntMap (TxEntry Int) -> Maybe (TxEntry Int)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
kClaimable (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedState') of
          Just TxEntry Int
entry -> case TxEntry Int -> TxLease Int
forall peeraddr. TxEntry peeraddr -> TxLease peeraddr
txLease TxEntry Int
entry of
            TxLeased Int
owner Time
_ -> Int
owner Int -> Int -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Int
peerAddr
            TxLease Int
_                -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure TestName
"claimable not leased to peerAddr"
          Maybe (TxEntry Int)
Nothing -> TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure TestName
"claimable entry vanished"
      PeerAction
other ->
        TestName -> IO ()
forall a. HasCallStack => TestName -> IO a
assertFailure (TestName
"unexpected action: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
other)
    -- submittingPeer is referenced only for clarity of the test setup.
    _ <- Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
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_nextPeerAction_nonOwnerWaitsUntilResolved :: ArbTxDecisionPolicy -> Int -> Property
prop_nextPeerAction_nonOwnerWaitsUntilResolved (ArbTxDecisionPolicy TxDecisionPolicy
policy)
                                               Int
txid0 =
  let
    txid :: Int
txid = Int -> Int
forall a. Num a => a -> a
abs Int
txid0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    key :: TxKey
key  = Int -> TxKey
TxKey Int
0
    k :: Int
k    = TxKey -> Int
unTxKey TxKey
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 :: SharedTxState Int Int
unresolvedSharedState = SharedTxState (ZonkAny 14) (ZonkAny 13)
forall peeraddr txid. SharedTxState peeraddr txid
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 :: SharedTxState peeraddr Int
resolvedSharedState = SharedTxState Int Int
unresolvedSharedState
      { sharedTxTable = IntMap.empty
      , sharedRetainedTxs = retainedSingleton k (addTime 17 now)
      }
    peerState0 :: PeerTxLocalState tx
peerState0 = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState
      { peerUnacknowledgedTxIds = StrictSeq.singleton key
      , peerRequestedTxIds = 0
      }
    peerInFlight0 :: PeerTxInFlight
peerInFlight0 = PeerTxInFlight
emptyPeerTxInFlight
      { pifAdvertised = IntSet.singleton k
      }

    (PeerAction
unresolvedAction, PeerTxLocalState tx
unresolvedPeerState', PeerTxInFlight
_, SharedTxState Int Int
_) =
      Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState tx
forall tx. PeerTxLocalState tx
peerState0 PeerTxInFlight
peerInFlight0
                     SharedTxState Int Int
unresolvedSharedState
    (PeerAction
resolvedAction, PeerTxLocalState tx
resolvedPeerState', PeerTxInFlight
_, SharedTxState Int Int
_) =
      Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
policy Int
peerAddr PeerTxLocalState tx
forall tx. PeerTxLocalState tx
peerState0 PeerTxInFlight
peerInFlight0
                     SharedTxState Int Int
forall {peeraddr}. SharedTxState peeraddr Int
resolvedSharedState
  in
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
      [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"unresolved: must not ack the unresolved txid" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          case PeerAction
unresolvedAction of
            PeerDoNothing Word64
_ Maybe DiffTime
_ ->
              PeerTxLocalState (ZonkAny 17) -> StrictSeq TxKey
forall tx. PeerTxLocalState tx -> StrictSeq TxKey
peerUnacknowledgedTxIds PeerTxLocalState (ZonkAny 17)
forall tx. PeerTxLocalState tx
unresolvedPeerState'
                StrictSeq TxKey -> StrictSeq TxKey -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== PeerTxLocalState (ZonkAny 18) -> StrictSeq TxKey
forall tx. PeerTxLocalState tx -> StrictSeq TxKey
peerUnacknowledgedTxIds PeerTxLocalState (ZonkAny 18)
forall tx. PeerTxLocalState tx
peerState0
            PeerRequestTxIds NumTxIdsToAck
ack NumTxIdsToReq
_ ->
              TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"ack should be 0, got " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ NumTxIdsToAck -> TestName
forall a. Show a => a -> TestName
show NumTxIdsToAck
ack)
                (NumTxIdsToAck
ack NumTxIdsToAck -> NumTxIdsToAck -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== NumTxIdsToAck
0)
            PeerAction
other ->
              TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"unexpected unresolved action: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
other)
                             Bool
False
      , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"resolved: must ack the now-retained txid" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          case PeerAction
resolvedAction of
            PeerRequestTxIds NumTxIdsToAck
ack NumTxIdsToReq
_ ->
              [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
                [ NumTxIdsToAck
ack NumTxIdsToAck -> NumTxIdsToAck -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== NumTxIdsToAck
1
                , PeerTxLocalState (ZonkAny 19) -> StrictSeq TxKey
forall tx. PeerTxLocalState tx -> StrictSeq TxKey
peerUnacknowledgedTxIds PeerTxLocalState (ZonkAny 19)
forall tx. PeerTxLocalState tx
resolvedPeerState' StrictSeq TxKey -> StrictSeq TxKey -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== StrictSeq TxKey
forall a. StrictSeq a
StrictSeq.empty
                ]
            PeerAction
other ->
              TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"unexpected resolved action: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PeerAction -> TestName
forall a. Show a => a -> TestName
show PeerAction
other)
                             Bool
False
      ]
  where
    peerAddr :: Int
peerAddr = Int
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 (PeerRole -> PeerRole -> Bool
(PeerRole -> PeerRole -> Bool)
-> (PeerRole -> PeerRole -> Bool) -> Eq PeerRole
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PeerRole -> PeerRole -> Bool
== :: PeerRole -> PeerRole -> Bool
$c/= :: PeerRole -> PeerRole -> Bool
/= :: PeerRole -> PeerRole -> Bool
Eq, Int -> PeerRole -> TestName -> TestName
[PeerRole] -> TestName -> TestName
PeerRole -> TestName
(Int -> PeerRole -> TestName -> TestName)
-> (PeerRole -> TestName)
-> ([PeerRole] -> TestName -> TestName)
-> Show PeerRole
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> PeerRole -> TestName -> TestName
showsPrec :: Int -> PeerRole -> TestName -> TestName
$cshow :: PeerRole -> TestName
show :: PeerRole -> TestName
$cshowList :: [PeerRole] -> TestName -> TestName
showList :: [PeerRole] -> TestName -> TestName
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 (LeaseStart -> LeaseStart -> Bool
(LeaseStart -> LeaseStart -> Bool)
-> (LeaseStart -> LeaseStart -> Bool) -> Eq LeaseStart
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LeaseStart -> LeaseStart -> Bool
== :: LeaseStart -> LeaseStart -> Bool
$c/= :: LeaseStart -> LeaseStart -> Bool
/= :: LeaseStart -> LeaseStart -> Bool
Eq, Int -> LeaseStart -> TestName -> TestName
[LeaseStart] -> TestName -> TestName
LeaseStart -> TestName
(Int -> LeaseStart -> TestName -> TestName)
-> (LeaseStart -> TestName)
-> ([LeaseStart] -> TestName -> TestName)
-> Show LeaseStart
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> LeaseStart -> TestName -> TestName
showsPrec :: Int -> LeaseStart -> TestName -> TestName
$cshow :: LeaseStart -> TestName
show :: LeaseStart -> TestName
$cshowList :: [LeaseStart] -> TestName -> TestName
showList :: [LeaseStart] -> TestName -> TestName
Show)

instance Arbitrary LeaseStart where
  arbitrary :: Gen LeaseStart
arbitrary = [LeaseStart] -> Gen LeaseStart
forall a. HasCallStack => [a] -> Gen a
elements [LeaseStart
ClaimableLease, LeaseStart
ExpiredLease]

-- | A scheduling order for the three peers.  Generated as a permutation
-- of the three roles.
newtype PeerOrder = PeerOrder [PeerRole]
  deriving Int -> PeerOrder -> TestName -> TestName
[PeerOrder] -> TestName -> TestName
PeerOrder -> TestName
(Int -> PeerOrder -> TestName -> TestName)
-> (PeerOrder -> TestName)
-> ([PeerOrder] -> TestName -> TestName)
-> Show PeerOrder
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> PeerOrder -> TestName -> TestName
showsPrec :: Int -> PeerOrder -> TestName -> TestName
$cshow :: PeerOrder -> TestName
show :: PeerOrder -> TestName
$cshowList :: [PeerOrder] -> TestName -> TestName
showList :: [PeerOrder] -> TestName -> TestName
Show

instance Arbitrary PeerOrder where
  arbitrary :: Gen PeerOrder
arbitrary = [PeerRole] -> PeerOrder
PeerOrder ([PeerRole] -> PeerOrder) -> Gen [PeerRole] -> Gen PeerOrder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PeerRole] -> Gen [PeerRole]
forall a. [a] -> Gen [a]
shuffle [PeerRole
Good, PeerRole
Bad, PeerRole
Confounder]

-- | Drives 'nextPeerAction' for three peers ('Good', 'Bad',
-- 'Confounder') in a generator-chosen order.  Asserts:
--
--   * '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_nextPeerAction_claimsClaimableTx :: ArbTxDecisionPolicy
-> Positive Int
-> Positive Int
-> Positive Int
-> Int
-> Positive Int
-> Positive Int
-> Positive Int
-> PeerOrder
-> LeaseStart
-> Property
prop_nextPeerAction_claimsClaimableTx
    (ArbTxDecisionPolicy TxDecisionPolicy
arbPolicy)
    (Positive Int
good0) (Positive Int
bad0) (Positive Int
conf0)
    Int
txid0 Positive Int
txSize0 (Positive Int
badScore0) (Positive Int
tDecay0) (PeerOrder [PeerRole]
order)
    LeaseStart
leaseStart =
      TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"order"     [[PeerRole] -> TestName
forall a. Show a => a -> TestName
show [PeerRole]
order]
    (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"lease"     [LeaseStart -> TestName
forall a. Show a => a -> TestName
show LeaseStart
leaseStart]
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
        [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Good must claim: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> TestName
forall a. Show a => a -> TestName
show (PeerRole
-> Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
lookupAction PeerRole
Good)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            case PeerRole
-> Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
lookupAction PeerRole
Good of
              Just (PeerRequestTxs [TxKey]
txKeys, PeerTxLocalState (Tx Int)
_, PeerTxInFlight
_) -> [TxKey]
txKeys [TxKey] -> [TxKey] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [TxKey
key]
              Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
_                                  -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
        , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Bad must yield with the score-delay derived wake: "
                            TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> TestName
forall a. Show a => a -> TestName
show (PeerRole
-> Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
lookupAction PeerRole
Bad)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            case PeerRole
-> Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
lookupAction PeerRole
Bad of
              Just (PeerDoNothing Word64
_ (Just DiffTime
delay), PeerTxLocalState (Tx Int)
_, PeerTxInFlight
_) ->
                let diff :: DiffTime
diff = DiffTime -> DiffTime
forall a. Num a => a -> a
abs (DiffTime
delay DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
expectedBadDelay) in
                TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
                  (TestName
"delay = " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ DiffTime -> TestName
forall a. Show a => a -> TestName
show DiffTime
delay
                    TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
", expected = " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ DiffTime -> TestName
forall a. Show a => a -> TestName
show DiffTime
expectedBadDelay
                    TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
", diff = " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ DiffTime -> TestName
forall a. Show a => a -> TestName
show DiffTime
diff)
                  (DiffTime
diff DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< DiffTime
1e-9)
              Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
other ->
                TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"got: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> TestName
forall a. Show a => a -> TestName
show Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
other) Bool
False
        , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Confounder must do nothing with no scheduled wake: "
                            TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> TestName
forall a. Show a => a -> TestName
show (PeerRole
-> Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
lookupAction PeerRole
Confounder)) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
            case PeerRole
-> Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
lookupAction PeerRole
Confounder of
              Just (PeerDoNothing Word64
_ Maybe DiffTime
Nothing, PeerTxLocalState (Tx Int)
_, PeerTxInFlight
_) -> Bool
True
              Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
_                                    -> Bool
False
        , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"Lease must end up at Good" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            case Int -> IntMap (TxEntry Int) -> Maybe (TxEntry Int)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedStateFinal) of
              Just TxEntry Int
entry -> case TxEntry Int -> TxLease Int
forall peeraddr. TxEntry peeraddr -> TxLease peeraddr
txLease TxEntry Int
entry of
                TxLeased Int
owner Time
_ -> Int
owner Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
goodPeer
                TxLease Int
_                -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
              Maybe (TxEntry Int)
Nothing -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
        ]
  where
    policy :: TxDecisionPolicy
policy = TxDecisionPolicy
arbPolicy
      { scoreMax  = max 200 (scoreMax arbPolicy)
      , scoreRate = max 0.01 (min 1.0 (scoreRate arbPolicy))
      }

    goodPeer :: Int
goodPeer = Int
good0
    badPeer :: Int
badPeer  = Int
bad0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1000
    confPeer :: Int
confPeer = Int
conf0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2000
    txid :: Int
txid     = Int -> Int
forall a. Num a => a -> a
abs Int
txid0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    txSize :: SizeInBytes
txSize   = Positive Int -> SizeInBytes
mkSize Positive Int
txSize0
    key :: TxKey
key      = Int -> TxKey
TxKey Int
0
    k :: Int
k        = TxKey -> Int
unTxKey TxKey
key

    claimableAt :: Time
claimableAt = DiffTime -> Time
Time DiffTime
99.999
    tDecaySec :: Double
    tDecaySec :: Double
tDecaySec = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
tDecay0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
10 :: Int)
    decayAmount :: Double
    decayAmount :: Double
decayAmount = Double
tDecaySec Double -> Double -> Double
forall a. Num a => a -> a -> a
* TxDecisionPolicy -> Double
scoreRate TxDecisionPolicy
policy
    decayedBadScore :: Double
    decayedBadScore :: Double
decayedBadScore = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
21 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
badScore0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
80 :: Int)
    badInitialScore :: Double
    badInitialScore :: Double
badInitialScore = Double
decayedBadScore Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
decayAmount
    badPeerScore :: PeerScore
badPeerScore = PeerScore
      { peerScoreValue :: Double
peerScoreValue = Double
badInitialScore
      , peerScoreTs :: Time
peerScoreTs    = DiffTime -> Time -> Time
addTime (DiffTime -> DiffTime
forall a. Num a => a -> a
negate (Double -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
tDecaySec)) Time
now
      }

    badRunsBeforeGood :: Bool
badRunsBeforeGood = case (PeerRole -> [PeerRole] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex PeerRole
Bad [PeerRole]
order, PeerRole -> [PeerRole] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex PeerRole
Good [PeerRole]
order) of
                         (Just Int
bi, Just Int
gi) -> Int
bi Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
gi
                         (Maybe Int, Maybe Int)
_                  -> Bool
False
    badClaimDelay :: DiffTime
    badClaimDelay :: DiffTime
badClaimDelay = TxDecisionPolicy -> Time -> PeerScore -> DiffTime
peerClaimDelay TxDecisionPolicy
policy Time
now PeerScore
badPeerScore
    expectedBadDelay :: DiffTime
    expectedBadDelay :: DiffTime
expectedBadDelay
      | Bool
badRunsBeforeGood = DiffTime
badClaimDelay DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- Time -> Time -> DiffTime
diffTime Time
now Time
claimableAt
      | Bool
otherwise         = DiffTime
badClaimDelay DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ TxDecisionPolicy -> DiffTime
interTxSpace TxDecisionPolicy
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 :: Int
oldOwner = Int
good0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bad0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
conf0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3000

    sharedState0 :: SharedTxState Int Int
sharedState0 = SharedTxState (ZonkAny 7) (ZonkAny 6)
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState
      { sharedTxIdToKey = Map.singleton (getRawTxId txid) key
      , sharedKeyToTxId = IntMap.singleton k txid
      , sharedNextTxKey = 1
      , sharedTxTable = IntMap.singleton k TxEntry
          { txLease = case leaseStart of
              LeaseStart
ClaimableLease -> Time -> TxLease Int
forall peeraddr. Time -> TxLease peeraddr
TxClaimable Time
claimableAt
              LeaseStart
ExpiredLease   -> Int -> Time -> TxLease Int
forall peeraddr. peeraddr -> Time -> TxLease peeraddr
TxLeased Int
oldOwner Time
claimableAt
          , txAttempt = 0
          , txInSubmission = False
          , currentMaxInflightMultiplicity = txInflightMultiplicity policy
          }
      }

    goodPeerState0 :: PeerTxLocalState tx
goodPeerState0 = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState
      { peerUnacknowledgedTxIds = StrictSeq.singleton key
      , peerAvailableTxIds      = IntMap.singleton k txSize
      }
    goodInFlight0 :: PeerTxInFlight
goodInFlight0 = PeerTxInFlight
emptyPeerTxInFlight { pifAdvertised = IntSet.singleton k }

    badPeerState0 :: PeerTxLocalState tx
badPeerState0 = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState
      { peerUnacknowledgedTxIds = StrictSeq.singleton key
      , peerAvailableTxIds      = IntMap.singleton k txSize
      , peerScore               = badPeerScore
        -- Saturate the request cap so the txid picker has no work for
        -- Bad; the only relevant action is the score-derived wake from
        -- 'PeerDoNothing'.
      , peerRequestedTxIds      = maxNumTxIdsToRequest policy
      }
    badInFlight0 :: PeerTxInFlight
badInFlight0 = PeerTxInFlight
emptyPeerTxInFlight { pifAdvertised = IntSet.singleton k }

    confPeerState0 :: PeerTxLocalState tx
confPeerState0 = PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState
      { peerRequestedTxIds = maxNumTxIdsToRequest policy
      }
    confInFlight0 :: PeerTxInFlight
confInFlight0 = PeerTxInFlight
emptyPeerTxInFlight

    roleSetup :: PeerRole -> (Int, PeerTxLocalState tx, PeerTxInFlight)
roleSetup PeerRole
Good       = (Int
goodPeer, PeerTxLocalState tx
forall tx. PeerTxLocalState tx
goodPeerState0, PeerTxInFlight
goodInFlight0)
    roleSetup PeerRole
Bad        = (Int
badPeer,  PeerTxLocalState tx
forall tx. PeerTxLocalState tx
badPeerState0,  PeerTxInFlight
badInFlight0)
    roleSetup PeerRole
Confounder = (Int
confPeer, PeerTxLocalState tx
forall tx. PeerTxLocalState tx
confPeerState0, PeerTxInFlight
confInFlight0)

    runOne :: (SharedTxState PeerAddr TxId,
               [(PeerRole, PeerAction, PeerTxLocalState (Tx TxId), PeerTxInFlight)])
           -> PeerRole
           -> (SharedTxState PeerAddr TxId,
               [(PeerRole, PeerAction, PeerTxLocalState (Tx TxId), PeerTxInFlight)])
    runOne :: (SharedTxState Int Int,
 [(PeerRole, PeerAction, PeerTxLocalState (Tx Int),
   PeerTxInFlight)])
-> PeerRole
-> (SharedTxState Int Int,
    [(PeerRole, PeerAction, PeerTxLocalState (Tx Int),
      PeerTxInFlight)])
runOne (SharedTxState Int Int
ss, [(PeerRole, PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)]
acc) PeerRole
role =
      let (Int
peer, PeerTxLocalState tx
ps0, PeerTxInFlight
pif0) = PeerRole -> (Int, PeerTxLocalState tx, PeerTxInFlight)
forall {tx}. PeerRole -> (Int, PeerTxLocalState tx, PeerTxInFlight)
roleSetup PeerRole
role
          (PeerAction
action, PeerTxLocalState tx
ps', PeerTxInFlight
pif', SharedTxState Int Int
ss') =
            Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
now TxDecisionPolicy
policy Int
peer PeerTxLocalState tx
forall tx. PeerTxLocalState tx
ps0 PeerTxInFlight
pif0 SharedTxState Int Int
ss
      in (SharedTxState Int Int
ss', (PeerRole
role, PeerAction
action, PeerTxLocalState (Tx Int)
forall tx. PeerTxLocalState tx
ps', PeerTxInFlight
pif') (PeerRole, PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> [(PeerRole, PeerAction, PeerTxLocalState (Tx Int),
     PeerTxInFlight)]
-> [(PeerRole, PeerAction, PeerTxLocalState (Tx Int),
     PeerTxInFlight)]
forall a. a -> [a] -> [a]
: [(PeerRole, PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)]
acc)

    (SharedTxState Int Int
sharedStateFinal, [(PeerRole, PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)]
results) = ((SharedTxState Int Int,
  [(PeerRole, PeerAction, PeerTxLocalState (Tx Int),
    PeerTxInFlight)])
 -> PeerRole
 -> (SharedTxState Int Int,
     [(PeerRole, PeerAction, PeerTxLocalState (Tx Int),
       PeerTxInFlight)]))
-> (SharedTxState Int Int,
    [(PeerRole, PeerAction, PeerTxLocalState (Tx Int),
      PeerTxInFlight)])
-> [PeerRole]
-> (SharedTxState Int Int,
    [(PeerRole, PeerAction, PeerTxLocalState (Tx Int),
      PeerTxInFlight)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (SharedTxState Int Int,
 [(PeerRole, PeerAction, PeerTxLocalState (Tx Int),
   PeerTxInFlight)])
-> PeerRole
-> (SharedTxState Int Int,
    [(PeerRole, PeerAction, PeerTxLocalState (Tx Int),
      PeerTxInFlight)])
runOne (SharedTxState Int Int
sharedState0, []) [PeerRole]
order

    lookupAction :: PeerRole
                 -> Maybe (PeerAction, PeerTxLocalState (Tx TxId), PeerTxInFlight)
    lookupAction :: PeerRole
-> Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
lookupAction PeerRole
role =
      case [ (PeerAction
a, PeerTxLocalState (Tx Int)
ps', PeerTxInFlight
pif') | (PeerRole
r, PeerAction
a, PeerTxLocalState (Tx Int)
ps', PeerTxInFlight
pif') <- [(PeerRole, PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)]
results, PeerRole
r PeerRole -> PeerRole -> Bool
forall a. Eq a => a -> a -> Bool
== PeerRole
role ] of
        []      -> Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
forall a. Maybe a
Nothing
        ((PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
x : [(PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)]
_) -> (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Maybe (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
forall a. a -> Maybe a
Just (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight)
x

--
-- 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 (ActionTrigger -> ActionTrigger -> Bool
(ActionTrigger -> ActionTrigger -> Bool)
-> (ActionTrigger -> ActionTrigger -> Bool) -> Eq ActionTrigger
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ActionTrigger -> ActionTrigger -> Bool
== :: ActionTrigger -> ActionTrigger -> Bool
$c/= :: ActionTrigger -> ActionTrigger -> Bool
/= :: ActionTrigger -> ActionTrigger -> Bool
Eq, Int -> ActionTrigger -> TestName -> TestName
[ActionTrigger] -> TestName -> TestName
ActionTrigger -> TestName
(Int -> ActionTrigger -> TestName -> TestName)
-> (ActionTrigger -> TestName)
-> ([ActionTrigger] -> TestName -> TestName)
-> Show ActionTrigger
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> ActionTrigger -> TestName -> TestName
showsPrec :: Int -> ActionTrigger -> TestName -> TestName
$cshow :: ActionTrigger -> TestName
show :: ActionTrigger -> TestName
$cshowList :: [ActionTrigger] -> TestName -> TestName
showList :: [ActionTrigger] -> TestName -> TestName
Show)

instance Arbitrary ActionTrigger where
  arbitrary :: Gen ActionTrigger
arbitrary = [Gen ActionTrigger] -> Gen ActionTrigger
forall a. HasCallStack => [Gen a] -> Gen a
oneof
    [ Int -> Positive Int -> ActionTrigger
TSubmittable    (Int -> Positive Int -> ActionTrigger)
-> Gen Int -> Gen (Positive Int -> ActionTrigger)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
arbitrary Gen (Positive Int -> ActionTrigger)
-> Gen (Positive Int) -> Gen ActionTrigger
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Positive Int)
forall a. Arbitrary a => Gen a
arbitrary
    , Int -> Positive Int -> ActionTrigger
TFetchable      (Int -> Positive Int -> ActionTrigger)
-> Gen Int -> Gen (Positive Int -> ActionTrigger)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
arbitrary Gen (Positive Int -> ActionTrigger)
-> Gen (Positive Int) -> Gen ActionTrigger
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Positive Int)
forall a. Arbitrary a => Gen a
arbitrary
    , Int -> ActionTrigger
TAckable        (Int -> ActionTrigger) -> Gen Int -> Gen ActionTrigger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
arbitrary
    , Positive Int -> Int -> Positive Int -> ActionTrigger
TFetchableLater (Positive Int -> Int -> Positive Int -> ActionTrigger)
-> Gen (Positive Int) -> Gen (Int -> Positive Int -> ActionTrigger)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Positive Int)
forall a. Arbitrary a => Gen a
arbitrary Gen (Int -> Positive Int -> ActionTrigger)
-> Gen Int -> Gen (Positive Int -> ActionTrigger)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Int
forall a. Arbitrary a => Gen a
arbitrary Gen (Positive Int -> ActionTrigger)
-> Gen (Positive Int) -> Gen ActionTrigger
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Positive Int)
forall a. Arbitrary a => Gen a
arbitrary
    ]
  shrink :: ActionTrigger -> [ActionTrigger]
shrink (TSubmittable Int
t Positive Int
s) =
       [ Int -> Positive Int -> ActionTrigger
TFetchable Int
t Positive Int
s, Int -> ActionTrigger
TAckable Int
t ]
    [ActionTrigger] -> [ActionTrigger] -> [ActionTrigger]
forall a. [a] -> [a] -> [a]
++ [ Int -> Positive Int -> ActionTrigger
TSubmittable Int
t' Positive Int
s | Int
t' <- Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
1 (Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink Int
t) ]
  shrink (TFetchable Int
t Positive Int
s) =
       Int -> ActionTrigger
TAckable Int
t ActionTrigger -> [ActionTrigger] -> [ActionTrigger]
forall a. a -> [a] -> [a]
:
       [ Int -> Positive Int -> ActionTrigger
TFetchable Int
t' Positive Int
s | Int
t' <- Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
1 (Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink Int
t) ]
  shrink (TAckable Int
t) =
       [ Int -> ActionTrigger
TAckable Int
t' | Int
t' <- Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
1 (Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink Int
t) ]
  shrink (TFetchableLater Positive Int
d Int
t Positive Int
s) =
       [ Int -> Positive Int -> ActionTrigger
TFetchable Int
t Positive Int
s, Int -> ActionTrigger
TAckable Int
t ]
    [ActionTrigger] -> [ActionTrigger] -> [ActionTrigger]
forall a. [a] -> [a] -> [a]
++ [ Positive Int -> Int -> Positive Int -> ActionTrigger
TFetchableLater Positive Int
d' Int
t Positive Int
s | Positive Int
d' <- Int -> [Positive Int] -> [Positive Int]
forall a. Int -> [a] -> [a]
take Int
1 (Positive Int -> [Positive Int]
forall a. Arbitrary a => a -> [a]
shrink Positive Int
d) ]

triggerTxid :: ActionTrigger -> TxId
triggerTxid :: ActionTrigger -> Int
triggerTxid (TSubmittable    Int
t Positive Int
_)   = Int
t
triggerTxid (TFetchable      Int
t Positive Int
_)   = Int
t
triggerTxid (TAckable        Int
t)     = Int
t
triggerTxid (TFetchableLater Positive Int
_ Int
t Positive Int
_) = Int
t

isTSubmittable :: ActionTrigger -> Bool
isTSubmittable :: ActionTrigger -> Bool
isTSubmittable TSubmittable{} = Bool
True
isTSubmittable ActionTrigger
_              = Bool
False

isTAckable :: ActionTrigger -> Bool
isTAckable :: ActionTrigger -> Bool
isTAckable TAckable{} = Bool
True
isTAckable ActionTrigger
_          = Bool
False

isTFetchableNow :: ActionTrigger -> Bool
isTFetchableNow :: ActionTrigger -> Bool
isTFetchableNow TFetchable{} = Bool
True
isTFetchableNow ActionTrigger
_            = Bool
False

isTFetchableLater :: ActionTrigger -> Bool
isTFetchableLater :: ActionTrigger -> Bool
isTFetchableLater TFetchableLater{} = Bool
True
isTFetchableLater ActionTrigger
_                 = Bool
False

setTxid :: ActionTrigger -> TxId -> ActionTrigger
setTxid :: ActionTrigger -> Int -> ActionTrigger
setTxid (TSubmittable    Int
_ Positive Int
s)   Int
t = Int -> Positive Int -> ActionTrigger
TSubmittable    Int
t Positive Int
s
setTxid (TFetchable      Int
_ Positive Int
s)   Int
t = Int -> Positive Int -> ActionTrigger
TFetchable      Int
t Positive Int
s
setTxid (TAckable        Int
_)     Int
t = Int -> ActionTrigger
TAckable        Int
t
setTxid (TFetchableLater Positive Int
d Int
_ Positive Int
s) Int
t = Positive Int -> Int -> Positive Int -> ActionTrigger
TFetchableLater Positive Int
d Int
t Positive Int
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 (OverlapMode -> OverlapMode -> Bool
(OverlapMode -> OverlapMode -> Bool)
-> (OverlapMode -> OverlapMode -> Bool) -> Eq OverlapMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OverlapMode -> OverlapMode -> Bool
== :: OverlapMode -> OverlapMode -> Bool
$c/= :: OverlapMode -> OverlapMode -> Bool
/= :: OverlapMode -> OverlapMode -> Bool
Eq, Int -> OverlapMode -> TestName -> TestName
[OverlapMode] -> TestName -> TestName
OverlapMode -> TestName
(Int -> OverlapMode -> TestName -> TestName)
-> (OverlapMode -> TestName)
-> ([OverlapMode] -> TestName -> TestName)
-> Show OverlapMode
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> OverlapMode -> TestName -> TestName
showsPrec :: Int -> OverlapMode -> TestName -> TestName
$cshow :: OverlapMode -> TestName
show :: OverlapMode -> TestName
$cshowList :: [OverlapMode] -> TestName -> TestName
showList :: [OverlapMode] -> TestName -> TestName
Show)

-- | A scenario is an overlap mode plus a per-peer trigger map.
data TriggerScenario =
       TriggerScenario OverlapMode (Map.Map PeerAddr [ActionTrigger])
  deriving (TriggerScenario -> TriggerScenario -> Bool
(TriggerScenario -> TriggerScenario -> Bool)
-> (TriggerScenario -> TriggerScenario -> Bool)
-> Eq TriggerScenario
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TriggerScenario -> TriggerScenario -> Bool
== :: TriggerScenario -> TriggerScenario -> Bool
$c/= :: TriggerScenario -> TriggerScenario -> Bool
/= :: TriggerScenario -> TriggerScenario -> Bool
Eq, Int -> TriggerScenario -> TestName -> TestName
[TriggerScenario] -> TestName -> TestName
TriggerScenario -> TestName
(Int -> TriggerScenario -> TestName -> TestName)
-> (TriggerScenario -> TestName)
-> ([TriggerScenario] -> TestName -> TestName)
-> Show TriggerScenario
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> TriggerScenario -> TestName -> TestName
showsPrec :: Int -> TriggerScenario -> TestName -> TestName
$cshow :: TriggerScenario -> TestName
show :: TriggerScenario -> TestName
$cshowList :: [TriggerScenario] -> TestName -> TestName
showList :: [TriggerScenario] -> TestName -> TestName
Show)

genPerPeerTriggers :: Gen [ActionTrigger]
genPerPeerTriggers :: Gen [ActionTrigger]
genPerPeerTriggers = do
  size <- [(Int, Gen Int)] -> Gen Int
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
2, Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1)
    , (Int
1, Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0)
    , (Int
3, (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
2, Int
10))
    , (Int
1, (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
11, Int
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 :: [ActionTrigger] -> [[ActionTrigger]]
shrinkTriggerList [ActionTrigger]
ts =
  let n :: Int
n = [ActionTrigger] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ActionTrigger]
ts in
     [ Int -> [ActionTrigger] -> [ActionTrigger]
forall a. Int -> [a] -> [a]
take (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [ActionTrigger]
ts | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 ]
  [[ActionTrigger]] -> [[ActionTrigger]] -> [[ActionTrigger]]
forall a. [a] -> [a] -> [a]
++ [ Int -> [ActionTrigger] -> [ActionTrigger]
forall a. Int -> [a] -> [a]
drop (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [ActionTrigger]
ts | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 ]
  [[ActionTrigger]] -> [[ActionTrigger]] -> [[ActionTrigger]]
forall a. [a] -> [a] -> [a]
++ [ Int -> [ActionTrigger] -> [ActionTrigger]
forall a. Int -> [a] -> [a]
take Int
i [ActionTrigger]
ts [ActionTrigger] -> [ActionTrigger] -> [ActionTrigger]
forall a. [a] -> [a] -> [a]
++ Int -> [ActionTrigger] -> [ActionTrigger]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [ActionTrigger]
ts | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]
  [[ActionTrigger]] -> [[ActionTrigger]] -> [[ActionTrigger]]
forall a. [a] -> [a] -> [a]
++ [ Int -> [ActionTrigger] -> [ActionTrigger]
forall a. Int -> [a] -> [a]
take Int
i [ActionTrigger]
ts [ActionTrigger] -> [ActionTrigger] -> [ActionTrigger]
forall a. [a] -> [a] -> [a]
++ ActionTrigger
t' ActionTrigger -> [ActionTrigger] -> [ActionTrigger]
forall a. a -> [a] -> [a]
: Int -> [ActionTrigger] -> [ActionTrigger]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [ActionTrigger]
ts
     | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
     , ActionTrigger
t' <- ActionTrigger -> [ActionTrigger]
forall a. Arbitrary a => a -> [a]
shrink ([ActionTrigger]
ts [ActionTrigger] -> Int -> ActionTrigger
forall a. HasCallStack => [a] -> Int -> a
!! Int
i)
     ]

renumberDisjoint :: [[ActionTrigger]] -> [[ActionTrigger]]
renumberDisjoint :: [[ActionTrigger]] -> [[ActionTrigger]]
renumberDisjoint = (Int, [[ActionTrigger]]) -> [[ActionTrigger]]
forall a b. (a, b) -> b
snd ((Int, [[ActionTrigger]]) -> [[ActionTrigger]])
-> ([[ActionTrigger]] -> (Int, [[ActionTrigger]]))
-> [[ActionTrigger]]
-> [[ActionTrigger]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> [ActionTrigger] -> (Int, [ActionTrigger]))
-> Int -> [[ActionTrigger]] -> (Int, [[ActionTrigger]])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Int -> [ActionTrigger] -> (Int, [ActionTrigger])
renumberOne Int
1
  where
    renumberOne :: Int -> [ActionTrigger] -> (Int, [ActionTrigger])
renumberOne Int
nextId [ActionTrigger]
triggers =
      let n :: Int
n = [ActionTrigger] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ActionTrigger]
triggers in
      (Int
nextId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n, (ActionTrigger -> Int -> ActionTrigger)
-> [ActionTrigger] -> [Int] -> [ActionTrigger]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ActionTrigger -> Int -> ActionTrigger
setTxid [ActionTrigger]
triggers [Int
nextId .. Int
nextId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1])

collapseToPool :: Int -> [[ActionTrigger]] -> Gen [[ActionTrigger]]
collapseToPool :: Int -> [[ActionTrigger]] -> Gen [[ActionTrigger]]
collapseToPool Int
poolSize = ([ActionTrigger] -> Gen [ActionTrigger])
-> [[ActionTrigger]] -> Gen [[ActionTrigger]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((ActionTrigger -> Gen ActionTrigger)
-> [ActionTrigger] -> Gen [ActionTrigger]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ActionTrigger -> Gen ActionTrigger
remap)
  where
    remap :: ActionTrigger -> Gen ActionTrigger
remap ActionTrigger
trig = do
      newId <- (Int, Int) -> Gen Int
chooseInt (Int
1, Int
poolSize)
      pure (setTxid trig newId)

instance Arbitrary TriggerScenario where
  arbitrary :: Gen TriggerScenario
arbitrary = do
    nPeers <- [(Int, Gen Int)] -> Gen Int
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
2, Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1)
      , (Int
2, Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
2)
      , (Int
1, Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
3)
      ]
    perPeer <- vectorOf nPeers genPerPeerTriggers
    mode <- frequency
      [ (2, pure ModeDisjoint)
      , (3, pure ModeShared)
      ]
    remapped <- case mode of
      OverlapMode
ModeDisjoint -> [[ActionTrigger]] -> Gen [[ActionTrigger]]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[ActionTrigger]] -> [[ActionTrigger]]
renumberDisjoint [[ActionTrigger]]
perPeer)
      OverlapMode
ModeShared   ->
        let totalT :: Int
totalT  = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (([ActionTrigger] -> Int) -> [[ActionTrigger]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [ActionTrigger] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[ActionTrigger]]
perPeer)
            poolSz :: Int
poolSz  = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
totalT Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) in
        Int -> [[ActionTrigger]] -> Gen [[ActionTrigger]]
collapseToPool Int
poolSz [[ActionTrigger]]
perPeer
    pure (TriggerScenario mode
            (Map.fromList (zip [1 .. nPeers] remapped)))
  shrink :: TriggerScenario -> [TriggerScenario]
shrink (TriggerScenario OverlapMode
mode Map Int [ActionTrigger]
m) =
       [ OverlapMode -> Map Int [ActionTrigger] -> TriggerScenario
TriggerScenario OverlapMode
mode (Int -> Map Int [ActionTrigger] -> Map Int [ActionTrigger]
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Int
p Map Int [ActionTrigger]
m)
       | Map Int [ActionTrigger] -> Int
forall k a. Map k a -> Int
Map.size Map Int [ActionTrigger]
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
       , Int
p <- Map Int [ActionTrigger] -> [Int]
forall k a. Map k a -> [k]
Map.keys Map Int [ActionTrigger]
m
       ]
    [TriggerScenario] -> [TriggerScenario] -> [TriggerScenario]
forall a. [a] -> [a] -> [a]
++ [ OverlapMode -> Map Int [ActionTrigger] -> TriggerScenario
TriggerScenario OverlapMode
mode (Int
-> [ActionTrigger]
-> Map Int [ActionTrigger]
-> Map Int [ActionTrigger]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
p [ActionTrigger]
ts' Map Int [ActionTrigger]
m)
       | (Int
p, [ActionTrigger]
ts) <- Map Int [ActionTrigger] -> [(Int, [ActionTrigger])]
forall k a. Map k a -> [(k, a)]
Map.toList Map Int [ActionTrigger]
m
       , [ActionTrigger]
ts' <- [ActionTrigger] -> [[ActionTrigger]]
shrinkTriggerList [ActionTrigger]
ts
       ]

-- | Strongest trigger category seen across all peers for a given txid.
data TxCategory = CatSubmit | CatFetch | CatAck
  deriving (TxCategory -> TxCategory -> Bool
(TxCategory -> TxCategory -> Bool)
-> (TxCategory -> TxCategory -> Bool) -> Eq TxCategory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TxCategory -> TxCategory -> Bool
== :: TxCategory -> TxCategory -> Bool
$c/= :: TxCategory -> TxCategory -> Bool
/= :: TxCategory -> TxCategory -> Bool
Eq, Int -> TxCategory -> TestName -> TestName
[TxCategory] -> TestName -> TestName
TxCategory -> TestName
(Int -> TxCategory -> TestName -> TestName)
-> (TxCategory -> TestName)
-> ([TxCategory] -> TestName -> TestName)
-> Show TxCategory
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> TxCategory -> TestName -> TestName
showsPrec :: Int -> TxCategory -> TestName -> TestName
$cshow :: TxCategory -> TestName
show :: TxCategory -> TestName
$cshowList :: [TxCategory] -> TestName -> TestName
showList :: [TxCategory] -> TestName -> TestName
Show)

categoryOf :: [ActionTrigger] -> TxCategory
categoryOf :: [ActionTrigger] -> TxCategory
categoryOf [ActionTrigger]
trigs
  | (ActionTrigger -> Bool) -> [ActionTrigger] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ActionTrigger -> Bool
isTSubmittable [ActionTrigger]
trigs                                  = TxCategory
CatSubmit
  | (ActionTrigger -> Bool) -> [ActionTrigger] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ActionTrigger -> Bool
isTFetchableNow [ActionTrigger]
trigs Bool -> Bool -> Bool
|| (ActionTrigger -> Bool) -> [ActionTrigger] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ActionTrigger -> Bool
isTFetchableLater [ActionTrigger]
trigs  = TxCategory
CatFetch
  | Bool
otherwise                                                 = TxCategory
CatAck

hasActiveEntry :: ActionTrigger -> Bool
hasActiveEntry :: ActionTrigger -> Bool
hasActiveEntry TAckable{} = Bool
False
hasActiveEntry ActionTrigger
_          = Bool
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 :: TxDecisionPolicy
-> Map Int [ActionTrigger]
-> (Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight),
    SharedTxState Int Int)
buildTriggerState TxDecisionPolicy
policy Map Int [ActionTrigger]
perPeer =
    (Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
peerStates, SharedTxState Int Int
sharedState0)
  where
    allTxids :: [TxId]
    allTxids :: [Int]
allTxids = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub
      [ ActionTrigger -> Int
triggerTxid ActionTrigger
t
      | (Int
_, [ActionTrigger]
ts) <- Map Int [ActionTrigger] -> [(Int, [ActionTrigger])]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Int [ActionTrigger]
perPeer
      , ActionTrigger
t <- [ActionTrigger]
ts
      ]

    txidToKey :: Map.Map TxId Int
    txidToKey :: Map Int Int
txidToKey = [(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
allTxids [Int
0..])

    txidKey :: TxId -> Int
    txidKey :: Int -> Int
txidKey Int
t = Map Int Int
txidToKey Map Int Int -> Int -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! Int
t

    triggersFor :: TxId -> [(PeerAddr, ActionTrigger)]
    triggersFor :: Int -> [(Int, ActionTrigger)]
triggersFor Int
txid =
      [ (Int
p, ActionTrigger
t)
      | (Int
p, [ActionTrigger]
ts) <- Map Int [ActionTrigger] -> [(Int, [ActionTrigger])]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Int [ActionTrigger]
perPeer
      , ActionTrigger
t <- [ActionTrigger]
ts
      , ActionTrigger -> Int
triggerTxid ActionTrigger
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
txid
      ]

    submittingPeer :: TxId -> Maybe PeerAddr
    submittingPeer :: Int -> Maybe Int
submittingPeer Int
txid = [Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe
      [ Int
p | (Int
p, ActionTrigger
t) <- Int -> [(Int, ActionTrigger)]
triggersFor Int
txid, ActionTrigger -> Bool
isTSubmittable ActionTrigger
t ]

    laterDelay :: TxId -> Maybe Int
    laterDelay :: Int -> Maybe Int
laterDelay Int
txid = [Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe
      [ Int
d | (Int
_, TFetchableLater (Positive Int
d) Int
_ Positive Int
_) <- Int -> [(Int, ActionTrigger)]
triggersFor Int
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 :: Int -> TxEntry Int
mkEntry Int
txid =
      let trigs :: [(Int, ActionTrigger)]
trigs = Int -> [(Int, ActionTrigger)]
triggersFor Int
txid
          attemptCount :: Int
attemptCount = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | (Int
_, ActionTrigger
t) <- [(Int, ActionTrigger)]
trigs, ActionTrigger -> Bool
isTSubmittable ActionTrigger
t]
          lease :: TxLease Int
lease = case Int -> Maybe Int
submittingPeer Int
txid of
            Just Int
p  -> Int -> Time -> TxLease Int
forall peeraddr. peeraddr -> Time -> TxLease peeraddr
TxLeased Int
p (DiffTime -> Time -> Time
addTime DiffTime
10 Time
now)
            Maybe Int
Nothing -> case Int -> Maybe Int
laterDelay Int
txid of
              Just Int
d  -> Time -> TxLease Int
forall peeraddr. Time -> TxLease peeraddr
TxClaimable (DiffTime -> Time -> Time
addTime (Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
d) Time
now)
              Maybe Int
Nothing -> Time -> TxLease Int
forall peeraddr. Time -> TxLease peeraddr
TxClaimable Time
now in
      TxEntry
        { txLease :: TxLease Int
txLease           = TxLease Int
lease
        , txAttempt :: Int
txAttempt         = Int
attemptCount
        , txInSubmission :: Bool
txInSubmission    = Bool
False
        , currentMaxInflightMultiplicity :: Int
currentMaxInflightMultiplicity = TxDecisionPolicy -> Int
txInflightMultiplicity TxDecisionPolicy
policy
        }

    activeTxids :: [Int]
activeTxids = [ Int
txid | Int
txid <- [Int]
allTxids
                  , [ActionTrigger] -> TxCategory
categoryOf (((Int, ActionTrigger) -> ActionTrigger)
-> [(Int, ActionTrigger)] -> [ActionTrigger]
forall a b. (a -> b) -> [a] -> [b]
map (Int, ActionTrigger) -> ActionTrigger
forall a b. (a, b) -> b
snd (Int -> [(Int, ActionTrigger)]
triggersFor Int
txid)) TxCategory -> TxCategory -> Bool
forall a. Eq a => a -> a -> Bool
/= TxCategory
CatAck ]
    retainedTxids :: [Int]
retainedTxids = [ Int
txid | Int
txid <- [Int]
allTxids
                    , [ActionTrigger] -> TxCategory
categoryOf (((Int, ActionTrigger) -> ActionTrigger)
-> [(Int, ActionTrigger)] -> [ActionTrigger]
forall a b. (a -> b) -> [a] -> [b]
map (Int, ActionTrigger) -> ActionTrigger
forall a b. (a, b) -> b
snd (Int -> [(Int, ActionTrigger)]
triggersFor Int
txid)) TxCategory -> TxCategory -> Bool
forall a. Eq a => a -> a -> Bool
== TxCategory
CatAck ]

    retainedUntil :: Time
retainedUntil   = DiffTime -> Time -> Time
addTime DiffTime
600 Time
now
    retainedEntries :: [(Int, Time)]
retainedEntries = [ (Int -> Int
txidKey Int
txid, Time
retainedUntil) | Int
txid <- [Int]
retainedTxids ]

    mkPeerState :: PeerAddr -> [ActionTrigger]
                -> (PeerTxLocalState (Tx TxId), PeerTxInFlight)
    mkPeerState :: Int
-> [ActionTrigger] -> (PeerTxLocalState (Tx Int), PeerTxInFlight)
mkPeerState Int
peeraddr [ActionTrigger]
ts =
      let peerLocal :: PeerTxLocalState (Tx Int)
peerLocal = PeerTxLocalState (ZonkAny 3)
forall tx. PeerTxLocalState tx
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
advertised = [Int] -> IntSet
IntSet.fromList
            [ Int -> Int
txidKey (ActionTrigger -> Int
triggerTxid ActionTrigger
t) | ActionTrigger
t <- [ActionTrigger]
ts, ActionTrigger -> Bool
hasActiveEntry ActionTrigger
t ]
          leasedHere :: IntSet
leasedHere = [Int] -> IntSet
IntSet.fromList
            [ Int -> Int
txidKey Int
t' | TSubmittable Int
t' Positive Int
_ <- [ActionTrigger]
ts
                         , Int -> Maybe Int
submittingPeer Int
t' Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just Int
peeraddr ]
          attemptingHere :: IntSet
attemptingHere = IntSet
leasedHere
          -- 'pifAcksPending' tracks the keys held in the unacked queue
          -- (a superset of 'pifAdvertised'), matching production.
          acksPending :: IntSet
acksPending = [Int] -> IntSet
IntSet.fromList
            [ Int
k | TxKey Int
k <- StrictSeq TxKey -> [TxKey]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (PeerTxLocalState (Tx Int) -> StrictSeq TxKey
forall tx. PeerTxLocalState tx -> StrictSeq TxKey
peerUnacknowledgedTxIds PeerTxLocalState (Tx Int)
peerLocal) ]
          peerInFlight :: PeerTxInFlight
peerInFlight = PeerTxInFlight
emptyPeerTxInFlight
            { pifAdvertised  = advertised
            , pifLeased      = leasedHere
            , pifAttempting  = attemptingHere
            , pifAcksPending = acksPending
            }
      in (PeerTxLocalState (Tx Int)
peerLocal, PeerTxInFlight
peerInFlight)

    peerStates :: Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
peerStates = (Int
 -> [ActionTrigger] -> (PeerTxLocalState (Tx Int), PeerTxInFlight))
-> Map Int [ActionTrigger]
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Int
-> [ActionTrigger] -> (PeerTxLocalState (Tx Int), PeerTxInFlight)
mkPeerState Map Int [ActionTrigger]
perPeer

    sharedState0 :: SharedTxState Int Int
sharedState0 = SharedTxState (ZonkAny 5) (ZonkAny 4)
forall peeraddr txid. SharedTxState peeraddr txid
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
      }

-- | Per-peer normalise: shift txids to >= 1, dedupe, reorder so
-- ackables come first, then submittables, then fetchables.
normaliseTriggers :: [ActionTrigger] -> [ActionTrigger]
normaliseTriggers :: [ActionTrigger] -> [ActionTrigger]
normaliseTriggers =
    [ActionTrigger] -> [ActionTrigger]
orderTriggers
  ([ActionTrigger] -> [ActionTrigger])
-> ([ActionTrigger] -> [ActionTrigger])
-> [ActionTrigger]
-> [ActionTrigger]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ActionTrigger -> ActionTrigger -> Bool)
-> [ActionTrigger] -> [ActionTrigger]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int -> Int -> Bool)
-> (ActionTrigger -> Int) -> ActionTrigger -> ActionTrigger -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ActionTrigger -> Int
triggerTxid)
  ([ActionTrigger] -> [ActionTrigger])
-> ([ActionTrigger] -> [ActionTrigger])
-> [ActionTrigger]
-> [ActionTrigger]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ActionTrigger -> ActionTrigger)
-> [ActionTrigger] -> [ActionTrigger]
forall a b. (a -> b) -> [a] -> [b]
map ActionTrigger -> ActionTrigger
shiftTrigger
  where
    shiftTrigger :: ActionTrigger -> ActionTrigger
shiftTrigger (TSubmittable    Int
t Positive Int
s)   = Int -> Positive Int -> ActionTrigger
TSubmittable    (Int -> Int
forall a. Num a => a -> a
abs Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Positive Int
s
    shiftTrigger (TFetchable      Int
t Positive Int
s)   = Int -> Positive Int -> ActionTrigger
TFetchable      (Int -> Int
forall a. Num a => a -> a
abs Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Positive Int
s
    shiftTrigger (TAckable        Int
t)     = Int -> ActionTrigger
TAckable        (Int -> Int
forall a. Num a => a -> a
abs Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    shiftTrigger (TFetchableLater Positive Int
d Int
t Positive Int
s) = Positive Int -> Int -> Positive Int -> ActionTrigger
TFetchableLater Positive Int
d (Int -> Int
forall a. Num a => a -> a
abs Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Positive Int
s
    orderTriggers :: [ActionTrigger] -> [ActionTrigger]
orderTriggers [ActionTrigger]
ts =
         (ActionTrigger -> Bool) -> [ActionTrigger] -> [ActionTrigger]
forall a. (a -> Bool) -> [a] -> [a]
filter ActionTrigger -> Bool
isTAckable        [ActionTrigger]
ts
      [ActionTrigger] -> [ActionTrigger] -> [ActionTrigger]
forall a. [a] -> [a] -> [a]
++ (ActionTrigger -> Bool) -> [ActionTrigger] -> [ActionTrigger]
forall a. (a -> Bool) -> [a] -> [a]
filter ActionTrigger -> Bool
isTSubmittable    [ActionTrigger]
ts
      [ActionTrigger] -> [ActionTrigger] -> [ActionTrigger]
forall a. [a] -> [a] -> [a]
++ (ActionTrigger -> Bool) -> [ActionTrigger] -> [ActionTrigger]
forall a. (a -> Bool) -> [a] -> [a]
filter ActionTrigger -> Bool
isTFetchableNow   [ActionTrigger]
ts
      [ActionTrigger] -> [ActionTrigger] -> [ActionTrigger]
forall a. [a] -> [a] -> [a]
++ (ActionTrigger -> Bool) -> [ActionTrigger] -> [ActionTrigger]
forall a. (a -> Bool) -> [a] -> [a]
filter ActionTrigger -> Bool
isTFetchableLater [ActionTrigger]
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 :: Map Int [ActionTrigger] -> Map Int [ActionTrigger]
dedupeAcrossPeers Map Int [ActionTrigger]
m = (Int -> [ActionTrigger] -> [ActionTrigger])
-> Map Int [ActionTrigger] -> Map Int [ActionTrigger]
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey ((ActionTrigger -> ActionTrigger)
-> [ActionTrigger] -> [ActionTrigger]
forall a b. (a -> b) -> [a] -> [b]
map ((ActionTrigger -> ActionTrigger)
 -> [ActionTrigger] -> [ActionTrigger])
-> (Int -> ActionTrigger -> ActionTrigger)
-> Int
-> [ActionTrigger]
-> [ActionTrigger]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ActionTrigger -> ActionTrigger
demote) Map Int [ActionTrigger]
m
  where
    primarySubmitter :: Map.Map TxId PeerAddr
    primarySubmitter :: Map Int Int
primarySubmitter = (Int -> Int -> Int) -> [(Int, Int)] -> Map Int Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Int -> Int -> Int
forall a. Ord a => a -> a -> a
min
      [ (Int
t, Int
p) | (Int
p, [ActionTrigger]
ts) <- Map Int [ActionTrigger] -> [(Int, [ActionTrigger])]
forall k a. Map k a -> [(k, a)]
Map.toList Map Int [ActionTrigger]
m, TSubmittable Int
t Positive Int
_ <- [ActionTrigger]
ts ]
    demote :: Int -> ActionTrigger -> ActionTrigger
demote Int
p (TSubmittable Int
t Positive Int
s)
      | Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
t Map Int Int
primarySubmitter Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> Maybe Int
forall a. a -> Maybe a
Just Int
p = Int -> Positive Int -> ActionTrigger
TFetchable Int
t Positive Int
s
    demote Int
_ ActionTrigger
trig = ActionTrigger
trig

normaliseScenario :: Map.Map PeerAddr [ActionTrigger]
                  -> Map.Map PeerAddr [ActionTrigger]
normaliseScenario :: Map Int [ActionTrigger] -> Map Int [ActionTrigger]
normaliseScenario = Map Int [ActionTrigger] -> Map Int [ActionTrigger]
dedupeAcrossPeers (Map Int [ActionTrigger] -> Map Int [ActionTrigger])
-> (Map Int [ActionTrigger] -> Map Int [ActionTrigger])
-> Map Int [ActionTrigger]
-> Map Int [ActionTrigger]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ActionTrigger] -> [ActionTrigger])
-> Map Int [ActionTrigger] -> Map Int [ActionTrigger]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map [ActionTrigger] -> [ActionTrigger]
normaliseTriggers

-- | Policy used by the 'TriggerScenario' meta-tests.
metaPolicy :: TxDecisionPolicy
metaPolicy :: TxDecisionPolicy
metaPolicy = TxDecisionPolicy
defaultTxDecisionPolicy { txInflightMultiplicity = 2 }

prop_TriggerScenario_validInitialState :: TriggerScenario -> Property
prop_TriggerScenario_validInitialState :: TriggerScenario -> Property
prop_TriggerScenario_validInitialState (TriggerScenario OverlapMode
_ Map Int [ActionTrigger]
rawPerPeer) =
    let perPeer :: Map Int [ActionTrigger]
perPeer           = Map Int [ActionTrigger] -> Map Int [ActionTrigger]
normaliseScenario Map Int [ActionTrigger]
rawPerPeer
        (Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
peerStates, SharedTxState Int Int
ss0) = TxDecisionPolicy
-> Map Int [ActionTrigger]
-> (Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight),
    SharedTxState Int Int)
buildTriggerState TxDecisionPolicy
metaPolicy Map Int [ActionTrigger]
perPeer in
    TxDecisionPolicy
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
-> SharedTxState Int Int
-> Property
forall peeraddr txid tx.
(Ord peeraddr, Ord txid, HasRawTxId txid, Show peeraddr, Show txid,
 NoThunks tx) =>
TxDecisionPolicy
-> Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> SharedTxState peeraddr txid
-> Property
combinedStateInvariant TxDecisionPolicy
metaPolicy Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
peerStates SharedTxState Int Int
ss0

prop_TriggerScenario_shrinkPreservesValidity :: TriggerScenario -> Property
prop_TriggerScenario_shrinkPreservesValidity :: TriggerScenario -> Property
prop_TriggerScenario_shrinkPreservesValidity TriggerScenario
ts =
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
      [ TriggerScenario -> Property
prop_TriggerScenario_validInitialState TriggerScenario
ts'
      | TriggerScenario
ts' <- TriggerScenario -> [TriggerScenario]
forall a. Arbitrary a => a -> [a]
shrink TriggerScenario
ts
      ]

prop_TriggerScenario_shrinkSmaller :: TriggerScenario -> Property
prop_TriggerScenario_shrinkSmaller :: TriggerScenario -> Property
prop_TriggerScenario_shrinkSmaller ts :: TriggerScenario
ts@(TriggerScenario OverlapMode
_ Map Int [ActionTrigger]
rawM) =
    let n :: Int
n = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (([ActionTrigger] -> Int) -> [[ActionTrigger]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [ActionTrigger] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Map Int [ActionTrigger] -> [[ActionTrigger]]
forall k a. Map k a -> [a]
Map.elems Map Int [ActionTrigger]
rawM)) in
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
      [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"shrink grew the trigger count: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TriggerScenario -> TestName
forall a. Show a => a -> TestName
show TriggerScenario
ts')
          (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (([ActionTrigger] -> Int) -> [[ActionTrigger]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [ActionTrigger] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Map Int [ActionTrigger] -> [[ActionTrigger]]
forall k a. Map k a -> [a]
Map.elems Map Int [ActionTrigger]
rawM')) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n
      | ts' :: TriggerScenario
ts'@(TriggerScenario OverlapMode
_ Map Int [ActionTrigger]
rawM') <- TriggerScenario -> [TriggerScenario]
forall a. Arbitrary a => a -> [a]
shrink TriggerScenario
ts
      ]

prop_TriggerScenario_shrinkExcludesOriginal :: TriggerScenario -> Property
prop_TriggerScenario_shrinkExcludesOriginal :: TriggerScenario -> Property
prop_TriggerScenario_shrinkExcludesOriginal TriggerScenario
ts =
    TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"shrink contains the original value"
      (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ TriggerScenario
ts TriggerScenario -> [TriggerScenario] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` TriggerScenario -> [TriggerScenario]
forall a. Arbitrary a => a -> [a]
shrink TriggerScenario
ts

-- | Drives 'nextPeerAction' for every peer in the scenario, advancing
-- the earliest-wake peer at each step.  Asserts:
--
--   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 -> TriggerScenario -> Property
prop_nextPeerAction_processesAllTriggers
    (ArbTxDecisionPolicy TxDecisionPolicy
arbPolicy) (TriggerScenario OverlapMode
mode Map Int [ActionTrigger]
rawPerPeer) =
      TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"trigger count" [Int -> TestName
bucket Int
totalTriggers]
    (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"peer count"    [Int -> TestName
forall a. Show a => a -> TestName
show Int
nPeers]
    (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"iterations"    [Int -> TestName
bucket Int
iterations]
    (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"shared txids"  [Int -> TestName
bucket Int
sharedTxidCount]
    (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"overlap mode"  [OverlapMode -> TestName
forall a. Show a => a -> TestName
show OverlapMode
mode]
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
        [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"loop must terminate within step budget"
            (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ Bool
terminated
        , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"submitted set must equal CatSubmit txids"
            (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ IntSet
allSubmitted IntSet -> IntSet -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== IntSet
expectedSubmitted
        , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"requested set must equal CatFetch txids"
            (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ IntSet
allRequested IntSet -> IntSet -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== IntSet
expectedFetched
        , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
            (TestName
"expected acks missing: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ [Int] -> TestName
forall a. Show a => a -> TestName
show (IntSet -> [Int]
IntSet.toList IntSet
missingAcks))
            (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ IntSet -> Bool
IntSet.null IntSet
missingAcks
        , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"initial combined invariant violated"
            (TxDecisionPolicy
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
-> SharedTxState Int Int
-> Property
forall peeraddr txid tx.
(Ord peeraddr, Ord txid, HasRawTxId txid, Show peeraddr, Show txid,
 NoThunks tx) =>
TxDecisionPolicy
-> Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> SharedTxState peeraddr txid
-> Property
combinedStateInvariant TxDecisionPolicy
policy Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
peerStates0 SharedTxState Int Int
sharedState0)
        , [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
            [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
                (TestName
"invariant after step " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
n
                  TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" (peer " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
p TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
")") Property
inv
            | (Int
n, Int
p, Property
inv) <- [(Int, Int, Property)]
stateInvariants
            ]
        ]
  where
    perPeer :: Map Int [ActionTrigger]
perPeer       = Map Int [ActionTrigger] -> Map Int [ActionTrigger]
normaliseScenario Map Int [ActionTrigger]
rawPerPeer
    totalTriggers :: Int
totalTriggers = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (([ActionTrigger] -> Int) -> [[ActionTrigger]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [ActionTrigger] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Map Int [ActionTrigger] -> [[ActionTrigger]]
forall k a. Map k a -> [a]
Map.elems Map Int [ActionTrigger]
perPeer))
    nPeers :: Int
nPeers        = Map Int [ActionTrigger] -> Int
forall k a. Map k a -> Int
Map.size Map Int [ActionTrigger]
perPeer

    txidPeerCounts :: Map.Map TxId Int
    txidPeerCounts :: Map Int Int
txidPeerCounts = (Int -> Int -> Int) -> [(Int, Int)] -> Map Int Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)
      [ (ActionTrigger -> Int
triggerTxid ActionTrigger
t, Int
1 :: Int)
      | (Int
_, [ActionTrigger]
ts) <- Map Int [ActionTrigger] -> [(Int, [ActionTrigger])]
forall k a. Map k a -> [(k, a)]
Map.toList Map Int [ActionTrigger]
perPeer
      , ActionTrigger
t       <- [ActionTrigger]
ts
      ]
    sharedTxidCount :: Int
sharedTxidCount = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
      [ () | (Int
_, Int
n) <- Map Int Int -> [(Int, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Int Int
txidPeerCounts, Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 ]

    policy :: TxDecisionPolicy
policy = TxDecisionPolicy
arbPolicy
      { txInflightMultiplicity         = 2
      , txsSizeInflightPerPeer         =
          max_TX_SIZE * fromIntegral (max 1 totalTriggers)
      , maxOutstandingTxBatchesPerPeer = max 1 totalTriggers
      }

    maxIters :: Int
maxIters = Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
totalTriggers Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
nPeers

    allTxids :: [Int]
allTxids = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub
      [ ActionTrigger -> Int
triggerTxid ActionTrigger
t | (Int
_, [ActionTrigger]
ts) <- Map Int [ActionTrigger] -> [(Int, [ActionTrigger])]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Int [ActionTrigger]
perPeer, ActionTrigger
t <- [ActionTrigger]
ts ]
    txidToKey :: Map Int Int
txidToKey = [(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
allTxids [Int
0..])
    txidKey :: Int -> Int
txidKey Int
t = Map Int Int
txidToKey Map Int Int -> Int -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! Int
t

    triggersFor :: Int -> [ActionTrigger]
triggersFor Int
txid =
      [ ActionTrigger
trig | (Int
_, [ActionTrigger]
ts) <- Map Int [ActionTrigger] -> [(Int, [ActionTrigger])]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Int [ActionTrigger]
perPeer
             , ActionTrigger
trig    <- [ActionTrigger]
ts
             , ActionTrigger -> Int
triggerTxid ActionTrigger
trig Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
txid ]
    catFor :: Int -> TxCategory
catFor Int
txid = [ActionTrigger] -> TxCategory
categoryOf (Int -> [ActionTrigger]
triggersFor Int
txid)

    expectedSubmitted :: IntSet
expectedSubmitted = [Int] -> IntSet
IntSet.fromList
      [ Int -> Int
txidKey Int
t | Int
t <- [Int]
allTxids
                  , let c :: TxCategory
c = Int -> TxCategory
catFor Int
t, TxCategory
c TxCategory -> TxCategory -> Bool
forall a. Eq a => a -> a -> Bool
== TxCategory
CatSubmit Bool -> Bool -> Bool
|| TxCategory
c TxCategory -> TxCategory -> Bool
forall a. Eq a => a -> a -> Bool
== TxCategory
CatFetch ]
    expectedFetched :: IntSet
expectedFetched   = [Int] -> IntSet
IntSet.fromList
      [ Int -> Int
txidKey Int
t | Int
t <- [Int]
allTxids, Int -> TxCategory
catFor Int
t TxCategory -> TxCategory -> Bool
forall a. Eq a => a -> a -> Bool
== TxCategory
CatFetch  ]
    expectedAcked :: IntSet
expectedAcked     = [Int] -> IntSet
IntSet.fromList
      [ Int -> Int
txidKey Int
t | Int
t <- [Int]
allTxids, Int -> TxCategory
catFor Int
t TxCategory -> TxCategory -> Bool
forall a. Eq a => a -> a -> Bool
== TxCategory
CatAck    ]

    (Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
peerStates0, SharedTxState Int Int
sharedState0) = TxDecisionPolicy
-> Map Int [ActionTrigger]
-> (Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight),
    SharedTxState Int Int)
buildTriggerState TxDecisionPolicy
policy Map Int [ActionTrigger]
perPeer

    -- Schedule entry: (next-wake-time, peerLocal, peerInFlight).
    initialSchedule
      :: Map.Map PeerAddr (Maybe Time, PeerTxLocalState (Tx TxId), PeerTxInFlight)
    initialSchedule :: Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
initialSchedule = ((PeerTxLocalState (Tx Int), PeerTxInFlight)
 -> (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight))
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\(PeerTxLocalState (Tx Int)
ps, PeerTxInFlight
pif) -> (Time -> Maybe Time
forall a. a -> Maybe a
Just Time
now, PeerTxLocalState (Tx Int)
ps, PeerTxInFlight
pif)) Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
peerStates0

    (IntSet
allSubmitted, IntSet
allRequested, IntSet
allAcked,
     [(Int, Int, Property)]
stateInvariants, Bool
terminated, Int
iterations) =
        SharedTxState Int Int
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int [(Int, Tx Int)]
-> IntSet
-> IntSet
-> IntSet
-> [(Int, Int, Property)]
-> Int
-> Time
-> (IntSet, IntSet, IntSet, [(Int, Int, Property)], Bool, Int)
runLoop SharedTxState Int Int
sharedState0 Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
initialSchedule Map Int [(Int, Tx Int)]
forall k a. Map k a
Map.empty
                IntSet
IntSet.empty IntSet
IntSet.empty IntSet
IntSet.empty
                [] Int
0 Time
now

    missingAcks :: IntSet
missingAcks = IntSet
expectedAcked IntSet -> IntSet -> IntSet
`IntSet.difference` IntSet
allAcked

    pickEarliest :: Map a (Maybe b, c, d) -> Maybe (a, b, c, d)
pickEarliest Map a (Maybe b, c, d)
schedule =
      case ((a, b) -> (a, b) -> Ordering) -> [(a, b)] -> [(a, b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (b -> b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (b -> b -> Ordering)
-> ((a, b) -> b) -> (a, b) -> (a, b) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (a, b) -> b
forall a b. (a, b) -> b
snd)
             [ (a
p, b
t) | (a
p, (Just b
t, c
_, d
_)) <- Map a (Maybe b, c, d) -> [(a, (Maybe b, c, d))]
forall k a. Map k a -> [(k, a)]
Map.toList Map a (Maybe b, c, d)
schedule ] of
        []         -> Maybe (a, b, c, d)
forall a. Maybe a
Nothing
        (a
p, b
t) : [(a, b)]
_ ->
          let (Maybe b
_, c
ps, d
pif) = Map a (Maybe b, c, d)
schedule Map a (Maybe b, c, d) -> a -> (Maybe b, c, d)
forall k a. Ord k => Map k a -> k -> a
Map.! a
p in
          (a, b, c, d) -> Maybe (a, b, c, d)
forall a. a -> Maybe a
Just (a
p, b
t, c
ps, d
pif)

    reactivateOthers :: a -> a -> Map a (Maybe a, b, c) -> Map a (Maybe a, b, c)
reactivateOthers a
acting a
time =
      (a -> (Maybe a, b, c) -> (Maybe a, b, c))
-> Map a (Maybe a, b, c) -> Map a (Maybe a, b, c)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey ((a -> (Maybe a, b, c) -> (Maybe a, b, c))
 -> Map a (Maybe a, b, c) -> Map a (Maybe a, b, c))
-> (a -> (Maybe a, b, c) -> (Maybe a, b, c))
-> Map a (Maybe a, b, c)
-> Map a (Maybe a, b, c)
forall a b. (a -> b) -> a -> b
$ \a
p (Maybe a
status, b
ps, c
pif) ->
        if a
p a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
acting
          then (Maybe a
status, b
ps, c
pif)
          else case Maybe a
status of
            Just a
t' | a
t' a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
time -> (a -> Maybe a
forall a. a -> Maybe a
Just a
t', b
ps, c
pif)
            Maybe a
_                    -> (a -> Maybe a
forall a. a -> Maybe a
Just a
time, b
ps, c
pif)

    mkBody :: SharedTxState PeerAddr TxId
           -> PeerTxLocalState (Tx TxId)
           -> TxKey
           -> (TxId, Tx TxId)
    mkBody :: SharedTxState Int Int
-> PeerTxLocalState (Tx Int) -> TxKey -> (Int, Tx Int)
mkBody SharedTxState Int Int
ss PeerTxLocalState (Tx Int)
ps (TxKey Int
k) =
      let txid :: Int
txid = SharedTxState Int Int -> IntMap Int
forall peeraddr txid. SharedTxState peeraddr txid -> IntMap txid
sharedKeyToTxId SharedTxState Int Int
ss IntMap Int -> Int -> Int
forall a. IntMap a -> Int -> a
IntMap.! Int
k
          size :: SizeInBytes
size = PeerTxLocalState (Tx Int) -> IntMap SizeInBytes
forall tx. PeerTxLocalState tx -> IntMap SizeInBytes
peerAvailableTxIds PeerTxLocalState (Tx Int)
ps IntMap SizeInBytes -> Int -> SizeInBytes
forall a. IntMap a -> Int -> a
IntMap.! Int
k in
      (Int
txid, Int -> SizeInBytes -> Tx Int
mkTx Int
txid SizeInBytes
size)

    runLoop :: SharedTxState Int Int
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int [(Int, Tx Int)]
-> IntSet
-> IntSet
-> IntSet
-> [(Int, Int, Property)]
-> Int
-> Time
-> (IntSet, IntSet, IntSet, [(Int, Int, Property)], Bool, Int)
runLoop SharedTxState Int Int
ss Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule Map Int [(Int, Tx Int)]
pending IntSet
subs IntSet
reqs IntSet
acks [(Int, Int, Property)]
invs Int
i Time
lastTime
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxIters =
          (IntSet
subs, IntSet
reqs, IntSet
acks, [(Int, Int, Property)] -> [(Int, Int, Property)]
forall a. [a] -> [a]
reverse [(Int, Int, Property)]
invs, Bool
False, Int
i)
      | Bool
otherwise =
          case Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Maybe (Int, Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
forall {b} {a} {c} {d}.
(Ord b, Ord a) =>
Map a (Maybe b, c, d) -> Maybe (a, b, c, d)
pickEarliest Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule of
            Maybe (Int, Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
Nothing ->
              (IntSet
subs, IntSet
reqs, IntSet
acks, [(Int, Int, Property)] -> [(Int, Int, Property)]
forall a. [a] -> [a]
reverse [(Int, Int, Property)]
invs, Bool
True, Int
i)
            Just (Int
p, Time
time, PeerTxLocalState (Tx Int)
ps, PeerTxInFlight
pif) ->
              let lastTime' :: Time
lastTime' = Time -> Time -> Time
forall a. Ord a => a -> a -> a
max Time
lastTime Time
time

                  -- Snapshot of every peer's @(peerLocal, peerInFlight)@
                  -- with @p@'s entry overridden to the supplied pair.
                  peerSnapshot :: Int
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
peerSnapshot Int
pSnap PeerTxLocalState (Tx Int)
psSnap PeerTxInFlight
pifSnap =
                    Int
-> (PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
pSnap (PeerTxLocalState (Tx Int)
psSnap, PeerTxInFlight
pifSnap)
                      (((Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
 -> (PeerTxLocalState (Tx Int), PeerTxInFlight))
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\(Maybe Time
_, PeerTxLocalState (Tx Int)
ps_, PeerTxInFlight
pif_) -> (PeerTxLocalState (Tx Int)
ps_, PeerTxInFlight
pif_)) Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule)

                  -- Drain p's pending body deliveries before its action.
                  (PeerTxLocalState (Tx Int)
psPre, PeerTxInFlight
pifPre, SharedTxState Int Int
ssPre, Map Int [(Int, Tx Int)]
pendingPre, [(Int, Int, Property)]
drainInvs, Int
stepDrain) =
                    case Int -> Map Int [(Int, Tx Int)] -> Maybe [(Int, Tx Int)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
p Map Int [(Int, Tx Int)]
pending of
                      Maybe [(Int, Tx Int)]
Nothing -> (PeerTxLocalState (Tx Int)
ps, PeerTxInFlight
pif, SharedTxState Int Int
ss, Map Int [(Int, Tx Int)]
pending, [], Int
i)
                      Just [(Int, Tx Int)]
deliveries ->
                        let (Int
_, Int
_, PeerTxLocalState (Tx Int)
ps2, PeerTxInFlight
pif2, SharedTxState Int Int
ss2) =
                              (Int -> Bool)
-> Time
-> TxDecisionPolicy
-> Int
-> [(Int, Tx Int)]
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (Int, Int, PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr txid tx.
(HasCallStack, Eq peeraddr, Show 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 (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False) Time
time TxDecisionPolicy
policy Int
p
                                [(Int, Tx Int)]
deliveries PeerTxLocalState (Tx Int)
ps PeerTxInFlight
pif SharedTxState Int Int
ss
                            stepD :: Int
stepD = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                            drainInv :: Property
drainInv = [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
                              [ TxDecisionPolicy
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
-> SharedTxState Int Int
-> SharedTxState Int Int
-> Property
forall peeraddr txid tx.
(Ord peeraddr, Ord txid, HasRawTxId txid, Show peeraddr, Show txid,
 NoThunks tx) =>
TxDecisionPolicy
-> Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> SharedTxState peeraddr txid
-> SharedTxState peeraddr txid
-> Property
combinedStateInvariantStep TxDecisionPolicy
policy
                                  (Int
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
peerSnapshot Int
p PeerTxLocalState (Tx Int)
ps2 PeerTxInFlight
pif2)
                                  SharedTxState Int Int
ss SharedTxState Int Int
ss2
                              , TestName -> PeerTxLocalState (Tx Int) -> Property
forall a. NoThunks a => TestName -> a -> Property
checkNoThunks
                                  (TestName
"peerState after drain (peer "
                                    TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
p TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
", step " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
stepD TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
")")
                                  PeerTxLocalState (Tx Int)
ps2
                              , TestName -> SharedTxState Int Int -> Property
forall a. NoThunks a => TestName -> a -> Property
checkNoThunks
                                  (TestName
"sharedState after drain (peer "
                                    TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
p TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
", step " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
stepD TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
")")
                                  SharedTxState Int Int
ss2
                              ] in
                        ( PeerTxLocalState (Tx Int)
ps2, PeerTxInFlight
pif2, SharedTxState Int Int
ss2, Int -> Map Int [(Int, Tx Int)] -> Map Int [(Int, Tx Int)]
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Int
p Map Int [(Int, Tx Int)]
pending
                           , [(Int
stepD, Int
p, Property
drainInv)], Int
stepD )

                  (PeerAction
action, PeerTxLocalState (Tx Int)
ps', PeerTxInFlight
pif', SharedTxState Int Int
ss') =
                    Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
time TxDecisionPolicy
policy Int
p PeerTxLocalState (Tx Int)
psPre PeerTxInFlight
pifPre SharedTxState Int Int
ssPre
                  oldUnacked :: StrictSeq TxKey
oldUnacked = PeerTxLocalState (Tx Int) -> StrictSeq TxKey
forall tx. PeerTxLocalState tx -> StrictSeq TxKey
peerUnacknowledgedTxIds PeerTxLocalState (Tx Int)
psPre
                  newUnacked :: StrictSeq TxKey
newUnacked = PeerTxLocalState (Tx Int) -> StrictSeq TxKey
forall tx. PeerTxLocalState tx -> StrictSeq TxKey
peerUnacknowledgedTxIds PeerTxLocalState (Tx Int)
ps'
                  numAcked :: Int
numAcked   = StrictSeq TxKey -> Int
forall a. StrictSeq a -> Int
StrictSeq.length StrictSeq TxKey
oldUnacked
                             Int -> Int -> Int
forall a. Num a => a -> a -> a
- StrictSeq TxKey -> Int
forall a. StrictSeq a -> Int
StrictSeq.length StrictSeq TxKey
newUnacked
                  ackedNow :: IntSet
ackedNow   = [Int] -> IntSet
IntSet.fromList ([Int] -> IntSet) -> [Int] -> IntSet
forall a b. (a -> b) -> a -> b
$ (TxKey -> Int) -> [TxKey] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map TxKey -> Int
unTxKey
                             ([TxKey] -> [Int]) -> [TxKey] -> [Int]
forall a b. (a -> b) -> a -> b
$ StrictSeq TxKey -> [TxKey]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Int -> StrictSeq TxKey -> StrictSeq TxKey
forall a. Int -> StrictSeq a -> StrictSeq a
StrictSeq.take Int
numAcked StrictSeq TxKey
oldUnacked)
                  step :: Int
step       = Int
stepDrain Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                  inv :: Property
inv        = [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
                    [ TxDecisionPolicy
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
-> SharedTxState Int Int
-> SharedTxState Int Int
-> Property
forall peeraddr txid tx.
(Ord peeraddr, Ord txid, HasRawTxId txid, Show peeraddr, Show txid,
 NoThunks tx) =>
TxDecisionPolicy
-> Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> SharedTxState peeraddr txid
-> SharedTxState peeraddr txid
-> Property
combinedStateInvariantStep TxDecisionPolicy
policy
                        (Int
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
peerSnapshot Int
p PeerTxLocalState (Tx Int)
ps' PeerTxInFlight
pif') SharedTxState Int Int
ssPre SharedTxState Int Int
ss'
                    , TestName -> PeerTxLocalState (Tx Int) -> Property
forall a. NoThunks a => TestName -> a -> Property
checkNoThunks
                        (TestName
"peerState' (peer " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
p
                          TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
", step " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
step TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
")")
                        PeerTxLocalState (Tx Int)
ps'
                    , TestName -> SharedTxState Int Int -> Property
forall a. NoThunks a => TestName -> a -> Property
checkNoThunks
                        (TestName
"sharedState' (peer " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
p
                          TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
", step " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
step TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
")")
                        SharedTxState Int Int
ss'
                    ] in
              case PeerAction
action of
                PeerDoNothing Word64
_ Maybe DiffTime
Nothing ->
                  let schedule' :: Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule' = Int
-> (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
p (Maybe Time
forall a. Maybe a
Nothing, PeerTxLocalState (Tx Int)
ps', PeerTxInFlight
pif') Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule in
                  SharedTxState Int Int
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int [(Int, Tx Int)]
-> IntSet
-> IntSet
-> IntSet
-> [(Int, Int, Property)]
-> Int
-> Time
-> (IntSet, IntSet, IntSet, [(Int, Int, Property)], Bool, Int)
runLoop SharedTxState Int Int
ss' Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule' Map Int [(Int, Tx Int)]
pendingPre IntSet
subs IntSet
reqs IntSet
acks
                       ((Int
step, Int
p, Property
inv) (Int, Int, Property)
-> [(Int, Int, Property)] -> [(Int, Int, Property)]
forall a. a -> [a] -> [a]
: [(Int, Int, Property)]
drainInvs [(Int, Int, Property)]
-> [(Int, Int, Property)] -> [(Int, Int, Property)]
forall a. [a] -> [a] -> [a]
++ [(Int, Int, Property)]
invs) Int
step Time
lastTime'
                PeerDoNothing Word64
_ (Just DiffTime
delay) ->
                  let nextWake :: Time
nextWake = DiffTime -> Time -> Time
addTime (DiffTime -> DiffTime -> DiffTime
forall a. Ord a => a -> a -> a
max DiffTime
delay DiffTime
0.001) Time
time
                      schedule' :: Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule' = Int
-> (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
p (Time -> Maybe Time
forall a. a -> Maybe a
Just Time
nextWake, PeerTxLocalState (Tx Int)
ps', PeerTxInFlight
pif') Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule in
                  SharedTxState Int Int
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int [(Int, Tx Int)]
-> IntSet
-> IntSet
-> IntSet
-> [(Int, Int, Property)]
-> Int
-> Time
-> (IntSet, IntSet, IntSet, [(Int, Int, Property)], Bool, Int)
runLoop SharedTxState Int Int
ss' Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule' Map Int [(Int, Tx Int)]
pendingPre IntSet
subs IntSet
reqs IntSet
acks
                       ((Int
step, Int
p, Property
inv) (Int, Int, Property)
-> [(Int, Int, Property)] -> [(Int, Int, Property)]
forall a. a -> [a] -> [a]
: [(Int, Int, Property)]
drainInvs [(Int, Int, Property)]
-> [(Int, Int, Property)] -> [(Int, Int, Property)]
forall a. [a] -> [a] -> [a]
++ [(Int, Int, Property)]
invs) Int
step Time
lastTime'
                PeerSubmitTxs [TxKey]
ks ->
                  let (PeerTxLocalState (Tx Int)
ps'', PeerTxInFlight
pif'', SharedTxState Int Int
ss'') =
                        Time
-> TxDecisionPolicy
-> Int
-> [TxKey]
-> [TxKey]
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Eq peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> [TxKey]
-> [TxKey]
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
handleSubmittedTxs Time
time TxDecisionPolicy
policy Int
p [TxKey]
ks [] PeerTxLocalState (Tx Int)
ps' PeerTxInFlight
pif' SharedTxState Int Int
ss'
                      postInv :: Property
postInv = [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
                        [ TxDecisionPolicy
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
-> SharedTxState Int Int
-> SharedTxState Int Int
-> Property
forall peeraddr txid tx.
(Ord peeraddr, Ord txid, HasRawTxId txid, Show peeraddr, Show txid,
 NoThunks tx) =>
TxDecisionPolicy
-> Map peeraddr (PeerTxLocalState tx, PeerTxInFlight)
-> SharedTxState peeraddr txid
-> SharedTxState peeraddr txid
-> Property
combinedStateInvariantStep TxDecisionPolicy
policy
                            (Int
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> Map Int (PeerTxLocalState (Tx Int), PeerTxInFlight)
peerSnapshot Int
p PeerTxLocalState (Tx Int)
ps'' PeerTxInFlight
pif'') SharedTxState Int Int
ss' SharedTxState Int Int
ss''
                        , TestName -> PeerTxLocalState (Tx Int) -> Property
forall a. NoThunks a => TestName -> a -> Property
checkNoThunks
                            (TestName
"peerState'' (peer " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
p
                              TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
", step " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
step TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
")")
                            PeerTxLocalState (Tx Int)
ps''
                        , TestName -> SharedTxState Int Int -> Property
forall a. NoThunks a => TestName -> a -> Property
checkNoThunks
                            (TestName
"sharedState'' (peer " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
p
                              TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
", step " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
step TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
")")
                            SharedTxState Int Int
ss''
                        ]
                      others' :: Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
others' = Int
-> Time
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
forall {a} {a} {b} {c}.
(Ord a, Eq a) =>
a -> a -> Map a (Maybe a, b, c) -> Map a (Maybe a, b, c)
reactivateOthers Int
p Time
time Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule
                      schedule' :: Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule' = Int
-> (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
p (Time -> Maybe Time
forall a. a -> Maybe a
Just Time
time, PeerTxLocalState (Tx Int)
ps'', PeerTxInFlight
pif'') Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
others'
                      subs' :: IntSet
subs' = IntSet -> IntSet -> IntSet
IntSet.union IntSet
subs
                                ([Int] -> IntSet
IntSet.fromList (TxKey -> Int
unTxKey (TxKey -> Int) -> [TxKey] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxKey]
ks)) in
                  SharedTxState Int Int
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int [(Int, Tx Int)]
-> IntSet
-> IntSet
-> IntSet
-> [(Int, Int, Property)]
-> Int
-> Time
-> (IntSet, IntSet, IntSet, [(Int, Int, Property)], Bool, Int)
runLoop SharedTxState Int Int
ss'' Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule' Map Int [(Int, Tx Int)]
pendingPre IntSet
subs' IntSet
reqs IntSet
acks
                       ( (Int
step, Int
p, Property
postInv) (Int, Int, Property)
-> [(Int, Int, Property)] -> [(Int, Int, Property)]
forall a. a -> [a] -> [a]
: (Int
step, Int
p, Property
inv)
                       (Int, Int, Property)
-> [(Int, Int, Property)] -> [(Int, Int, Property)]
forall a. a -> [a] -> [a]
: [(Int, Int, Property)]
drainInvs [(Int, Int, Property)]
-> [(Int, Int, Property)] -> [(Int, Int, Property)]
forall a. [a] -> [a] -> [a]
++ [(Int, Int, Property)]
invs ) Int
step Time
lastTime'
                PeerRequestTxs [TxKey]
ks ->
                  let bodies :: [(Int, Tx Int)]
bodies   = [ SharedTxState Int Int
-> PeerTxLocalState (Tx Int) -> TxKey -> (Int, Tx Int)
mkBody SharedTxState Int Int
ssPre PeerTxLocalState (Tx Int)
psPre TxKey
k | TxKey
k <- [TxKey]
ks ]
                      pending' :: Map Int [(Int, Tx Int)]
pending' = Int
-> [(Int, Tx Int)]
-> Map Int [(Int, Tx Int)]
-> Map Int [(Int, Tx Int)]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
p [(Int, Tx Int)]
bodies Map Int [(Int, Tx Int)]
pendingPre
                      others' :: Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
others'  = Int
-> Time
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
forall {a} {a} {b} {c}.
(Ord a, Eq a) =>
a -> a -> Map a (Maybe a, b, c) -> Map a (Maybe a, b, c)
reactivateOthers Int
p Time
time Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule
                      schedule' :: Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule' = Int
-> (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
p (Time -> Maybe Time
forall a. a -> Maybe a
Just Time
time, PeerTxLocalState (Tx Int)
ps', PeerTxInFlight
pif') Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
others'
                      reqs' :: IntSet
reqs'     = IntSet -> IntSet -> IntSet
IntSet.union IntSet
reqs
                                    ([Int] -> IntSet
IntSet.fromList (TxKey -> Int
unTxKey (TxKey -> Int) -> [TxKey] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxKey]
ks)) in
                  SharedTxState Int Int
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int [(Int, Tx Int)]
-> IntSet
-> IntSet
-> IntSet
-> [(Int, Int, Property)]
-> Int
-> Time
-> (IntSet, IntSet, IntSet, [(Int, Int, Property)], Bool, Int)
runLoop SharedTxState Int Int
ss' Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule' Map Int [(Int, Tx Int)]
pending' IntSet
subs IntSet
reqs' IntSet
acks
                       ((Int
step, Int
p, Property
inv) (Int, Int, Property)
-> [(Int, Int, Property)] -> [(Int, Int, Property)]
forall a. a -> [a] -> [a]
: [(Int, Int, Property)]
drainInvs [(Int, Int, Property)]
-> [(Int, Int, Property)] -> [(Int, Int, Property)]
forall a. [a] -> [a] -> [a]
++ [(Int, Int, Property)]
invs) Int
step Time
lastTime'
                PeerRequestTxIds{} ->
                  let others' :: Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
others'   = Int
-> Time
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
forall {a} {a} {b} {c}.
(Ord a, Eq a) =>
a -> a -> Map a (Maybe a, b, c) -> Map a (Maybe a, b, c)
reactivateOthers Int
p Time
time Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule
                      schedule' :: Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule' = Int
-> (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
p (Time -> Maybe Time
forall a. a -> Maybe a
Just Time
time, PeerTxLocalState (Tx Int)
ps', PeerTxInFlight
pif') Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
others'
                      acks' :: IntSet
acks'     = IntSet -> IntSet -> IntSet
IntSet.union IntSet
acks IntSet
ackedNow in
                  SharedTxState Int Int
-> Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> Map Int [(Int, Tx Int)]
-> IntSet
-> IntSet
-> IntSet
-> [(Int, Int, Property)]
-> Int
-> Time
-> (IntSet, IntSet, IntSet, [(Int, Int, Property)], Bool, Int)
runLoop SharedTxState Int Int
ss' Map Int (Maybe Time, PeerTxLocalState (Tx Int), PeerTxInFlight)
schedule' Map Int [(Int, Tx Int)]
pendingPre IntSet
subs IntSet
reqs IntSet
acks'
                       ((Int
step, Int
p, Property
inv) (Int, Int, Property)
-> [(Int, Int, Property)] -> [(Int, Int, Property)]
forall a. a -> [a] -> [a]
: [(Int, Int, Property)]
drainInvs [(Int, Int, Property)]
-> [(Int, Int, Property)] -> [(Int, Int, Property)]
forall a. [a] -> [a] -> [a]
++ [(Int, Int, Property)]
invs) Int
step Time
lastTime'

-- Generate a self-consistent local peer view of requested, available, and downloaded txs.
genPeerTxLocalState :: Gen (PeerTxLocalState (Tx TxId))
genPeerTxLocalState :: Gen (PeerTxLocalState (Tx Int))
genPeerTxLocalState = (Int -> Gen (PeerTxLocalState (Tx Int)))
-> Gen (PeerTxLocalState (Tx Int))
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen (PeerTxLocalState (Tx Int)))
 -> Gen (PeerTxLocalState (Tx Int)))
-> (Int -> Gen (PeerTxLocalState (Tx Int)))
-> Gen (PeerTxLocalState (Tx Int))
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
  let maxKeys :: Int
maxKeys = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
12 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)

  numKeys <- (Int, Int) -> Gen Int
chooseInt (Int
0, Int
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 =
        [Int] -> IntSet
IntSet.fromList [ TxKey -> Int
unTxKey TxKey
key | TxKey
key <- [TxKey]
downloadedKeys ]
      remainingKeys =
        [ TxKey
key
        | TxKey
key <- StrictSeq TxKey -> [TxKey]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq TxKey
peerUnacknowledgedTxIds
        , Bool -> Bool
not (Int -> IntSet -> Bool
IntSet.member (TxKey -> Int
unTxKey TxKey
key) IntSet
downloadedSet)
        ]

  requestedKeys <- sublistOf remainingKeys
  let requestedSet =
        [Int] -> IntSet
IntSet.fromList [ TxKey -> Int
unTxKey TxKey
key | TxKey
key <- [TxKey]
requestedKeys ]
      availableExtraCandidates =
        [ TxKey
key
        | TxKey
key <- [TxKey]
remainingKeys
        , Bool -> Bool
not (Int -> IntSet -> Bool
IntSet.member (TxKey -> Int
unTxKey TxKey
key) IntSet
requestedSet)
        ]
  availableExtraKeys <- sublistOf availableExtraCandidates

  let availableKeys = [TxKey]
requestedKeys [TxKey] -> [TxKey] -> [TxKey]
forall a. Semigroup a => a -> a -> a
<> [TxKey]
availableExtraKeys
  peerAvailableTxIds <-
    IntMap.fromList <$> mapM genAvailableTx availableKeys

  let requestedKeysOrdered =
        [ TxKey
key
        | TxKey
key <- StrictSeq TxKey -> [TxKey]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq TxKey
peerUnacknowledgedTxIds
        , Int -> IntSet -> Bool
IntSet.member (TxKey -> Int
unTxKey TxKey
key) IntSet
requestedSet
        ]
  (peerRequestedTxBatches, peerRequestedTxsSize) <-
    genRequestedTxBatches peerAvailableTxIds requestedKeysOrdered

  peerDownloadedTxs <-
    IntMap.fromList <$> mapM genDownloadedTx downloadedKeys

  peerScoreTs <- genSmallTime
  -- Generated peer states default to a zero score.
  let peerScoreValue = Double
0
  pure PeerTxLocalState {
      peerPhase = PeerIdle,
      peerUnacknowledgedTxIds,
      peerAvailableTxIds,
      peerRequestedTxs = requestedSet,
      peerRequestedTxBatches,
      peerRequestedTxsSize,
      peerRequestedTxIds,
      peerDownloadedTxs,
      peerDownloadStartTime = Nothing,
      peerScore = PeerScore peerScoreValue peerScoreTs,
      peerLastTxIdReplyWasEmpty = False
    }
  where
    genAvailableTx :: TxKey -> Gen (Int, SizeInBytes)
genAvailableTx TxKey
key = do
      txSize <- Gen SizeInBytes
genPositiveSize
      pure (unTxKey key, txSize)

    genDownloadedTx :: TxKey -> Gen (Int, Tx Int)
genDownloadedTx TxKey
key = do
      txSize <- Gen SizeInBytes
genPositiveSize
      pure (unTxKey key, mkTx (txIdForKey key) txSize)

-- Generate a shared tx state with distinct active and retained entries.
--
-- 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 :: Gen (SharedTxState Int Int)
genSharedTxState = (Int -> Gen (SharedTxState Int Int)) -> Gen (SharedTxState Int Int)
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen (SharedTxState Int Int))
 -> Gen (SharedTxState Int Int))
-> (Int -> Gen (SharedTxState Int Int))
-> Gen (SharedTxState Int Int)
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
  let maxPeers :: Int
maxPeers = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
6 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      maxActiveTxs :: Int
maxActiveTxs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
8 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
      maxRetainedTxs :: Int
maxRetainedTxs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
6 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)

  numPeers <- (Int, Int) -> Gen Int
chooseInt (Int
1, Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
maxPeers)
  peeraddrs <- genDistinctPositiveInts numPeers

  numActiveTxs <- chooseInt (0, maxActiveTxs)
  numRetainedTxs <- chooseInt (0, maxRetainedTxs)

  txids <- genDistinctPositiveInts (numActiveTxs + numRetainedTxs)
  let (activeTxIds, retainedTxIds) = splitAt numActiveTxs txids

  activeEntries <- mapM (genActiveTxEntry peeraddrs) activeTxIds
  retainedEntries <- mapM genRetainedEntry retainedTxIds

  buildSharedTxState activeEntries retainedEntries <$> genSmallWord64
  where
    genRetainedEntry :: a -> Gen (a, Time)
genRetainedEntry a
txid = do
      retainUntil <- Gen Time
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 :: [Int] -> Int -> Gen (Int, TxEntry Int)
genActiveTxEntry [Int]
peeraddrs Int
txid = do
  txEntry <- [(Int, Gen (TxEntry Int))] -> Gen (TxEntry Int)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
5, [Int] -> Gen (TxEntry Int)
genLeasedTxEntry [Int]
peeraddrs)
    , (Int
3, Gen (TxEntry Int)
genClaimableTxEntry)
    ]
  pure (txid, txEntry)

-- Generate a leased entry where the owner may also be in submission.
genLeasedTxEntry :: [PeerAddr] -> Gen (TxEntry PeerAddr)
genLeasedTxEntry :: [Int] -> Gen (TxEntry Int)
genLeasedTxEntry [Int]
peeraddrs = do
  owner <- [Int] -> Gen Int
forall a. HasCallStack => [a] -> Gen a
elements [Int]
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
    }

-- Generate a claimable entry with no in-flight attempt.
genClaimableTxEntry :: Gen (TxEntry PeerAddr)
genClaimableTxEntry :: Gen (TxEntry Int)
genClaimableTxEntry = do
  claimableAt <- Gen Time
genSharedExpiryTime
  pure TxEntry {
      txLease = TxClaimable claimableAt,
      txAttempt = 0,
      txInSubmission = False,
      currentMaxInflightMultiplicity =
        txInflightMultiplicity defaultTxDecisionPolicy
    }

-- Rebuild a shared state from tx-centric fixtures while preserving interned keys.
buildSharedTxState
  :: [(TxId, TxEntry PeerAddr)]
  -> [(TxId, Time)]
  -> Word64
  -> SharedTxState PeerAddr TxId
buildSharedTxState :: [(Int, TxEntry Int)]
-> [(Int, Time)] -> Word64 -> SharedTxState Int Int
buildSharedTxState [(Int, TxEntry Int)]
activeEntries [(Int, Time)]
retainedEntries Word64
sharedGeneration =
  SharedTxState Int Int
baseState {
      sharedTxTable =
        IntMap.fromList
          [ (unTxKey (lookupKeyOrFail txid baseState), txEntry)
          | (txid, txEntry) <- activeEntries
          ],
      sharedRetainedTxs =
        retainedFromList
          [ (unTxKey (lookupKeyOrFail txid baseState), retainUntil)
          | (txid, retainUntil) <- retainedEntries
          ],
      sharedGeneration
    }
  where
    baseState :: SharedTxState Int Int
baseState =
      [Int] -> SharedTxState Int Int
mkSharedState (((Int, TxEntry Int) -> Int) -> [(Int, TxEntry Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, TxEntry Int) -> Int
forall a b. (a, b) -> a
fst [(Int, TxEntry Int)]
activeEntries [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> ((Int, Time) -> Int) -> [(Int, Time)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Time) -> Int
forall a b. (a, b) -> a
fst [(Int, Time)]
retainedEntries)

-- Shrink shared state by dropping active or retained txs.
shrinkSharedTxState
  :: SharedTxState PeerAddr TxId
  -> [SharedTxState PeerAddr TxId]
shrinkSharedTxState :: SharedTxState Int Int -> [SharedTxState Int Int]
shrinkSharedTxState SharedTxState Int Int
sharedState =
  [SharedTxState Int Int] -> [SharedTxState Int Int]
forall a. Eq a => [a] -> [a]
nub ([SharedTxState Int Int] -> [SharedTxState Int Int])
-> [SharedTxState Int Int] -> [SharedTxState Int Int]
forall a b. (a -> b) -> a -> b
$
    [ SharedTxState Int Int
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState
    , [(Int, TxEntry Int)]
-> [(Int, Time)] -> Word64 -> SharedTxState Int Int
buildSharedTxState [] [(Int, Time)]
retainedEntries Word64
0
    , [(Int, TxEntry Int)]
-> [(Int, Time)] -> Word64 -> SharedTxState Int Int
buildSharedTxState [(Int, TxEntry Int)]
activeEntries [] Word64
0
    ] [SharedTxState Int Int]
-> [SharedTxState Int Int] -> [SharedTxState Int Int]
forall a. [a] -> [a] -> [a]
++
    [ [(Int, TxEntry Int)]
-> [(Int, Time)] -> Word64 -> SharedTxState Int Int
buildSharedTxState [(Int, TxEntry Int)]
activeEntries' [(Int, Time)]
retainedEntries Word64
0
    | [(Int, TxEntry Int)]
activeEntries' <- [[(Int, TxEntry Int)]]
smallerActiveEntries
    ] [SharedTxState Int Int]
-> [SharedTxState Int Int] -> [SharedTxState Int Int]
forall a. [a] -> [a] -> [a]
++
    [ [(Int, TxEntry Int)]
-> [(Int, Time)] -> Word64 -> SharedTxState Int Int
buildSharedTxState [(Int, TxEntry Int)]
activeEntries [(Int, Time)]
retainedEntries' Word64
0
    | [(Int, Time)]
retainedEntries' <- [[(Int, Time)]]
smallerRetainedEntries
    ]
  where
    activeEntries :: [(Int, TxEntry Int)]
activeEntries =
      [ (SharedTxState Int Int -> TxKey -> Int
forall peeraddr txid.
HasCallStack =>
SharedTxState peeraddr txid -> TxKey -> txid
resolveTxKey SharedTxState Int Int
sharedState (Int -> TxKey
TxKey Int
k), TxEntry Int
txEntry)
      | (Int
k, TxEntry Int
txEntry) <- IntMap (TxEntry Int) -> [(Int, TxEntry Int)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
sharedState)
      ]
    retainedEntries :: [(Int, Time)]
retainedEntries =
      [ (SharedTxState Int Int -> TxKey -> Int
forall peeraddr txid.
HasCallStack =>
SharedTxState peeraddr txid -> TxKey -> txid
resolveTxKey SharedTxState Int Int
sharedState (Int -> TxKey
TxKey Int
k), Time
retainUntil)
      | (Int
k, Time
retainUntil) <- RetainedTxs -> [(Int, Time)]
retainedToList (SharedTxState Int Int -> RetainedTxs
forall peeraddr txid. SharedTxState peeraddr txid -> RetainedTxs
sharedRetainedTxs SharedTxState Int Int
sharedState)
      ]
    smallerActiveEntries :: [[(Int, TxEntry Int)]]
smallerActiveEntries =
      Int -> [[(Int, TxEntry Int)]] -> [[(Int, TxEntry Int)]]
forall a. Int -> [a] -> [a]
take Int
6
        [ [(Int, TxEntry Int)]
activeEntries'
        | [(Int, TxEntry Int)]
activeEntries' <- ((Int, TxEntry Int) -> [(Int, TxEntry Int)])
-> [(Int, TxEntry Int)] -> [[(Int, TxEntry Int)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([(Int, TxEntry Int)] -> (Int, TxEntry Int) -> [(Int, TxEntry Int)]
forall a b. a -> b -> a
const []) [(Int, TxEntry Int)]
activeEntries
        , [(Int, TxEntry Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, TxEntry Int)]
activeEntries' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [(Int, TxEntry Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, TxEntry Int)]
activeEntries
        ]
    smallerRetainedEntries :: [[(Int, Time)]]
smallerRetainedEntries =
      Int -> [[(Int, Time)]] -> [[(Int, Time)]]
forall a. Int -> [a] -> [a]
take Int
6
        [ [(Int, Time)]
retainedEntries'
        | [(Int, Time)]
retainedEntries' <- ((Int, Time) -> [(Int, Time)]) -> [(Int, Time)] -> [[(Int, Time)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([(Int, Time)] -> (Int, Time) -> [(Int, Time)]
forall a b. a -> b -> a
const []) [(Int, Time)]
retainedEntries
        , [(Int, Time)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Time)]
retainedEntries' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [(Int, Time)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Time)]
retainedEntries
        ]

-- Partition requested keys into a small number of contiguous request batches.
genRequestedTxBatches
  :: IntMap.IntMap SizeInBytes
  -> [TxKey]
  -> Gen (StrictSeq.StrictSeq RequestedTxBatch, SizeInBytes)
genRequestedTxBatches :: IntMap SizeInBytes
-> [TxKey] -> Gen (StrictSeq RequestedTxBatch, SizeInBytes)
genRequestedTxBatches IntMap SizeInBytes
_ [] =
  (StrictSeq RequestedTxBatch, SizeInBytes)
-> Gen (StrictSeq RequestedTxBatch, SizeInBytes)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StrictSeq RequestedTxBatch
forall a. StrictSeq a
StrictSeq.empty, SizeInBytes
0)
genRequestedTxBatches IntMap SizeInBytes
peerAvailableTxIds [TxKey]
requestedKeys = do
  batchCount <- (Int, Int) -> Gen Int
chooseInt (Int
1, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
3 ([TxKey] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxKey]
requestedKeys))
  batchLengths <- genPositivePartition (length requestedKeys) batchCount
  let batches =
        [ [TxKey] -> SizeInBytes -> RequestedTxBatch
mkRequestedTxBatch [TxKey]
keys ([SizeInBytes] -> SizeInBytes
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ TxKey -> SizeInBytes
lookupAvailableTxSize TxKey
key | TxKey
key <- [TxKey]
keys ])
        | [TxKey]
keys <- [Int] -> [TxKey] -> [[TxKey]]
forall a. [Int] -> [a] -> [[a]]
splitByLengths [Int]
batchLengths [TxKey]
requestedKeys
        ]
      peerRequestedTxsSize =
        [SizeInBytes] -> SizeInBytes
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ RequestedTxBatch -> SizeInBytes
requestedTxBatchSize RequestedTxBatch
batch | RequestedTxBatch
batch <- [RequestedTxBatch]
batches ]
  pure (StrictSeq.fromList batches, peerRequestedTxsSize)
  where
    lookupAvailableTxSize :: TxKey -> SizeInBytes
lookupAvailableTxSize TxKey
key =
      case Int -> IntMap SizeInBytes -> Maybe SizeInBytes
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (TxKey -> Int
unTxKey TxKey
key) IntMap SizeInBytes
peerAvailableTxIds of
        Just SizeInBytes
txSize -> SizeInBytes
txSize
        Maybe SizeInBytes
Nothing -> TestName -> SizeInBytes
forall a. HasCallStack => TestName -> a
error TestName
"TxLogic.genRequestedTxBatches: missing requested tx size"

-- Split a positive total into a fixed number of positive parts.
genPositivePartition :: Int -> Int -> Gen [Int]
genPositivePartition :: Int -> Int -> Gen [Int]
genPositivePartition Int
totalCount Int
1 =
  [Int] -> Gen [Int]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int
totalCount]
genPositivePartition Int
totalCount Int
parts = do
  n <- (Int, Int) -> Gen Int
chooseInt (Int
1, Int
totalCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
parts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  (n :) <$> genPositivePartition (totalCount - n) (parts - 1)

-- Split a list according to a list of chunk lengths.
splitByLengths :: [Int] -> [a] -> [[a]]
splitByLengths :: forall a. [Int] -> [a] -> [[a]]
splitByLengths [] [] = []
splitByLengths [] [a]
_ = []
splitByLengths (Int
n : [Int]
ns) [a]
xs =
  let ([a]
prefix, [a]
suffix) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs in
  [a]
prefix [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [Int] -> [a] -> [[a]]
forall a. [Int] -> [a] -> [[a]]
splitByLengths [Int]
ns [a]
suffix

-- Generate distinct positive ints from a bounded shuffled range.
genDistinctPositiveInts :: Int -> Gen [Int]
genDistinctPositiveInts :: Int -> Gen [Int]
genDistinctPositiveInts Int
count
  | Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [Int] -> Gen [Int]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  | Bool
otherwise = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
count ([Int] -> [Int]) -> Gen [Int] -> Gen [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> Gen [Int]
forall a. [a] -> Gen [a]
shuffle [Int
1 .. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
count (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5)]

-- Generate expiry times near the shared test reference time.
genSharedExpiryTime :: Gen Time
genSharedExpiryTime :: Gen Time
genSharedExpiryTime =
  DiffTime -> Time
Time (DiffTime -> Time) -> (Int -> DiffTime) -> Int -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Time) -> Gen Int -> Gen Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
chooseInt (Int
80, Int
120)

-- Generate a positive tx size
genPositiveSize :: Gen SizeInBytes
genPositiveSize :: Gen SizeInBytes
genPositiveSize =
  Int -> SizeInBytes
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> SizeInBytes) -> Gen Int -> Gen SizeInBytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
chooseInt (Int
1, Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ SizeInBytes -> Word32
getSizeInBytes SizeInBytes
max_TX_SIZE)

-- Generate a small test timestamp.
genSmallTime :: Gen Time
genSmallTime :: Gen Time
genSmallTime =
  DiffTime -> Time
Time (DiffTime -> Time) -> (Int -> DiffTime) -> Int -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Time) -> Gen Int -> Gen Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
chooseInt (Int
0, Int
1000)

-- Generate a small test generation counter.
genSmallWord64 :: Gen Word64
genSmallWord64 :: Gen Word64
genSmallWord64 =
  Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Gen Int -> Gen Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
chooseInt (Int
0, Int
1000)

-- Recover the fixture txid associated with an interned key.
txIdForKey :: TxKey -> TxId
txIdForKey :: TxKey -> Int
txIdForKey (TxKey Int
key) = Int
key Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

-- Fixed reference time used by deterministic test fixtures.
now :: Time
now :: Time
now = DiffTime -> Time
Time DiffTime
100

-- Convert a positive QuickCheck value into a bounded non-zero tx size.
mkSize :: Positive Int -> SizeInBytes
mkSize :: Positive Int -> SizeInBytes
mkSize (Positive Int
n) = Int -> SizeInBytes
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
65535) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

-- Render a count into a coarse bucket label for QuickCheck's 'tabulate'.
bucket :: Int -> String
bucket :: Int -> TestName
bucket Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = TestName
"0"
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1    = TestName
"1"
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
5    = TestName
"2-5"
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
10   = TestName
"6-10"
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
25   = TestName
"11-25"
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
100  = TestName
"26-100"
  | Bool
otherwise = TestName
"100+"

-- Build a valid test transaction with matching body and advertised size.
mkTx :: TxId -> SizeInBytes -> Tx TxId
mkTx :: Int -> SizeInBytes -> Tx Int
mkTx Int
txid SizeInBytes
txSize = Tx
  { getTxId :: Int
getTxId = Int
txid
  , getTxSize :: SizeInBytes
getTxSize = SizeInBytes
txSize
  , getTxAdvSize :: SizeInBytes
getTxAdvSize = SizeInBytes
txSize
  , getTxValid :: Bool
getTxValid = Bool
True
  , getTxParent :: Maybe Int
getTxParent = Maybe Int
forall a. Maybe a
Nothing
  }

-- Intern a list of txids into an otherwise empty shared state.
mkSharedState :: [TxId] -> SharedTxState PeerAddr TxId
mkSharedState :: [Int] -> SharedTxState Int Int
mkSharedState [Int]
txids = (Map Int TxKey, SharedTxState Int Int) -> SharedTxState Int Int
forall a b. (a, b) -> b
snd ([Int]
-> SharedTxState Int Int
-> (Map (RawTxId Int) TxKey, SharedTxState Int Int)
forall (f :: * -> *) txid peeraddr.
(Foldable f, HasRawTxId txid) =>
f txid
-> SharedTxState peeraddr txid
-> (Map (RawTxId txid) TxKey, SharedTxState peeraddr txid)
internTxIds [Int]
txids SharedTxState Int Int
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState)

-- Construct a requested batch together with its cached key set.
mkRequestedTxBatch :: [TxKey] -> SizeInBytes -> RequestedTxBatch
mkRequestedTxBatch :: [TxKey] -> SizeInBytes -> RequestedTxBatch
mkRequestedTxBatch [TxKey]
keys SizeInBytes
requestedTxBatchSize = RequestedTxBatch
  { requestedTxBatchSet :: IntSet
requestedTxBatchSet = [Int] -> IntSet
IntSet.fromList ((TxKey -> Int) -> [TxKey] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map TxKey -> Int
unTxKey [TxKey]
keys)
  , SizeInBytes
requestedTxBatchSize :: SizeInBytes
requestedTxBatchSize :: SizeInBytes
requestedTxBatchSize
  }

-- Look up an interned key and fail fast in test setup code.
lookupKeyOrFail :: TxId -> SharedTxState PeerAddr TxId -> TxKey
lookupKeyOrFail :: Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
st =
  case Int -> SharedTxState Int Int -> Maybe TxKey
forall txid peeraddr.
HasRawTxId txid =>
txid -> SharedTxState peeraddr txid -> Maybe TxKey
lookupTxKey Int
txid SharedTxState Int Int
st of
    Just TxKey
txKey -> TxKey
txKey
    Maybe TxKey
Nothing    -> TestName -> TxKey
forall a. HasCallStack => TestName -> a
error TestName
"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 -> SharedTxState Int Int -> TxEntry Int
lookupEntryOrFail (TxKey Int
k) SharedTxState Int Int
st =
  case Int -> IntMap (TxEntry Int) -> Maybe (TxEntry Int)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k (SharedTxState Int Int -> IntMap (TxEntry Int)
forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable SharedTxState Int Int
st) of
    Just TxEntry Int
txEntry -> TxEntry Int
txEntry
    Maybe (TxEntry Int)
Nothing      -> TestName -> TxEntry Int
forall a. HasCallStack => TestName -> a
error TestName
"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 :: TxDecisionPolicy
-> [(Int, SizeInBytes)]
-> SharedTxState Int Int
-> SharedTxState Int Int
seedRetainedTxids TxDecisionPolicy
policy [(Int, SizeInBytes)]
entries SharedTxState Int Int
st0 =
  SharedTxState Int Int
stInterned {
    sharedRetainedTxs =
      List.foldl' (\RetainedTxs
r Int
k -> Int -> Time -> RetainedTxs -> RetainedTxs
retainedInsertMax Int
k Time
retainUntil RetainedTxs
r)
                  (sharedRetainedTxs stInterned)
                  retainedKeys
  }
  where
    retainUntil :: Time
retainUntil         = DiffTime -> Time -> Time
addTime (TxDecisionPolicy -> DiffTime
bufferedTxsMinLifetime TxDecisionPolicy
policy) Time
now
    (Map (RawTxId Int) TxKey
_, SharedTxState Int Int
stInterned)     = [Int]
-> SharedTxState Int Int
-> (Map (RawTxId Int) TxKey, SharedTxState Int Int)
forall (f :: * -> *) txid peeraddr.
(Foldable f, HasRawTxId txid) =>
f txid
-> SharedTxState peeraddr txid
-> (Map (RawTxId txid) TxKey, SharedTxState peeraddr txid)
internTxIds (((Int, SizeInBytes) -> Int) -> [(Int, SizeInBytes)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, SizeInBytes) -> Int
forall a b. (a, b) -> a
fst [(Int, SizeInBytes)]
entries) SharedTxState Int Int
st0
    retainedKeys :: [Int]
retainedKeys        = [ TxKey -> Int
unTxKey (Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
stInterned)
                          | (Int
txid, SizeInBytes
_) <- [(Int, SizeInBytes)]
entries
                          ]

mkReceiveDuplicateFixture :: Int -> Int -> ReceiveDuplicateFixture
mkReceiveDuplicateFixture :: Int -> Int -> ReceiveDuplicateFixture
mkReceiveDuplicateFixture Int
existingAdvertisers Int
txidCount =
  ReceiveDuplicateFixture
    { rdfPeerAddr :: Int
rdfPeerAddr = Int
targetPeer
    , rdfRequestedTxIds :: NumTxIdsToReq
rdfRequestedTxIds = Int -> NumTxIdsToReq
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
txidCount
    , rdfTxidsAndSizes :: [(Int, SizeInBytes)]
rdfTxidsAndSizes = [(Int, SizeInBytes)]
txidsAndSizes
    , rdfPeerState :: PeerTxLocalState (Tx Int)
rdfPeerState =
        PeerTxLocalState (Tx Int)
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState {
          peerRequestedTxIds = fromIntegral txidCount
        }
    , rdfSharedState :: SharedTxState Int Int
rdfSharedState =
        [Int]
-> Int -> [Int] -> [(Int, SizeInBytes)] -> SharedTxState Int Int
mkActiveSharedState [Int]
allPeers Int
ownerPeer [Int]
existingPeers [(Int, SizeInBytes)]
txidsAndSizes
    }
  where
    ownerPeer :: Int
ownerPeer = Int
0
    targetPeer :: Int
targetPeer = Int
existingAdvertisers
    existingPeers :: [Int]
existingPeers = [Int
1 .. Int
existingAdvertisers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
    allPeers :: [Int]
allPeers = Int
ownerPeer Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int
targetPeer Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
existingPeers
    txidsAndSizes :: [(Int, SizeInBytes)]
txidsAndSizes = Int -> [(Int, SizeInBytes)]
mkTxidsAndSizes Int
txidCount

-- Prebuild an ack-only workload after all advertised txs have resolved into
-- retained entries.
mkResolvedAckFixture :: Int -> Int -> PeerActionFixture
mkResolvedAckFixture :: Int -> Int -> PeerActionFixture
mkResolvedAckFixture Int
advertiserCount Int
txidCount =
  PeerActionFixture
    { pafPeerAddr :: Int
pafPeerAddr = Int
targetPeer
    , pafPeerState :: PeerTxLocalState (Tx Int)
pafPeerState =
        PeerTxLocalState (Tx Int)
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState {
          peerUnacknowledgedTxIds = StrictSeq.fromList txKeys
        }
    , pafSharedState :: SharedTxState Int Int
pafSharedState = SharedTxState Int Int
sharedState
    }
  where
    ownerPeer :: Int
ownerPeer = Int
0
    targetPeer :: Int
targetPeer = Int
1
    otherPeers :: [Int]
otherPeers = [Int
2 .. Int
advertiserCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
    allPeers :: [Int]
allPeers = [Int
0 .. Int
advertiserCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
    txidsAndSizes :: [(Int, SizeInBytes)]
txidsAndSizes = Int -> [(Int, SizeInBytes)]
mkTxidsAndSizes Int
txidCount
    sharedState0 :: SharedTxState Int Int
sharedState0 =
      [Int]
-> Int -> [Int] -> [(Int, SizeInBytes)] -> SharedTxState Int Int
mkActiveSharedState [Int]
allPeers Int
ownerPeer (Int
targetPeer Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
otherPeers) [(Int, SizeInBytes)]
txidsAndSizes
    sharedState :: SharedTxState Int Int
sharedState = SharedTxState Int Int -> SharedTxState Int Int
retainAllActiveTxs SharedTxState Int Int
sharedState0
    txKeys :: [TxKey]
txKeys = ((Int, SizeInBytes) -> TxKey) -> [(Int, SizeInBytes)] -> [TxKey]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> SharedTxState Int Int -> TxKey
`lookupKeyOrFail` SharedTxState Int Int
sharedState0) (Int -> TxKey)
-> ((Int, SizeInBytes) -> Int) -> (Int, SizeInBytes) -> TxKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, SizeInBytes) -> Int
forall a b. (a, b) -> a
fst) [(Int, SizeInBytes)]
txidsAndSizes

-- | Compatibility alias for the previous benchmark helper name.
mkForeignRejectedFixture :: Int -> Int -> PeerActionFixture
mkForeignRejectedFixture :: Int -> Int -> PeerActionFixture
mkForeignRejectedFixture = Int -> Int -> PeerActionFixture
mkResolvedAckFixture

mkFanoutFixture :: Int -> Int -> FanoutFixture
mkFanoutFixture :: Int -> Int -> FanoutFixture
mkFanoutFixture Int
peerCount Int
txidCount =
  FanoutFixture
    { ffPeers :: [Int]
ffPeers = [Int]
peers
    , ffRequestedTxIds :: NumTxIdsToReq
ffRequestedTxIds = Int -> NumTxIdsToReq
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
txidCount
    , ffTxidsAndSizes :: [(Int, SizeInBytes)]
ffTxidsAndSizes = [(Int, SizeInBytes)]
txidsAndSizes
    , ffInitialSharedState :: SharedTxState Int Int
ffInitialSharedState =
        [Int]
-> Int -> [Int] -> [(Int, SizeInBytes)] -> SharedTxState Int Int
mkActiveSharedState [Int]
allPeers Int
ownerPeer [] [(Int, SizeInBytes)]
txidsAndSizes
    }
  where
    ownerPeer :: Int
ownerPeer = Int
0
    peers :: [Int]
peers = [Int
1 .. Int
peerCount]
    allPeers :: [Int]
allPeers = Int
ownerPeer Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
peers
    txidsAndSizes :: [(Int, SizeInBytes)]
txidsAndSizes = Int -> [(Int, SizeInBytes)]
mkTxidsAndSizes Int
txidCount

-- | Per-iteration timestamp for the benchmark loops below.
--
-- The offset (one picosecond per loop index) is far below any policy
-- timescale, so every iteration exercises the same code path, but it makes
-- each iteration's workload a distinct expression.  Without it GHC shares a
-- single result across all iterations (directly via a where-binding, or via
-- let-floating of a loop-invariant body), and the loop degenerates into
-- compute-once-then-'rnf'.
iterationTime :: Int -> Time
iterationTime :: Int -> Time
iterationTime Int
n = DiffTime -> Time -> Time
addTime (Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
1e-12) Time
now

runReceiveDuplicateLoop :: Int -> ReceiveDuplicateFixture -> IO ()
runReceiveDuplicateLoop :: Int -> ReceiveDuplicateFixture -> IO ()
runReceiveDuplicateLoop Int
iterations ReceiveDuplicateFixture
  { NumTxIdsToReq
rdfRequestedTxIds :: ReceiveDuplicateFixture -> NumTxIdsToReq
rdfRequestedTxIds :: NumTxIdsToReq
rdfRequestedTxIds
  , [(Int, SizeInBytes)]
rdfTxidsAndSizes :: ReceiveDuplicateFixture -> [(Int, SizeInBytes)]
rdfTxidsAndSizes :: [(Int, SizeInBytes)]
rdfTxidsAndSizes
  , PeerTxLocalState (Tx Int)
rdfPeerState :: ReceiveDuplicateFixture -> PeerTxLocalState (Tx Int)
rdfPeerState :: PeerTxLocalState (Tx Int)
rdfPeerState
  , SharedTxState Int Int
rdfSharedState :: ReceiveDuplicateFixture -> SharedTxState Int Int
rdfSharedState :: SharedTxState Int Int
rdfSharedState
  } =
    Int -> IO ()
go Int
iterations
  where
    go :: Int -> IO ()
go Int
0 = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go Int
n = do
      let result :: (PeerTxLocalState (Tx Int), PeerTxInFlight, SharedTxState Int Int)
result =
            (Int -> Bool)
-> Time
-> TxDecisionPolicy
-> NumTxIdsToReq
-> [(Int, SizeInBytes)]
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
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
              (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False)
              (Int -> Time
iterationTime Int
n)
              TxDecisionPolicy
defaultTxDecisionPolicy
              NumTxIdsToReq
rdfRequestedTxIds
              [(Int, SizeInBytes)]
rdfTxidsAndSizes
              PeerTxLocalState (Tx Int)
rdfPeerState
              PeerTxInFlight
emptyPeerTxInFlight
              SharedTxState Int Int
rdfSharedState
      _ <- () -> IO ()
forall a. a -> IO a
evaluate ((PeerTxLocalState (Tx Int), PeerTxInFlight, SharedTxState Int Int)
-> ()
forall a. NFData a => a -> ()
rnf (PeerTxLocalState (Tx Int), PeerTxInFlight, SharedTxState Int Int)
result)
      go (n - 1)

runPeerActionLoop :: Int -> PeerActionFixture -> IO ()
runPeerActionLoop :: Int -> PeerActionFixture -> IO ()
runPeerActionLoop Int
iterations PeerActionFixture
  { Int
pafPeerAddr :: PeerActionFixture -> Int
pafPeerAddr :: Int
pafPeerAddr
  , PeerTxLocalState (Tx Int)
pafPeerState :: PeerActionFixture -> PeerTxLocalState (Tx Int)
pafPeerState :: PeerTxLocalState (Tx Int)
pafPeerState
  , SharedTxState Int Int
pafSharedState :: PeerActionFixture -> SharedTxState Int Int
pafSharedState :: SharedTxState Int Int
pafSharedState
  } =
    Int -> IO ()
go Int
iterations
  where
    go :: Int -> IO ()
go Int
0 = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go Int
n = do
      let result :: (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight,
 SharedTxState Int Int)
result =
            Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction (Int -> Time
iterationTime Int
n) TxDecisionPolicy
defaultTxDecisionPolicy Int
pafPeerAddr
              PeerTxLocalState (Tx Int)
pafPeerState PeerTxInFlight
emptyPeerTxInFlight SharedTxState Int Int
pafSharedState
      _ <- () -> IO ()
forall a. a -> IO a
evaluate ((PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight,
 SharedTxState Int Int)
-> ()
forall a. NFData a => a -> ()
rnf (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight,
 SharedTxState Int Int)
result)
      go (n - 1)

runFanoutLoop :: Int -> FanoutFixture -> IO ()
runFanoutLoop :: Int -> FanoutFixture -> IO ()
runFanoutLoop Int
iterations FanoutFixture
  { [Int]
ffPeers :: FanoutFixture -> [Int]
ffPeers :: [Int]
ffPeers
  , NumTxIdsToReq
ffRequestedTxIds :: FanoutFixture -> NumTxIdsToReq
ffRequestedTxIds :: NumTxIdsToReq
ffRequestedTxIds
  , [(Int, SizeInBytes)]
ffTxidsAndSizes :: FanoutFixture -> [(Int, SizeInBytes)]
ffTxidsAndSizes :: [(Int, SizeInBytes)]
ffTxidsAndSizes
  , SharedTxState Int Int
ffInitialSharedState :: FanoutFixture -> SharedTxState Int Int
ffInitialSharedState :: SharedTxState Int Int
ffInitialSharedState
  } =
    Int -> IO ()
go Int
iterations
  where
    go :: Int -> IO ()
go Int
0 = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go Int
n = do
      _ <- () -> IO ()
forall a. a -> IO a
evaluate (([(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)],
 [(Int, PeerAction, PeerTxLocalState (Tx Int))],
 SharedTxState Int Int)
-> ()
forall a. NFData a => a -> ()
rnf (Time
-> ([(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)],
    [(Int, PeerAction, PeerTxLocalState (Tx Int))],
    SharedTxState Int Int)
roundResult (Int -> Time
iterationTime Int
n)))
      go (n - 1)

    roundResult :: Time
-> ([(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)],
    [(Int, PeerAction, PeerTxLocalState (Tx Int))],
    SharedTxState Int Int)
roundResult Time
iterNow =
      let (![(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)]
peerStatesRev, !SharedTxState Int Int
sharedStateAfterReceive) =
            (([(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)],
  SharedTxState Int Int)
 -> Int
 -> ([(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)],
     SharedTxState Int Int))
-> ([(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)],
    SharedTxState Int Int)
-> [Int]
-> ([(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)],
    SharedTxState Int Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (Time
-> ([(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)],
    SharedTxState Int Int)
-> Int
-> ([(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)],
    SharedTxState Int Int)
receiveOne Time
iterNow) ([], SharedTxState Int Int
ffInitialSharedState) [Int]
ffPeers
          !sharedStateResolved :: SharedTxState Int Int
sharedStateResolved = SharedTxState Int Int -> SharedTxState Int Int
retainAllActiveTxs SharedTxState Int Int
sharedStateAfterReceive
          (![(Int, PeerAction, PeerTxLocalState (Tx Int))]
ackResultsRev, !SharedTxState Int Int
sharedStateAfterAck) =
            (([(Int, PeerAction, PeerTxLocalState (Tx Int))],
  SharedTxState Int Int)
 -> (Int, PeerTxLocalState (Tx Int), PeerTxInFlight)
 -> ([(Int, PeerAction, PeerTxLocalState (Tx Int))],
     SharedTxState Int Int))
-> ([(Int, PeerAction, PeerTxLocalState (Tx Int))],
    SharedTxState Int Int)
-> [(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)]
-> ([(Int, PeerAction, PeerTxLocalState (Tx Int))],
    SharedTxState Int Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (Time
-> ([(Int, PeerAction, PeerTxLocalState (Tx Int))],
    SharedTxState Int Int)
-> (Int, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> ([(Int, PeerAction, PeerTxLocalState (Tx Int))],
    SharedTxState Int Int)
acknowledgeOne Time
iterNow) ([], SharedTxState Int Int
sharedStateResolved) ([(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)]
-> [(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)]
forall a. [a] -> [a]
reverse [(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)]
peerStatesRev)
      in ([(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)]
-> [(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)]
forall a. [a] -> [a]
reverse [(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)]
peerStatesRev, [(Int, PeerAction, PeerTxLocalState (Tx Int))]
-> [(Int, PeerAction, PeerTxLocalState (Tx Int))]
forall a. [a] -> [a]
reverse [(Int, PeerAction, PeerTxLocalState (Tx Int))]
ackResultsRev, SharedTxState Int Int
sharedStateAfterAck)

    receiveOne
      :: Time
      -> ([(PeerAddr, PeerTxLocalState (Tx TxId), PeerTxInFlight)], SharedTxState PeerAddr TxId)
      -> PeerAddr
      -> ([(PeerAddr, PeerTxLocalState (Tx TxId), PeerTxInFlight)], SharedTxState PeerAddr TxId)
    receiveOne :: Time
-> ([(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)],
    SharedTxState Int Int)
-> Int
-> ([(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)],
    SharedTxState Int Int)
receiveOne Time
iterNow (![(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)]
peerStatesAcc, !SharedTxState Int Int
sharedStateAcc) Int
peeraddr =
      let peerState0 :: PeerTxLocalState tx
peerState0 =
            PeerTxLocalState tx
forall tx. PeerTxLocalState tx
emptyPeerTxLocalState {
              peerRequestedTxIds = ffRequestedTxIds
            }
          !(PeerTxLocalState tx
peerState', PeerTxInFlight
peerInFlight', SharedTxState Int Int
sharedStateAcc') =
            (Int -> Bool)
-> Time
-> TxDecisionPolicy
-> NumTxIdsToReq
-> [(Int, SizeInBytes)]
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerTxLocalState tx, PeerTxInFlight, SharedTxState Int Int)
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
              (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False)
              Time
iterNow
              TxDecisionPolicy
defaultTxDecisionPolicy
              NumTxIdsToReq
ffRequestedTxIds
              [(Int, SizeInBytes)]
ffTxidsAndSizes
              PeerTxLocalState tx
forall tx. PeerTxLocalState tx
peerState0
              PeerTxInFlight
emptyPeerTxInFlight
              SharedTxState Int Int
sharedStateAcc
      in ((Int
peeraddr, PeerTxLocalState (Tx Int)
forall tx. PeerTxLocalState tx
peerState', PeerTxInFlight
peerInFlight') (Int, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> [(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)]
-> [(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)]
forall a. a -> [a] -> [a]
: [(Int, PeerTxLocalState (Tx Int), PeerTxInFlight)]
peerStatesAcc, SharedTxState Int Int
sharedStateAcc')

    acknowledgeOne
      :: Time
      -> ([(PeerAddr, PeerAction, PeerTxLocalState (Tx TxId))], SharedTxState PeerAddr TxId)
      -> (PeerAddr, PeerTxLocalState (Tx TxId), PeerTxInFlight)
      -> ([(PeerAddr, PeerAction, PeerTxLocalState (Tx TxId))], SharedTxState PeerAddr TxId)
    acknowledgeOne :: Time
-> ([(Int, PeerAction, PeerTxLocalState (Tx Int))],
    SharedTxState Int Int)
-> (Int, PeerTxLocalState (Tx Int), PeerTxInFlight)
-> ([(Int, PeerAction, PeerTxLocalState (Tx Int))],
    SharedTxState Int Int)
acknowledgeOne Time
iterNow (![(Int, PeerAction, PeerTxLocalState (Tx Int))]
ackResultsAcc, !SharedTxState Int Int
sharedStateAcc) (Int
peeraddr, PeerTxLocalState (Tx Int)
peerState0, PeerTxInFlight
peerInFlight0) =
      let !(PeerAction
peerAction, PeerTxLocalState (Tx Int)
peerState', PeerTxInFlight
_peerInFlight', SharedTxState Int Int
sharedStateAcc') =
            Time
-> TxDecisionPolicy
-> Int
-> PeerTxLocalState (Tx Int)
-> PeerTxInFlight
-> SharedTxState Int Int
-> (PeerAction, PeerTxLocalState (Tx Int), PeerTxInFlight,
    SharedTxState Int Int)
forall peeraddr tx txid.
Ord peeraddr =>
Time
-> TxDecisionPolicy
-> peeraddr
-> PeerTxLocalState tx
-> PeerTxInFlight
-> SharedTxState peeraddr txid
-> (PeerAction, PeerTxLocalState tx, PeerTxInFlight,
    SharedTxState peeraddr txid)
nextPeerAction Time
iterNow TxDecisionPolicy
defaultTxDecisionPolicy Int
peeraddr
              PeerTxLocalState (Tx Int)
peerState0 PeerTxInFlight
peerInFlight0 SharedTxState Int Int
sharedStateAcc
      in ( (Int
peeraddr, PeerAction
peerAction, PeerTxLocalState (Tx Int)
peerState') (Int, PeerAction, PeerTxLocalState (Tx Int))
-> [(Int, PeerAction, PeerTxLocalState (Tx Int))]
-> [(Int, PeerAction, PeerTxLocalState (Tx Int))]
forall a. a -> [a] -> [a]
: [(Int, PeerAction, PeerTxLocalState (Tx Int))]
ackResultsAcc
         , SharedTxState Int Int
sharedStateAcc'
         )

mkTxidsAndSizes :: Int -> [(TxId, SizeInBytes)]
mkTxidsAndSizes :: Int -> [(Int, SizeInBytes)]
mkTxidsAndSizes Int
count =
  [ (Int
txid, Int -> SizeInBytes
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
128 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
txid))
  | Int
txid <- [Int
1 .. Int
count]
  ]

mkActiveSharedState
  :: [PeerAddr]
  -> PeerAddr
  -> [PeerAddr]
  -> [(TxId, SizeInBytes)]
  -> SharedTxState PeerAddr TxId
mkActiveSharedState :: [Int]
-> Int -> [Int] -> [(Int, SizeInBytes)] -> SharedTxState Int Int
mkActiveSharedState [Int]
_allPeers Int
ownerPeer [Int]
_resolvedAdvertisers [(Int, SizeInBytes)]
txidsAndSizes =
  SharedTxState (ZonkAny 0) Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1 {
      sharedTxTable =
        IntMap.fromList
          [ (unTxKey txKey, mkEntry txKey)
          | (txid, _txSize) <- txidsAndSizes
          , let txKey = Int -> SharedTxState Int Int -> TxKey
lookupKeyOrFail Int
txid SharedTxState Int Int
forall {peeraddr}. SharedTxState peeraddr Int
sharedState1
          ]
    }
  where
    sharedState0 :: SharedTxState peeraddr txid
sharedState0 = SharedTxState peeraddr txid
forall peeraddr txid. SharedTxState peeraddr txid
emptySharedTxState
    sharedState1 :: SharedTxState peeraddr Int
sharedState1 = (Map Int TxKey, SharedTxState peeraddr Int)
-> SharedTxState peeraddr Int
forall a b. (a, b) -> b
snd ([Int]
-> SharedTxState peeraddr Int
-> (Map (RawTxId Int) TxKey, SharedTxState peeraddr Int)
forall (f :: * -> *) txid peeraddr.
(Foldable f, HasRawTxId txid) =>
f txid
-> SharedTxState peeraddr txid
-> (Map (RawTxId txid) TxKey, SharedTxState peeraddr txid)
internTxIds (((Int, SizeInBytes) -> Int) -> [(Int, SizeInBytes)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, SizeInBytes) -> Int
forall a b. (a, b) -> a
fst [(Int, SizeInBytes)]
txidsAndSizes) SharedTxState peeraddr Int
forall peeraddr txid. SharedTxState peeraddr txid
sharedState0)

    mkEntry :: p -> TxEntry Int
mkEntry p
_txKey = TxEntry
      { txLease :: TxLease Int
txLease = Int -> Time -> TxLease Int
forall peeraddr. peeraddr -> Time -> TxLease peeraddr
TxLeased Int
ownerPeer (DiffTime -> Time -> Time
addTime DiffTime
10 Time
now)
      , txAttempt :: Int
txAttempt = Int
1
      , txInSubmission :: Bool
txInSubmission = Bool
False
      , currentMaxInflightMultiplicity :: Int
currentMaxInflightMultiplicity =
          TxDecisionPolicy -> Int
txInflightMultiplicity TxDecisionPolicy
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 :: SharedTxState Int Int -> SharedTxState Int Int
retainAllActiveTxs st :: SharedTxState Int Int
st@SharedTxState { IntMap (TxEntry Int)
sharedTxTable :: forall peeraddr txid.
SharedTxState peeraddr txid -> IntMap (TxEntry peeraddr)
sharedTxTable :: IntMap (TxEntry Int)
sharedTxTable, RetainedTxs
sharedRetainedTxs :: forall peeraddr txid. SharedTxState peeraddr txid -> RetainedTxs
sharedRetainedTxs :: RetainedTxs
sharedRetainedTxs, Word64
sharedGeneration :: forall peeraddr txid. SharedTxState peeraddr txid -> Word64
sharedGeneration :: Word64
sharedGeneration } =
  SharedTxState Int Int
st {
      sharedTxTable = IntMap.empty,
      sharedRetainedTxs = IntMap.foldlWithKey' retainOne sharedRetainedTxs sharedTxTable,
      sharedGeneration = sharedGeneration + 1
    }
  where
    retainUntil :: Time
retainUntil = DiffTime -> Time -> Time
addTime (TxDecisionPolicy -> DiffTime
bufferedTxsMinLifetime TxDecisionPolicy
defaultTxDecisionPolicy) Time
now

    retainOne :: RetainedTxs -> Int -> p -> RetainedTxs
retainOne RetainedTxs
retainedAcc Int
k p
_ =
      Int -> Time -> RetainedTxs -> RetainedTxs
retainedInsertMax Int
k Time
retainUntil RetainedTxs
retainedAcc