{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Ouroboros.Network.TxSubmission.AppV2 (tests) where

import Prelude hiding (seq)

import NoThunks.Class

import Control.Concurrent.Class.MonadMVar.Strict
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadSay
import Control.Monad.Class.MonadST
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Monad.IOSim
import Control.Tracer (Tracer (..), contramap)

import Data.Bifoldable
import Data.ByteString.Lazy qualified as BSL
import Data.Foldable (traverse_)
import Data.Function (on)
import Data.Hashable
import Data.List (nubBy)
import Data.List qualified as List
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, isJust)
import Data.Monoid (Sum (..))
import Data.Set qualified as Set
import Data.Typeable (Typeable)
import System.Random (mkStdGen)

import Cardano.Network.NodeToNode (NodeToNodeVersion (..))

import Ouroboros.Network.Channel
import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM)
import Ouroboros.Network.Driver
import Ouroboros.Network.Protocol.TxSubmission2.Client
import Ouroboros.Network.Protocol.TxSubmission2.Codec
import Ouroboros.Network.Protocol.TxSubmission2.Server
import Ouroboros.Network.Protocol.TxSubmission2.Type
import Ouroboros.Network.TxSubmission.Inbound.V2 (txSubmissionInboundV2)
import Ouroboros.Network.TxSubmission.Inbound.V2.Policy
import Ouroboros.Network.TxSubmission.Inbound.V2.Registry
import Ouroboros.Network.TxSubmission.Inbound.V2.Types
import Ouroboros.Network.TxSubmission.Outbound
import Ouroboros.Network.Util.ShowProxy

import Test.Ouroboros.Network.TxSubmission.TxLogic hiding (tests)
import Test.Ouroboros.Network.TxSubmission.Types
import Test.Ouroboros.Network.Utils hiding (debugTracer)

import Test.QuickCheck
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)


tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"AppV2"
  [ TestName -> (TxSubmissionState -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"diffusion"     TxSubmissionState -> Property
prop_txSubmission_diffusion
  , TestName -> (TxSubmissionState -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"inflight"      TxSubmissionState -> Property
prop_txSubmission_inflight
  , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"SharedTxState" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSize Int
25
                                 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Int -> (TxSubmissionState -> Property) -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
25
                                 TxSubmissionState -> Property
prop_sharedTxStateInvariant
  ]

data TxSubmissionState =
  TxSubmissionState {
      TxSubmissionState
-> Map
     Int
     ([Tx Int], Maybe (Positive SmallDelay),
      Maybe (Positive SmallDelay))
peerMap :: Map Int ( [Tx Int]
                         , Maybe (Positive SmallDelay)
                         , Maybe (Positive SmallDelay)
                         -- ^ The delay must be smaller (<) than 5s, so that overall
                         -- delay is less than 10s, otherwise 'smallDelay' in
                         -- 'timeLimitsTxSubmission2' will kick in.
                         )
    , TxSubmissionState -> TxDecisionPolicy
decisionPolicy :: TxDecisionPolicy
  } deriving (Int -> TxSubmissionState -> ShowS
[TxSubmissionState] -> ShowS
TxSubmissionState -> TestName
(Int -> TxSubmissionState -> ShowS)
-> (TxSubmissionState -> TestName)
-> ([TxSubmissionState] -> ShowS)
-> Show TxSubmissionState
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TxSubmissionState -> ShowS
showsPrec :: Int -> TxSubmissionState -> ShowS
$cshow :: TxSubmissionState -> TestName
show :: TxSubmissionState -> TestName
$cshowList :: [TxSubmissionState] -> ShowS
showList :: [TxSubmissionState] -> ShowS
Show)

instance Arbitrary TxSubmissionState where
  arbitrary :: Gen TxSubmissionState
arbitrary = do
    ArbTxDecisionPolicy decisionPolicy <- Gen ArbTxDecisionPolicy
forall a. Arbitrary a => Gen a
arbitrary
    peersN <- choose (1, 10)
    txsN <- choose (1, 10)
    -- NOTE: using sortOn would forces tx-decision logic to download txs in the
    -- order of unacknowledgedTxIds.  This could be useful to get better
    -- properties when wrongly sized txs are present.
    txs <- divvy txsN . nubBy (on (==) getTxId) {- . List.sortOn getTxId -} <$> vectorOf (peersN * txsN) arbitrary
    peers <- vectorOf peersN arbitrary
    peersState <- zipWith (curry (\([Tx Int]
a, (Maybe (Positive SmallDelay)
b, Maybe (Positive SmallDelay)
c)) -> ([Tx Int]
a, Maybe (Positive SmallDelay)
b, Maybe (Positive SmallDelay)
c))) txs
              <$> vectorOf peersN arbitrary
    return TxSubmissionState  { peerMap = Map.fromList (zip peers peersState),
                                decisionPolicy
                              }
  shrink :: TxSubmissionState -> [TxSubmissionState]
shrink TxSubmissionState { Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
peerMap :: TxSubmissionState
-> Map
     Int
     ([Tx Int], Maybe (Positive SmallDelay),
      Maybe (Positive SmallDelay))
peerMap :: Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
peerMap, TxDecisionPolicy
decisionPolicy :: TxSubmissionState -> TxDecisionPolicy
decisionPolicy :: TxDecisionPolicy
decisionPolicy } =
    Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
-> TxDecisionPolicy -> TxSubmissionState
TxSubmissionState (Map
   Int
   ([Tx Int], Maybe (Positive SmallDelay),
    Maybe (Positive SmallDelay))
 -> TxDecisionPolicy -> TxSubmissionState)
-> [Map
      Int
      ([Tx Int], Maybe (Positive SmallDelay),
       Maybe (Positive SmallDelay))]
-> [TxDecisionPolicy -> TxSubmissionState]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
-> [Map
      Int
      ([Tx Int], Maybe (Positive SmallDelay),
       Maybe (Positive SmallDelay))]
forall k v.
(Ord k, Arbitrary k, Arbitrary v) =>
Map k v -> [Map k v]
shrinkMap1 Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
peerMap
                      [TxDecisionPolicy -> TxSubmissionState]
-> [TxDecisionPolicy] -> [TxSubmissionState]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [ TxDecisionPolicy
policy
                          | ArbTxDecisionPolicy TxDecisionPolicy
policy <- ArbTxDecisionPolicy -> [ArbTxDecisionPolicy]
forall a. Arbitrary a => a -> [a]
shrink (TxDecisionPolicy -> ArbTxDecisionPolicy
ArbTxDecisionPolicy TxDecisionPolicy
decisionPolicy)
                          ]
    where
      shrinkMap1 :: (Ord k, Arbitrary k, Arbitrary v) => Map k v -> [Map k v]
      shrinkMap1 :: forall k v.
(Ord k, Arbitrary k, Arbitrary v) =>
Map k v -> [Map k v]
shrinkMap1 Map k v
m
        | Map k v -> Int
forall k a. Map k a -> Int
Map.size Map k v
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 = [Map k v
m]
        | Bool
otherwise       = [k -> Map k v -> Map k v
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete k
k Map k v
m | k
k <- Map k v -> [k]
forall k a. Map k a -> [k]
Map.keys Map k v
m] [Map k v] -> [Map k v] -> [Map k v]
forall a. [a] -> [a] -> [a]
++ [Map k v]
singletonMaps
        where
          singletonMaps :: [Map k v]
singletonMaps = [k -> v -> Map k v
forall k a. k -> a -> Map k a
Map.singleton k
k v
v | (k
k, v
v) <- Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toList Map k v
m]


newtype TxStateTrace peeraddr txid =
    TxStateTrace (SharedTxState peeraddr txid (Tx txid))
type TxStateTraceType = TxStateTrace PeerAddr TxId


runTxSubmission
  :: forall m peeraddr txid.
     ( MonadAsync m
     , MonadDelay m
     , MonadFork  m
     , MonadMask  m
     , MonadMVar  m
     , MonadSay   m
     , MonadST    m
     , MonadLabelledSTM m
     , MonadTimer m
     , MonadThrow m
     , MonadThrow (STM m)
     , MonadMonotonicTime m
     , MonadTraceSTM m
     , Ord txid
     , Eq  txid
     , ShowProxy txid
     , NoThunks (Tx txid)
     , Typeable txid
     , Show peeraddr
     , Ord peeraddr
     , Hashable peeraddr
     , Typeable peeraddr

     , txid ~ Int
     )
  => Tracer m (String, TraceSendRecv (TxSubmission2 txid (Tx txid)))
  -> Tracer m (TraceTxLogic peeraddr txid (Tx txid))
  -> Map peeraddr ( [Tx txid]
                  , ControlMessageSTM m
                  , Maybe DiffTime
                  , Maybe DiffTime
                  )
  -> TxDecisionPolicy
  -> m ([Tx txid], [[Tx txid]])
  -- ^ inbound and outbound mempools
runTxSubmission :: forall (m :: * -> *) peeraddr txid.
(MonadAsync m, MonadDelay m, MonadFork m, MonadMask m, MonadMVar m,
 MonadSay m, MonadST m, MonadLabelledSTM m, MonadTimer m,
 MonadThrow m, MonadThrow (STM m), MonadMonotonicTime m,
 MonadTraceSTM m, Ord txid, Eq txid, ShowProxy txid,
 NoThunks (Tx txid), Typeable txid, Show peeraddr, Ord peeraddr,
 Hashable peeraddr, Typeable peeraddr, txid ~ Int) =>
Tracer m (TestName, TraceSendRecv (TxSubmission2 txid (Tx txid)))
-> Tracer m (TraceTxLogic peeraddr txid (Tx txid))
-> Map
     peeraddr
     ([Tx txid], ControlMessageSTM m, Maybe DiffTime, Maybe DiffTime)
-> TxDecisionPolicy
-> m ([Tx txid], [[Tx txid]])
runTxSubmission Tracer m (TestName, TraceSendRecv (TxSubmission2 txid (Tx txid)))
tracer Tracer m (TraceTxLogic peeraddr txid (Tx txid))
tracerTxLogic Map
  peeraddr
  ([Tx txid], ControlMessageSTM m, Maybe DiffTime, Maybe DiffTime)
st0 TxDecisionPolicy
txDecisionPolicy = do
    st <- (([Tx txid], ControlMessageSTM m, Maybe DiffTime, Maybe DiffTime)
 -> m (Mempool m (Tx txid), ControlMessageSTM m, Maybe DiffTime,
       Maybe DiffTime, Channel m ByteString, Channel m ByteString))
-> Map
     peeraddr
     ([Tx txid], ControlMessageSTM m, Maybe DiffTime, Maybe DiffTime)
-> m (Map
        peeraddr
        (Mempool m (Tx txid), ControlMessageSTM m, Maybe DiffTime,
         Maybe DiffTime, Channel m ByteString, Channel m ByteString))
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) -> Map peeraddr a -> f (Map peeraddr b)
traverse (\([Tx txid]
b, ControlMessageSTM m
c, Maybe DiffTime
d, Maybe DiffTime
e) -> do
        mempool <- [Tx txid] -> m (Mempool m (Tx txid))
forall (m :: * -> *) txid.
MonadSTM m =>
[Tx txid] -> m (Mempool m (Tx txid))
newMempool [Tx txid]
b
        (outChannel, inChannel) <- createConnectedChannels
        return (mempool, c, d, e, outChannel, inChannel)
        ) Map
  peeraddr
  ([Tx txid], ControlMessageSTM m, Maybe DiffTime, Maybe DiffTime)
st0
    inboundMempool <- emptyMempool
    let txRng = Int -> StdGen
mkStdGen Int
42 -- TODO

    txChannelsVar <- newMVar (TxChannels Map.empty)
    txMempoolSem <- newTxMempoolSem
    sharedTxStateVar <- newSharedTxStateVar txRng
    traceTVarIO sharedTxStateVar \Maybe (SharedTxState peeraddr txid (Tx txid))
_ -> TraceValue -> InspectMonadSTM m TraceValue
forall a. a -> InspectMonadSTM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TraceValue -> InspectMonadSTM m TraceValue)
-> (SharedTxState peeraddr txid (Tx txid) -> TraceValue)
-> SharedTxState peeraddr txid (Tx txid)
-> InspectMonadSTM m TraceValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxStateTrace peeraddr txid -> TraceValue
forall tr. Typeable tr => tr -> TraceValue
TraceDynamic (TxStateTrace peeraddr txid -> TraceValue)
-> (SharedTxState peeraddr txid (Tx txid)
    -> TxStateTrace peeraddr txid)
