{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- | Property tests for the mempool.
--
-- The mempool collects transactions from downstream nodes, makes them
-- available to upstream nodes, and of course provides the pool of transactions
-- that we use when forging blocks.
--
-- These tests for the mempool are not model based, but instead check various
-- simple properties and invariants, for instance:
--
-- * After adding valid transactions to the mempool, they can be retrieved.
-- * Adding invalid transactions from the mempool will report them as invalid,
--   and they are not added.
-- * Transactions cannot be retrieved after they are removed.
-- * The mempool capacity is not exceeded
--
-- NOTE: the test mempool's default capacity is set to a very large value in
-- module "Ouroboros.Consensus.Mock.Ledger.Block". This is why the generators do
-- not care about the mempool capacity when generating transactions for a
-- mempool with the 'NoMempoolCapacityBytesOverride' option set.
module Test.Consensus.Mempool (tests) where

import Cardano.Binary (toCBOR)
import Cardano.Crypto.Hash
import Control.Monad (foldM, forM, forM_, void)
import Control.Monad.Class.MonadTimer.SI (MonadTimer)
import Control.Monad.Except (runExcept)
import Control.Monad.IOSim (runSimOrThrow)
import Control.Monad.State (State, evalState, get, modify)
import Control.Tracer (Tracer (..))
import Data.Bifunctor (first, second)
import Data.Either (isRight)
import Data.Functor ((<&>))
import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (mapMaybe)
import Data.Semigroup (stimes)
import qualified Data.Set as Set
import Data.Word
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.Ledger.Tables.Utils
import Ouroboros.Consensus.Mempool
import Ouroboros.Consensus.Mempool.API (ExnMempoolTimeout (..))
import Ouroboros.Consensus.Mempool.Impl.Common (MempoolLedgerDBView (..))
import Ouroboros.Consensus.Mempool.TxSeq as TxSeq
import Ouroboros.Consensus.Mock.Ledger hiding (TxId)
import Ouroboros.Consensus.Storage.LedgerDB.Forker
import Ouroboros.Consensus.Util (repeatedly, repeatedlyM)
import Ouroboros.Consensus.Util.Condense (condense)
import Ouroboros.Consensus.Util.IOLike
import Test.Consensus.Mempool.Util
import Test.Crypto.Hash ()
import Test.QuickCheck
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
import Test.Util.Orphans.IOLike ()

tests :: TestTree
tests :: TestTree
tests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Mempool"
    [ String -> [TestTree] -> TestTree
testGroup
        String
"TxSeq"
        [ String -> ([Int] -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"lookupByTicketNo complete" [Int] -> Property
prop_TxSeq_lookupByTicketNo_complete
        , String -> ([Small Int] -> Small Int -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"lookupByTicketNo sound" [Small Int] -> Small Int -> Property
prop_TxSeq_lookupByTicketNo_sound
        , String -> (TxSizeSplitTestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"splitAfterTxSize" TxSizeSplitTestSetup -> Property
prop_TxSeq_splitAfterTxSize
        , String -> (TxSizeSplitTestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"splitAfterTxSizeSpec" TxSizeSplitTestSetup -> Property
prop_TxSeq_splitAfterTxSizeSpec
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"IOSim properties"
        [ String -> (TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty
            String
"snapshotTxs == snapshotTxsAfter zeroTicketNo"
            TestSetup -> Property
prop_Mempool_snapshotTxs_snapshotTxsAfter
        , String -> (TestSetupWithTxs -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"valid added txs == getTxs" TestSetupWithTxs -> Property
prop_Mempool_addTxs_getTxs
        , String -> (TestSetupWithTxs -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"addTxs [..] == forM [..] addTxs" TestSetupWithTxs -> Property
prop_Mempool_semigroup_addTxs
        , String -> (TestSetupWithTxs -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"result of addTxs" TestSetupWithTxs -> Property
prop_Mempool_addTxs_result
        , String -> (TestSetupWithTxs -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Invalid transactions are never added" TestSetupWithTxs -> Property
prop_Mempool_InvalidTxsNeverAdded
        , String -> (TestSetupWithTxInMempool -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"removeTxs" TestSetupWithTxInMempool -> Property
prop_Mempool_removeTxs
        , String
-> (TestSetupWithTxsInMempoolToRemove -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"removeTxs [..] == forM [..] removeTxs" TestSetupWithTxsInMempoolToRemove -> Property
prop_Mempool_semigroup_removeTxs
        , String -> (MempoolCapTestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"result of getCapacity" MempoolCapTestSetup -> Property
prop_Mempool_getCapacity
        , -- FIXME: we should add an issue to test this aspect somehow.
          -- , testProperty "Mempool capacity implementation"              prop_Mempool_Capacity
          String -> (TestSetupWithTxs -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Added valid transactions are traced" TestSetupWithTxs -> Property
prop_Mempool_TraceValidTxs
        , String -> (TestSetupWithTxs -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Rejected invalid txs are traced" TestSetupWithTxs -> Property
prop_Mempool_TraceRejectedTxs
        , String -> (TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Removed invalid txs are traced" TestSetup -> Property
prop_Mempool_TraceRemovedTxs
        , String -> (Actions -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"idx consistency" Actions -> Property
prop_Mempool_idx_consistency
        , String -> (TestSetupWithTxsAndDiffTimes -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Mempool timeout" TestSetupWithTxsAndDiffTimes -> Property
prop_Mempool_timeout
        ]
    ]

{-------------------------------------------------------------------------------
  Mempool Implementation Properties
-------------------------------------------------------------------------------}

-- | Test that @snapshotTxs == snapshotTxsAfter zeroTicketNo@.
prop_Mempool_snapshotTxs_snapshotTxsAfter :: TestSetup -> Property
prop_Mempool_snapshotTxs_snapshotTxsAfter :: TestSetup -> Property
prop_Mempool_snapshotTxs_snapshotTxsAfter TestSetup
setup =
  TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempool TestSetup
setup ((forall (m :: * -> *).
  (IOLike m, MonadTimer m) =>
  TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool{Mempool m TestBlock
mempool :: Mempool m TestBlock
mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool} -> do
    let Mempool{STM m (MempoolSnapshot TestBlock)
getSnapshot :: STM m (MempoolSnapshot TestBlock)
getSnapshot :: forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot} = Mempool m TestBlock
mempool
    MempoolSnapshot{snapshotTxs, snapshotTxsAfter} <- STM m (MempoolSnapshot TestBlock) -> m (MempoolSnapshot TestBlock)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (MempoolSnapshot TestBlock)
getSnapshot
    return $ snapshotTxs === snapshotTxsAfter zeroTicketNo

-- | Test that all valid transactions added to a 'Mempool' can be retrieved
-- afterward.
prop_Mempool_addTxs_getTxs :: TestSetupWithTxs -> Property
prop_Mempool_addTxs_getTxs :: TestSetupWithTxs -> Property
prop_Mempool_addTxs_getTxs TestSetupWithTxs
setup =
  TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempool (TestSetupWithTxs -> TestSetup
testSetup TestSetupWithTxs
setup) ((forall (m :: * -> *).
  (IOLike m, MonadTimer m) =>
  TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool{Mempool m TestBlock
mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool :: Mempool m TestBlock
mempool} -> do
    _ <- Mempool m TestBlock
-> [GenTx TestBlock] -> m [MempoolAddTxResult TestBlock]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool m TestBlock
mempool (TestSetupWithTxs -> [GenTx TestBlock]
allTxs TestSetupWithTxs
setup)
    MempoolSnapshot{snapshotTxs} <- atomically $ getSnapshot mempool
    return $
      counterexample (ppTxs (txs setup)) $
        validTxs setup `List.isSuffixOf` map (txForgetValidated . prjTx) snapshotTxs

-- | Test that both adding the transactions one by one and adding them in one go
-- produce the same result.
prop_Mempool_semigroup_addTxs :: TestSetupWithTxs -> Property
prop_Mempool_semigroup_addTxs :: TestSetupWithTxs -> Property
prop_Mempool_semigroup_addTxs TestSetupWithTxs
setup =
  TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempool (TestSetupWithTxs -> TestSetup
testSetup TestSetupWithTxs
setup) ((forall (m :: * -> *).
  (IOLike m, MonadTimer m) =>
  TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool{mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool = Mempool m TestBlock
mempool1} -> do
    _ <- Mempool m TestBlock
-> [GenTx TestBlock] -> m [MempoolAddTxResult TestBlock]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool m TestBlock
mempool1 (TestSetupWithTxs -> [GenTx TestBlock]
allTxs TestSetupWithTxs
setup)
    snapshot1 <- atomically $ getSnapshot mempool1

    return $ withTestMempool (testSetup setup) $ \TestMempool{mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool = Mempool m TestBlock
mempool2} -> do
      [GenTx TestBlock]
-> (GenTx TestBlock -> m [MempoolAddTxResult TestBlock]) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (TestSetupWithTxs -> [GenTx TestBlock]
allTxs TestSetupWithTxs
setup) ((GenTx TestBlock -> m [MempoolAddTxResult TestBlock]) -> m ())
-> (GenTx TestBlock -> m [MempoolAddTxResult TestBlock]) -> m ()
forall a b. (a -> b) -> a -> b
$ \GenTx TestBlock
tx -> Mempool m TestBlock
-> [GenTx TestBlock] -> m [MempoolAddTxResult TestBlock]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool m TestBlock
mempool2 [GenTx TestBlock
tx]
      snapshot2 <- STM m (MempoolSnapshot TestBlock) -> m (MempoolSnapshot TestBlock)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (MempoolSnapshot TestBlock)
 -> m (MempoolSnapshot TestBlock))
-> STM m (MempoolSnapshot TestBlock)
-> m (MempoolSnapshot TestBlock)
forall a b. (a -> b) -> a -> b
$ Mempool m TestBlock -> STM m (MempoolSnapshot TestBlock)
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool m TestBlock
mempool2

      return
        $ counterexample
          ( "Transactions after adding in one go: "
              <> show (snapshotTxs snapshot1)
              <> "\nTransactions after adding one by one: "
              <> show (snapshotTxs snapshot2)
          )
        $ snapshotTxs snapshot1 === snapshotTxs snapshot2
          .&&. snapshotMempoolSize snapshot1 === snapshotMempoolSize snapshot2
          .&&. snapshotSlotNo snapshot1 === snapshotSlotNo snapshot1

-- | Test that the result of adding transaction to a 'Mempool' matches our
-- expectation: invalid transactions have errors associated with them and
-- valid transactions don't.
prop_Mempool_addTxs_result :: TestSetupWithTxs -> Property
prop_Mempool_addTxs_result :: TestSetupWithTxs -> Property
prop_Mempool_addTxs_result TestSetupWithTxs
setup =
  TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempool (TestSetupWithTxs -> TestSetup
testSetup TestSetupWithTxs
setup) ((forall (m :: * -> *).
  (IOLike m, MonadTimer m) =>
  TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool{Mempool m TestBlock
mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool :: Mempool m TestBlock
mempool} -> do
    result <- Mempool m TestBlock
-> [GenTx TestBlock] -> m [MempoolAddTxResult TestBlock]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool m TestBlock
mempool (TestSetupWithTxs -> [GenTx TestBlock]
allTxs TestSetupWithTxs
setup)
    return $
      counterexample (ppTxs (txs setup)) $
        [ case res of
            MempoolTxAdded Validated (GenTx TestBlock)
vtx LedgerTables TestBlock DiffMK
_ -> (Validated (GenTx TestBlock) -> GenTx TestBlock
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated (GenTx TestBlock)
vtx, Bool
True)
            MempoolTxRejected GenTx TestBlock
tx TestTxError
_err -> (GenTx TestBlock
tx, Bool
False)
        | res <- result
        ]
          === txs setup

-- | Test that invalid transactions are never added to the 'Mempool'.
prop_Mempool_InvalidTxsNeverAdded :: TestSetupWithTxs -> Property
prop_Mempool_InvalidTxsNeverAdded :: TestSetupWithTxs -> Property
prop_Mempool_InvalidTxsNeverAdded TestSetupWithTxs
setup =
  TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempool (TestSetupWithTxs -> TestSetup
testSetup TestSetupWithTxs
setup) ((forall (m :: * -> *).
  (IOLike m, MonadTimer m) =>
  TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool{Mempool m TestBlock
mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool :: Mempool m TestBlock
mempool} -> do
    txsInMempoolBefore <-
      ((Validated (GenTx TestBlock), TicketNo, TheMeasure)
 -> Validated (GenTx TestBlock))
-> [(Validated (GenTx TestBlock), TicketNo, TheMeasure)]
-> [Validated (GenTx TestBlock)]
forall a b. (a -> b) -> [a] -> [b]
map (Validated (GenTx TestBlock), TicketNo, TheMeasure)
-> Validated (GenTx TestBlock)
(Validated (GenTx TestBlock), TicketNo, TxMeasure TestBlock)
-> Validated (GenTx TestBlock)
prjTx ([(Validated (GenTx TestBlock), TicketNo, TheMeasure)]
 -> [Validated (GenTx TestBlock)])
-> (MempoolSnapshot TestBlock
    -> [(Validated (GenTx TestBlock), TicketNo, TheMeasure)])
-> MempoolSnapshot TestBlock
-> [Validated (GenTx TestBlock)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MempoolSnapshot TestBlock
-> [(Validated (GenTx TestBlock), TicketNo, TheMeasure)]
MempoolSnapshot TestBlock
-> [(Validated (GenTx TestBlock), TicketNo, TxMeasure TestBlock)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxs
        (MempoolSnapshot TestBlock -> [Validated (GenTx TestBlock)])
-> m (MempoolSnapshot TestBlock) -> m [Validated (GenTx TestBlock)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (MempoolSnapshot TestBlock) -> m (MempoolSnapshot TestBlock)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Mempool m TestBlock -> STM m (MempoolSnapshot TestBlock)
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool m TestBlock
mempool)
    _ <- addTxs mempool (allTxs setup)
    txsInMempoolAfter <-
      map prjTx . snapshotTxs
        <$> atomically (getSnapshot mempool)
    return $
      counterexample (ppTxs (txs setup)) $
        conjoin
          -- Check for each transaction in the mempool (ignoring those already
          -- in the mempool beforehand) that it was a valid transaction.
          --
          -- Note that we can't check that no invalid transactions are in the
          -- mempool because the same transaction could be added twice: the
          -- first time as a valid one and the second time as an invalid one.
          [ (txForgetValidated txInMempool `elem` validTxs setup) === True
          | txInMempool <- txsInMempoolAfter
          , txInMempool `notElem` txsInMempoolBefore
          ]

-- | After removing a transaction from the Mempool, it's actually gone.
prop_Mempool_removeTxs :: TestSetupWithTxInMempool -> Property
prop_Mempool_removeTxs :: TestSetupWithTxInMempool -> Property
prop_Mempool_removeTxs (TestSetupWithTxInMempool TestSetup
testSetup GenTx TestBlock
txToRemove) =
  TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempool TestSetup
testSetup ((forall (m :: * -> *).
  (IOLike m, MonadTimer m) =>
  TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool{Mempool m TestBlock
mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool :: Mempool m TestBlock
mempool} -> do
    let Mempool{NonEmpty TestTxId -> m ()
removeTxsEvenIfValid :: NonEmpty TestTxId -> m ()
removeTxsEvenIfValid :: forall (m :: * -> *) blk.
Mempool m blk -> NonEmpty (GenTxId blk) -> m ()
removeTxsEvenIfValid, STM m (MempoolSnapshot TestBlock)
getSnapshot :: forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot :: STM m (MempoolSnapshot TestBlock)
getSnapshot} = Mempool m TestBlock
mempool
    NonEmpty TestTxId -> m ()
removeTxsEvenIfValid (NonEmpty TestTxId -> m ()) -> NonEmpty TestTxId -> m ()
forall a b. (a -> b) -> a -> b
$ [TestTxId] -> NonEmpty TestTxId
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [GenTx TestBlock -> TestTxId
forall tx. HasTxId tx => tx -> TxId tx
txId GenTx TestBlock
txToRemove]
    txsInMempoolAfter <- ((Validated (GenTx TestBlock), TicketNo, TheMeasure)
 -> Validated (GenTx TestBlock))
-> [(Validated (GenTx TestBlock), TicketNo, TheMeasure)]
-> [Validated (GenTx TestBlock)]
forall a b. (a -> b) -> [a] -> [b]
map (Validated (GenTx TestBlock), TicketNo, TheMeasure)
-> Validated (GenTx TestBlock)
(Validated (GenTx TestBlock), TicketNo, TxMeasure TestBlock)
-> Validated (GenTx TestBlock)
prjTx ([(Validated (GenTx TestBlock), TicketNo, TheMeasure)]
 -> [Validated (GenTx TestBlock)])
-> (MempoolSnapshot TestBlock
    -> [(Validated (GenTx TestBlock), TicketNo, TheMeasure)])
-> MempoolSnapshot TestBlock
-> [Validated (GenTx TestBlock)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MempoolSnapshot TestBlock
-> [(Validated (GenTx TestBlock), TicketNo, TheMeasure)]
MempoolSnapshot TestBlock
-> [(Validated (GenTx TestBlock), TicketNo, TxMeasure TestBlock)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxs (MempoolSnapshot TestBlock -> [Validated (GenTx TestBlock)])
-> m (MempoolSnapshot TestBlock) -> m [Validated (GenTx TestBlock)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (MempoolSnapshot TestBlock) -> m (MempoolSnapshot TestBlock)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (MempoolSnapshot TestBlock)
getSnapshot
    return $
      counterexample
        ( "Transactions in the mempool after removing ("
            <> show txToRemove
            <> "): "
            <> show txsInMempoolAfter
        )
        (txToRemove `notElem` map txForgetValidated txsInMempoolAfter)

-- | Test that both removing transactions one by one and removing them in one go
-- produce the same result.
prop_Mempool_semigroup_removeTxs :: TestSetupWithTxsInMempoolToRemove -> Property
prop_Mempool_semigroup_removeTxs :: TestSetupWithTxsInMempoolToRemove -> Property
prop_Mempool_semigroup_removeTxs (TestSetupWithTxsInMempoolToRemove TestSetup
testSetup NonEmpty (GenTx TestBlock)
txsToRemove) =
  TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempool TestSetup
testSetup ((forall (m :: * -> *).
  (IOLike m, MonadTimer m) =>
  TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool{mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool = Mempool m TestBlock
mempool1} -> do
    Mempool m TestBlock -> NonEmpty TestTxId -> m ()
forall (m :: * -> *) blk.
Mempool m blk -> NonEmpty (GenTxId blk) -> m ()
removeTxsEvenIfValid Mempool m TestBlock
mempool1 (NonEmpty TestTxId -> m ()) -> NonEmpty TestTxId -> m ()
forall a b. (a -> b) -> a -> b
$ (GenTx TestBlock -> TestTxId)
-> NonEmpty (GenTx TestBlock) -> NonEmpty TestTxId
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map GenTx TestBlock -> TestTxId
forall tx. HasTxId tx => tx -> TxId tx
txId NonEmpty (GenTx TestBlock)
txsToRemove
    snapshot1 <- STM m (MempoolSnapshot TestBlock) -> m (MempoolSnapshot TestBlock)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Mempool m TestBlock -> STM m (MempoolSnapshot TestBlock)
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool m TestBlock
mempool1)

    return $ withTestMempool testSetup $ \TestMempool{mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool = Mempool m TestBlock
mempool2} -> do
      NonEmpty TestTxId -> (TestTxId -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((GenTx TestBlock -> TestTxId)
-> NonEmpty (GenTx TestBlock) -> NonEmpty TestTxId
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map GenTx TestBlock -> TestTxId
forall tx. HasTxId tx => tx -> TxId tx
txId NonEmpty (GenTx TestBlock)
txsToRemove) (Mempool m TestBlock -> NonEmpty TestTxId -> m ()
forall (m :: * -> *) blk.
Mempool m blk -> NonEmpty (GenTxId blk) -> m ()
removeTxsEvenIfValid Mempool m TestBlock
mempool2 (NonEmpty TestTxId -> m ())
-> (TestTxId -> NonEmpty TestTxId) -> TestTxId -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestTxId -> [TestTxId] -> NonEmpty TestTxId
forall a. a -> [a] -> NonEmpty a
NE.:| []))
      snapshot2 <- STM m (MempoolSnapshot TestBlock) -> m (MempoolSnapshot TestBlock)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Mempool m TestBlock -> STM m (MempoolSnapshot TestBlock)
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool m TestBlock
mempool2)

      return
        $ counterexample
          ( "Transactions after removing in one go: "
              <> show (snapshotTxs snapshot1)
              <> "\nTransactions after removing one by one: "
              <> show (snapshotTxs snapshot2)
          )
        $ snapshotTxs snapshot1 === snapshotTxs snapshot2
          .&&. snapshotMempoolSize snapshot1 === snapshotMempoolSize snapshot2
          .&&. snapshotSlotNo snapshot1 === snapshotSlotNo snapshot1

-- | Test that 'getCapacity' returns the greatest multiple of the block
-- capacity that is not greater than the requested capacity.
--
-- Ignore the "100% empty Mempool" label in the test output, that is there
-- because we reuse 'withTestMempool' and always start with an empty Mempool
-- and 'LedgerState'.
prop_Mempool_getCapacity :: MempoolCapTestSetup -> Property
prop_Mempool_getCapacity :: MempoolCapTestSetup -> Property
prop_Mempool_getCapacity MempoolCapTestSetup
mcts =
  TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempool TestSetup
testSetup ((forall (m :: * -> *).
  (IOLike m, MonadTimer m) =>
  TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool{Mempool m TestBlock
mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool :: Mempool m TestBlock
mempool} -> do
    IgnoringOverflow actualCapacity <- STM m TheMeasure -> m TheMeasure
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m TheMeasure -> m TheMeasure)
-> STM m TheMeasure -> m TheMeasure
forall a b. (a -> b) -> a -> b
$ Mempool m TestBlock -> STM m (TxMeasure TestBlock)
forall (m :: * -> *) blk. Mempool m blk -> STM m (TxMeasure blk)
getCapacity Mempool m TestBlock
mempool
    pure $ actualCapacity === expectedCapacity
 where
  MempoolCapacityBytesOverride ByteSize32
testCapacity = TestSetup -> MempoolCapacityBytesOverride
testMempoolCapOverride TestSetup
testSetup
  MempoolCapTestSetup (TestSetupWithTxs TestSetup
testSetup [(GenTx TestBlock, Bool)]
_txsToAdd) = MempoolCapTestSetup
mcts

  ByteSize32 Word32
dnom = ByteSize32
simpleBlockCapacity

  expectedCapacity :: ByteSize32
expectedCapacity =
    (\Word32
n -> Word32 -> ByteSize32 -> ByteSize32
forall b. Integral b => b -> ByteSize32 -> ByteSize32
forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes Word32
n ByteSize32
simpleBlockCapacity) (Word32 -> ByteSize32) -> Word32 -> ByteSize32
forall a b. (a -> b) -> a -> b
$
      Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
1
      -- adding one less than the denom to the numer achieves rounding up
      (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$
        (ByteSize32 -> Word32
unByteSize32 ByteSize32
testCapacity Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
dnom Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Word32
dnom

-- | Test that all valid transactions added to a 'Mempool' via 'addTxs' are
-- appropriately represented in the trace of events.
prop_Mempool_TraceValidTxs :: TestSetupWithTxs -> Property
prop_Mempool_TraceValidTxs :: TestSetupWithTxs -> Property
prop_Mempool_TraceValidTxs TestSetupWithTxs
setup =
  TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempool (TestSetupWithTxs -> TestSetup
testSetup TestSetupWithTxs
setup) ((forall (m :: * -> *).
  (IOLike m, MonadTimer m) =>
  TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool m
testMempool -> do
    let TestMempool{Mempool m TestBlock
mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool :: Mempool m TestBlock
mempool, m [TraceEventMempool TestBlock]
getTraceEvents :: m [TraceEventMempool TestBlock]
getTraceEvents :: forall (m :: * -> *).
TestMempool m -> m [TraceEventMempool TestBlock]
getTraceEvents} = TestMempool m
testMempool
    _ <- Mempool m TestBlock
-> [GenTx TestBlock] -> m [MempoolAddTxResult TestBlock]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool m TestBlock
mempool (TestSetupWithTxs -> [GenTx TestBlock]
allTxs TestSetupWithTxs
setup)
    evs <- getTraceEvents
    return $
      counterexample (ppTxs (txs setup)) $
        let addedTxs = (TraceEventMempool TestBlock -> Maybe (GenTx TestBlock))
-> [TraceEventMempool TestBlock] -> [GenTx TestBlock]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TraceEventMempool TestBlock -> Maybe (GenTx TestBlock)
isAddedTxsEvent [TraceEventMempool TestBlock]
evs
         in validTxs setup === addedTxs
 where
  isAddedTxsEvent :: TraceEventMempool TestBlock -> Maybe (GenTx TestBlock)
  isAddedTxsEvent :: TraceEventMempool TestBlock -> Maybe (GenTx TestBlock)
isAddedTxsEvent (TraceMempoolAddedTx Validated (GenTx TestBlock)
tx MempoolSize
_ MempoolSize
_) = GenTx TestBlock -> Maybe (GenTx TestBlock)
forall a. a -> Maybe a
Just (Validated (GenTx TestBlock) -> GenTx TestBlock
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated (GenTx TestBlock)
tx)
  isAddedTxsEvent TraceEventMempool TestBlock
_ = Maybe (GenTx TestBlock)
forall a. Maybe a
Nothing

-- | Test that all invalid rejected transactions returned from 'addTxs' are
-- appropriately represented in the trace of events.
prop_Mempool_TraceRejectedTxs :: TestSetupWithTxs -> Property
prop_Mempool_TraceRejectedTxs :: TestSetupWithTxs -> Property
prop_Mempool_TraceRejectedTxs TestSetupWithTxs
setup =
  TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempool (TestSetupWithTxs -> TestSetup
testSetup TestSetupWithTxs
setup) ((forall (m :: * -> *).
  (IOLike m, MonadTimer m) =>
  TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool m
testMempool -> do
    let TestMempool{Mempool m TestBlock
mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool :: Mempool m TestBlock
mempool, m [TraceEventMempool TestBlock]
getTraceEvents :: forall (m :: * -> *).
TestMempool m -> m [TraceEventMempool TestBlock]
getTraceEvents :: m [TraceEventMempool TestBlock]
getTraceEvents} = TestMempool m
testMempool
    _ <- Mempool m TestBlock
-> [GenTx TestBlock] -> m [MempoolAddTxResult TestBlock]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool m TestBlock
mempool (TestSetupWithTxs -> [GenTx TestBlock]
allTxs TestSetupWithTxs
setup)
    evs <- getTraceEvents
    return $
      counterexample (ppTxs (txs setup)) $
        let rejectedTxs = (TraceEventMempool TestBlock -> Maybe (GenTx TestBlock))
-> [TraceEventMempool TestBlock] -> [GenTx TestBlock]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TraceEventMempool TestBlock -> Maybe (GenTx TestBlock)
forall blk. TraceEventMempool blk -> Maybe (GenTx blk)
isRejectedTxEvent [TraceEventMempool TestBlock]
evs
         in invalidTxs setup === rejectedTxs
 where
  isRejectedTxEvent :: TraceEventMempool blk -> Maybe (GenTx blk)
  isRejectedTxEvent :: forall blk. TraceEventMempool blk -> Maybe (GenTx blk)
isRejectedTxEvent (TraceMempoolRejectedTx GenTx blk
tx ApplyTxErr blk
_ MempoolRejectionDetails
_ MempoolSize
_) = GenTx blk -> Maybe (GenTx blk)
forall a. a -> Maybe a
Just GenTx blk
tx
  isRejectedTxEvent TraceEventMempool blk
_ = Maybe (GenTx blk)
forall a. Maybe a
Nothing

-- | Test that all transactions in the 'Mempool' that have become invalid
-- because of an update to the ledger are appropriately represented in the
-- trace of events.
prop_Mempool_TraceRemovedTxs :: TestSetup -> Property
prop_Mempool_TraceRemovedTxs :: TestSetup -> Property
prop_Mempool_TraceRemovedTxs TestSetup
setup =
  TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempool TestSetup
setup ((forall (m :: * -> *).
  (IOLike m, MonadTimer m) =>
  TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool m
testMempool -> do
    let TestMempool{Mempool m TestBlock
mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool :: Mempool m TestBlock
mempool, m [TraceEventMempool TestBlock]
getTraceEvents :: forall (m :: * -> *).
TestMempool m -> m [TraceEventMempool TestBlock]
getTraceEvents :: m [TraceEventMempool TestBlock]
getTraceEvents, [GenTx TestBlock] -> STM m [Either TestTxError ()]
addTxsToLedger :: [GenTx TestBlock] -> STM m [Either TestTxError ()]
addTxsToLedger :: forall (m :: * -> *).
TestMempool m -> [GenTx TestBlock] -> STM m [Either TestTxError ()]
addTxsToLedger, STM m (LedgerState TestBlock ValuesMK)
getCurrentLedger :: STM m (LedgerState TestBlock ValuesMK)
getCurrentLedger :: forall (m :: * -> *).
TestMempool m -> STM m (LedgerState TestBlock ValuesMK)
getCurrentLedger} = TestMempool m
testMempool
    MempoolSnapshot{snapshotTxs} <- STM m (MempoolSnapshot TestBlock) -> m (MempoolSnapshot TestBlock)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (MempoolSnapshot TestBlock)
 -> m (MempoolSnapshot TestBlock))
-> STM m (MempoolSnapshot TestBlock)
-> m (MempoolSnapshot TestBlock)
forall a b. (a -> b) -> a -> b
$ Mempool m TestBlock -> STM m (MempoolSnapshot TestBlock)
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool m TestBlock
mempool
    -- We add all the transactions in the mempool to the ledger. Some of
    -- them will become invalid because all inputs have been spent.
    let txsInMempool = ((Validated (GenTx TestBlock), TicketNo, TheMeasure)
 -> Validated (GenTx TestBlock))
-> [(Validated (GenTx TestBlock), TicketNo, TheMeasure)]
-> [Validated (GenTx TestBlock)]
forall a b. (a -> b) -> [a] -> [b]
map (Validated (GenTx TestBlock), TicketNo, TheMeasure)
-> Validated (GenTx TestBlock)
(Validated (GenTx TestBlock), TicketNo, TxMeasure TestBlock)
-> Validated (GenTx TestBlock)
prjTx [(Validated (GenTx TestBlock), TicketNo, TheMeasure)]
[(Validated (GenTx TestBlock), TicketNo, TxMeasure TestBlock)]
snapshotTxs
    errs <- atomically $ addTxsToLedger (map txForgetValidated txsInMempool)

    -- Sync the mempool with the ledger. Now some of the transactions in the
    -- mempool should have been removed.
    void $ testSyncWithLedger mempool

    -- Predict which transactions should have been removed
    curLedger <- atomically getCurrentLedger
    let expected = LedgerState TestBlock ValuesMK
-> [GenTx TestBlock] -> [(GenTx TestBlock, TestTxError)]
expectedToBeRemoved LedgerState TestBlock ValuesMK
curLedger ((Validated (GenTx TestBlock) -> GenTx TestBlock)
-> [Validated (GenTx TestBlock)] -> [GenTx TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map Validated (GenTx TestBlock) -> GenTx TestBlock
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated [Validated (GenTx TestBlock)]
txsInMempool)

    -- Look at the trace to see which transactions actually got removed
    evs <- getTraceEvents
    let removedTxs = [[(GenTx TestBlock, MockError TestBlock)]]
-> [(GenTx TestBlock, MockError TestBlock)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(GenTx TestBlock, MockError TestBlock)]]
 -> [(GenTx TestBlock, MockError TestBlock)])
-> [[(GenTx TestBlock, MockError TestBlock)]]
-> [(GenTx TestBlock, MockError TestBlock)]
forall a b. (a -> b) -> a -> b
$ (TraceEventMempool TestBlock
 -> Maybe [(GenTx TestBlock, MockError TestBlock)])
-> [TraceEventMempool TestBlock]
-> [[(GenTx TestBlock, MockError TestBlock)]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TraceEventMempool TestBlock
-> Maybe [(GenTx TestBlock, TestTxError)]
TraceEventMempool TestBlock
-> Maybe [(GenTx TestBlock, MockError TestBlock)]
isRemoveTxsEvent [TraceEventMempool TestBlock]
evs

    -- Also check that 'addTxsToLedger' never resulted in an error.
    return $
      classify (not (null removedTxs)) "Removed some transactions" $
        map (const (Right ())) errs === errs
          .&&. List.sortOn fst expected === List.sortOn fst removedTxs
 where
  cfg :: LedgerConfig TestBlock
cfg = TestSetup -> LedgerConfig TestBlock
testLedgerCfg TestSetup
setup

  isRemoveTxsEvent :: TraceEventMempool TestBlock -> Maybe [(TestTx, TestTxError)]
  isRemoveTxsEvent :: TraceEventMempool TestBlock
-> Maybe [(GenTx TestBlock, TestTxError)]
isRemoveTxsEvent (TraceMempoolRemoveTxs [(Validated (GenTx TestBlock), TestTxError)]
txs MempoolSize
_) = [(GenTx TestBlock, MockError TestBlock)]
-> Maybe [(GenTx TestBlock, MockError TestBlock)]
forall a. a -> Maybe a
Just (((Validated (GenTx TestBlock), MockError TestBlock)
 -> (GenTx TestBlock, MockError TestBlock))
-> [(Validated (GenTx TestBlock), MockError TestBlock)]
-> [(GenTx TestBlock, MockError TestBlock)]
forall a b. (a -> b) -> [a] -> [b]
map ((Validated (GenTx TestBlock) -> GenTx TestBlock)
-> (Validated (GenTx TestBlock), MockError TestBlock)
-> (GenTx TestBlock, MockError TestBlock)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Validated (GenTx TestBlock) -> GenTx TestBlock
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated) [(Validated (GenTx TestBlock), TestTxError)]
[(Validated (GenTx TestBlock), MockError TestBlock)]
txs)
  isRemoveTxsEvent TraceEventMempool TestBlock
_ = Maybe [(GenTx TestBlock, TestTxError)]
Maybe [(GenTx TestBlock, MockError TestBlock)]
forall a. Maybe a
Nothing

  expectedToBeRemoved :: LedgerState TestBlock ValuesMK -> [TestTx] -> [(TestTx, TestTxError)]
  expectedToBeRemoved :: LedgerState TestBlock ValuesMK
-> [GenTx TestBlock] -> [(GenTx TestBlock, TestTxError)]
expectedToBeRemoved LedgerState TestBlock ValuesMK
ledgerState [GenTx TestBlock]
txsInMempool =
    [ (GenTx TestBlock
tx, TestTxError
err)
    | (GenTx TestBlock
tx, Left TestTxError
err) <- ([(GenTx TestBlock, Either TestTxError ())],
 LedgerState TestBlock ValuesMK)
-> [(GenTx TestBlock, Either TestTxError ())]
forall a b. (a, b) -> a
fst (([(GenTx TestBlock, Either TestTxError ())],
  LedgerState TestBlock ValuesMK)
 -> [(GenTx TestBlock, Either TestTxError ())])
-> ([(GenTx TestBlock, Either TestTxError ())],
    LedgerState TestBlock ValuesMK)
-> [(GenTx TestBlock, Either TestTxError ())]
forall a b. (a -> b) -> a -> b
$ LedgerConfig TestBlock
-> LedgerState TestBlock ValuesMK
-> [GenTx TestBlock]
-> ([(GenTx TestBlock, Either TestTxError ())],
    LedgerState TestBlock ValuesMK)
validateTxs LedgerConfig TestBlock
SimpleLedgerConfig
  SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)
cfg LedgerState TestBlock ValuesMK
ledgerState [GenTx TestBlock]
txsInMempool
    ]

prjTx ::
  (Validated (GenTx TestBlock), TicketNo, TxMeasure TestBlock) ->
  Validated (GenTx TestBlock)
prjTx :: (Validated (GenTx TestBlock), TicketNo, TxMeasure TestBlock)
-> Validated (GenTx TestBlock)
prjTx (Validated (GenTx TestBlock)
a, TicketNo
_b, TxMeasure TestBlock
_c) = Validated (GenTx TestBlock)
a

{-------------------------------------------------------------------------------
  TestSetup: how to set up a TestMempool
-------------------------------------------------------------------------------}

data TestSetup = TestSetup
  { TestSetup -> LedgerConfig TestBlock
testLedgerCfg :: LedgerConfig TestBlock
  , TestSetup -> LedgerState TestBlock ValuesMK
testLedgerState :: LedgerState TestBlock ValuesMK
  -- ^ The ledger state resulting from the last of 'testInitialTxs'.
  , TestSetup -> [GenTx TestBlock]
testInitialTxs :: [TestTx]
  -- ^ These are all valid and will be the initial contents of the Mempool.
  , TestSetup -> MempoolCapacityBytesOverride
testMempoolCapOverride :: MempoolCapacityBytesOverride
  -- ^ An override. Most generators ensure the mempool capacity fits at least
  -- 'testInitialTxs', but that's not a necessity. (Recall that mere time
  -- passing can cause an epoch/era change, which can lower the capacity.)
  }
  deriving Int -> TestSetup -> String -> String
[TestSetup] -> String -> String
TestSetup -> String
(Int -> TestSetup -> String -> String)
-> (TestSetup -> String)
-> ([TestSetup] -> String -> String)
-> Show TestSetup
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestSetup -> String -> String
showsPrec :: Int -> TestSetup -> String -> String
$cshow :: TestSetup -> String
show :: TestSetup -> String
$cshowList :: [TestSetup] -> String -> String
showList :: [TestSetup] -> String -> String
Show

ppTestSetup :: TestSetup -> String
ppTestSetup :: TestSetup -> String
ppTestSetup
  TestSetup
    { [GenTx TestBlock]
testInitialTxs :: TestSetup -> [GenTx TestBlock]
testInitialTxs :: [GenTx TestBlock]
testInitialTxs
    , MempoolCapacityBytesOverride
testMempoolCapOverride :: TestSetup -> MempoolCapacityBytesOverride
testMempoolCapOverride :: MempoolCapacityBytesOverride
testMempoolCapOverride
    } =
    [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
      [String
"Initial contents of the Mempool:"]
        [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> ((GenTx TestBlock -> String) -> [GenTx TestBlock] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map GenTx TestBlock -> String
ppTestTxWithHash [GenTx TestBlock]
testInitialTxs)
        [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"Total size:"]
        [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [ByteSize32 -> String
forall a. Show a => a -> String
show (ByteSize32 -> String) -> ByteSize32 -> String
forall a b. (a -> b) -> a -> b
$ (GenTx TestBlock -> ByteSize32) -> [GenTx TestBlock] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GenTx TestBlock -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize ([GenTx TestBlock] -> ByteSize32)
-> [GenTx TestBlock] -> ByteSize32
forall a b. (a -> b) -> a -> b
$ [GenTx TestBlock]
testInitialTxs]
        [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"Mempool capacity override:"]
        [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [MempoolCapacityBytesOverride -> String
forall a. Show a => a -> String
show MempoolCapacityBytesOverride
testMempoolCapOverride]

ppTestTxWithHash :: TestTx -> String
ppTestTxWithHash :: GenTx TestBlock -> String
ppTestTxWithHash GenTx TestBlock
x =
  (Hash SHA256 Tx, GenTx TestBlock) -> String
forall a. Condense a => a -> String
condense
    ((Tx -> Encoding) -> Tx -> Hash SHA256 Tx
forall h a. HashAlgorithm h => (a -> Encoding) -> a -> Hash h a
hashWithSerialiser Tx -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (GenTx TestBlock -> Tx
forall c ext. GenTx (SimpleBlock c ext) -> Tx
simpleGenTx GenTx TestBlock
x) :: Hash SHA256 Tx, GenTx TestBlock
x)

-- | Generate a 'TestSetup' and return the ledger obtained by applying all of
-- the initial transactions.
--
-- The generated 'testMempoolCap' will be:
-- > foldMap 'genTxSize' 'testInitialTxs' + extraCapacity
genTestSetupWithExtraCapacity ::
  Int -> ByteSize32 -> Gen (TestSetup, LedgerState TestBlock ValuesMK)
genTestSetupWithExtraCapacity :: Int
-> ByteSize32 -> Gen (TestSetup, LedgerState TestBlock ValuesMK)
genTestSetupWithExtraCapacity Int
maxInitialTxs ByteSize32
extraCapacity = do
  ledgerSize <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
maxInitialTxs)
  nbInitialTxs <- choose (0, maxInitialTxs)
  (_txs1, ledger1) <- genValidTxs ledgerSize testInitLedger
  (txs2, ledger2) <- genValidTxs nbInitialTxs ledger1
  let initTxsSizeInBytes = (GenTx TestBlock -> ByteSize32) -> [GenTx TestBlock] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GenTx TestBlock -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize [GenTx TestBlock]
txs2
      mpCap = ByteSize32
initTxsSizeInBytes ByteSize32 -> ByteSize32 -> ByteSize32
forall a. Semigroup a => a -> a -> a
<> ByteSize32
extraCapacity
      testSetup =
        TestSetup
          { testLedgerCfg :: LedgerConfig TestBlock
testLedgerCfg = LedgerConfig TestBlock
testLedgerConfigNoSizeLimits
          , testLedgerState :: LedgerState TestBlock ValuesMK
testLedgerState = LedgerState TestBlock ValuesMK
ledger1
          , testInitialTxs :: [GenTx TestBlock]
testInitialTxs = [GenTx TestBlock]
txs2
          , testMempoolCapOverride :: MempoolCapacityBytesOverride
testMempoolCapOverride = ByteSize32 -> MempoolCapacityBytesOverride
MempoolCapacityBytesOverride ByteSize32
mpCap
          }
  return (testSetup, ledger2)

-- | Generate a 'TestSetup' and return the ledger obtained by applying all of
-- the initial transactions. Generates setups with a fixed
-- 'MempoolCapacityBytesOverride', no 'NoMempoolCapacityBytesOverride'.
genTestSetup :: Int -> Gen (TestSetup, LedgerState TestBlock ValuesMK)
genTestSetup :: Int -> Gen (TestSetup, LedgerState TestBlock ValuesMK)
genTestSetup Int
maxInitialTxs =
  Int
-> ByteSize32 -> Gen (TestSetup, LedgerState TestBlock ValuesMK)
genTestSetupWithExtraCapacity Int
maxInitialTxs (Word32 -> ByteSize32
ByteSize32 Word32
0)

-- | Random 'testMempoolCapOverride', but never smaller than the
-- 'testInitialTxs'.
instance Arbitrary TestSetup where
  arbitrary :: Gen TestSetup
arbitrary = (Int -> Gen TestSetup) -> Gen TestSetup
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen TestSetup) -> Gen TestSetup)
-> (Int -> Gen TestSetup) -> Gen TestSetup
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
    extraCapacity <- (Word32 -> ByteSize32
ByteSize32 (Word32 -> ByteSize32) -> (Int -> Word32) -> Int -> ByteSize32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Int -> ByteSize32) -> Gen Int -> Gen ByteSize32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n)
    testSetup <- fst <$> genTestSetupWithExtraCapacity n extraCapacity
    -- NB this @testSetup@ always has a @MempoolCapacityOverride@.
    noOverride <- arbitrary
    let initialSize = (GenTx TestBlock -> ByteSize32) -> [GenTx TestBlock] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GenTx TestBlock -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize ([GenTx TestBlock] -> ByteSize32)
-> [GenTx TestBlock] -> ByteSize32
forall a b. (a -> b) -> a -> b
$ TestSetup -> [GenTx TestBlock]
testInitialTxs TestSetup
testSetup
        defaultCap = ByteSize32
simpleBlockCapacity ByteSize32 -> ByteSize32 -> ByteSize32
forall a. Semigroup a => a -> a -> a
<> ByteSize32
simpleBlockCapacity
    return $
      if noOverride && initialSize <= defaultCap
        then testSetup{testMempoolCapOverride = NoMempoolCapacityBytesOverride}
        else testSetup

  shrink :: TestSetup -> [TestSetup]
shrink
    TestSetup
      { LedgerConfig TestBlock
testLedgerCfg :: TestSetup -> LedgerConfig TestBlock
testLedgerCfg :: LedgerConfig TestBlock
testLedgerCfg
      , LedgerState TestBlock ValuesMK
testLedgerState :: TestSetup -> LedgerState TestBlock ValuesMK
testLedgerState :: LedgerState TestBlock ValuesMK
testLedgerState
      , [GenTx TestBlock]
testInitialTxs :: TestSetup -> [GenTx TestBlock]
testInitialTxs :: [GenTx TestBlock]
testInitialTxs
      , testMempoolCapOverride :: TestSetup -> MempoolCapacityBytesOverride
testMempoolCapOverride =
        MempoolCapacityBytesOverride (ByteSize32 Word32
mpCap)
      } =
      -- TODO we could shrink @testLedgerState@ too
      [ TestSetup
          { LedgerConfig TestBlock
testLedgerCfg :: LedgerConfig TestBlock
testLedgerCfg :: LedgerConfig TestBlock
testLedgerCfg
          , LedgerState TestBlock ValuesMK
testLedgerState :: LedgerState TestBlock ValuesMK
testLedgerState :: LedgerState TestBlock ValuesMK
testLedgerState
          , testInitialTxs :: [GenTx TestBlock]
testInitialTxs = [GenTx TestBlock]
testInitialTxs'
          , testMempoolCapOverride :: MempoolCapacityBytesOverride
testMempoolCapOverride =
              ByteSize32 -> MempoolCapacityBytesOverride
MempoolCapacityBytesOverride ByteSize32
mpCap'
          }
      | let ByteSize32 Word32
initial = (GenTx TestBlock -> ByteSize32) -> [GenTx TestBlock] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GenTx TestBlock -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize [GenTx TestBlock]
testInitialTxs
            extraCap :: Word32
extraCap = Word32
mpCap Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
initial
      , [GenTx TestBlock]
testInitialTxs' <- (GenTx TestBlock -> [GenTx TestBlock])
-> [GenTx TestBlock] -> [[GenTx TestBlock]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([GenTx TestBlock] -> GenTx TestBlock -> [GenTx TestBlock]
forall a b. a -> b -> a
const []) [GenTx TestBlock]
testInitialTxs
      , Either TestTxError (LedgerState TestBlock ValuesMK) -> Bool
forall a b. Either a b -> Bool
isRight (Either TestTxError (LedgerState TestBlock ValuesMK) -> Bool)
-> Either TestTxError (LedgerState TestBlock ValuesMK) -> Bool
forall a b. (a -> b) -> a -> b
$ LedgerConfig TestBlock
-> LedgerState TestBlock ValuesMK
-> [GenTx TestBlock]
-> Either TestTxError (LedgerState TestBlock ValuesMK)
txsAreValid LedgerConfig TestBlock
testLedgerCfg LedgerState TestBlock ValuesMK
testLedgerState [GenTx TestBlock]
testInitialTxs'
      , let mpCap' :: ByteSize32
mpCap' = (GenTx TestBlock -> ByteSize32) -> [GenTx TestBlock] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GenTx TestBlock -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize [GenTx TestBlock]
testInitialTxs' ByteSize32 -> ByteSize32 -> ByteSize32
forall a. Semigroup a => a -> a -> a
<> Word32 -> ByteSize32
ByteSize32 Word32
extraCap
      ]
  -- TODO shrink to an override, that's an easier test case
  shrink
    TestSetup
      { LedgerConfig TestBlock
testLedgerCfg :: TestSetup -> LedgerConfig TestBlock
testLedgerCfg :: LedgerConfig TestBlock
testLedgerCfg
      , LedgerState TestBlock ValuesMK
testLedgerState :: TestSetup -> LedgerState TestBlock ValuesMK
testLedgerState :: LedgerState TestBlock ValuesMK
testLedgerState
      , [GenTx TestBlock]
testInitialTxs :: TestSetup -> [GenTx TestBlock]
testInitialTxs :: [GenTx TestBlock]
testInitialTxs
      , testMempoolCapOverride :: TestSetup -> MempoolCapacityBytesOverride
testMempoolCapOverride = MempoolCapacityBytesOverride
NoMempoolCapacityBytesOverride
      } =
      -- TODO we could shrink @testLedgerState@ too
      [ TestSetup
          { LedgerConfig TestBlock
testLedgerCfg :: LedgerConfig TestBlock
testLedgerCfg :: LedgerConfig TestBlock
testLedgerCfg
          , LedgerState TestBlock ValuesMK
testLedgerState :: LedgerState TestBlock ValuesMK
testLedgerState :: LedgerState TestBlock ValuesMK
testLedgerState
          , testInitialTxs :: [GenTx TestBlock]
testInitialTxs = [GenTx TestBlock]
testInitialTxs'
          , testMempoolCapOverride :: MempoolCapacityBytesOverride
testMempoolCapOverride = MempoolCapacityBytesOverride
NoMempoolCapacityBytesOverride
          }
      | [GenTx TestBlock]
testInitialTxs' <- (GenTx TestBlock -> [GenTx TestBlock])
-> [GenTx TestBlock] -> [[GenTx TestBlock]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([GenTx TestBlock] -> GenTx TestBlock -> [GenTx TestBlock]
forall a b. a -> b -> a
const []) [GenTx TestBlock]
testInitialTxs
      , Either TestTxError (LedgerState TestBlock ValuesMK) -> Bool
forall a b. Either a b -> Bool
isRight (Either TestTxError (LedgerState TestBlock ValuesMK) -> Bool)
-> Either TestTxError (LedgerState TestBlock ValuesMK) -> Bool
forall a b. (a -> b) -> a -> b
$ LedgerConfig TestBlock
-> LedgerState TestBlock ValuesMK
-> [GenTx TestBlock]
-> Either TestTxError (LedgerState TestBlock ValuesMK)
txsAreValid LedgerConfig TestBlock
testLedgerCfg LedgerState TestBlock ValuesMK
testLedgerState [GenTx TestBlock]
testInitialTxs'
      ]

txsAreValid ::
  LedgerConfig TestBlock ->
  LedgerState TestBlock ValuesMK ->
  [TestTx] ->
  Either TestTxError (LedgerState TestBlock ValuesMK)
txsAreValid :: LedgerConfig TestBlock
-> LedgerState TestBlock ValuesMK
-> [GenTx TestBlock]
-> Either TestTxError (LedgerState TestBlock ValuesMK)
txsAreValid LedgerConfig TestBlock
cfg LedgerState TestBlock ValuesMK
ledgerState [GenTx TestBlock]
txs =
  Except TestTxError (LedgerState TestBlock ValuesMK)
-> Either TestTxError (LedgerState TestBlock ValuesMK)
forall e a. Except e a -> Either e a
runExcept (Except TestTxError (LedgerState TestBlock ValuesMK)
 -> Either TestTxError (LedgerState TestBlock ValuesMK))
-> Except TestTxError (LedgerState TestBlock ValuesMK)
-> Either TestTxError (LedgerState TestBlock ValuesMK)
forall a b. (a -> b) -> a -> b
$ (GenTx TestBlock
 -> LedgerState TestBlock ValuesMK
 -> Except TestTxError (LedgerState TestBlock ValuesMK))
-> [GenTx TestBlock]
-> LedgerState TestBlock ValuesMK
-> Except TestTxError (LedgerState TestBlock ValuesMK)
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m b) -> [a] -> b -> m b
repeatedlyM ((LedgerState TestBlock ValuesMK
 -> GenTx TestBlock
 -> ExceptT
      (MockError TestBlock) Identity (LedgerState TestBlock ValuesMK))
-> GenTx TestBlock
-> LedgerState TestBlock ValuesMK
-> ExceptT
     (MockError TestBlock) Identity (LedgerState TestBlock ValuesMK)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (LedgerConfig TestBlock
-> LedgerState TestBlock ValuesMK
-> GenTx TestBlock
-> Except TestTxError (LedgerState TestBlock ValuesMK)
applyTxToLedger LedgerConfig TestBlock
cfg)) [GenTx TestBlock]
txs LedgerState TestBlock ValuesMK
ledgerState

validateTxs ::
  LedgerConfig TestBlock ->
  LedgerState TestBlock ValuesMK ->
  [TestTx] ->
  ([(TestTx, Either TestTxError ())], LedgerState TestBlock ValuesMK)
validateTxs :: LedgerConfig TestBlock
-> LedgerState TestBlock ValuesMK
-> [GenTx TestBlock]
-> ([(GenTx TestBlock, Either TestTxError ())],
    LedgerState TestBlock ValuesMK)
validateTxs LedgerConfig TestBlock
cfg = [(GenTx TestBlock, Either (MockError TestBlock) ())]
-> LedgerState TestBlock ValuesMK
-> [GenTx TestBlock]
-> ([(GenTx TestBlock, Either (MockError TestBlock) ())],
    LedgerState TestBlock ValuesMK)
go []
 where
  go :: [(GenTx TestBlock, Either (MockError TestBlock) ())]
-> LedgerState TestBlock ValuesMK
-> [GenTx TestBlock]
-> ([(GenTx TestBlock, Either (MockError TestBlock) ())],
    LedgerState TestBlock ValuesMK)
go [(GenTx TestBlock, Either (MockError TestBlock) ())]
revalidated LedgerState TestBlock ValuesMK
ledgerState = \case
    [] -> ([(GenTx TestBlock, Either (MockError TestBlock) ())]
-> [(GenTx TestBlock, Either (MockError TestBlock) ())]
forall a. [a] -> [a]
reverse [(GenTx TestBlock, Either (MockError TestBlock) ())]
revalidated, LedgerState TestBlock ValuesMK
ledgerState)
    GenTx TestBlock
tx : [GenTx TestBlock]
txs' -> case ExceptT
  (MockError TestBlock) Identity (LedgerState TestBlock ValuesMK)
-> Either (MockError TestBlock) (LedgerState TestBlock ValuesMK)
forall e a. Except e a -> Either e a
runExcept (LedgerConfig TestBlock
-> LedgerState TestBlock ValuesMK
-> GenTx TestBlock
-> Except TestTxError (LedgerState TestBlock ValuesMK)
applyTxToLedger LedgerConfig TestBlock
cfg LedgerState TestBlock ValuesMK
ledgerState GenTx TestBlock
tx) of
      Left MockError TestBlock
err -> [(GenTx TestBlock, Either (MockError TestBlock) ())]
-> LedgerState TestBlock ValuesMK
-> [GenTx TestBlock]
-> ([(GenTx TestBlock, Either (MockError TestBlock) ())],
    LedgerState TestBlock ValuesMK)
go ((GenTx TestBlock
tx, MockError TestBlock -> Either (MockError TestBlock) ()
forall a b. a -> Either a b
Left MockError TestBlock
err) (GenTx TestBlock, Either (MockError TestBlock) ())
-> [(GenTx TestBlock, Either (MockError TestBlock) ())]
-> [(GenTx TestBlock, Either (MockError TestBlock) ())]
forall a. a -> [a] -> [a]
: [(GenTx TestBlock, Either (MockError TestBlock) ())]
revalidated) LedgerState TestBlock ValuesMK
ledgerState [GenTx TestBlock]
txs'
      Right LedgerState TestBlock ValuesMK
ledgerState' -> [(GenTx TestBlock, Either (MockError TestBlock) ())]
-> LedgerState TestBlock ValuesMK
-> [GenTx TestBlock]
-> ([(GenTx TestBlock, Either (MockError TestBlock) ())],
    LedgerState TestBlock ValuesMK)
go ((GenTx TestBlock
tx, () -> Either (MockError TestBlock) ()
forall a b. b -> Either a b
Right ()) (GenTx TestBlock, Either (MockError TestBlock) ())
-> [(GenTx TestBlock, Either (MockError TestBlock) ())]
-> [(GenTx TestBlock, Either (MockError TestBlock) ())]
forall a. a -> [a] -> [a]
: [(GenTx TestBlock, Either (MockError TestBlock) ())]
revalidated) LedgerState TestBlock ValuesMK
ledgerState' [GenTx TestBlock]
txs'

{-------------------------------------------------------------------------------
  TestSetupWithTxs
-------------------------------------------------------------------------------}

data TestSetupWithTxs = TestSetupWithTxs
  { TestSetupWithTxs -> TestSetup
testSetup :: TestSetup
  -- ^ The capacity allows at least for the /valid/ 'txs' to be added.
  , TestSetupWithTxs -> [(GenTx TestBlock, Bool)]
txs :: [(TestTx, Bool)]
  -- ^ These txs are not yet in the mempool
  --
  -- The 'Bool' indicates whether the transaction is valid (when they're all
  -- supplied in this order).
  }
  deriving Int -> TestSetupWithTxs -> String -> String
[TestSetupWithTxs] -> String -> String
TestSetupWithTxs -> String
(Int -> TestSetupWithTxs -> String -> String)
-> (TestSetupWithTxs -> String)
-> ([TestSetupWithTxs] -> String -> String)
-> Show TestSetupWithTxs
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestSetupWithTxs -> String -> String
showsPrec :: Int -> TestSetupWithTxs -> String -> String
$cshow :: TestSetupWithTxs -> String
show :: TestSetupWithTxs -> String
$cshowList :: [TestSetupWithTxs] -> String -> String
showList :: [TestSetupWithTxs] -> String -> String
Show

ppTxs :: [(TestTx, Bool)] -> String
ppTxs :: [(GenTx TestBlock, Bool)] -> String
ppTxs [(GenTx TestBlock, Bool)]
txs =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [String
"Transactions:"]
      [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [ GenTx TestBlock -> String
forall a. Condense a => a -> String
condense GenTx TestBlock
tx String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> if Bool
valid then String
"VALID" else String
"INVALID"
         | (GenTx TestBlock
tx, Bool
valid) <- [(GenTx TestBlock, Bool)]
txs
         ]

allTxs :: TestSetupWithTxs -> [GenTx TestBlock]
allTxs :: TestSetupWithTxs -> [GenTx TestBlock]
allTxs = ((GenTx TestBlock, Bool) -> GenTx TestBlock)
-> [(GenTx TestBlock, Bool)] -> [GenTx TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx TestBlock, Bool) -> GenTx TestBlock
forall a b. (a, b) -> a
fst ([(GenTx TestBlock, Bool)] -> [GenTx TestBlock])
-> (TestSetupWithTxs -> [(GenTx TestBlock, Bool)])
-> TestSetupWithTxs
-> [GenTx TestBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetupWithTxs -> [(GenTx TestBlock, Bool)]
txs

validTxs :: TestSetupWithTxs -> [GenTx TestBlock]
validTxs :: TestSetupWithTxs -> [GenTx TestBlock]
validTxs = ((GenTx TestBlock, Bool) -> GenTx TestBlock)
-> [(GenTx TestBlock, Bool)] -> [GenTx TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx TestBlock, Bool) -> GenTx TestBlock
forall a b. (a, b) -> a
fst ([(GenTx TestBlock, Bool)] -> [GenTx TestBlock])
-> (TestSetupWithTxs -> [(GenTx TestBlock, Bool)])
-> TestSetupWithTxs
-> [GenTx TestBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((GenTx TestBlock, Bool) -> Bool)
-> [(GenTx TestBlock, Bool)] -> [(GenTx TestBlock, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (GenTx TestBlock, Bool) -> Bool
forall a b. (a, b) -> b
snd ([(GenTx TestBlock, Bool)] -> [(GenTx TestBlock, Bool)])
-> (TestSetupWithTxs -> [(GenTx TestBlock, Bool)])
-> TestSetupWithTxs
-> [(GenTx TestBlock, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetupWithTxs -> [(GenTx TestBlock, Bool)]
txs

invalidTxs :: TestSetupWithTxs -> [GenTx TestBlock]
invalidTxs :: TestSetupWithTxs -> [GenTx TestBlock]
invalidTxs = ((GenTx TestBlock, Bool) -> GenTx TestBlock)
-> [(GenTx TestBlock, Bool)] -> [GenTx TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx TestBlock, Bool) -> GenTx TestBlock
forall a b. (a, b) -> a
fst ([(GenTx TestBlock, Bool)] -> [GenTx TestBlock])
-> (TestSetupWithTxs -> [(GenTx TestBlock, Bool)])
-> TestSetupWithTxs
-> [GenTx TestBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((GenTx TestBlock, Bool) -> Bool)
-> [(GenTx TestBlock, Bool)] -> [(GenTx TestBlock, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((GenTx TestBlock, Bool) -> Bool)
-> (GenTx TestBlock, Bool)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenTx TestBlock, Bool) -> Bool
forall a b. (a, b) -> b
snd) ([(GenTx TestBlock, Bool)] -> [(GenTx TestBlock, Bool)])
-> (TestSetupWithTxs -> [(GenTx TestBlock, Bool)])
-> TestSetupWithTxs
-> [(GenTx TestBlock, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetupWithTxs -> [(GenTx TestBlock, Bool)]
txs

{-
Note [Transaction size limit]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

An important property of the mempool is that adding a transaction that can never
fit into the mempool must not block, also see
https://github.com/IntersectMBO/ouroboros-consensus/issues/1226. We test this
while generating a TestSetupWithTxs by always including a transaction that is
larger than the entire mempool, and setting the per-tx size limit such that just
this transaction is invalid due to its size, but not impacting the validity of
any other transactions. Therefore, we disable the size limit in e.g.
'genValidTx' to only capture UTxO-related validity for them by using an
appropriate ledger config ('testLedgerConfigNoSizeLimits').
-}

instance Arbitrary TestSetupWithTxs where
  arbitrary :: Gen TestSetupWithTxs
arbitrary = (Int -> Gen TestSetupWithTxs) -> Gen TestSetupWithTxs
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen TestSetupWithTxs) -> Gen TestSetupWithTxs)
-> (Int -> Gen TestSetupWithTxs) -> Gen TestSetupWithTxs
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
    nbTxs <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n)
    (testSetup, ledger) <- genTestSetup n
    (txs, _ledger') <- genTxs nbTxs ledger
    testSetup' <- case testMempoolCapOverride testSetup of
      MempoolCapacityBytesOverride
NoMempoolCapacityBytesOverride -> String -> Gen TestSetup
forall a. HasCallStack => String -> a
error String
"unreachable"
      MempoolCapacityBytesOverride ByteSize32
mpCap -> do
        noOverride <- Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
        let initialSize = (GenTx TestBlock -> ByteSize32) -> [GenTx TestBlock] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GenTx TestBlock -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize ([GenTx TestBlock] -> ByteSize32)
-> [GenTx TestBlock] -> ByteSize32
forall a b. (a -> b) -> a -> b
$ TestSetup -> [GenTx TestBlock]
testInitialTxs TestSetup
testSetup
            defaultCap = ByteSize32
simpleBlockCapacity ByteSize32 -> ByteSize32 -> ByteSize32
forall a. Semigroup a => a -> a -> a
<> ByteSize32
simpleBlockCapacity
            newSize =
              ((GenTx TestBlock, Bool) -> ByteSize32)
-> [(GenTx TestBlock, Bool)] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (GenTx TestBlock -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize (GenTx TestBlock -> ByteSize32)
-> ((GenTx TestBlock, Bool) -> GenTx TestBlock)
-> (GenTx TestBlock, Bool)
-> ByteSize32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenTx TestBlock, Bool) -> GenTx TestBlock
forall a b. (a, b) -> a
fst) (((GenTx TestBlock, Bool) -> Bool)
-> [(GenTx TestBlock, Bool)] -> [(GenTx TestBlock, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (GenTx TestBlock, Bool) -> Bool
forall a b. (a, b) -> b
snd [(GenTx TestBlock, Bool)]
txs)
                ByteSize32 -> ByteSize32 -> ByteSize32
forall a. Semigroup a => a -> a -> a
<> [ByteSize32] -> ByteSize32
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Word32 -> ByteSize32
ByteSize32 Word32
0 ByteSize32 -> [ByteSize32] -> [ByteSize32]
forall a. a -> [a] -> [a]
: ((GenTx TestBlock, Bool) -> ByteSize32)
-> [(GenTx TestBlock, Bool)] -> [ByteSize32]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx TestBlock -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize (GenTx TestBlock -> ByteSize32)
-> ((GenTx TestBlock, Bool) -> GenTx TestBlock)
-> (GenTx TestBlock, Bool)
-> ByteSize32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenTx TestBlock, Bool) -> GenTx TestBlock
forall a b. (a, b) -> a
fst) (((GenTx TestBlock, Bool) -> Bool)
-> [(GenTx TestBlock, Bool)] -> [(GenTx TestBlock, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((GenTx TestBlock, Bool) -> Bool)
-> (GenTx TestBlock, Bool)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenTx TestBlock, Bool) -> Bool
forall a b. (a, b) -> b
snd) [(GenTx TestBlock, Bool)]
txs))
        return
          testSetup
            { testMempoolCapOverride =
                if noOverride && initialSize <> newSize <= defaultCap
                  then NoMempoolCapacityBytesOverride
                  else MempoolCapacityBytesOverride $ mpCap <> newSize
            }
    let mempoolCap :: TheMeasure
        mempoolCap =
          LedgerConfig TestBlock
-> TickedLedgerState TestBlock ValuesMK
-> MempoolCapacityBytesOverride
-> TxMeasure TestBlock
forall blk (mk :: * -> * -> *).
LedgerSupportsMempool blk =>
LedgerConfig blk
-> TickedLedgerState blk mk
-> MempoolCapacityBytesOverride
-> TxMeasure blk
computeMempoolCapacity
            LedgerConfig TestBlock
testLedgerConfigNoSizeLimits
            (LedgerState TestBlock ValuesMK
-> TickedLedgerState TestBlock ValuesMK
forall c ext (mk :: * -> * -> *).
LedgerState (SimpleBlock c ext) mk
-> Ticked LedgerState (SimpleBlock c ext) mk
TickedSimpleLedgerState LedgerState TestBlock ValuesMK
ledger)
            (TestSetup -> MempoolCapacityBytesOverride
testMempoolCapOverride TestSetup
testSetup')

    largeInvalidTx <- genLargeInvalidTx mempoolCap
    let txs' = (GenTx TestBlock
largeInvalidTx, Bool
False) (GenTx TestBlock, Bool)
-> [(GenTx TestBlock, Bool)] -> [(GenTx TestBlock, Bool)]
forall a. a -> [a] -> [a]
: [(GenTx TestBlock, Bool)]
txs
        -- Set the maximum tx size to the mempool capacity. This won't
        -- invalidate any valid tx in @txs@ as the capacity was chosen such that
        -- all @txs@ fit into the mempool. Also see Note [Transaction size
        -- limit].
        testSetup'' =
          TestSetup
testSetup'
            { testLedgerCfg =
                (testLedgerCfg testSetup')
                  { simpleLedgerMockConfig =
                      MockConfig
                        { mockCfgMaxTxSize = Just (unIgnoringOverflow mempoolCap)
                        }
                  }
            }

    return TestSetupWithTxs{testSetup = testSetup'', txs = txs'}

  shrink :: TestSetupWithTxs -> [TestSetupWithTxs]
shrink TestSetupWithTxs{TestSetup
testSetup :: TestSetupWithTxs -> TestSetup
testSetup :: TestSetup
testSetup, [(GenTx TestBlock, Bool)]
txs :: TestSetupWithTxs -> [(GenTx TestBlock, Bool)]
txs :: [(GenTx TestBlock, Bool)]
txs} =
    [ TestSetupWithTxs{testSetup :: TestSetup
testSetup = TestSetup
testSetup', [(GenTx TestBlock, Bool)]
txs :: [(GenTx TestBlock, Bool)]
txs :: [(GenTx TestBlock, Bool)]
txs}
    | TestSetup
testSetup' <- TestSetup -> [TestSetup]
forall a. Arbitrary a => a -> [a]
shrink TestSetup
testSetup
    ]
      [TestSetupWithTxs] -> [TestSetupWithTxs] -> [TestSetupWithTxs]
forall a. Semigroup a => a -> a -> a
<> [ TestSetupWithTxs{TestSetup
testSetup :: TestSetup
testSetup :: TestSetup
testSetup, txs :: [(GenTx TestBlock, Bool)]
txs = [(GenTx TestBlock, Bool)]
txs'}
         | [(GenTx TestBlock, Bool)]
txs' <-
             ([GenTx TestBlock] -> [(GenTx TestBlock, Bool)])
-> [[GenTx TestBlock]] -> [[(GenTx TestBlock, Bool)]]
forall a b. (a -> b) -> [a] -> [b]
map (((GenTx TestBlock, Either (MockError TestBlock) ())
 -> (GenTx TestBlock, Bool))
-> [(GenTx TestBlock, Either (MockError TestBlock) ())]
-> [(GenTx TestBlock, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map ((Either (MockError TestBlock) () -> Bool)
-> (GenTx TestBlock, Either (MockError TestBlock) ())
-> (GenTx TestBlock, Bool)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Either (MockError TestBlock) () -> Bool
forall a b. Either a b -> Bool
isRight) ([(GenTx TestBlock, Either (MockError TestBlock) ())]
 -> [(GenTx TestBlock, Bool)])
-> ([GenTx TestBlock]
    -> [(GenTx TestBlock, Either (MockError TestBlock) ())])
-> [GenTx TestBlock]
-> [(GenTx TestBlock, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(GenTx TestBlock, Either (MockError TestBlock) ())],
 LedgerState TestBlock ValuesMK)
-> [(GenTx TestBlock, Either (MockError TestBlock) ())]
forall a b. (a, b) -> a
fst (([(GenTx TestBlock, Either (MockError TestBlock) ())],
  LedgerState TestBlock ValuesMK)
 -> [(GenTx TestBlock, Either (MockError TestBlock) ())])
-> ([GenTx TestBlock]
    -> ([(GenTx TestBlock, Either (MockError TestBlock) ())],
        LedgerState TestBlock ValuesMK))
-> [GenTx TestBlock]
-> [(GenTx TestBlock, Either (MockError TestBlock) ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetup
-> [GenTx TestBlock]
-> ([(GenTx TestBlock, Either TestTxError ())],
    LedgerState TestBlock ValuesMK)
revalidate TestSetup
testSetup)
               ([[GenTx TestBlock]] -> [[(GenTx TestBlock, Bool)]])
-> ([(GenTx TestBlock, Bool)] -> [[GenTx TestBlock]])
-> [(GenTx TestBlock, Bool)]
-> [[(GenTx TestBlock, Bool)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenTx TestBlock -> [GenTx TestBlock])
-> [GenTx TestBlock] -> [[GenTx TestBlock]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([GenTx TestBlock] -> GenTx TestBlock -> [GenTx TestBlock]
forall a b. a -> b -> a
const [])
               ([GenTx TestBlock] -> [[GenTx TestBlock]])
-> ([(GenTx TestBlock, Bool)] -> [GenTx TestBlock])
-> [(GenTx TestBlock, Bool)]
-> [[GenTx TestBlock]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((GenTx TestBlock, Bool) -> GenTx TestBlock)
-> [(GenTx TestBlock, Bool)] -> [GenTx TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx TestBlock, Bool) -> GenTx TestBlock
forall a b. (a, b) -> a
fst
               ([(GenTx TestBlock, Bool)] -> [[(GenTx TestBlock, Bool)]])
-> [(GenTx TestBlock, Bool)] -> [[(GenTx TestBlock, Bool)]]
forall a b. (a -> b) -> a -> b
$ [(GenTx TestBlock, Bool)]
txs
         ]

revalidate ::
  TestSetup ->
  [TestTx] ->
  ([(TestTx, Either TestTxError ())], LedgerState TestBlock ValuesMK)
revalidate :: TestSetup
-> [GenTx TestBlock]
-> ([(GenTx TestBlock, Either TestTxError ())],
    LedgerState TestBlock ValuesMK)
revalidate TestSetup{LedgerConfig TestBlock
testLedgerCfg :: TestSetup -> LedgerConfig TestBlock
testLedgerCfg :: LedgerConfig TestBlock
testLedgerCfg, LedgerState TestBlock ValuesMK
testLedgerState :: TestSetup -> LedgerState TestBlock ValuesMK
testLedgerState :: LedgerState TestBlock ValuesMK
testLedgerState, [GenTx TestBlock]
testInitialTxs :: TestSetup -> [GenTx TestBlock]
testInitialTxs :: [GenTx TestBlock]
testInitialTxs} =
  LedgerConfig TestBlock
-> LedgerState TestBlock ValuesMK
-> [GenTx TestBlock]
-> ([(GenTx TestBlock, Either TestTxError ())],
    LedgerState TestBlock ValuesMK)
validateTxs LedgerConfig TestBlock
testLedgerCfg LedgerState TestBlock ValuesMK
initLedgerState
 where
  -- The LedgerState after adding the transactions initially in the mempool
  initLedgerState :: LedgerState TestBlock ValuesMK
initLedgerState =
    (GenTx TestBlock
 -> LedgerState TestBlock ValuesMK
 -> LedgerState TestBlock ValuesMK)
-> [GenTx TestBlock]
-> LedgerState TestBlock ValuesMK
-> LedgerState TestBlock ValuesMK
forall a b. (a -> b -> b) -> [a] -> b -> b
repeatedly
      (\GenTx TestBlock
tx LedgerState TestBlock ValuesMK
l -> HasCallStack =>
Except TestTxError (LedgerState TestBlock ValuesMK)
-> LedgerState TestBlock ValuesMK
Except TestTxError (LedgerState TestBlock ValuesMK)
-> LedgerState TestBlock ValuesMK
mustBeValid (LedgerConfig TestBlock
-> LedgerState TestBlock ValuesMK
-> GenTx TestBlock
-> Except TestTxError (LedgerState TestBlock ValuesMK)
applyTxToLedger LedgerConfig TestBlock
testLedgerCfg LedgerState TestBlock ValuesMK
l GenTx TestBlock
tx))
      [GenTx TestBlock]
testInitialTxs
      LedgerState TestBlock ValuesMK
testLedgerState

{-------------------------------------------------------------------------------
  TestSetupWithTxInMempol: a mempool and a transaction that is in the mempool
-------------------------------------------------------------------------------}

-- | A 'TestSetup' along with a transaction that is in the Mempool.
--
-- > 'txInMempool' `elem` 'testInitialTxs' 'testSetup'
data TestSetupWithTxInMempool = TestSetupWithTxInMempool TestSetup TestTx
  deriving Int -> TestSetupWithTxInMempool -> String -> String
[TestSetupWithTxInMempool] -> String -> String
TestSetupWithTxInMempool -> String
(Int -> TestSetupWithTxInMempool -> String -> String)
-> (TestSetupWithTxInMempool -> String)
-> ([TestSetupWithTxInMempool] -> String -> String)
-> Show TestSetupWithTxInMempool
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestSetupWithTxInMempool -> String -> String
showsPrec :: Int -> TestSetupWithTxInMempool -> String -> String
$cshow :: TestSetupWithTxInMempool -> String
show :: TestSetupWithTxInMempool -> String
$cshowList :: [TestSetupWithTxInMempool] -> String -> String
showList :: [TestSetupWithTxInMempool] -> String -> String
Show

instance Arbitrary TestSetupWithTxInMempool where
  arbitrary :: Gen TestSetupWithTxInMempool
arbitrary = do
    TestSetupWithTxs{testSetup} <-
      Gen TestSetupWithTxs
forall a. Arbitrary a => Gen a
arbitrary Gen TestSetupWithTxs
-> (TestSetupWithTxs -> Bool) -> Gen TestSetupWithTxs
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Bool -> Bool
not (Bool -> Bool)
-> (TestSetupWithTxs -> Bool) -> TestSetupWithTxs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenTx TestBlock] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([GenTx TestBlock] -> Bool)
-> (TestSetupWithTxs -> [GenTx TestBlock])
-> TestSetupWithTxs
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetup -> [GenTx TestBlock]
testInitialTxs (TestSetup -> [GenTx TestBlock])
-> (TestSetupWithTxs -> TestSetup)
-> TestSetupWithTxs
-> [GenTx TestBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetupWithTxs -> TestSetup
testSetup)
    tx <- elements (testInitialTxs testSetup)
    return $ TestSetupWithTxInMempool testSetup tx

  shrink :: TestSetupWithTxInMempool -> [TestSetupWithTxInMempool]
shrink (TestSetupWithTxInMempool TestSetup
testSetup GenTx TestBlock
_tx) =
    [ TestSetup -> GenTx TestBlock -> TestSetupWithTxInMempool
TestSetupWithTxInMempool TestSetup
testSetup' GenTx TestBlock
tx'
    | TestSetup
testSetup' <- TestSetup -> [TestSetup]
forall a. Arbitrary a => a -> [a]
shrink TestSetup
testSetup
    , Bool -> Bool
not (Bool -> Bool) -> (TestSetup -> Bool) -> TestSetup -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenTx TestBlock] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([GenTx TestBlock] -> Bool)
-> (TestSetup -> [GenTx TestBlock]) -> TestSetup -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetup -> [GenTx TestBlock]
testInitialTxs (TestSetup -> Bool) -> TestSetup -> Bool
forall a b. (a -> b) -> a -> b
$ TestSetup
testSetup'
    , GenTx TestBlock
tx' <- TestSetup -> [GenTx TestBlock]
testInitialTxs TestSetup
testSetup'
    ]

-- | 'testInitialTxs' is nonempty and the juxtaposed list of txs is
-- 'testInitialTxs' with any number of elements randomly dropped.
--
-- FYI, the 'TestSetupWithTxsInMempoolToRemove' type is similar, but the list
-- of txs is definitely nonempty.
data TestSetupWithTxsInMempool = TestSetupWithTxsInMempool TestSetup [TestTx]
  deriving Int -> TestSetupWithTxsInMempool -> String -> String
[TestSetupWithTxsInMempool] -> String -> String
TestSetupWithTxsInMempool -> String
(Int -> TestSetupWithTxsInMempool -> String -> String)
-> (TestSetupWithTxsInMempool -> String)
-> ([TestSetupWithTxsInMempool] -> String -> String)
-> Show TestSetupWithTxsInMempool
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestSetupWithTxsInMempool -> String -> String
showsPrec :: Int -> TestSetupWithTxsInMempool -> String -> String
$cshow :: TestSetupWithTxsInMempool -> String
show :: TestSetupWithTxsInMempool -> String
$cshowList :: [TestSetupWithTxsInMempool] -> String -> String
showList :: [TestSetupWithTxsInMempool] -> String -> String
Show

instance Arbitrary TestSetupWithTxsInMempool where
  arbitrary :: Gen TestSetupWithTxsInMempool
arbitrary = do
    TestSetupWithTxs{testSetup} <-
      Gen TestSetupWithTxs
forall a. Arbitrary a => Gen a
arbitrary Gen TestSetupWithTxs
-> (TestSetupWithTxs -> Bool) -> Gen TestSetupWithTxs
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Bool -> Bool
not (Bool -> Bool)
-> (TestSetupWithTxs -> Bool) -> TestSetupWithTxs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenTx TestBlock] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([GenTx TestBlock] -> Bool)
-> (TestSetupWithTxs -> [GenTx TestBlock])
-> TestSetupWithTxs
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetup -> [GenTx TestBlock]
testInitialTxs (TestSetup -> [GenTx TestBlock])
-> (TestSetupWithTxs -> TestSetup)
-> TestSetupWithTxs
-> [GenTx TestBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetupWithTxs -> TestSetup
testSetup)
    txs <- sublistOf (testInitialTxs testSetup)
    return $ TestSetupWithTxsInMempool testSetup txs

-- TODO shrink

-- | Like 'TestSetupWithTxsInMempool', but the list of txs is nonempty.
data TestSetupWithTxsInMempoolToRemove
  = TestSetupWithTxsInMempoolToRemove TestSetup (NE.NonEmpty TestTx)
  deriving Int -> TestSetupWithTxsInMempoolToRemove -> String -> String
[TestSetupWithTxsInMempoolToRemove] -> String -> String
TestSetupWithTxsInMempoolToRemove -> String
(Int -> TestSetupWithTxsInMempoolToRemove -> String -> String)
-> (TestSetupWithTxsInMempoolToRemove -> String)
-> ([TestSetupWithTxsInMempoolToRemove] -> String -> String)
-> Show TestSetupWithTxsInMempoolToRemove
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestSetupWithTxsInMempoolToRemove -> String -> String
showsPrec :: Int -> TestSetupWithTxsInMempoolToRemove -> String -> String
$cshow :: TestSetupWithTxsInMempoolToRemove -> String
show :: TestSetupWithTxsInMempoolToRemove -> String
$cshowList :: [TestSetupWithTxsInMempoolToRemove] -> String -> String
showList :: [TestSetupWithTxsInMempoolToRemove] -> String -> String
Show

instance Arbitrary TestSetupWithTxsInMempoolToRemove where
  arbitrary :: Gen TestSetupWithTxsInMempoolToRemove
arbitrary =
    (TestSetupWithTxsInMempool -> TestSetupWithTxsInMempoolToRemove)
-> Gen TestSetupWithTxsInMempool
-> Gen TestSetupWithTxsInMempoolToRemove
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TestSetupWithTxsInMempool -> TestSetupWithTxsInMempoolToRemove
convertToRemove (Gen TestSetupWithTxsInMempool
 -> Gen TestSetupWithTxsInMempoolToRemove)
-> Gen TestSetupWithTxsInMempool
-> Gen TestSetupWithTxsInMempoolToRemove
forall a b. (a -> b) -> a -> b
$
      Gen TestSetupWithTxsInMempool
forall a. Arbitrary a => Gen a
arbitrary Gen TestSetupWithTxsInMempool
-> (TestSetupWithTxsInMempool -> Bool)
-> Gen TestSetupWithTxsInMempool
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` TestSetupWithTxsInMempool -> Bool
thereIsAtLeastOneTx

  shrink :: TestSetupWithTxsInMempoolToRemove
-> [TestSetupWithTxsInMempoolToRemove]
shrink =
    (TestSetupWithTxsInMempool -> TestSetupWithTxsInMempoolToRemove)
-> [TestSetupWithTxsInMempool]
-> [TestSetupWithTxsInMempoolToRemove]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TestSetupWithTxsInMempool -> TestSetupWithTxsInMempoolToRemove
convertToRemove
      ([TestSetupWithTxsInMempool]
 -> [TestSetupWithTxsInMempoolToRemove])
-> (TestSetupWithTxsInMempoolToRemove
    -> [TestSetupWithTxsInMempool])
-> TestSetupWithTxsInMempoolToRemove
-> [TestSetupWithTxsInMempoolToRemove]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestSetupWithTxsInMempool -> Bool)
-> [TestSetupWithTxsInMempool] -> [TestSetupWithTxsInMempool]
forall a. (a -> Bool) -> [a] -> [a]
filter TestSetupWithTxsInMempool -> Bool
thereIsAtLeastOneTx
      ([TestSetupWithTxsInMempool] -> [TestSetupWithTxsInMempool])
-> (TestSetupWithTxsInMempoolToRemove
    -> [TestSetupWithTxsInMempool])
-> TestSetupWithTxsInMempoolToRemove
-> [TestSetupWithTxsInMempool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetupWithTxsInMempool -> [TestSetupWithTxsInMempool]
forall a. Arbitrary a => a -> [a]
shrink
      (TestSetupWithTxsInMempool -> [TestSetupWithTxsInMempool])
-> (TestSetupWithTxsInMempoolToRemove -> TestSetupWithTxsInMempool)
-> TestSetupWithTxsInMempoolToRemove
-> [TestSetupWithTxsInMempool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetupWithTxsInMempoolToRemove -> TestSetupWithTxsInMempool
revertToRemove

thereIsAtLeastOneTx :: TestSetupWithTxsInMempool -> Bool
thereIsAtLeastOneTx :: TestSetupWithTxsInMempool -> Bool
thereIsAtLeastOneTx (TestSetupWithTxsInMempool TestSetup
_ [GenTx TestBlock]
txs) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [GenTx TestBlock] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenTx TestBlock]
txs

convertToRemove :: TestSetupWithTxsInMempool -> TestSetupWithTxsInMempoolToRemove
convertToRemove :: TestSetupWithTxsInMempool -> TestSetupWithTxsInMempoolToRemove
convertToRemove (TestSetupWithTxsInMempool TestSetup
ts [GenTx TestBlock]
txs) =
  TestSetup
-> NonEmpty (GenTx TestBlock) -> TestSetupWithTxsInMempoolToRemove
TestSetupWithTxsInMempoolToRemove TestSetup
ts ([GenTx TestBlock] -> NonEmpty (GenTx TestBlock)
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [GenTx TestBlock]
txs)

revertToRemove :: TestSetupWithTxsInMempoolToRemove -> TestSetupWithTxsInMempool
revertToRemove :: TestSetupWithTxsInMempoolToRemove -> TestSetupWithTxsInMempool
revertToRemove (TestSetupWithTxsInMempoolToRemove TestSetup
ts NonEmpty (GenTx TestBlock)
txs) =
  TestSetup -> [GenTx TestBlock] -> TestSetupWithTxsInMempool
TestSetupWithTxsInMempool TestSetup
ts (NonEmpty (GenTx TestBlock) -> [GenTx TestBlock]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (GenTx TestBlock)
txs)

{-------------------------------------------------------------------------------
  TestMempool: a mempool with random contents
-------------------------------------------------------------------------------}

data TestMempool m = TestMempool
  { forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool :: Mempool m TestBlock
  -- ^ A mempool with random contents.
  --
  -- Starts out synced with the ledger.
  , forall (m :: * -> *).
TestMempool m -> m [TraceEventMempool TestBlock]
getTraceEvents :: m [TraceEventMempool TestBlock]
  -- ^ When called, obtains all events traced after opening the mempool at
  -- the given state from oldest-to-newest.
  --
  -- Events traced while setting up the mempool to contain random contents
  -- are not included.
  , forall (m :: * -> *). TestMempool m -> m ()
eraseTraceEvents :: m ()
  -- ^ Erase the events traced so far. The return of 'getTraceEvents' will
  -- again be an empty list until another event is traced.
  , forall (m :: * -> *).
TestMempool m -> [GenTx TestBlock] -> STM m [Either TestTxError ()]
addTxsToLedger :: [TestTx] -> STM m [Either TestTxError ()]
  -- ^ This function can be used to add transactions to the ledger/chain.
  --
  -- Remember to synchronise the mempool afterwards.
  , forall (m :: * -> *).
TestMempool m -> STM m (LedgerState TestBlock ValuesMK)
getCurrentLedger :: STM m (LedgerState TestBlock ValuesMK)
  -- ^ Return the current ledger.
  }

withTestMempool ::
  forall prop.
  Testable prop =>
  TestSetup ->
  (forall m. (IOLike m, MonadTimer m) => TestMempool m -> m prop) ->
  Property
withTestMempool :: forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempool =
  Maybe MempoolTimeoutConfig
-> TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
forall prop.
Testable prop =>
Maybe MempoolTimeoutConfig
-> TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempoolWithTimeoutConfig
    (Maybe MempoolTimeoutConfig
forall a. Maybe a
Nothing :: Maybe MempoolTimeoutConfig)

-- NOTE: at the end of the test, this function also checks whether the Mempool
-- contents are valid w.r.t. the current ledger.
--
-- NOTE: the test mempool's default capacity is set to a very large value in
-- module "Ouroboros.Consensus.Mock.Ledger.Block". This is why the generators do
-- not care about the mempool capacity when generating transactions for a
-- mempool with the 'NoMempoolCapacityBytesOverride' option set.
withTestMempoolWithTimeoutConfig ::
  forall prop.
  Testable prop =>
  Maybe MempoolTimeoutConfig ->
  TestSetup ->
  (forall m. (IOLike m, MonadTimer m) => TestMempool m -> m prop) ->
  Property
withTestMempoolWithTimeoutConfig :: forall prop.
Testable prop =>
Maybe MempoolTimeoutConfig
-> TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempoolWithTimeoutConfig Maybe MempoolTimeoutConfig
timeoutConfig setup :: TestSetup
setup@TestSetup{[GenTx TestBlock]
LedgerConfig TestBlock
LedgerState TestBlock ValuesMK
MempoolCapacityBytesOverride
testMempoolCapOverride :: TestSetup -> MempoolCapacityBytesOverride
testLedgerCfg :: TestSetup -> LedgerConfig TestBlock
testLedgerState :: TestSetup -> LedgerState TestBlock ValuesMK
testInitialTxs :: TestSetup -> [GenTx TestBlock]
testLedgerCfg :: LedgerConfig TestBlock
testLedgerState :: LedgerState TestBlock ValuesMK
testInitialTxs :: [GenTx TestBlock]
testMempoolCapOverride :: MempoolCapacityBytesOverride
..} forall (m :: * -> *).
(IOLike m, MonadTimer m) =>
TestMempool m -> m prop
prop =
  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (TestSetup -> String
ppTestSetup TestSetup
setup)
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify
      (MempoolCapacityBytesOverride -> Bool
isOverride MempoolCapacityBytesOverride
testMempoolCapOverride)
      String
"MempoolCapacityBytesOverride"
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify
      (Bool -> Bool
not (MempoolCapacityBytesOverride -> Bool
isOverride MempoolCapacityBytesOverride
testMempoolCapOverride))
      String
"NoMempoolCapacityBytesOverride"
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify ([GenTx TestBlock] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenTx TestBlock]
testInitialTxs) String
"empty Mempool"
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (Bool -> Bool
not ([GenTx TestBlock] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenTx TestBlock]
testInitialTxs)) String
"non-empty Mempool"
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow IOSim s Property
forall s. IOSim s Property
forall (m :: * -> *). (IOLike m, MonadTimer m) => m Property
setUpAndRun
 where
  isOverride :: MempoolCapacityBytesOverride -> Bool
isOverride (MempoolCapacityBytesOverride ByteSize32
_) = Bool
True
  isOverride MempoolCapacityBytesOverride
NoMempoolCapacityBytesOverride = Bool
False

  setUpAndRun :: forall m. (IOLike m, MonadTimer m) => m Property
  setUpAndRun :: forall (m :: * -> *). (IOLike m, MonadTimer m) => m Property
setUpAndRun = do
    -- Set up the LedgerInterface
    varCurrentLedgerState <- LedgerState TestBlock ValuesMK
-> m (StrictTVar m (LedgerState TestBlock ValuesMK))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM LedgerState TestBlock ValuesMK
testLedgerState
    let ledgerInterface =
          LedgerInterface
            { getCurrentLedgerState :: STM m (MempoolLedgerDBView m TestBlock)
getCurrentLedgerState = do
                st <- StrictTVar m (LedgerState TestBlock ValuesMK)
-> STM m (LedgerState TestBlock ValuesMK)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (LedgerState TestBlock ValuesMK)
varCurrentLedgerState
                pure $
                  MempoolLedgerDBView
                    (forgetLedgerTables st)
                    ( pure $
                        Right $
                          ReadOnlyForker
                            { roforkerClose = pure ()
                            , roforkerReadTables =
                                pure . ltliftA2 restrictValuesMK (projectLedgerTables st)
                            , roforkerRangeReadTables = const $ pure (emptyLedgerTables, Nothing)
                            , roforkerGetLedgerState = pure $ forgetLedgerTables st
                            , roforkerReadStatistics = pure $ Statistics 0
                            }
                    )
            }

    -- Set up the Tracer
    varEvents <- uncheckedNewTVarM []
    -- TODO use IOSim's dynamicTracer
    let tracer = (TraceEventMempool TestBlock -> m ())
-> Tracer m (TraceEventMempool TestBlock)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceEventMempool TestBlock -> m ())
 -> Tracer m (TraceEventMempool TestBlock))
-> (TraceEventMempool TestBlock -> m ())
-> Tracer m (TraceEventMempool TestBlock)
forall a b. (a -> b) -> a -> b
$ \TraceEventMempool TestBlock
ev -> STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m [TraceEventMempool TestBlock]
-> ([TraceEventMempool TestBlock] -> [TraceEventMempool TestBlock])
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m [TraceEventMempool TestBlock]
varEvents (TraceEventMempool TestBlock
ev TraceEventMempool TestBlock
-> [TraceEventMempool TestBlock] -> [TraceEventMempool TestBlock]
forall a. a -> [a] -> [a]
:)

    -- Open the mempool and add the initial transactions
    mempool <-
      openMempoolWithoutSyncThread
        ledgerInterface
        testLedgerCfg
        testMempoolCapOverride
        timeoutConfig
        tracer
    result <- addTxs mempool testInitialTxs

    -- the invalid transactions are reported in the same order they were
    -- added, so the first error is not the result of a cascade
    sequence_
      [ error $ "Invalid initial transaction: " <> condense invalidTx <> " because of error " <> show err
      | MempoolTxRejected invalidTx err <- result
      ]

    -- Clear the trace
    atomically $ writeTVar varEvents []

    -- Apply the property to the 'TestMempool' record
    res <-
      property
        <$> prop
          TestMempool
            { mempool
            , getTraceEvents = atomically $ reverse <$> readTVar varEvents
            , eraseTraceEvents = atomically $ writeTVar varEvents []
            , addTxsToLedger = addTxsToLedger varCurrentLedgerState
            , getCurrentLedger = readTVar varCurrentLedgerState
            }
    validContents <-
      atomically $
        checkMempoolValidity
          <$> readTVar varCurrentLedgerState
          <*> getSnapshot mempool
    return $ res .&&. validContents

  addTxToLedger ::
    forall m.
    IOLike m =>
    StrictTVar m (LedgerState TestBlock ValuesMK) ->
    TestTx ->
    STM m (Either TestTxError ())
  addTxToLedger :: forall (m :: * -> *).
IOLike m =>
StrictTVar m (LedgerState TestBlock ValuesMK)
-> GenTx TestBlock -> STM m (Either TestTxError ())
addTxToLedger StrictTVar m (LedgerState TestBlock ValuesMK)
varCurrentLedgerState GenTx TestBlock
tx = do
    ledgerState <- StrictTVar m (LedgerState TestBlock ValuesMK)
-> STM m (LedgerState TestBlock ValuesMK)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (LedgerState TestBlock ValuesMK)
varCurrentLedgerState
    case runExcept (applyTxToLedger testLedgerCfg ledgerState tx) of
      Left MockError TestBlock
e -> Either (MockError TestBlock) ()
-> STM m (Either (MockError TestBlock) ())
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (MockError TestBlock) ()
 -> STM m (Either (MockError TestBlock) ()))
-> Either (MockError TestBlock) ()
-> STM m (Either (MockError TestBlock) ())
forall a b. (a -> b) -> a -> b
$ MockError TestBlock -> Either (MockError TestBlock) ()
forall a b. a -> Either a b
Left MockError TestBlock
e
      Right LedgerState TestBlock ValuesMK
ledgerState' -> do
        StrictTVar m (LedgerState TestBlock ValuesMK)
-> LedgerState TestBlock ValuesMK -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (LedgerState TestBlock ValuesMK)
varCurrentLedgerState LedgerState TestBlock ValuesMK
ledgerState'
        Either (MockError TestBlock) ()
-> STM m (Either (MockError TestBlock) ())
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (MockError TestBlock) ()
 -> STM m (Either (MockError TestBlock) ()))
-> Either (MockError TestBlock) ()
-> STM m (Either (MockError TestBlock) ())
forall a b. (a -> b) -> a -> b
$ () -> Either (MockError TestBlock) ()
forall a b. b -> Either a b
Right ()

  addTxsToLedger ::
    forall m.
    IOLike m =>
    StrictTVar m (LedgerState TestBlock ValuesMK) ->
    [TestTx] ->
    STM m [(Either TestTxError ())]
  addTxsToLedger :: forall (m :: * -> *).
IOLike m =>
StrictTVar m (LedgerState TestBlock ValuesMK)
-> [GenTx TestBlock] -> STM m [Either TestTxError ()]
addTxsToLedger StrictTVar m (LedgerState TestBlock ValuesMK)
varCurrentLedgerState [GenTx TestBlock]
txs =
    (GenTx TestBlock -> STM m (Either (MockError TestBlock) ()))
-> [GenTx TestBlock] -> STM m [Either (MockError TestBlock) ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (StrictTVar m (LedgerState TestBlock ValuesMK)
-> GenTx TestBlock -> STM m (Either TestTxError ())
forall (m :: * -> *).
IOLike m =>
StrictTVar m (LedgerState TestBlock ValuesMK)
-> GenTx TestBlock -> STM m (Either TestTxError ())
addTxToLedger StrictTVar m (LedgerState TestBlock ValuesMK)
varCurrentLedgerState) [GenTx TestBlock]
txs

  -- \| Check whether the transactions in the 'MempoolSnapshot' are valid
  -- w.r.t. the current ledger state.
  checkMempoolValidity ::
    LedgerState TestBlock ValuesMK ->
    MempoolSnapshot TestBlock ->
    Property
  checkMempoolValidity :: LedgerState TestBlock ValuesMK
-> MempoolSnapshot TestBlock -> Property
checkMempoolValidity
    LedgerState TestBlock ValuesMK
ledgerState
    MempoolSnapshot
      { [(Validated (GenTx TestBlock), TicketNo, TxMeasure TestBlock)]
snapshotTxs :: forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxs :: [(Validated (GenTx TestBlock), TicketNo, TxMeasure TestBlock)]
snapshotTxs
      , SlotNo
snapshotSlotNo :: forall blk. MempoolSnapshot blk -> SlotNo
snapshotSlotNo :: SlotNo
snapshotSlotNo
      } =
      case Except (MockError TestBlock) (TickedLedgerState TestBlock ValuesMK)
-> Either
     (MockError TestBlock) (TickedLedgerState TestBlock ValuesMK)
forall e a. Except e a -> Either e a
runExcept (Except
   (MockError TestBlock) (TickedLedgerState TestBlock ValuesMK)
 -> Either
      (MockError TestBlock) (TickedLedgerState TestBlock ValuesMK))
-> Except
     (MockError TestBlock) (TickedLedgerState TestBlock ValuesMK)
-> Either
     (MockError TestBlock) (TickedLedgerState TestBlock ValuesMK)
forall a b. (a -> b) -> a -> b
$
        (GenTx TestBlock
 -> TickedLedgerState TestBlock ValuesMK
 -> Except
      (MockError TestBlock) (TickedLedgerState TestBlock ValuesMK))
-> [GenTx TestBlock]
-> TickedLedgerState TestBlock ValuesMK
-> Except
     (MockError TestBlock) (TickedLedgerState TestBlock ValuesMK)
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m b) -> [a] -> b -> m b
repeatedlyM
          GenTx TestBlock
-> TickedLedgerState TestBlock ValuesMK
-> ExceptT
     TestTxError Identity (TickedLedgerState TestBlock ValuesMK)
GenTx TestBlock
-> TickedLedgerState TestBlock ValuesMK
-> Except
     (MockError TestBlock) (TickedLedgerState TestBlock ValuesMK)
forall {blk}.
(LedgerCfg LedgerState blk
 ~ SimpleLedgerConfig
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto),
 LedgerSupportsMempool blk) =>
GenTx blk
-> Ticked LedgerState blk ValuesMK
-> ExceptT
     (ApplyTxErr blk) Identity (Ticked LedgerState blk ValuesMK)
applyTx'
          [Validated (GenTx TestBlock) -> GenTx TestBlock
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated (GenTx TestBlock)
tx | (Validated (GenTx TestBlock)
tx, TicketNo
_, TheMeasure
_) <- [(Validated (GenTx TestBlock), TicketNo, TheMeasure)]
[(Validated (GenTx TestBlock), TicketNo, TxMeasure TestBlock)]
snapshotTxs]
          (LedgerState TestBlock ValuesMK
-> TickedLedgerState TestBlock ValuesMK
forall c ext (mk :: * -> * -> *).
LedgerState (SimpleBlock c ext) mk
-> Ticked LedgerState (SimpleBlock c ext) mk
TickedSimpleLedgerState LedgerState TestBlock ValuesMK
ledgerState) of
        Right TickedLedgerState TestBlock ValuesMK
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
        Left MockError TestBlock
e -> String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (MockError TestBlock -> String
forall a. Show a => a -> String
mkErrMsg MockError TestBlock
e) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
     where
      applyTx' :: GenTx blk
-> Ticked LedgerState blk ValuesMK
-> ExceptT
     (ApplyTxErr blk) Identity (Ticked LedgerState blk ValuesMK)
applyTx' GenTx blk
tx Ticked LedgerState blk ValuesMK
st = do
        st' <-
          LedgerCfg LedgerState blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> Ticked LedgerState blk ValuesMK
-> ExceptT
     (ApplyTxErr blk)
     Identity
     (TickedLedgerState blk DiffMK, Validated (GenTx blk))
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk ValuesMK
-> Except
     (ApplyTxErr blk)
     (TickedLedgerState blk DiffMK, Validated (GenTx blk))
applyTx
            LedgerCfg LedgerState blk
LedgerConfig TestBlock
testLedgerCfg
            WhetherToIntervene
DoNotIntervene
            SlotNo
snapshotSlotNo
            GenTx blk
tx
            Ticked LedgerState blk ValuesMK
st
        pure $ applyDiffs st (fst st')

      mkErrMsg :: a -> String
mkErrMsg a
e =
        String
"At the end of the test, the Mempool contents were invalid: "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
e

{-------------------------------------------------------------------------------
  MempoolCapTestSetup
-------------------------------------------------------------------------------}

-- | Reuse 'TestSetupWithTxs' but just pick a specific capacity based on the
-- transactions to add.
newtype MempoolCapTestSetup = MempoolCapTestSetup TestSetupWithTxs
  deriving Int -> MempoolCapTestSetup -> String -> String
[MempoolCapTestSetup] -> String -> String
MempoolCapTestSetup -> String
(Int -> MempoolCapTestSetup -> String -> String)
-> (MempoolCapTestSetup -> String)
-> ([MempoolCapTestSetup] -> String -> String)
-> Show MempoolCapTestSetup
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> MempoolCapTestSetup -> String -> String
showsPrec :: Int -> MempoolCapTestSetup -> String -> String
$cshow :: MempoolCapTestSetup -> String
show :: MempoolCapTestSetup -> String
$cshowList :: [MempoolCapTestSetup] -> String -> String
showList :: [MempoolCapTestSetup] -> String -> String
Show

instance Arbitrary MempoolCapTestSetup where
  -- TODO: shrink
  arbitrary :: Gen MempoolCapTestSetup
arbitrary = do
    testSetupWithTxs@TestSetupWithTxs{testSetup, txs} <- Gen TestSetupWithTxs
forall a. Arbitrary a => Gen a
arbitrary
    -- The Mempool should at least be capable of containing the transactions
    -- it already contains.
    let currentSize = (GenTx TestBlock -> ByteSize32) -> [GenTx TestBlock] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GenTx TestBlock -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize (TestSetup -> [GenTx TestBlock]
testInitialTxs TestSetup
testSetup)
        capacityMinBound = ByteSize32
currentSize
        validTxsToAdd = [GenTx TestBlock
tx | (GenTx TestBlock
tx, Bool
True) <- [(GenTx TestBlock, Bool)]
txs]
        -- Use the current size + the sum of all the valid transactions to add
        -- as the upper bound.
        capacityMaxBound = ByteSize32
currentSize ByteSize32 -> ByteSize32 -> ByteSize32
forall a. Semigroup a => a -> a -> a
<> (GenTx TestBlock -> ByteSize32) -> [GenTx TestBlock] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GenTx TestBlock -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize [GenTx TestBlock]
validTxsToAdd
    -- Note that we could pick @currentSize@, meaning that we can't add any
    -- more transactions to the Mempool

    capacity <-
      choose
        ( unByteSize32 capacityMinBound
        , unByteSize32 capacityMaxBound
        )
    let testSetup' =
          TestSetup
testSetup
            { testMempoolCapOverride =
                MempoolCapacityBytesOverride $
                  ByteSize32 $
                    capacity
            }
    return $ MempoolCapTestSetup testSetupWithTxs{testSetup = testSetup'}

{-------------------------------------------------------------------------------
  TxSeq Properties
-------------------------------------------------------------------------------}

-- | Finds elements in the sequence
prop_TxSeq_lookupByTicketNo_complete :: [Int] -> Property
prop_TxSeq_lookupByTicketNo_complete :: [Int] -> Property
prop_TxSeq_lookupByTicketNo_complete [Int]
xs =
  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (TxSeq TheMeasure Int -> String
forall a. Show a => a -> String
show TxSeq TheMeasure Int
txseq) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
      [ case TxSeq TheMeasure Int -> TicketNo -> Maybe Int
forall sz tx. Measure sz => TxSeq sz tx -> TicketNo -> Maybe tx
TxSeq.lookupByTicketNo TxSeq TheMeasure Int
txseq TicketNo
tn of
          Just Int
tx' -> Int
tx Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
tx'
          Maybe Int
Nothing -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
      | (Int
tx, TicketNo
tn, TheMeasure
_byteSize) <- TxSeq TheMeasure Int -> [(Int, TicketNo, TheMeasure)]
forall sz tx. TxSeq sz tx -> [(tx, TicketNo, sz)]
TxSeq.toTuples TxSeq TheMeasure Int
txseq
      ]
 where
  txseq :: TxSeq TheMeasure Int
  txseq :: TxSeq TheMeasure Int
txseq =
    [TxTicket TheMeasure Int] -> TxSeq TheMeasure Int
forall sz tx. Measure sz => [TxTicket sz tx] -> TxSeq sz tx
TxSeq.fromList ([TxTicket TheMeasure Int] -> TxSeq TheMeasure Int)
-> [TxTicket TheMeasure Int] -> TxSeq TheMeasure Int
forall a b. (a -> b) -> a -> b
$
      [Int -> TicketNo -> TheMeasure -> TxTicket TheMeasure Int
forall sz tx. tx -> TicketNo -> sz -> TxTicket sz tx
TxTicket Int
x (Word64 -> TicketNo
TicketNo Word64
i) TheMeasure
forall a. Monoid a => a
mempty | Int
x <- [Int]
xs | Word64
i <- [Word64
0 ..]]

-- | Only finds elements in the sequence
prop_TxSeq_lookupByTicketNo_sound ::
  [Small Int] -> Small Int -> Property
prop_TxSeq_lookupByTicketNo_sound :: [Small Int] -> Small Int -> Property
prop_TxSeq_lookupByTicketNo_sound [Small Int]
smalls Small Int
small =
  case TxSeq TheMeasure Int -> TicketNo -> Maybe Int
forall sz tx. Measure sz => TxSeq sz tx -> TicketNo -> Maybe tx
TxSeq.lookupByTicketNo TxSeq TheMeasure Int
txseq (Int -> TicketNo
mkTicketNo Int
needle) of
    Just Int
tx' ->
      String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label String
"successful hit" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"needle: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
needle) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"haystack: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show [Int]
haystack) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            Int
tx' Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
needle
    Maybe Int
Nothing ->
      String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label String
"successful miss" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
          Int
needle Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Int
haystack'
 where
  -- an ascending haystack of nonnegatives
  haystack :: [Int]
haystack = Set Int -> [Int]
forall a. Set a -> [a]
Set.toAscList Set Int
haystack'
  haystack' :: Set Int
haystack' = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ([Int] -> Set Int) -> [Int] -> Set Int
forall a b. (a -> b) -> a -> b
$ (Small Int -> Int) -> [Small Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> (Small Int -> Int) -> Small Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Small Int -> Int
forall a. Small a -> a
getSmall) [Small Int]
smalls

  -- a nonnegative needle
  needle :: Int
needle = Int -> Int
forall a. Num a => a -> a
abs (Small Int -> Int
forall a. Small a -> a
getSmall Small Int
small)

  -- the identity mapping over haystack
  txseq :: TxSeq TheMeasure Int
  txseq :: TxSeq TheMeasure Int
txseq =
    (TxSeq TheMeasure Int
 -> TxTicket TheMeasure Int -> TxSeq TheMeasure Int)
-> TxSeq TheMeasure Int
-> [TxTicket TheMeasure Int]
-> TxSeq TheMeasure 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' TxSeq TheMeasure Int
-> TxTicket TheMeasure Int -> TxSeq TheMeasure Int
forall sz tx.
Measure sz =>
TxSeq sz tx -> TxTicket sz tx -> TxSeq sz tx
(TxSeq.:>) TxSeq TheMeasure Int
forall sz tx. Measure sz => TxSeq sz tx
TxSeq.Empty ([TxTicket TheMeasure Int] -> TxSeq TheMeasure Int)
-> [TxTicket TheMeasure Int] -> TxSeq TheMeasure Int
forall a b. (a -> b) -> a -> b
$ (Int -> TxTicket TheMeasure Int)
-> [Int] -> [TxTicket TheMeasure Int]
forall a b. (a -> b) -> [a] -> [b]
map Int -> TxTicket TheMeasure Int
forall {sz}. Monoid sz => Int -> TxTicket sz Int
mkTicket [Int]
haystack

  mkTicket :: Int -> TxTicket sz Int
mkTicket Int
x = Int -> TicketNo -> sz -> TxTicket sz Int
forall sz tx. tx -> TicketNo -> sz -> TxTicket sz tx
TxTicket Int
x (Int -> TicketNo
mkTicketNo Int
x) sz
forall a. Monoid a => a
mempty
  mkTicketNo :: Int -> TicketNo
mkTicketNo = Word64 -> TicketNo
TicketNo (Word64 -> TicketNo) -> (Int -> Word64) -> Int -> TicketNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word64
forall a. Enum a => Int -> a
toEnum

-- | Test that the 'fst' of the result of 'splitAfterTxSize' only contains
-- 'TxTicket's whose summed up transaction sizes are less than or equal to
-- that of the byte size which the 'TxSeq' was split on.
prop_TxSeq_splitAfterTxSize :: TxSizeSplitTestSetup -> Property
prop_TxSeq_splitAfterTxSize :: TxSizeSplitTestSetup -> Property
prop_TxSeq_splitAfterTxSize TxSizeSplitTestSetup
tss =
  Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ [TxTicket TheMeasure Int] -> TheMeasure
forall tx. [TxTicket TheMeasure tx] -> TheMeasure
txSizeSum (TxSeq TheMeasure Int -> [TxTicket TheMeasure Int]
forall sz tx. TxSeq sz tx -> [TxTicket sz tx]
TxSeq.toList TxSeq TheMeasure Int
before) TheMeasure -> TheMeasure -> Bool
forall a. Ord a => a -> a -> Bool
<= TheMeasure
tssTxSizeToSplitOn
 where
  TxSizeSplitTestSetup{TheMeasure
tssTxSizeToSplitOn :: TheMeasure
tssTxSizeToSplitOn :: TxSizeSplitTestSetup -> TheMeasure
tssTxSizeToSplitOn} = TxSizeSplitTestSetup
tss

  (TxSeq TheMeasure Int
before, TxSeq TheMeasure Int
_after) = TxSeq TheMeasure Int
-> TheMeasure -> (TxSeq TheMeasure Int, TxSeq TheMeasure Int)
forall sz tx.
Measure sz =>
TxSeq sz tx -> sz -> (TxSeq sz tx, TxSeq sz tx)
splitAfterTxSize TxSeq TheMeasure Int
txseq TheMeasure
tssTxSizeToSplitOn

  txseq :: TxSeq TheMeasure Int
  txseq :: TxSeq TheMeasure Int
txseq = TxSizeSplitTestSetup -> TxSeq TheMeasure Int
txSizeSplitTestSetupToTxSeq TxSizeSplitTestSetup
tss

  txSizeSum :: [TxTicket TheMeasure tx] -> TheMeasure
  txSizeSum :: forall tx. [TxTicket TheMeasure tx] -> TheMeasure
txSizeSum = (TxTicket TheMeasure tx -> TheMeasure)
-> [TxTicket TheMeasure tx] -> TheMeasure
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxTicket TheMeasure tx -> TheMeasure
forall sz tx. TxTicket sz tx -> sz
txTicketSize

-- | Test that the results of 'splitAfterTxSizeSpec', a specification of
-- 'splitAfterTxSize', match those of the real 'splitAfterTxSize'
-- implementation.
prop_TxSeq_splitAfterTxSizeSpec :: TxSizeSplitTestSetup -> Property
prop_TxSeq_splitAfterTxSizeSpec :: TxSizeSplitTestSetup -> Property
prop_TxSeq_splitAfterTxSizeSpec TxSizeSplitTestSetup
tss =
  TxSeq TheMeasure Int -> [TxTicket TheMeasure Int]
forall sz tx. TxSeq sz tx -> [TxTicket sz tx]
TxSeq.toList TxSeq TheMeasure Int
implBefore [TxTicket TheMeasure Int] -> [TxTicket TheMeasure Int] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TxSeq TheMeasure Int -> [TxTicket TheMeasure Int]
forall sz tx. TxSeq sz tx -> [TxTicket sz tx]
TxSeq.toList TxSeq TheMeasure Int
specBefore
    Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. TxSeq TheMeasure Int -> [TxTicket TheMeasure Int]
forall sz tx. TxSeq sz tx -> [TxTicket sz tx]
TxSeq.toList TxSeq TheMeasure Int
implAfter [TxTicket TheMeasure Int] -> [TxTicket TheMeasure Int] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TxSeq TheMeasure Int -> [TxTicket TheMeasure Int]
forall sz tx. TxSeq sz tx -> [TxTicket sz tx]
TxSeq.toList TxSeq TheMeasure Int
specAfter
 where
  TxSizeSplitTestSetup{TheMeasure
tssTxSizeToSplitOn :: TxSizeSplitTestSetup -> TheMeasure
tssTxSizeToSplitOn :: TheMeasure
tssTxSizeToSplitOn} = TxSizeSplitTestSetup
tss

  (TxSeq TheMeasure Int
implBefore, TxSeq TheMeasure Int
implAfter) = TxSeq TheMeasure Int
-> TheMeasure -> (TxSeq TheMeasure Int, TxSeq TheMeasure Int)
forall sz tx.
Measure sz =>
TxSeq sz tx -> sz -> (TxSeq sz tx, TxSeq sz tx)
splitAfterTxSize TxSeq TheMeasure Int
txseq TheMeasure
tssTxSizeToSplitOn

  (TxSeq TheMeasure Int
specBefore, TxSeq TheMeasure Int
specAfter) = TxSeq TheMeasure Int
-> TheMeasure -> (TxSeq TheMeasure Int, TxSeq TheMeasure Int)
forall sz tx.
Measure sz =>
TxSeq sz tx -> sz -> (TxSeq sz tx, TxSeq sz tx)
splitAfterTxSizeSpec TxSeq TheMeasure Int
txseq TheMeasure
tssTxSizeToSplitOn

  txseq :: TxSeq TheMeasure Int
  txseq :: TxSeq TheMeasure Int
txseq = TxSizeSplitTestSetup -> TxSeq TheMeasure Int
txSizeSplitTestSetupToTxSeq TxSizeSplitTestSetup
tss

{-------------------------------------------------------------------------------
  TxSizeSplitTestSetup
-------------------------------------------------------------------------------}

-- | No notable invariants.
data TxSizeSplitTestSetup = TxSizeSplitTestSetup
  { TxSizeSplitTestSetup -> [TheMeasure]
tssTxSizes :: ![TheMeasure]
  , TxSizeSplitTestSetup -> TheMeasure
tssTxSizeToSplitOn :: !TheMeasure
  }
  deriving Int -> TxSizeSplitTestSetup -> String -> String
[TxSizeSplitTestSetup] -> String -> String
TxSizeSplitTestSetup -> String
(Int -> TxSizeSplitTestSetup -> String -> String)
-> (TxSizeSplitTestSetup -> String)
-> ([TxSizeSplitTestSetup] -> String -> String)
-> Show TxSizeSplitTestSetup
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TxSizeSplitTestSetup -> String -> String
showsPrec :: Int -> TxSizeSplitTestSetup -> String -> String
$cshow :: TxSizeSplitTestSetup -> String
show :: TxSizeSplitTestSetup -> String
$cshowList :: [TxSizeSplitTestSetup] -> String -> String
showList :: [TxSizeSplitTestSetup] -> String -> String
Show

instance Arbitrary TxSizeSplitTestSetup where
  arbitrary :: Gen TxSizeSplitTestSetup
arbitrary = do
    let txSizeMaxBound :: Word32
txSizeMaxBound = Word32
10 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
1024 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
1024 -- 10 mebibyte transaction max bound
    txSizes <- Gen Word32 -> Gen [Word32]
forall a. Gen a -> Gen [a]
listOf (Gen Word32 -> Gen [Word32]) -> Gen Word32 -> Gen [Word32]
forall a b. (a -> b) -> a -> b
$ (Word32, Word32) -> Gen Word32
forall a. Random a => (a, a) -> Gen a
choose (Word32
1, Word32
txSizeMaxBound :: Word32)
    let totalTxsSize = [Word32] -> Word32
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Word32]
txSizes
    txSizeToSplitOn <-
      frequency
        [ (1, pure 0)
        , (7, choose (0, totalTxsSize))
        , (1, pure totalTxsSize)
        , (1, choose (totalTxsSize + 1, totalTxsSize + 1000))
        ]
    pure
      TxSizeSplitTestSetup
        { tssTxSizes = map (IgnoringOverflow . ByteSize32) txSizes
        , tssTxSizeToSplitOn = IgnoringOverflow $ ByteSize32 txSizeToSplitOn
        }

  shrink :: TxSizeSplitTestSetup -> [TxSizeSplitTestSetup]
shrink TxSizeSplitTestSetup{[TheMeasure]
tssTxSizes :: TxSizeSplitTestSetup -> [TheMeasure]
tssTxSizes :: [TheMeasure]
tssTxSizes, TheMeasure
tssTxSizeToSplitOn :: TxSizeSplitTestSetup -> TheMeasure
tssTxSizeToSplitOn :: TheMeasure
tssTxSizeToSplitOn} =
    [ TxSizeSplitTestSetup
        { tssTxSizes :: [TheMeasure]
tssTxSizes = (Word32 -> TheMeasure) -> [Word32] -> [TheMeasure]
forall a b. (a -> b) -> [a] -> [b]
map (ByteSize32 -> TheMeasure
forall a. a -> IgnoringOverflow a
IgnoringOverflow (ByteSize32 -> TheMeasure)
-> (Word32 -> ByteSize32) -> Word32 -> TheMeasure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> ByteSize32
ByteSize32) [Word32]
tssTxSizes'
        , tssTxSizeToSplitOn :: TheMeasure
tssTxSizeToSplitOn = ByteSize32 -> TheMeasure
forall a. a -> IgnoringOverflow a
IgnoringOverflow (ByteSize32 -> TheMeasure) -> ByteSize32 -> TheMeasure
forall a b. (a -> b) -> a -> b
$ Word32 -> ByteSize32
ByteSize32 Word32
tssTxSizeToSplitOn'
        }
    | [Word32]
tssTxSizes' <- (Word32 -> [Word32]) -> [Word32] -> [[Word32]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([Word32] -> Word32 -> [Word32]
forall a b. a -> b -> a
const []) [Word32
y | IgnoringOverflow (ByteSize32 Word32
y) <- [TheMeasure]
tssTxSizes]
    , Word32
tssTxSizeToSplitOn' <- Word32 -> [Word32]
forall a. Integral a => a -> [a]
shrinkIntegral Word32
x
    ]
   where
    IgnoringOverflow (ByteSize32 Word32
x) = TheMeasure
tssTxSizeToSplitOn

-- | Convert a 'TxSizeSplitTestSetup' to a 'TxSeq'.
txSizeSplitTestSetupToTxSeq :: TxSizeSplitTestSetup -> TxSeq TheMeasure Int
txSizeSplitTestSetupToTxSeq :: TxSizeSplitTestSetup -> TxSeq TheMeasure Int
txSizeSplitTestSetupToTxSeq TxSizeSplitTestSetup{[TheMeasure]
tssTxSizes :: TxSizeSplitTestSetup -> [TheMeasure]
tssTxSizes :: [TheMeasure]
tssTxSizes} =
  [TxTicket TheMeasure Int] -> TxSeq TheMeasure Int
forall sz tx. Measure sz => [TxTicket sz tx] -> TxSeq sz tx
TxSeq.fromList
    [ Int -> TicketNo -> TheMeasure -> TxTicket TheMeasure Int
forall sz tx. tx -> TicketNo -> sz -> TxTicket sz tx
TxTicket Int
1 (Word64 -> TicketNo
TicketNo Word64
i) TheMeasure
tssTxSize
    | TheMeasure
tssTxSize <- [TheMeasure]
tssTxSizes
    | Word64
i <- [Word64
0 ..]
    ]

{-------------------------------------------------------------------------------
  TicketNo Properties
-------------------------------------------------------------------------------}

-- | Testing plan:
--
-- * Perform a number of actions: either add a new valid transaction to the
--   Mempool (invalid transactions have no effect on the @idx@s) or remove an
--   existing transaction from the Mempool.
--
-- * After executing each action, check whether the current ticket assignment
--   is still consistent with the expected ticket assignment. The ticket
--   assignment is a mapping from 'TicketNo' (@idx@) to transaction. The same
--   ticket may never be reused for another transaction, which is exactly what
--   we're testing here.
--
-- Ignore the "100% empty Mempool" label in the test output, that is there
-- because we reuse 'withTestMempool' and always start with an empty Mempool
-- and 'LedgerState'. This makes it easier to generate 'Actions', because they
-- don't have to take the initial contents of the Mempool and 'LedgerState'
-- into account.
prop_Mempool_idx_consistency :: Actions -> Property
prop_Mempool_idx_consistency :: Actions -> Property
prop_Mempool_idx_consistency (Actions [Action]
actions) =
  TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempool TestSetup
emptyTestSetup ((forall (m :: * -> *).
  (IOLike m, MonadTimer m) =>
  TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \testMempool :: TestMempool m
testMempool@TestMempool{Mempool m TestBlock
mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool :: Mempool m TestBlock
mempool} ->
    ([Property] -> Property) -> m [Property] -> m Property
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin (m [Property] -> m Property) -> m [Property] -> m Property
forall a b. (a -> b) -> a -> b
$ [Action] -> (Action -> m Property) -> m [Property]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Action]
actions ((Action -> m Property) -> m [Property])
-> (Action -> m Property) -> m [Property]
forall a b. (a -> b) -> a -> b
$ \Action
action -> do
      txsInMempool <-
        ((Validated (GenTx TestBlock), TicketNo, TheMeasure)
 -> Validated (GenTx TestBlock))
-> [(Validated (GenTx TestBlock), TicketNo, TheMeasure)]
-> [Validated (GenTx TestBlock)]
forall a b. (a -> b) -> [a] -> [b]
map (Validated (GenTx TestBlock), TicketNo, TheMeasure)
-> Validated (GenTx TestBlock)
(Validated (GenTx TestBlock), TicketNo, TxMeasure TestBlock)
-> Validated (GenTx TestBlock)
prjTx ([(Validated (GenTx TestBlock), TicketNo, TheMeasure)]
 -> [Validated (GenTx TestBlock)])
-> (MempoolSnapshot TestBlock
    -> [(Validated (GenTx TestBlock), TicketNo, TheMeasure)])
-> MempoolSnapshot TestBlock
-> [Validated (GenTx TestBlock)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MempoolSnapshot TestBlock
-> [(Validated (GenTx TestBlock), TicketNo, TheMeasure)]
MempoolSnapshot TestBlock
-> [(Validated (GenTx TestBlock), TicketNo, TxMeasure TestBlock)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxs
          (MempoolSnapshot TestBlock -> [Validated (GenTx TestBlock)])
-> m (MempoolSnapshot TestBlock) -> m [Validated (GenTx TestBlock)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (MempoolSnapshot TestBlock) -> m (MempoolSnapshot TestBlock)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Mempool m TestBlock -> STM m (MempoolSnapshot TestBlock)
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool m TestBlock
mempool)
      actionProp <- executeAction testMempool action
      currentAssignment <- currentTicketAssignment mempool
      return
        $
        --  #692, fixed in #742: if the mempool becomes empty during
        -- operation. In this case, the 'TicketNo' counter would "reset" to
        -- 'zeroTicketNo'. Clients interacting with the mempool likely won't
        -- account for this.
        classify
          (Map.null currentAssignment)
          "Mempool became empty"
        $
        -- #692, fixed in #742: the transaction at the "back" of the mempool
        -- becomes invalid and is removed. In this case, the next
        -- transaction to be appended would take on the 'TicketNo' of the
        -- removed transaction (since this function only increments the
        -- 'TicketNo' associated with the transaction at the back of the
        -- mempool). Clients interacting with the mempool likely won't
        -- account for this.
        classify
          (lastOfMempoolRemoved (map txForgetValidated txsInMempool) action)
          "The last transaction in the mempool is removed"
        $ actionProp
          .&&. currentAssignment `isConsistentWith` expectedAssignment
 where
  expectedAssignment :: Map TicketNo TestTxId
expectedAssignment = [Action] -> Map TicketNo TestTxId
expectedTicketAssignment [Action]
actions

  emptyTestSetup :: TestSetup
emptyTestSetup =
    TestSetup
      { testLedgerCfg :: LedgerConfig TestBlock
testLedgerCfg = LedgerConfig TestBlock
testLedgerConfigNoSizeLimits
      , testLedgerState :: LedgerState TestBlock ValuesMK
testLedgerState = LedgerState TestBlock ValuesMK
testInitLedger
      , testInitialTxs :: [GenTx TestBlock]
testInitialTxs = []
      , testMempoolCapOverride :: MempoolCapacityBytesOverride
testMempoolCapOverride =
          ByteSize32 -> MempoolCapacityBytesOverride
MempoolCapacityBytesOverride (ByteSize32 -> MempoolCapacityBytesOverride)
-> ByteSize32 -> MempoolCapacityBytesOverride
forall a b. (a -> b) -> a -> b
$
            Word32 -> ByteSize32
ByteSize32 (Word32 -> ByteSize32) -> Word32 -> ByteSize32
forall a b. (a -> b) -> a -> b
$
              Word32
1024 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
1024 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
1024
              -- There's no way this test will need more than a gibibyte.
      }

  lastOfMempoolRemoved :: [GenTx TestBlock] -> Action -> Bool
lastOfMempoolRemoved [GenTx TestBlock]
txsInMempool = \case
    AddTxs [GenTx TestBlock]
_ -> Bool
False
    RemoveTxs [GenTx TestBlock]
txs -> [GenTx TestBlock] -> GenTx TestBlock
forall a. HasCallStack => [a] -> a
last [GenTx TestBlock]
txsInMempool GenTx TestBlock -> [GenTx TestBlock] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [GenTx TestBlock]
txs

  isConsistentWith :: Map k a -> Map k a -> Property
isConsistentWith Map k a
curAsgn Map k a
expAsgn
    | Map k a
curAsgn Map k a -> Map k a -> Bool
forall k a. (Ord k, Eq a) => Map k a -> Map k a -> Bool
`Map.isSubmapOf` Map k a
expAsgn =
        Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    | Bool
otherwise =
        String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
          ( String
"Current tickets assignments: "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map k a -> String
forall a. Show a => a -> String
show Map k a
curAsgn
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\ninconsistent with expected: "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map k a -> String
forall a. Show a => a -> String
show Map k a
expAsgn
          )
          Bool
False

{-------------------------------------------------------------------------------
  TicketAssignment & Actions
-------------------------------------------------------------------------------}

data Action
  = -- | When part of 'Actions', all these transactions are valid.
    AddTxs [TestTx]
  | -- | When part of 'Actions', removing these transactions will not
    -- invalidate any other transactions.
    RemoveTxs [TestTx]
  deriving Int -> Action -> String -> String
[Action] -> String -> String
Action -> String
(Int -> Action -> String -> String)
-> (Action -> String)
-> ([Action] -> String -> String)
-> Show Action
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Action -> String -> String
showsPrec :: Int -> Action -> String -> String
$cshow :: Action -> String
show :: Action -> String
$cshowList :: [Action] -> String -> String
showList :: [Action] -> String -> String
Show

newtype Actions = Actions [Action]
  deriving Int -> Actions -> String -> String
[Actions] -> String -> String
Actions -> String
(Int -> Actions -> String -> String)
-> (Actions -> String)
-> ([Actions] -> String -> String)
-> Show Actions
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Actions -> String -> String
showsPrec :: Int -> Actions -> String -> String
$cshow :: Actions -> String
show :: Actions -> String
$cshowList :: [Actions] -> String -> String
showList :: [Actions] -> String -> String
Show

-- | Track to which ticket number each transaction is assigned.
--
-- * We don't want multiple transaction to be assigned the same ticket number.
-- * We want each transaction to be always assigned the same ticket number.
type TicketAssignment = Map TicketNo TestTxId

-- | Compute the expected 'TicketAssignment' for the given actions.
expectedTicketAssignment :: [Action] -> TicketAssignment
expectedTicketAssignment :: [Action] -> Map TicketNo TestTxId
expectedTicketAssignment [Action]
actions =
  State TicketNo (Map TicketNo TestTxId)
-> TicketNo -> Map TicketNo TestTxId
forall s a. State s a -> s -> a
evalState ((Map TicketNo TestTxId
 -> Action -> State TicketNo (Map TicketNo TestTxId))
-> Map TicketNo TestTxId
-> [Action]
-> State TicketNo (Map TicketNo TestTxId)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map TicketNo TestTxId
-> Action -> State TicketNo (Map TicketNo TestTxId)
addMapping Map TicketNo TestTxId
forall a. Monoid a => a
mempty [Action]
actions) (TicketNo -> TicketNo
forall a. Enum a => a -> a
succ TicketNo
zeroTicketNo)
 where
  addMapping :: TicketAssignment -> Action -> State TicketNo TicketAssignment
  addMapping :: Map TicketNo TestTxId
-> Action -> State TicketNo (Map TicketNo TestTxId)
addMapping Map TicketNo TestTxId
mapping (RemoveTxs [GenTx TestBlock]
_txs) = Map TicketNo TestTxId -> State TicketNo (Map TicketNo TestTxId)
forall a. a -> StateT TicketNo Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Map TicketNo TestTxId
mapping
  addMapping Map TicketNo TestTxId
mapping (AddTxs [GenTx TestBlock]
txs) = do
    newMappings <- [GenTx TestBlock]
-> (GenTx TestBlock
    -> StateT TicketNo Identity (TicketNo, TestTxId))
-> StateT TicketNo Identity [(TicketNo, TestTxId)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [GenTx TestBlock]
txs ((GenTx TestBlock -> StateT TicketNo Identity (TicketNo, TestTxId))
 -> StateT TicketNo Identity [(TicketNo, TestTxId)])
-> (GenTx TestBlock
    -> StateT TicketNo Identity (TicketNo, TestTxId))
-> StateT TicketNo Identity [(TicketNo, TestTxId)]
forall a b. (a -> b) -> a -> b
$ \GenTx TestBlock
tx -> do
      nextTicketNo <- StateT TicketNo Identity TicketNo
forall s (m :: * -> *). MonadState s m => m s
get
      modify succ
      return (nextTicketNo, txId tx)
    return $ Map.union mapping (Map.fromList newMappings)

-- | Executes the action and verifies that it is actually executed using the
-- tracer, hence the 'Property' in the return type.
executeAction :: forall m. IOLike m => TestMempool m -> Action -> m Property
executeAction :: forall (m :: * -> *).
IOLike m =>
TestMempool m -> Action -> m Property
executeAction TestMempool m
testMempool Action
action = case Action
action of
  AddTxs [GenTx TestBlock]
txs -> do
    m [MempoolAddTxResult TestBlock] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [MempoolAddTxResult TestBlock] -> m ())
-> m [MempoolAddTxResult TestBlock] -> m ()
forall a b. (a -> b) -> a -> b
$ Mempool m TestBlock
-> [GenTx TestBlock] -> m [MempoolAddTxResult TestBlock]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool m TestBlock
mempool [GenTx TestBlock]
txs
    allTraces <- (TraceEventMempool TestBlock
 -> Maybe (TraceEventMempool TestBlock))
-> m [TraceEventMempool TestBlock]
forall a. (TraceEventMempool TestBlock -> Maybe a) -> m [a]
expectTraceEvent TraceEventMempool TestBlock -> Maybe (TraceEventMempool TestBlock)
forall a. a -> Maybe a
Just
    let tracedAddedTxs = [Validated (GenTx TestBlock)
tx | TraceMempoolAddedTx Validated (GenTx TestBlock)
tx MempoolSize
_ MempoolSize
_ <- [TraceEventMempool TestBlock]
allTraces] -- expectTraceEvent $ \case
    -- TraceMempoolAddedTx tx _ _ -> Just tx
    -- _                          -> Nothing
    return $
      if map txForgetValidated tracedAddedTxs == txs
        then property True
        else
          counterexample
            ( "Expected TraceMempoolAddedTx events for "
                <> condense txs
                <> " but got "
                <> condense (map txForgetValidated tracedAddedTxs)
                <> " evs: "
                <> show allTraces
            )
            False
  RemoveTxs [GenTx TestBlock]
txs -> do
    let txs' :: NonEmpty TestTxId
txs' = [TestTxId] -> NonEmpty TestTxId
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([TestTxId] -> NonEmpty TestTxId)
-> [TestTxId] -> NonEmpty TestTxId
forall a b. (a -> b) -> a -> b
$ (GenTx TestBlock -> TestTxId) -> [GenTx TestBlock] -> [TestTxId]
forall a b. (a -> b) -> [a] -> [b]
map GenTx TestBlock -> TestTxId
forall tx. HasTxId tx => tx -> TxId tx
txId [GenTx TestBlock]
txs
    Mempool m TestBlock -> NonEmpty TestTxId -> m ()
forall (m :: * -> *) blk.
Mempool m blk -> NonEmpty (GenTxId blk) -> m ()
removeTxsEvenIfValid Mempool m TestBlock
mempool NonEmpty TestTxId
txs'
    tracedManuallyRemovedTxs <- (TraceEventMempool TestBlock -> Maybe (NonEmpty TestTxId))
-> m [NonEmpty TestTxId]
forall a. (TraceEventMempool TestBlock -> Maybe a) -> m [a]
expectTraceEvent ((TraceEventMempool TestBlock -> Maybe (NonEmpty TestTxId))
 -> m [NonEmpty TestTxId])
-> (TraceEventMempool TestBlock -> Maybe (NonEmpty TestTxId))
-> m [NonEmpty TestTxId]
forall a b. (a -> b) -> a -> b
$ \case
      TraceMempoolManuallyRemovedTxs NonEmpty TestTxId
txIds [Validated (GenTx TestBlock)]
_ MempoolSize
_ -> NonEmpty TestTxId -> Maybe (NonEmpty TestTxId)
forall a. a -> Maybe a
Just NonEmpty TestTxId
txIds
      TraceEventMempool TestBlock
_ -> Maybe (NonEmpty TestTxId)
forall a. Maybe a
Nothing
    return $
      if concatMap NE.toList tracedManuallyRemovedTxs == map txId txs
        then property True
        else
          counterexample
            ( "Expected a TraceMempoolManuallyRemovedTxs event for "
                <> condense txs
                <> " but got "
                <> condense (map NE.toList tracedManuallyRemovedTxs)
            )
            False
 where
  TestMempool
    { Mempool m TestBlock
mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool :: Mempool m TestBlock
mempool
    , m ()
eraseTraceEvents :: forall (m :: * -> *). TestMempool m -> m ()
eraseTraceEvents :: m ()
eraseTraceEvents
    , m [TraceEventMempool TestBlock]
getTraceEvents :: forall (m :: * -> *).
TestMempool m -> m [TraceEventMempool TestBlock]
getTraceEvents :: m [TraceEventMempool TestBlock]
getTraceEvents
    } = TestMempool m
testMempool

  expectTraceEvent :: (TraceEventMempool TestBlock -> Maybe a) -> m [a]
  expectTraceEvent :: forall a. (TraceEventMempool TestBlock -> Maybe a) -> m [a]
expectTraceEvent TraceEventMempool TestBlock -> Maybe a
extractor = do
    evs <- m [TraceEventMempool TestBlock]
getTraceEvents
    eraseTraceEvents
    return $ mapMaybe extractor evs

currentTicketAssignment ::
  IOLike m =>
  Mempool m TestBlock -> m TicketAssignment
currentTicketAssignment :: forall (m :: * -> *).
IOLike m =>
Mempool m TestBlock -> m (Map TicketNo TestTxId)
currentTicketAssignment Mempool{m (MempoolSnapshot TestBlock)
testSyncWithLedger :: forall (m :: * -> *) blk. Mempool m blk -> m (MempoolSnapshot blk)
testSyncWithLedger :: m (MempoolSnapshot TestBlock)
testSyncWithLedger} = do
  MempoolSnapshot{snapshotTxs} <- m (MempoolSnapshot TestBlock)
testSyncWithLedger
  return $
    Map.fromList
      [ (ticketNo, txId (txForgetValidated tx))
      | (tx, ticketNo, _byteSize) <- snapshotTxs
      ]

instance Arbitrary Actions where
  arbitrary :: Gen Actions
arbitrary = (Int -> Gen Actions) -> Gen Actions
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen Actions) -> Gen Actions)
-> (Int -> Gen Actions) -> Gen Actions
forall a b. (a -> b) -> a -> b
$ Gen Int -> Int -> Gen Actions
genActions ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
3))

genActions ::
  -- | Generate the number of transactions to add
  Gen Int ->
  -- | How many actions
  Int ->
  Gen Actions
genActions :: Gen Int -> Int -> Gen Actions
genActions Gen Int
genNbToAdd = LedgerState TestBlock ValuesMK
-> [GenTx TestBlock] -> [Action] -> Int -> Gen Actions
go LedgerState TestBlock ValuesMK
testInitLedger [GenTx TestBlock]
forall a. Monoid a => a
mempty [Action]
forall a. Monoid a => a
mempty
 where
  cfg :: LedgerConfig TestBlock
cfg = LedgerConfig TestBlock
testLedgerConfigNoSizeLimits

  go ::
    LedgerState TestBlock ValuesMK ->
    -- \^ Current ledger state with the contents of the Mempool applied
    [TestTx] ->
    -- \^ Transactions currently in the Mempool
    [Action] ->
    -- \^ Already generated actions
    Int ->
    -- \^ Number of actions left to generate
    Gen Actions
  go :: LedgerState TestBlock ValuesMK
-> [GenTx TestBlock] -> [Action] -> Int -> Gen Actions
go LedgerState TestBlock ValuesMK
ledger [GenTx TestBlock]
txs [Action]
actions Int
n
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Actions -> Gen Actions
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Actions -> Gen Actions) -> Actions -> Gen Actions
forall a b. (a -> b) -> a -> b
$ [Action] -> Actions
Actions ([Action] -> [Action]
forall a. [a] -> [a]
reverse [Action]
actions)
    | Bool
otherwise =
        Gen Bool
forall a. Arbitrary a => Gen a
arbitrary Gen Bool -> (Bool -> Gen Actions) -> Gen Actions
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
True
            | Bool -> Bool
not ([GenTx TestBlock] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenTx TestBlock]
txs) ->
                -- Remove a transaction (or multiple), but only if there are
                -- transactions to remove
                do
                  tx <- [GenTx TestBlock] -> Gen (GenTx TestBlock)
forall a. HasCallStack => [a] -> Gen a
elements [GenTx TestBlock]
txs
                  let ((vTxs, iTxs), ledger') =
                        first (List.partition (isRight . snd)) $
                          validateTxs cfg testInitLedger (filter (/= tx) txs)
                      txs' = ((GenTx TestBlock, Either (MockError TestBlock) ())
 -> GenTx TestBlock)
-> [(GenTx TestBlock, Either (MockError TestBlock) ())]
-> [GenTx TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx TestBlock, Either (MockError TestBlock) ())
-> GenTx TestBlock
forall a b. (a, b) -> a
fst [(GenTx TestBlock, Either (MockError TestBlock) ())]
vTxs
                      removedTxs = GenTx TestBlock
tx GenTx TestBlock -> [GenTx TestBlock] -> [GenTx TestBlock]
forall a. a -> [a] -> [a]
: ((GenTx TestBlock, Either (MockError TestBlock) ())
 -> GenTx TestBlock)
-> [(GenTx TestBlock, Either (MockError TestBlock) ())]
-> [GenTx TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx TestBlock, Either (MockError TestBlock) ())
-> GenTx TestBlock
forall a b. (a, b) -> a
fst [(GenTx TestBlock, Either (MockError TestBlock) ())]
iTxs
                  go ledger' txs' (RemoveTxs removedTxs : actions) (n - 1)
          Bool
_ -> do
            nbToAdd <- Gen Int
genNbToAdd
            (txs', ledger') <- genValidTxs nbToAdd ledger
            go ledger' (txs' <> txs) (AddTxs txs' : actions) (n - 1)

{-------------------------------------------------------------------------------
  Mempool timeout
-------------------------------------------------------------------------------}

-- | Like 'TestSetupWithTxs', but also has a 'DiffTime' for each tx to add.
--
-- The 'testInitialTxs' effectively have a 'DiffTime' of 0.
--
-- TODO effectively vary the cumulative 'DiffTime' of the 'testInitialTxs'?
data TestSetupWithTxsAndDiffTimes
  = TestSetupWithTxsAndDiffTimes MempoolTimeoutConfig TestSetup [(TestTx, Bool, DiffTime)]
  deriving Int -> TestSetupWithTxsAndDiffTimes -> String -> String
[TestSetupWithTxsAndDiffTimes] -> String -> String
TestSetupWithTxsAndDiffTimes -> String
(Int -> TestSetupWithTxsAndDiffTimes -> String -> String)
-> (TestSetupWithTxsAndDiffTimes -> String)
-> ([TestSetupWithTxsAndDiffTimes] -> String -> String)
-> Show TestSetupWithTxsAndDiffTimes
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestSetupWithTxsAndDiffTimes -> String -> String
showsPrec :: Int -> TestSetupWithTxsAndDiffTimes -> String -> String
$cshow :: TestSetupWithTxsAndDiffTimes -> String
show :: TestSetupWithTxsAndDiffTimes -> String
$cshowList :: [TestSetupWithTxsAndDiffTimes] -> String -> String
showList :: [TestSetupWithTxsAndDiffTimes] -> String -> String
Show

instance Arbitrary TestSetupWithTxsAndDiffTimes where
  arbitrary :: Gen TestSetupWithTxsAndDiffTimes
arbitrary = do
    soft <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
2000)
    hard <- choose (soft + 1, 10000)
    cap <- choose (soft + 1, 10000)
    let fromMs Int
x = Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
x :: Int) DiffTime -> DiffTime -> DiffTime
forall a. Fractional a => a -> a -> a
/ DiffTime
1000 :: DiffTime
        toCfg =
          MempoolTimeoutConfig
            { mempoolTimeoutSoft :: DiffTime
mempoolTimeoutSoft = Int -> DiffTime
fromMs Int
soft
            , mempoolTimeoutHard :: DiffTime
mempoolTimeoutHard = Int -> DiffTime
fromMs Int
hard
            , mempoolTimeoutCapacity :: DiffTime
mempoolTimeoutCapacity = Int -> DiffTime
fromMs Int
cap
            }
    TestSetupWithTxs testSetup txs <- arbitrary
    let genDiffTime Bool
valid = do
          -- If the tx is valid, the the 'TestSetupWithTxs' expects it to pass.
          --
          -- So we usually want to avoid that. But not always, since we still
          -- want "valid" txs to fail the timeout sometimes.
          forceValid <- [(Int, Gen Bool)] -> Gen Bool
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
95, Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
valid), (Int
5, Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)]
          fromMs <$> choose (1, if forceValid then soft else (3 * hard) `div` 2)
    txs' <- sequence [genDiffTime valid <&> \DiffTime
dt -> (GenTx TestBlock
tx, Bool
valid, DiffTime
dt) | (tx, valid) <- txs]
    pure $ TestSetupWithTxsAndDiffTimes toCfg testSetup txs'

data MempoolTimeoutCategory = MtcAccepted | MtcRejected | MtcDiscard | MtcDisconnect | MtcNoSpace
  deriving Int -> MempoolTimeoutCategory -> String -> String
[MempoolTimeoutCategory] -> String -> String
MempoolTimeoutCategory -> String
(Int -> MempoolTimeoutCategory -> String -> String)
-> (MempoolTimeoutCategory -> String)
-> ([MempoolTimeoutCategory] -> String -> String)
-> Show MempoolTimeoutCategory
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> MempoolTimeoutCategory -> String -> String
showsPrec :: Int -> MempoolTimeoutCategory -> String -> String
$cshow :: MempoolTimeoutCategory -> String
show :: MempoolTimeoutCategory -> String
$cshowList :: [MempoolTimeoutCategory] -> String -> String
showList :: [MempoolTimeoutCategory] -> String -> String
Show

-- | Like 'prop_Mempool_addTxs_result', but also exercising mempool timeouts.
prop_Mempool_timeout :: TestSetupWithTxsAndDiffTimes -> Property
prop_Mempool_timeout :: TestSetupWithTxsAndDiffTimes -> Property
prop_Mempool_timeout (TestSetupWithTxsAndDiffTimes MempoolTimeoutConfig
timeoutConfig TestSetup
testSetup [(GenTx TestBlock, Bool, DiffTime)]
txs) =
  Maybe MempoolTimeoutConfig
-> TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
Maybe MempoolTimeoutConfig
-> TestSetup
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m prop)
-> Property
withTestMempoolWithTimeoutConfig (MempoolTimeoutConfig -> Maybe MempoolTimeoutConfig
forall a. a -> Maybe a
Just MempoolTimeoutConfig
timeoutConfig) TestSetup
testSetup ((forall (m :: * -> *).
  (IOLike m, MonadTimer m) =>
  TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *).
    (IOLike m, MonadTimer m) =>
    TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool{Mempool m TestBlock
mempool :: forall (m :: * -> *). TestMempool m -> Mempool m TestBlock
mempool :: Mempool m TestBlock
mempool} -> do
    let go :: DiffTime -> [(GenTx TestBlock, Bool, DiffTime)] -> m Property
go !DiffTime
acc = \case
          [] -> Property -> m Property
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ () -> Property
forall prop. Testable prop => prop -> Property
property ()
          (GenTx TestBlock
tx, Bool
valid, DiffTime
dt) : [(GenTx TestBlock, Bool, DiffTime)]
txs' -> do
            let eTxsz :: Either (MockError blk) ByteSize32
eTxsz =
                  -- check whether the tx's measure is immediately rejected
                  Except (MockError blk) ByteSize32
-> Either (MockError blk) ByteSize32
forall e a. Except e a -> Either e a
runExcept (Except (MockError blk) ByteSize32
 -> Either (MockError blk) ByteSize32)
-> Except (MockError blk) ByteSize32
-> Either (MockError blk) ByteSize32
forall a b. (a -> b) -> a -> b
$
                    MockConfig -> Tx -> Except (MockError blk) ByteSize32
forall blk. MockConfig -> Tx -> Except (MockError blk) ByteSize32
checkTxSize
                      (SimpleLedgerConfig
  SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)
-> MockConfig
forall c ext. SimpleLedgerConfig c ext -> MockConfig
simpleLedgerMockConfig (SimpleLedgerConfig
   SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)
 -> MockConfig)
-> SimpleLedgerConfig
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)
-> MockConfig
forall a b. (a -> b) -> a -> b
$ TestSetup -> LedgerConfig TestBlock
testLedgerCfg TestSetup
testSetup)
                      (GenTx TestBlock -> Tx
forall c ext. GenTx (SimpleBlock c ext) -> Tx
simpleGenTx GenTx TestBlock
tx)
            let expected :: MempoolTimeoutCategory
expected
                  | Left{} <- Either (MockError (ZonkAny 1)) ByteSize32
forall {blk}. Either (MockError blk) ByteSize32
eTxsz = MempoolTimeoutCategory
MtcRejected
                  | DiffTime
acc DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> MempoolTimeoutConfig -> DiffTime
mempoolTimeoutCapacity MempoolTimeoutConfig
timeoutConfig = MempoolTimeoutCategory
MtcNoSpace
                  -- Recall that the test setup generator ensures other
                  -- dimensions of the mempool capacity are big enough to
                  -- fit all the valid @txs@.
                  | DiffTime
dt DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> MempoolTimeoutConfig -> DiffTime
mempoolTimeoutHard MempoolTimeoutConfig
timeoutConfig = MempoolTimeoutCategory
MtcDisconnect
                  | DiffTime
dt DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> MempoolTimeoutConfig -> DiffTime
mempoolTimeoutSoft MempoolTimeoutConfig
timeoutConfig = MempoolTimeoutCategory
MtcDiscard
                  | Bool -> Bool
not Bool
valid = MempoolTimeoutCategory
MtcRejected
                  | Bool
otherwise = MempoolTimeoutCategory
MtcAccepted
            let notMempoolError :: MockError blk -> Bool
notMempoolError = \case
                  MockMempoolError{} -> Bool
False
                  MockError blk
_ -> Bool
True
            eRes <- m (Maybe (MempoolAddTxResult TestBlock))
-> m (Either
        ExnMempoolTimeout (Maybe (MempoolAddTxResult TestBlock)))
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m (Maybe (MempoolAddTxResult TestBlock))
 -> m (Either
         ExnMempoolTimeout (Maybe (MempoolAddTxResult TestBlock))))
-> m (Maybe (MempoolAddTxResult TestBlock))
-> m (Either
        ExnMempoolTimeout (Maybe (MempoolAddTxResult TestBlock)))
forall a b. (a -> b) -> a -> b
$ Mempool m TestBlock
-> DiffTime
-> AddTxOnBehalfOf
-> GenTx TestBlock
-> m (Maybe (MempoolAddTxResult TestBlock))
forall (m :: * -> *) blk.
Mempool m blk
-> DiffTime
-> AddTxOnBehalfOf
-> GenTx blk
-> m (Maybe (MempoolAddTxResult blk))
testTryAddTx Mempool m TestBlock
mempool DiffTime
dt AddTxOnBehalfOf
AddTxForRemotePeer GenTx TestBlock
tx
            tabulate "addTextTx expectation" [show expected] <$> case (expected, eRes) of
              (MempoolTimeoutCategory
MtcAccepted, Right (Just MempoolTxAdded{})) ->
                DiffTime -> [(GenTx TestBlock, Bool, DiffTime)] -> m Property
go (DiffTime
acc DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
dt) [(GenTx TestBlock, Bool, DiffTime)]
txs'
              (MempoolTimeoutCategory
MtcRejected, Right (Just (MempoolTxRejected GenTx TestBlock
_ TestTxError
err)))
                | MockError TestBlock -> Bool
forall {blk}. MockError blk -> Bool
notMempoolError TestTxError
MockError TestBlock
err ->
                    DiffTime -> [(GenTx TestBlock, Bool, DiffTime)] -> m Property
go DiffTime
acc [(GenTx TestBlock, Bool, DiffTime)]
txs'
              (MempoolTimeoutCategory
MtcDiscard, Right (Just (MempoolTxRejected GenTx TestBlock
_ MockMempoolError{}))) ->
                if Bool
valid
                  then Property -> m Property
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ String -> () -> Property
forall prop. Testable prop => String -> prop -> Property
label String
"soft-timeout for otherwise-valid tx" ()
                  else
                    DiffTime -> [(GenTx TestBlock, Bool, DiffTime)] -> m Property
go DiffTime
acc [(GenTx TestBlock, Bool, DiffTime)]
txs'
              (MempoolTimeoutCategory
MtcDisconnect, Left MkExnMempoolTimeout{}) ->
                Property -> m Property
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ () -> Property
forall prop. Testable prop => prop -> Property
property ()
              (MempoolTimeoutCategory
MtcNoSpace, Right Maybe (MempoolAddTxResult TestBlock)
Nothing) ->
                Property -> m Property
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ () -> Property
forall prop. Testable prop => prop -> Property
property ()
              (MempoolTimeoutCategory,
 Either ExnMempoolTimeout (Maybe (MempoolAddTxResult TestBlock)))
_ ->
                Property -> m Property
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$
                  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> MempoolTimeoutCategory -> String
forall a. Show a => a -> String
show MempoolTimeoutCategory
expected String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but got...") (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                    String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Either ExnMempoolTimeout (Maybe (MempoolAddTxResult TestBlock))
-> String
forall a. Show a => a -> String
show Either ExnMempoolTimeout (Maybe (MempoolAddTxResult TestBlock))
eRes) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
                      Bool
False
    DiffTime -> [(GenTx TestBlock, Bool, DiffTime)] -> m Property
go DiffTime
0 [(GenTx TestBlock, Bool, DiffTime)]
txs