-> SharedTxState peeraddr txid (Tx txid)
-> TraceValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SharedTxState peeraddr txid (Tx txid) -> TxStateTrace peeraddr txid
forall peeraddr txid.
SharedTxState peeraddr txid (Tx txid) -> TxStateTrace peeraddr txid
TxStateTrace
    labelTVarIO sharedTxStateVar "shared-tx-state"

    withAsync (decisionLogicThreads tracerTxLogic sayTracer
                                    txDecisionPolicy txChannelsVar sharedTxStateVar) $ \Async m Void
a -> do
          -- Construct txSubmission outbound client
      let clients :: [m ((), Maybe ByteString)]
clients = (\(peeraddr
addr, (Mempool m (Tx txid)
mempool {- txs -}, ControlMessageSTM m
ctrlMsgSTM, Maybe DiffTime
outDelay, Maybe DiffTime
_, Channel m ByteString
outChannel, Channel m ByteString
_)) -> do
                      let client :: TxSubmissionClient txid (Tx txid) m ()
client = Tracer m (TraceTxSubmissionOutbound txid (Tx txid))
-> NumTxIdsToAck
-> TxSubmissionMempoolReader txid (Tx txid) Int m
-> NodeToNodeVersion
-> ControlMessageSTM m
-> TxSubmissionClient txid (Tx txid) m ()
forall version txid tx idx (m :: * -> *).
(Ord txid, Ord idx, MonadSTM m, MonadThrow m) =>
Tracer m (TraceTxSubmissionOutbound txid tx)
-> NumTxIdsToAck
-> TxSubmissionMempoolReader txid tx idx m
-> version
-> ControlMessageSTM m
-> TxSubmissionClient txid tx m ()
txSubmissionOutbound
                                     ((TraceTxSubmissionOutbound txid (Tx txid) -> m ())
-> Tracer m (TraceTxSubmissionOutbound txid (Tx txid))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceTxSubmissionOutbound txid (Tx txid) -> m ())
 -> Tracer m (TraceTxSubmissionOutbound txid (Tx txid)))
-> (TraceTxSubmissionOutbound txid (Tx txid) -> m ())
-> Tracer m (TraceTxSubmissionOutbound txid (Tx txid))
forall a b. (a -> b) -> a -> b
$ TestName -> m ()
forall (m :: * -> *). MonadSay m => TestName -> m ()
say (TestName -> m ())
-> (TraceTxSubmissionOutbound txid (Tx txid) -> TestName)
-> TraceTxSubmissionOutbound txid (Tx txid)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceTxSubmissionOutbound txid (Tx txid) -> TestName
forall a. Show a => a -> TestName
show)
                                     (Word16 -> NumTxIdsToAck
NumTxIdsToAck (Word16 -> NumTxIdsToAck) -> Word16 -> NumTxIdsToAck
forall a b. (a -> b) -> a -> b
$ NumTxIdsToReq -> Word16
getNumTxIdsToReq
                                       (NumTxIdsToReq -> Word16) -> NumTxIdsToReq -> Word16
forall a b. (a -> b) -> a -> b
$ TxDecisionPolicy -> NumTxIdsToReq
maxUnacknowledgedTxIds TxDecisionPolicy
txDecisionPolicy)
                                     (Mempool m (Tx txid)
-> TxSubmissionMempoolReader txid (Tx txid) Int m
forall txid (m :: * -> *).
(MonadSTM m, Eq txid, Show txid) =>
Mempool m (Tx txid)
-> TxSubmissionMempoolReader txid (Tx txid) Int m
getMempoolReader Mempool m (Tx txid)
mempool)
                                     (NodeToNodeVersion
forall a. Bounded a => a
maxBound :: NodeToNodeVersion)
                                     ControlMessageSTM m
ctrlMsgSTM
                      Tracer m (TraceSendRecv (TxSubmission2 txid (Tx txid)))
-> Codec
     (TxSubmission2 txid (Tx txid)) DeserialiseFailure m ByteString
-> ProtocolSizeLimits (TxSubmission2 txid (Tx txid)) ByteString
-> ProtocolTimeLimits (TxSubmission2 txid (Tx txid))
-> Channel m ByteString
-> Peer
     (TxSubmission2 txid (Tx txid)) 'AsClient 'NonPipelined 'StInit m ()
-> m ((), Maybe ByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
 MonadTimer m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeerWithLimits ((TestName
"OUTBOUND " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ peeraddr -> TestName
forall a. Show a => a -> TestName
show peeraddr
addr,) (TraceSendRecv (TxSubmission2 txid (Tx txid))
 -> (TestName, TraceSendRecv (TxSubmission2 txid (Tx txid))))
-> Tracer
     m (TestName, TraceSendRecv (TxSubmission2 txid (Tx txid)))
-> Tracer m (TraceSendRecv (TxSubmission2 txid (Tx txid)))
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer m (TestName, TraceSendRecv (TxSubmission2 txid (Tx txid)))
tracer)
                                        Codec
  (TxSubmission2 txid (Tx txid)) DeserialiseFailure m ByteString
Codec (TxSubmission2 Int (Tx Int)) DeserialiseFailure m ByteString
forall (m :: * -> *).
MonadST m =>
Codec (TxSubmission2 Int (Tx Int)) DeserialiseFailure m ByteString
txSubmissionCodec2
                                        ((ByteString -> Word)
-> ProtocolSizeLimits (TxSubmission2 txid (Tx txid)) ByteString
forall bytes txid tx.
(bytes -> Word) -> ProtocolSizeLimits (TxSubmission2 txid tx) bytes
byteLimitsTxSubmission2 (Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word) -> (ByteString -> Int64) -> ByteString -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BSL.length))
                                        ProtocolTimeLimits (TxSubmission2 txid (Tx txid))
forall txid tx. ProtocolTimeLimits (TxSubmission2 txid tx)
timeLimitsTxSubmission2
                                        ((Channel m ByteString -> Channel m ByteString)
-> (DiffTime -> Channel m ByteString -> Channel m ByteString)
-> Maybe DiffTime
-> Channel m ByteString
-> Channel m ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Channel m ByteString -> Channel m ByteString
forall a. a -> a
id DiffTime -> Channel m ByteString -> Channel m ByteString
forall (m :: * -> *) a.
MonadDelay m =>
DiffTime -> Channel m a -> Channel m a
delayChannel Maybe DiffTime
outDelay Channel m ByteString
outChannel)
                                        (TxSubmissionClient txid (Tx txid) m ()
-> Peer
     (TxSubmission2 txid (Tx txid)) 'AsClient 'NonPipelined 'StInit m ()
forall txid tx (m :: * -> *) a.
Monad m =>
TxSubmissionClient txid tx m a
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StInit m a
txSubmissionClientPeer TxSubmissionClient txid (Tx txid) m ()
client)
                    )
                   ((peeraddr,
  (Mempool m (Tx txid), ControlMessageSTM m, Maybe DiffTime,
   Maybe DiffTime, Channel m ByteString, Channel m ByteString))
 -> m ((), Maybe ByteString))
-> [(peeraddr,
     (Mempool m (Tx txid), ControlMessageSTM m, Maybe DiffTime,
      Maybe DiffTime, Channel m ByteString, Channel m ByteString))]
-> [m ((), Maybe ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map
  peeraddr
  (Mempool m (Tx txid), ControlMessageSTM m, Maybe DiffTime,
   Maybe DiffTime, Channel m ByteString, Channel m ByteString)
-> [(peeraddr,
     (Mempool m (Tx txid), ControlMessageSTM m, Maybe DiffTime,
      Maybe DiffTime, Channel m ByteString, Channel m ByteString))]
forall k a. Map k a -> [(k, a)]
Map.assocs Map
  peeraddr
  (Mempool m (Tx txid), ControlMessageSTM m, Maybe DiffTime,
   Maybe DiffTime, Channel m ByteString, Channel m ByteString)
st

          -- Construct txSubmission inbound server
          servers :: [m ((), Maybe ByteString)]
servers = (\(peeraddr
addr, (Mempool m (Tx txid)
_, ControlMessageSTM m
_, Maybe DiffTime
_, Maybe DiffTime
inDelay, Channel m ByteString
_, Channel m ByteString
inChannel)) ->
                       Tracer m (TraceTxLogic peeraddr txid (Tx txid))
-> StrictMVar m (TxChannels m peeraddr txid (Tx txid))
-> TxMempoolSem m
-> TxDecisionPolicy
-> SharedTxStateVar m peeraddr txid (Tx txid)
-> TxSubmissionMempoolReader txid (Tx txid) Int m
-> TxSubmissionMempoolWriter txid (Tx txid) Int m
-> (Tx txid -> SizeInBytes)
-> peeraddr
-> (PeerTxAPI m txid (Tx txid) -> m ((), Maybe ByteString))
-> m ((), Maybe ByteString)
forall tx peeraddr txid idx (m :: * -> *) a.
(MonadMask m, MonadMVar m, MonadSTM m, MonadMonotonicTime m,
 Ord txid, Show txid, Typeable txid, Ord peeraddr, Show peeraddr) =>
Tracer m (TraceTxLogic peeraddr txid tx)
-> TxChannelsVar m peeraddr txid tx
-> TxMempoolSem m
-> TxDecisionPolicy
-> SharedTxStateVar m peeraddr txid tx
-> TxSubmissionMempoolReader txid tx idx m
-> TxSubmissionMempoolWriter txid tx idx m
-> (tx -> SizeInBytes)
-> peeraddr
-> (PeerTxAPI m txid tx -> m a)
-> m a
withPeer Tracer m (TraceTxLogic peeraddr txid (Tx txid))
tracerTxLogic
                                StrictMVar m (TxChannels m peeraddr txid (Tx txid))
txChannelsVar
                                TxMempoolSem m
txMempoolSem
                                TxDecisionPolicy
txDecisionPolicy
                                SharedTxStateVar m peeraddr txid (Tx txid)
sharedTxStateVar
                                (Mempool m (Tx txid)
-> TxSubmissionMempoolReader txid (Tx txid) Int m
forall txid (m :: * -> *).
(MonadSTM m, Eq txid, Show txid) =>
Mempool m (Tx txid)
-> TxSubmissionMempoolReader txid (Tx txid) Int m
getMempoolReader Mempool m (Tx txid)
inboundMempool)
                                (Mempool m (Tx txid)
-> TxSubmissionMempoolWriter txid (Tx txid) Int m
forall txid (m :: * -> *).
(MonadSTM m, Ord txid, Eq txid) =>
Mempool m (Tx txid)
-> TxSubmissionMempoolWriter txid (Tx txid) Int m
getMempoolWriter Mempool m (Tx txid)
inboundMempool)
                                Tx txid -> SizeInBytes
forall txid. Tx txid -> SizeInBytes
getTxSize
                                peeraddr
addr ((PeerTxAPI m txid (Tx txid) -> m ((), Maybe ByteString))
 -> m ((), Maybe ByteString))
-> (PeerTxAPI m txid (Tx txid) -> m ((), Maybe ByteString))
-> m ((), Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \PeerTxAPI m txid (Tx txid)
api -> do
                                  let server :: TxSubmissionServerPipelined txid (Tx txid) m ()
server = Tracer m (TraceTxSubmissionInbound txid (Tx txid))
-> TxSubmissionInitDelay
-> TxSubmissionMempoolWriter txid (Tx txid) Int m
-> PeerTxAPI m txid (Tx txid)
-> TxSubmissionServerPipelined txid (Tx txid) m ()
forall txid tx idx (m :: * -> *).
(MonadDelay m, MonadThrow m, Ord txid) =>
Tracer m (TraceTxSubmissionInbound txid tx)
-> TxSubmissionInitDelay
-> TxSubmissionMempoolWriter txid tx idx m
-> PeerTxAPI m txid tx
-> TxSubmissionServerPipelined txid tx m ()
txSubmissionInboundV2 Tracer m (TraceTxSubmissionInbound txid (Tx txid))
forall a (m :: * -> *).
(MonadAsync m, MonadDelay m, MonadSay m, MonadMonotonicTime m,
 Show a) =>
Tracer m a
verboseTracer
                                                                     TxSubmissionInitDelay
NoTxSubmissionInitDelay
                                                                     (Mempool m (Tx txid)
-> TxSubmissionMempoolWriter txid (Tx txid) Int m
forall txid (m :: * -> *).
(MonadSTM m, Ord txid, Eq txid) =>
Mempool m (Tx txid)
-> TxSubmissionMempoolWriter txid (Tx txid) Int m
getMempoolWriter Mempool m (Tx txid)
inboundMempool)
                                                                     PeerTxAPI m txid (Tx txid)
api
                                  Tracer m (TraceSendRecv (TxSubmission2 Int (Tx Int)))
-> Codec
     (TxSubmission2 Int (Tx Int)) DeserialiseFailure m ByteString
-> ProtocolSizeLimits (TxSubmission2 Int (Tx Int)) ByteString
-> ProtocolTimeLimits (TxSubmission2 Int (Tx Int))
-> Channel m ByteString
-> PeerPipelined
     (TxSubmission2 Int (Tx Int)) 'AsServer 'StInit m ()
-> m ((), Maybe ByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadTimer m,
 MonadThrow (STM m), ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeerWithLimits
                                    ((TestName
"INBOUND " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ peeraddr -> TestName
forall a. Show a => a -> TestName
show peeraddr
addr,) (TraceSendRecv (TxSubmission2 Int (Tx Int))
 -> (TestName, TraceSendRecv (TxSubmission2 Int (Tx Int))))
-> Tracer m (TestName, TraceSendRecv (TxSubmission2 Int (Tx Int)))
-> Tracer m (TraceSendRecv (TxSubmission2 Int (Tx Int)))
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer m (TestName, TraceSendRecv (TxSubmission2 Int (Tx Int)))
forall a (m :: * -> *).
(MonadAsync m, MonadDelay m, MonadSay m, MonadMonotonicTime m,
 Show a) =>
Tracer m a
verboseTracer)
                                    Codec (TxSubmission2 Int (Tx Int)) DeserialiseFailure m ByteString
forall (m :: * -> *).
MonadST m =>
Codec (TxSubmission2 Int (Tx Int)) DeserialiseFailure m ByteString
txSubmissionCodec2
                                    ((ByteString -> Word)
-> ProtocolSizeLimits (TxSubmission2 Int (Tx Int)) ByteString
forall bytes txid tx.
(bytes -> Word) -> ProtocolSizeLimits (TxSubmission2 txid tx) bytes
byteLimitsTxSubmission2 (Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word) -> (ByteString -> Int64) -> ByteString -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BSL.length))
                                    ProtocolTimeLimits (TxSubmission2 Int (Tx Int))
forall txid tx. ProtocolTimeLimits (TxSubmission2 txid tx)
timeLimitsTxSubmission2
                                    ((Channel m ByteString -> Channel m ByteString)
-> (DiffTime -> Channel m ByteString -> Channel m ByteString)
-> Maybe DiffTime
-> Channel m ByteString
-> Channel m ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Channel m ByteString -> Channel m ByteString
forall a. a -> a
id DiffTime -> Channel m ByteString -> Channel m ByteString
forall (m :: * -> *) a.
MonadDelay m =>
DiffTime -> Channel m a -> Channel m a
delayChannel Maybe DiffTime
inDelay Channel m ByteString
inChannel)
                                    (TxSubmissionServerPipelined Int (Tx Int) m ()
-> PeerPipelined
     (TxSubmission2 Int (Tx Int)) 'AsServer 'StInit m ()
forall txid tx (m :: * -> *) a.
Functor m =>
TxSubmissionServerPipelined txid tx m a
-> ServerPipelined (TxSubmission2 txid tx) 'StInit m a
txSubmissionServerPeerPipelined TxSubmissionServerPipelined txid (Tx txid) m ()
TxSubmissionServerPipelined Int (Tx Int) m ()
server)
                    ) ((peeraddr,
  (Mempool m (Tx txid), ControlMessageSTM m, Maybe DiffTime,
   Maybe DiffTime, Channel m ByteString, Channel m ByteString))
 -> m ((), Maybe ByteString))
-> [(peeraddr,
     (Mempool m (Tx txid), ControlMessageSTM m, Maybe DiffTime,
      Maybe DiffTime, Channel m ByteString, Channel m ByteString))]
-> [m ((), Maybe ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map
  peeraddr
  (Mempool m (Tx txid), ControlMessageSTM m, Maybe DiffTime,
   Maybe DiffTime, Channel m ByteString, Channel m ByteString)
-> [(peeraddr,
     (Mempool m (Tx txid), ControlMessageSTM m, Maybe DiffTime,
      Maybe DiffTime, Channel m ByteString, Channel m ByteString))]
forall k a. Map k a -> [(k, a)]
Map.assocs Map
  peeraddr
  (Mempool m (Tx txid), ControlMessageSTM m, Maybe DiffTime,
   Maybe DiffTime, Channel m ByteString, Channel m ByteString)
st

      -- Run clients and servers
      [(m ((), Maybe ByteString), m ((), Maybe ByteString))]
-> ([(Async m ((), Maybe ByteString),
      Async m ((), Maybe ByteString))]
    -> m ([Tx txid], [[Tx txid]]))
-> m ([Tx txid], [[Tx txid]])
forall a b.
MonadAsync m =>
[(m a, m a)] -> ([(Async m a, Async m a)] -> m b) -> m b
withAsyncAll ([m ((), Maybe ByteString)]
-> [m ((), Maybe ByteString)]
-> [(m ((), Maybe ByteString), m ((), Maybe ByteString))]
forall a b. [a] -> [b] -> [(a, b)]
zip [m ((), Maybe ByteString)]
clients [m ((), Maybe ByteString)]
servers) (([(Async m ((), Maybe ByteString),
    Async m ((), Maybe ByteString))]
  -> m ([Tx txid], [[Tx txid]]))
 -> m ([Tx txid], [[Tx txid]]))
-> ([(Async m ((), Maybe ByteString),
      Async m ((), Maybe ByteString))]
    -> m ([Tx txid], [[Tx txid]]))
-> m ([Tx txid], [[Tx txid]])
forall a b. (a -> b) -> a -> b
$ \[(Async m ((), Maybe ByteString), Async m ((), Maybe ByteString))]
as -> do
        _ <- [(Async m ((), Maybe ByteString), Async m ((), Maybe ByteString))]
-> m [Either SomeException ((), Maybe ByteString)]
forall x. [(Async m x, Async m x)] -> m [Either SomeException x]
waitAllServers [(Async m ((), Maybe ByteString), Async m ((), Maybe ByteString))]
as
        -- cancel decision logic thread
        cancel a

        inmp <- readMempool inboundMempool
        let outmp = (([Tx txid], ControlMessageSTM m, Maybe DiffTime, Maybe DiffTime)
 -> [Tx txid])
-> [([Tx txid], ControlMessageSTM m, Maybe DiffTime,
     Maybe DiffTime)]
-> [[Tx txid]]
forall a b. (a -> b) -> [a] -> [b]
map (\([Tx txid]
txs, ControlMessageSTM m
_, Maybe DiffTime
_, Maybe DiffTime
_) -> [Tx txid]
txs)
                  ([([Tx txid], ControlMessageSTM m, Maybe DiffTime, Maybe DiffTime)]
 -> [[Tx txid]])
-> [([Tx txid], ControlMessageSTM m, Maybe DiffTime,
     Maybe DiffTime)]
-> [[Tx txid]]
forall a b. (a -> b) -> a -> b
$ Map
  peeraddr
  ([Tx txid], ControlMessageSTM m, Maybe DiffTime, Maybe DiffTime)
-> [([Tx txid], ControlMessageSTM m, Maybe DiffTime,
     Maybe DiffTime)]
forall k a. Map k a -> [a]
Map.elems Map
  peeraddr
  ([Tx txid], ControlMessageSTM m, Maybe DiffTime, Maybe DiffTime)
st0

        return (inmp, outmp)
  where
    waitAllServers :: [(Async m x, Async m x)] -> m [Either SomeException x]
    waitAllServers :: forall x. [(Async m x, Async m x)] -> m [Either SomeException x]
waitAllServers [] = [Either SomeException x] -> m [Either SomeException x]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    waitAllServers ((Async m x
client, Async m x
server):[(Async m x, Async m x)]
as) = do
      r <- Async m x -> m (Either SomeException x)
forall a. Async m a -> m (Either SomeException a)
forall (m :: * -> *) a.
MonadAsync m =>
Async m a -> m (Either SomeException a)
waitCatch Async m x
server
      -- cancel client as soon as the server exits
      cancel client
      rs <- waitAllServers as
      return (r : rs)

    withAsyncAll :: MonadAsync m
                 => [(m a, m a)]
                 -> ([(Async m a, Async m a)] -> m b)
                 -> m b
    withAsyncAll :: forall a b.
MonadAsync m =>
[(m a, m a)] -> ([(Async m a, Async m a)] -> m b) -> m b
withAsyncAll [(m a, m a)]
xs0 [(Async m a, Async m a)] -> m b
action = [(Async m a, Async m a)] -> [(m a, m a)] -> m b
go [] [(m a, m a)]
xs0
      where
        go :: [(Async m a, Async m a)] -> [(m a, m a)] -> m b
go [(Async m a, Async m a)]
as []         = [(Async m a, Async m a)] -> m b
action ([(Async m a, Async m a)] -> [(Async m a, Async m a)]
forall a. [a] -> [a]
reverse [(Async m a, Async m a)]
as)
        go [(Async m a, Async m a)]
as ((m a
x,m a
y):[(m a, m a)]
xs) = m a -> (Async m a -> m b) -> m b
forall a b. m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync m a
x (\Async m a
a -> m a -> (Async m a -> m b) -> m b
forall a b. m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync m a
y (\Async m a
b -> [(Async m a, Async m a)] -> [(m a, m a)] -> m b
go ((Async m a
a, Async m a
b)(Async m a, Async m a)
-> [(Async m a, Async m a)] -> [(Async m a, Async m a)]
forall a. a -> [a] -> [a]
:[(Async m a, Async m a)]
as) [(m a, m a)]
xs))


txSubmissionSimulation :: forall s . TxSubmissionState
                       -> IOSim s ([Tx Int], [[Tx Int]])
                       -- ^ inbound & outbound mempools
txSubmissionSimulation :: forall s. TxSubmissionState -> IOSim s ([Tx Int], [[Tx Int]])
txSubmissionSimulation (TxSubmissionState Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
state TxDecisionPolicy
txDecisionPolicy) = do
  state' <- (([Tx Int], Maybe (Positive SmallDelay),
  Maybe (Positive SmallDelay))
 -> IOSim
      s
      ([Tx Int], StrictTVar (IOSim s) ControlMessage, Maybe DiffTime,
       Maybe DiffTime))
-> Map
     Int
     ([Tx Int], Maybe (Positive SmallDelay),
      Maybe (Positive SmallDelay))
-> IOSim
     s
     (Map
        Int
        ([Tx Int], StrictTVar (IOSim s) ControlMessage, Maybe DiffTime,
         Maybe DiffTime))
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) -> Map Int a -> f (Map Int b)
traverse (\([Tx Int]
txs, Maybe (Positive SmallDelay)
mbOutDelay, Maybe (Positive SmallDelay)
mbInDelay) -> do
                      let mbOutDelayTime :: Maybe DiffTime
mbOutDelayTime = SmallDelay -> DiffTime
getSmallDelay (SmallDelay -> DiffTime)
-> (Positive SmallDelay -> SmallDelay)
-> Positive SmallDelay
-> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive SmallDelay -> SmallDelay
forall a. Positive a -> a
getPositive (Positive SmallDelay -> DiffTime)
-> Maybe (Positive SmallDelay) -> Maybe DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Positive SmallDelay)
mbOutDelay
                          mbInDelayTime :: Maybe DiffTime
mbInDelayTime  = SmallDelay -> DiffTime
getSmallDelay (SmallDelay -> DiffTime)
-> (Positive SmallDelay -> SmallDelay)
-> Positive SmallDelay
-> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive SmallDelay -> SmallDelay
forall a. Positive a -> a
getPositive (Positive SmallDelay -> DiffTime)
-> Maybe (Positive SmallDelay) -> Maybe DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Positive SmallDelay)
mbInDelay
                      controlMessageVar <- ControlMessage -> IOSim s (StrictTVar (IOSim s) ControlMessage)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO ControlMessage
Continue
                      return ( txs
                             , controlMessageVar
                             , mbOutDelayTime
                             , mbInDelayTime
                             )
                    )
                    Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
state

  state'' <- traverse (\([Tx Int]
txs, StrictTVar (IOSim s) ControlMessage
var, Maybe DiffTime
mbOutDelay, Maybe DiffTime
mbInDelay) -> do
                       ([Tx Int], STM s ControlMessage, Maybe DiffTime, Maybe DiffTime)
-> IOSim
     s ([Tx Int], STM s ControlMessage, Maybe DiffTime, Maybe DiffTime)
forall a. a -> IOSim s a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [Tx Int]
txs
                              , StrictTVar (IOSim s) ControlMessage -> STM (IOSim s) ControlMessage
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar (IOSim s) ControlMessage
var
                              , Maybe DiffTime
mbOutDelay
                              , Maybe DiffTime
mbInDelay
                              )
                    )
                    state'

  let simDelayTime = (DiffTime
 -> ([Tx Int], STM s ControlMessage, Maybe DiffTime, Maybe DiffTime)
 -> DiffTime)
-> DiffTime
-> Map
     Int
     ([Tx Int], STM s ControlMessage, Maybe DiffTime, Maybe DiffTime)
-> DiffTime
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' (\DiffTime
m ([Tx Int]
txs, STM s ControlMessage
_, Maybe DiffTime
mbInDelay, Maybe DiffTime
mbOutDelay) ->
                                  DiffTime -> DiffTime -> DiffTime
forall a. Ord a => a -> a -> a
max DiffTime
m ( DiffTime -> Maybe DiffTime -> DiffTime
forall a. a -> Maybe a -> a
fromMaybe DiffTime
1 (DiffTime -> DiffTime -> DiffTime
forall a. Ord a => a -> a -> a
max (DiffTime -> DiffTime -> DiffTime)
-> Maybe DiffTime -> Maybe (DiffTime -> DiffTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe DiffTime
mbInDelay Maybe (DiffTime -> DiffTime) -> Maybe DiffTime -> Maybe DiffTime
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe DiffTime
mbOutDelay)
                                        DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* Int -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac ([Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
txs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4)
                                        )
                                )
                                DiffTime
0
                                Map
  Int
  ([Tx Int], STM s ControlMessage, Maybe DiffTime, Maybe DiffTime)
state''
      controlMessageVars = (\([Tx Int]
_, StrictTVar (IOSim s) ControlMessage
x, Maybe DiffTime
_, Maybe DiffTime
_) -> StrictTVar (IOSim s) ControlMessage
x)
                        (([Tx Int], StrictTVar (IOSim s) ControlMessage, Maybe DiffTime,
  Maybe DiffTime)
 -> StrictTVar (IOSim s) ControlMessage)
-> [([Tx Int], StrictTVar (IOSim s) ControlMessage, Maybe DiffTime,
     Maybe DiffTime)]
-> [StrictTVar (IOSim s) ControlMessage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map
  Int
  ([Tx Int], StrictTVar (IOSim s) ControlMessage, Maybe DiffTime,
   Maybe DiffTime)
-> [([Tx Int], StrictTVar (IOSim s) ControlMessage, Maybe DiffTime,
     Maybe DiffTime)]
forall k a. Map k a -> [a]
Map.elems Map
  Int
  ([Tx Int], StrictTVar (IOSim s) ControlMessage, Maybe DiffTime,
   Maybe DiffTime)
state'

  withAsync
    (do threadDelay (simDelayTime + 1000)
        atomically (traverse_ (`writeTVar` Terminate) controlMessageVars)
    ) \Async (IOSim s) ()
_ -> do
      let tracer :: forall a. (Show a, Typeable a) => Tracer (IOSim s) a
          tracer :: forall a. (Show a, Typeable a) => Tracer (IOSim s) a
tracer = Tracer (IOSim s) a
forall a (m :: * -> *).
(MonadAsync m, MonadDelay m, MonadSay m, MonadMonotonicTime m,
 Show a) =>
Tracer m a
verboseTracer
                Tracer (IOSim s) a -> Tracer (IOSim s) a -> Tracer (IOSim s) a
forall a. Semigroup a => a -> a -> a
<> Tracer (IOSim s) a
forall a s. Show a => Tracer (IOSim s) a
debugTracer
                Tracer (IOSim s) a -> Tracer (IOSim s) a -> Tracer (IOSim s) a
forall a. Semigroup a => a -> a -> a
<> (a -> IOSim s ()) -> Tracer (IOSim s) a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer a -> IOSim s ()
forall a s. Typeable a => a -> IOSim s ()
traceM
      Tracer
  (IOSim s) (TestName, TraceSendRecv (TxSubmission2 Int (Tx Int)))
-> Tracer (IOSim s) (TraceTxLogic Int Int (Tx Int))
-> Map
     Int
     ([Tx Int], STM (IOSim s) ControlMessage, Maybe DiffTime,
      Maybe DiffTime)
-> TxDecisionPolicy
-> IOSim s ([Tx Int], [[Tx Int]])
forall (m :: * -> *) peeraddr txid.
(MonadAsync m, MonadDelay m, MonadFork m, MonadMask m, MonadMVar m,
 MonadSay m, MonadST m, MonadLabelledSTM m, MonadTimer m,
 MonadThrow m, MonadThrow (STM m), MonadMonotonicTime m,
 MonadTraceSTM m, Ord txid, Eq txid, ShowProxy txid,
 NoThunks (Tx txid), Typeable txid, Show peeraddr, Ord peeraddr,
 Hashable peeraddr, Typeable peeraddr, txid ~ Int) =>
Tracer m (TestName, TraceSendRecv (TxSubmission2 txid (Tx txid)))
-> Tracer m (TraceTxLogic peeraddr txid (Tx txid))
-> Map
     peeraddr
     ([Tx txid], ControlMessageSTM m, Maybe DiffTime, Maybe DiffTime)
-> TxDecisionPolicy
-> m ([Tx txid], [[Tx txid]])
runTxSubmission Tracer
  (IOSim s) (TestName, TraceSendRecv (TxSubmission2 Int (Tx Int)))
forall a. (Show a, Typeable a) => Tracer (IOSim s) a
tracer Tracer (IOSim s) (TraceTxLogic Int Int (Tx Int))
forall a. (Show a, Typeable a) => Tracer (IOSim s) a
tracer Map
  Int
  ([Tx Int], STM (IOSim s) ControlMessage, Maybe DiffTime,
   Maybe DiffTime)
Map
  Int
  ([Tx Int], STM s ControlMessage, Maybe DiffTime, Maybe DiffTime)
state'' TxDecisionPolicy
txDecisionPolicy

filterValidTxs :: [Tx txid] -> [Tx txid]
filterValidTxs :: forall txid. [Tx txid] -> [Tx txid]
filterValidTxs
  = (Tx txid -> Bool) -> [Tx txid] -> [Tx txid]
forall a. (a -> Bool) -> [a] -> [a]
filter Tx txid -> Bool
forall txid. Tx txid -> Bool
getTxValid
  ([Tx txid] -> [Tx txid])
-> ([Tx txid] -> [Tx txid]) -> [Tx txid] -> [Tx txid]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx txid -> Bool) -> [Tx txid] -> [Tx txid]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Tx{SizeInBytes
getTxSize :: forall txid. Tx txid -> SizeInBytes
getTxSize :: SizeInBytes
getTxSize, SizeInBytes
getTxAdvSize :: SizeInBytes
getTxAdvSize :: forall txid. Tx txid -> SizeInBytes
getTxAdvSize} -> SizeInBytes
getTxSize SizeInBytes -> SizeInBytes -> Bool
forall a. Eq a => a -> a -> Bool
== SizeInBytes
getTxAdvSize)

-- | Tests overall tx submission semantics. The properties checked in this
-- property test are the same as for tx submission v1. We need this to know we
-- didn't regress.
--
prop_txSubmission_diffusion :: TxSubmissionState -> Property
prop_txSubmission_diffusion :: TxSubmissionState -> Property
prop_txSubmission_diffusion st :: TxSubmissionState
st@(TxSubmissionState Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
peers TxDecisionPolicy
_) =
    let tr :: SimTrace ([Tx Int], [[Tx Int]])
tr = (forall s. IOSim s ([Tx Int], [[Tx Int]]))
-> SimTrace ([Tx Int], [[Tx Int]])
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace (TxSubmissionState -> IOSim s ([Tx Int], [[Tx Int]])
forall s. TxSubmissionState -> IOSim s ([Tx Int], [[Tx Int]])
txSubmissionSimulation TxSubmissionState
st)
        numPeersWithWronglySizedTx :: Int
        numPeersWithWronglySizedTx :: Int
numPeersWithWronglySizedTx =
          (([Tx Int], Maybe (Positive SmallDelay),
  Maybe (Positive SmallDelay))
 -> Int -> Int)
-> Int
-> Map
     Int
     ([Tx Int], Maybe (Positive SmallDelay),
      Maybe (Positive SmallDelay))
-> Int
forall a b. (a -> b -> b) -> b -> Map Int a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
            (\([Tx Int]
txs, Maybe (Positive SmallDelay)
_, Maybe (Positive SmallDelay)
_) Int
r ->
              case (Tx Int -> Bool) -> [Tx Int] -> Maybe (Tx Int)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\Tx Int
tx -> Tx Int -> SizeInBytes
forall txid. Tx txid -> SizeInBytes
getTxSize Tx Int
tx SizeInBytes -> SizeInBytes -> Bool
forall a. Eq a => a -> a -> Bool
/= Tx Int -> SizeInBytes
forall txid. Tx txid -> SizeInBytes
getTxAdvSize Tx Int
tx) [Tx Int]
txs of
                Just {} -> Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                Maybe (Tx Int)
Nothing -> Int
r
            ) Int
0 Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
peers
    in
        TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
label (TestName
"number of peers: " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Int -> TestName
renderRanges Int
3 (Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
-> Int
forall k a. Map k a -> Int
Map.size Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
peers))
      (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
label (TestName
"number of txs: "
              TestName -> ShowS
forall a. [a] -> [a] -> [a]
++
              Int -> Int -> TestName
renderRanges Int
10
                ( Set Int -> Int
forall a. Set a -> Int
Set.size
                (Set Int -> Int)
-> ([([Tx Int], Maybe (Positive SmallDelay),
      Maybe (Positive SmallDelay))]
    -> Set Int)
-> [([Tx Int], Maybe (Positive SmallDelay),
     Maybe (Positive SmallDelay))]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Tx Int], Maybe (Positive SmallDelay),
  Maybe (Positive SmallDelay))
 -> Set Int)
-> [([Tx Int], Maybe (Positive SmallDelay),
     Maybe (Positive SmallDelay))]
-> Set Int
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ([Int] -> Set Int)
-> (([Tx Int], Maybe (Positive SmallDelay),
     Maybe (Positive SmallDelay))
    -> [Int])
-> ([Tx Int], Maybe (Positive SmallDelay),
    Maybe (Positive SmallDelay))
-> Set Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\([Tx Int]
txs, Maybe (Positive SmallDelay)
_, Maybe (Positive SmallDelay)
_) -> Tx Int -> Int
forall txid. Tx txid -> txid
getTxId (Tx Int -> Int) -> [Tx Int] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx Int]
txs))
                ([([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))]
 -> Int)
-> [([Tx Int], Maybe (Positive SmallDelay),
     Maybe (Positive SmallDelay))]
-> Int
forall a b. (a -> b) -> a -> b
$ Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
-> [([Tx Int], Maybe (Positive SmallDelay),
     Maybe (Positive SmallDelay))]
forall k a. Map k a -> [a]
Map.elems Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
peers
                ))
      (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
label (TestName
"number of peers with wrongly sized tx: "
             TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
numPeersWithWronglySizedTx)
      (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ case Bool
-> SimTrace ([Tx Int], [[Tx Int]])
-> Either Failure ([Tx Int], [[Tx Int]])
forall a. Bool -> SimTrace a -> Either Failure a
traceResult Bool
True SimTrace ([Tx Int], [[Tx Int]])
tr of
         Left Failure
e ->
             TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (Failure -> TestName
forall a. Show a => a -> TestName
show Failure
e)
           (Property -> Property) -> (Bool -> Property) -> Bool -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (SimTrace ([Tx Int], [[Tx Int]]) -> TestName
forall a. Show a => SimTrace a -> TestName
ppTrace SimTrace ([Tx Int], [[Tx Int]])
tr)
           (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ Bool
False
         Right ([Tx Int]
inmp, [[Tx Int]]
outmps) ->
             TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (SimTrace ([Tx Int], [[Tx Int]]) -> TestName
forall a. Show a => SimTrace a -> TestName
ppTrace SimTrace ([Tx Int], [[Tx Int]])
tr)
           (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Tx Int] -> [Tx Int] -> Property
validate [Tx Int]
inmp ([Tx Int] -> Property) -> [[Tx Int]] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
`map` [[Tx Int]]
outmps)
  where
    validate :: [Tx Int] -- the inbound mempool
             -> [Tx Int] -- one of the outbound mempools
             -> Property
    validate :: [Tx Int] -> [Tx Int] -> Property
validate [Tx Int]
inmp [Tx Int]
outmp =
       let outUniqueTxIds :: [Tx Int]
outUniqueTxIds = (Tx Int -> Tx Int -> Bool) -> [Tx Int] -> [Tx Int]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy ((Int -> Int -> Bool) -> (Tx Int -> Int) -> Tx Int -> Tx Int -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) Tx Int -> Int
forall txid. Tx txid -> txid
getTxId) [Tx Int]
outmp
           outValidTxs :: [Tx Int]
outValidTxs    = [Tx Int] -> [Tx Int]
forall txid. [Tx txid] -> [Tx txid]
filterValidTxs [Tx Int]
outmp
       in
       case ( [Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
outUniqueTxIds Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
outmp
            , [Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
outValidTxs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
outmp
            ) of
         x :: (Bool, Bool)
x@(Bool
True, Bool
True) ->
           -- If we are presented with a stream of unique txids for valid
           -- transactions the inbound transactions should match the outbound
           -- transactions exactly.
             TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample ((Bool, Bool) -> TestName
forall a. Show a => a -> TestName
show (Bool, Bool)
x)
           (Property -> Property) -> (Bool -> Property) -> Bool -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample ([Tx Int] -> TestName
forall a. Show a => a -> TestName
show [Tx Int]
inmp)
           (Property -> Property) -> (Bool -> Property) -> Bool -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample ([Tx Int] -> TestName
forall a. Show a => a -> TestName
show [Tx Int]
outmp)
           (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ [Tx Int] -> [Tx Int] -> Bool
forall tx. Eq tx => [tx] -> [tx] -> Bool
checkMempools [Tx Int]
inmp (Int -> [Tx Int] -> [Tx Int]
forall a. Int -> [a] -> [a]
take ([Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
inmp) [Tx Int]
outValidTxs)

         x :: (Bool, Bool)
x@(Bool
True, Bool
False) | Maybe (Tx Int)
Nothing <- (Tx Int -> Bool) -> [Tx Int] -> Maybe (Tx Int)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\Tx Int
tx -> Tx Int -> SizeInBytes
forall txid. Tx txid -> SizeInBytes
getTxAdvSize Tx Int
tx SizeInBytes -> SizeInBytes -> Bool
forall a. Eq a => a -> a -> Bool
/= Tx Int -> SizeInBytes
forall txid. Tx txid -> SizeInBytes
getTxSize Tx Int
tx) [Tx Int]
outmp  ->
           -- If we are presented with a stream of unique txids then we should have
           -- fetched all valid transactions if all txs have valid sizes.
             TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample ((Bool, Bool) -> TestName
forall a. Show a => a -> TestName
show (Bool, Bool)
x)
           (Property -> Property) -> (Bool -> Property) -> Bool -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample ([Tx Int] -> TestName
forall a. Show a => a -> TestName
show [Tx Int]
inmp)
           (Property -> Property) -> (Bool -> Property) -> Bool -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample ([Tx Int] -> TestName
forall a. Show a => a -> TestName
show [Tx Int]
outValidTxs)

           (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ [Tx Int] -> [Tx Int] -> Bool
forall tx. Eq tx => [tx] -> [tx] -> Bool
checkMempools [Tx Int]
inmp (Int -> [Tx Int] -> [Tx Int]
forall a. Int -> [a] -> [a]
take ([Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
inmp) [Tx Int]
outValidTxs)
                         | Bool
otherwise ->
             -- If there's one tx with an invalid size, we will download only
             -- some of them, but we don't guarantee how many we will download.
             --
             -- This is ok, the peer is cheating.
             Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True


         x :: (Bool, Bool)
x@(Bool
False, Bool
True) ->
           -- If we are presented with a stream of valid txids then we should have
           -- fetched some version of those transactions.
             TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample ((Bool, Bool) -> TestName
forall a. Show a => a -> TestName
show (Bool, Bool)
x)
           (Property -> Property) -> (Bool -> Property) -> Bool -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample ([Tx Int] -> TestName
forall a. Show a => a -> TestName
show [Tx Int]
inmp)
           (Property -> Property) -> (Bool -> Property) -> Bool -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample ([Tx Int] -> TestName
forall a. Show a => a -> TestName
show [Tx Int]
outmp)
           (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> Bool
forall tx. Eq tx => [tx] -> [tx] -> Bool
checkMempools ((Tx Int -> Int) -> [Tx Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Tx Int -> Int
forall txid. Tx txid -> txid
getTxId [Tx Int]
inmp)
                           (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take ([Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
inmp)
                                 (Tx Int -> Int
forall txid. Tx txid -> txid
getTxId (Tx Int -> Int) -> [Tx Int] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx Int] -> [Tx Int]
forall txid. [Tx txid] -> [Tx txid]
filterValidTxs [Tx Int]
outUniqueTxIds))

         (Bool
False, Bool
False) ->
           -- If we are presented with a stream of valid and invalid Txs with
           -- duplicate txids we're content with completing the protocol
           -- without error.
           Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True


-- | This test checks that all txs are downloaded from all available peers if
-- available.
--
-- This test takes advantage of the fact that the mempool implementation
-- allows duplicates.
--
-- TODO: do we generated enough outbound mempools which intersect in interesting
-- ways?
prop_txSubmission_inflight :: TxSubmissionState -> Property
prop_txSubmission_inflight :: TxSubmissionState -> Property
prop_txSubmission_inflight st :: TxSubmissionState
st@(TxSubmissionState Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
state TxDecisionPolicy
_) =
  let maxRepeatedValidTxs :: Map (Tx Int) Int
maxRepeatedValidTxs = (([Tx Int], Maybe (Positive SmallDelay),
  Maybe (Positive SmallDelay))
 -> Map (Tx Int) Int -> Map (Tx Int) Int)
-> Map (Tx Int) Int
-> Map
     Int
     ([Tx Int], Maybe (Positive SmallDelay),
      Maybe (Positive SmallDelay))
-> Map (Tx Int) Int
forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr (\([Tx Int]
txs, Maybe (Positive SmallDelay)
_, Maybe (Positive SmallDelay)
_) Map (Tx Int) Int
r -> (Tx Int -> Map (Tx Int) Int -> Map (Tx Int) Int)
-> Map (Tx Int) Int -> [Tx Int] -> Map (Tx Int) Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Map (Tx Int) Int -> Tx Int -> Map (Tx Int) Int -> Map (Tx Int) Int
forall {txid}.
Ord txid =>
Map (Tx txid) Int
-> Tx txid -> Map (Tx txid) Int -> Map (Tx txid) Int
fn Map (Tx Int) Int
r) Map (Tx Int) Int
r [Tx Int]
txs)
                                      Map (Tx Int) Int
forall k a. Map k a
Map.empty
                                      Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
state
      hasInvalidSize :: Bool
hasInvalidSize =
          Maybe
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
-> Bool
forall a. Maybe a -> Bool
isJust
        (Maybe
   ([Tx Int], Maybe (Positive SmallDelay),
    Maybe (Positive SmallDelay))
 -> Bool)
-> Maybe
     ([Tx Int], Maybe (Positive SmallDelay),
      Maybe (Positive SmallDelay))
-> Bool
forall a b. (a -> b) -> a -> b
$ (([Tx Int], Maybe (Positive SmallDelay),
  Maybe (Positive SmallDelay))
 -> Bool)
-> Map
     Int
     ([Tx Int], Maybe (Positive SmallDelay),
      Maybe (Positive SmallDelay))
-> Maybe
     ([Tx Int], Maybe (Positive SmallDelay),
      Maybe (Positive SmallDelay))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\([Tx Int]
txs, Maybe (Positive SmallDelay)
_, Maybe (Positive SmallDelay)
_) ->
                    Maybe (Tx Int) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Tx Int) -> Bool) -> Maybe (Tx Int) -> Bool
forall a b. (a -> b) -> a -> b
$ (Tx Int -> Bool) -> [Tx Int] -> Maybe (Tx Int)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\Tx Int
tx -> Tx Int -> SizeInBytes
forall txid. Tx txid -> SizeInBytes
getTxAdvSize Tx Int
tx SizeInBytes -> SizeInBytes -> Bool
forall a. Eq a => a -> a -> Bool
/= Tx Int -> SizeInBytes
forall txid. Tx txid -> SizeInBytes
getTxSize Tx Int
tx) [Tx Int]
txs
                  )
                  Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
state
      trace :: SimTrace ([Tx Int], [[Tx Int]])
trace = (forall s. IOSim s ([Tx Int], [[Tx Int]]))
-> SimTrace ([Tx Int], [[Tx Int]])
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace (TxSubmissionState -> IOSim s ([Tx Int], [[Tx Int]])
forall s. TxSubmissionState -> IOSim s ([Tx Int], [[Tx Int]])
txSubmissionSimulation TxSubmissionState
st)
  in case Bool
-> SimTrace ([Tx Int], [[Tx Int]])
-> Either Failure ([Tx Int], [[Tx Int]])
forall a. Bool -> SimTrace a -> Either Failure a
traceResult Bool
True SimTrace ([Tx Int], [[Tx Int]])
trace of
       Left Failure
err -> TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (SimTrace ([Tx Int], [[Tx Int]]) -> TestName
forall a. Show a => SimTrace a -> TestName
ppTrace SimTrace ([Tx Int], [[Tx Int]])
trace)
                 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (Failure -> TestName
forall a. Show a => a -> TestName
show Failure
err)
                 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
       Right ([Tx Int]
inmp, [[Tx Int]]
_) ->
         let resultRepeatedValidTxs :: Map (Tx Int) Int
resultRepeatedValidTxs =
               (Tx Int -> Map (Tx Int) Int -> Map (Tx Int) Int)
-> Map (Tx Int) Int -> [Tx Int] -> Map (Tx Int) Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Map (Tx Int) Int -> Tx Int -> Map (Tx Int) Int -> Map (Tx Int) Int
forall {txid}.
Ord txid =>
Map (Tx txid) Int
-> Tx txid -> Map (Tx txid) Int -> Map (Tx txid) Int
fn Map (Tx Int) Int
forall k a. Map k a
Map.empty) Map (Tx Int) Int
forall k a. Map k a
Map.empty [Tx Int]
inmp
         in TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
label (if Bool
hasInvalidSize then TestName
"has wrongly sized tx" else TestName
"has no wrongly sized tx")
          (Property -> Property) -> (Bool -> Property) -> Bool -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (SimTrace ([Tx Int], [[Tx Int]]) -> TestName
forall a. Show a => SimTrace a -> TestName
ppTrace SimTrace ([Tx Int], [[Tx Int]])
trace)
          (Property -> Property) -> (Bool -> Property) -> Bool -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (Map (Tx Int) Int -> TestName
forall a. Show a => a -> TestName
show Map (Tx Int) Int
resultRepeatedValidTxs)
          (Property -> Property) -> (Bool -> Property) -> Bool -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (Map (Tx Int) Int -> TestName
forall a. Show a => a -> TestName
show Map (Tx Int) Int
maxRepeatedValidTxs)
          (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ if Bool
hasInvalidSize
              then Map (Tx Int) Int
resultRepeatedValidTxs Map (Tx Int) Int -> Map (Tx Int) Int -> Bool
forall k a. (Ord k, Eq a) => Map k a -> Map k a -> Bool
`Map.isSubmapOf` Map (Tx Int) Int
maxRepeatedValidTxs
              else Map (Tx Int) Int
resultRepeatedValidTxs Map (Tx Int) Int -> Map (Tx Int) Int -> Bool
forall a. Eq a => a -> a -> Bool
== Map (Tx Int) Int
maxRepeatedValidTxs
  where
    fn :: Map (Tx txid) Int
-> Tx txid -> Map (Tx txid) Int -> Map (Tx txid) Int
fn Map (Tx txid) Int
empty Tx txid
tx Map (Tx txid) Int
rr  | Tx txid -> SizeInBytes
forall txid. Tx txid -> SizeInBytes
getTxAdvSize Tx txid
tx SizeInBytes -> SizeInBytes -> Bool
forall a. Eq a => a -> a -> Bool
/= Tx txid -> SizeInBytes
forall txid. Tx txid -> SizeInBytes
getTxSize Tx txid
tx
                    = Map (Tx txid) Int
empty
                    | Tx txid -> Map (Tx txid) Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Tx txid
tx Map (Tx txid) Int
rr
                    , Tx txid -> Bool
forall txid. Tx txid -> Bool
getTxValid Tx txid
tx
                    = (Int -> Maybe Int)
-> Tx txid -> Map (Tx txid) Int -> Map (Tx txid) Int
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Int -> Int) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> a
succ @Int) Tx txid
tx Map (Tx txid) Int
rr
                    | Tx txid -> Bool
forall txid. Tx txid -> Bool
getTxValid Tx txid
tx
                    = Tx txid -> Int -> Map (Tx txid) Int -> Map (Tx txid) Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Tx txid
tx Int
1 Map (Tx txid) Int
rr
                    | Bool
otherwise
                    = Map (Tx txid) Int
rr


prop_sharedTxStateInvariant :: TxSubmissionState -> Property
prop_sharedTxStateInvariant :: TxSubmissionState -> Property
prop_sharedTxStateInvariant initialState :: TxSubmissionState
initialState@(TxSubmissionState Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
st0 TxDecisionPolicy
_) =
  let tr :: SimTrace ()
tr = (forall s. IOSim s ()) -> SimTrace ()
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace (() () -> IOSim s ([Tx Int], [[Tx Int]]) -> IOSim s ()
forall a b. a -> IOSim s b -> IOSim s a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TxSubmissionState -> IOSim s ([Tx Int], [[Tx Int]])
forall s. TxSubmissionState -> IOSim s ([Tx Int], [[Tx Int]])
txSubmissionSimulation TxSubmissionState
initialState)
  in case Bool -> SimTrace () -> Either Failure ()
forall a. Bool -> SimTrace a -> Either Failure a
traceResult Bool
True SimTrace ()
tr of
    Left Failure
err -> TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (SimTrace () -> TestName
forall a. Show a => SimTrace a -> TestName
ppTrace SimTrace ()
tr)
              (Property -> Property) -> (Bool -> Property) -> Bool -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (Failure -> TestName
forall a. Show a => a -> TestName
show Failure
err)
              (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ Bool
False
    Right ()
_ ->
      let tr' :: Trace (SimResult ()) TxStateTraceType
          tr' :: Trace (SimResult ()) TxStateTraceType
tr' = SimTrace () -> Trace (SimResult ()) TxStateTraceType
forall a b. Typeable b => Trace a SimEvent -> Trace a b
traceSelectTraceEventsDynamic SimTrace ()
tr
      in case
         (SimResult () -> (Every, Sum Int))
-> (TxStateTraceType -> (Every, Sum Int))
-> Trace (SimResult ()) TxStateTraceType
-> (Every, Sum Int)
forall m a b. Monoid m => (a -> m) -> (b -> m) -> Trace a b -> m
forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap (\SimResult ()
_ -> (Property -> Every
forall p. Testable p => p -> Every
Every (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True), Int -> Sum Int
forall a. a -> Sum a
Sum Int
0))
                   (\case
                      (TxStateTrace SharedTxState Int Int (Tx Int)
st)-> ( Property -> Every
forall p. Testable p => p -> Every
Every (Property -> Every) -> Property -> Every
forall a b. (a -> b) -> a -> b
$ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (SharedTxState Int Int (Tx Int) -> TestName
forall a. Show a => a -> TestName
show SharedTxState Int Int (Tx Int)
st)
                                                  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ InvariantStrength -> SharedTxState Int Int (Tx Int) -> Property
forall peeraddr txid tx.
(Ord txid, Show txid, Show tx) =>
InvariantStrength -> SharedTxState peeraddr txid tx -> Property
sharedTxStateInvariant InvariantStrength
WeakInvariant SharedTxState Int Int (Tx Int)
st
                                          , Int -> Sum Int
forall a. a -> Sum a
Sum Int
1
                                          )
                   )
                   Trace (SimResult ()) TxStateTraceType
tr'
         of (Every
p, Sum Int
c) ->
               TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
label (TestName
"number of txs: "
                       TestName -> ShowS
forall a. [a] -> [a] -> [a]
++
                       Int -> Int -> TestName
renderRanges Int
10
                         ( Set Int -> Int
forall a. Set a -> Int
Set.size
                         (Set Int -> Int)
-> ([([Tx Int], Maybe (Positive SmallDelay),
      Maybe (Positive SmallDelay))]
    -> Set Int)
-> [([Tx Int], Maybe (Positive SmallDelay),
     Maybe (Positive SmallDelay))]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Tx Int], Maybe (Positive SmallDelay),
  Maybe (Positive SmallDelay))
 -> Set Int)
-> [([Tx Int], Maybe (Positive SmallDelay),
     Maybe (Positive SmallDelay))]
-> Set Int
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ([Int] -> Set Int)
-> (([Tx Int], Maybe (Positive SmallDelay),
     Maybe (Positive SmallDelay))
    -> [Int])
-> ([Tx Int], Maybe (Positive SmallDelay),
    Maybe (Positive SmallDelay))
-> Set Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\([Tx Int]
txs, Maybe (Positive SmallDelay)
_, Maybe (Positive SmallDelay)
_) -> Tx Int -> Int
forall txid. Tx txid -> txid
getTxId (Tx Int -> Int) -> [Tx Int] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx Int]
txs))
                         ([([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))]
 -> Int)
-> [([Tx Int], Maybe (Positive SmallDelay),
     Maybe (Positive SmallDelay))]
-> Int
forall a b. (a -> b) -> a -> b
$ Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
-> [([Tx Int], Maybe (Positive SmallDelay),
     Maybe (Positive SmallDelay))]
forall k a. Map k a -> [a]
Map.elems Map
  Int
  ([Tx Int], Maybe (Positive SmallDelay),
   Maybe (Positive SmallDelay))
st0
                         ))
             (Property -> Property) -> (Every -> Property) -> Every -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Every -> Property
forall prop. Testable prop => TestName -> prop -> Property
label (TestName
"number of evaluated states: "
                       TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Int -> TestName
renderRanges Int
100 Int
c)
             (Every -> Property) -> Every -> Property
forall a b. (a -> b) -> a -> b
$ Every
p


--
-- Utils
--

-- | Check that the inbound mempool contains all outbound `tx`s as a proper
-- subsequence.  It might contain more `tx`s from other peers.
--
checkMempools :: Eq tx
              => [tx] -- inbound mempool
              -> [tx] -- outbound mempool
              -> Bool
checkMempools :: forall tx. Eq tx => [tx] -> [tx] -> Bool
checkMempools [tx]
_  []    = Bool
True  -- all outbound `tx` were found in the inbound
                               -- mempool
checkMempools [] (tx
_:[tx]
_) = Bool
False -- outbound mempool contains `tx`s which were
                               -- not transferred to the inbound mempool
checkMempools (tx
i : [tx]
is') os :: [tx]
os@(tx
o : [tx]
os')
  | tx
i tx -> tx -> Bool
forall a. Eq a => a -> a -> Bool
== tx
o
  = [tx] -> [tx] -> Bool
forall tx. Eq tx => [tx] -> [tx] -> Bool
checkMempools [tx]
is' [tx]
os'

  | Bool
otherwise
  -- `_i` is not present in the outbound mempool, we can skip it.
  = [tx] -> [tx] -> Bool
forall tx. Eq tx => [tx] -> [tx] -> Bool
checkMempools [tx]
is' [tx]
os


-- | Split a list into sub list of at most `n` elements.
--
divvy :: Int -> [a] -> [[a]]
divvy :: forall a. Int -> [a] -> [[a]]
divvy Int
_ [] = []
divvy Int
n [a]
as = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
n [a]
as [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
divvy Int
n (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
n [a]
as)