{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# 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.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 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.Block
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Ledger.Tables.Utils
import           Ouroboros.Consensus.Mempool
import           Ouroboros.Consensus.Mempool.TxSeq as TxSeq
import           Ouroboros.Consensus.Mock.Ledger hiding (TxId)
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
      ]
  ]

{-------------------------------------------------------------------------------
  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 => TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m prop)
-> Property
withTestMempool TestSetup
setup ((forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool { Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool } -> do
      let Mempool { STM
  m
  (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
getSnapshot :: STM
  m
  (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
getSnapshot :: forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot } = Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool
      MempoolSnapshot { snapshotTxs, snapshotTxsAfter} <- STM
  m
  (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM
  m
  (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
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 => TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m prop)
-> Property
withTestMempool (TestSetupWithTxs -> TestSetup
testSetup TestSetupWithTxs
setup) ((forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool { Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool } -> do
      _ <- Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> m [MempoolAddTxResult
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool (TestSetupWithTxs -> [TestTx]
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 => TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m prop)
-> Property
withTestMempool (TestSetupWithTxs -> TestSetup
testSetup TestSetupWithTxs
setup) ((forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool {mempool :: forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool = Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool1} -> do
  _ <- Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> m [MempoolAddTxResult
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool1 (TestSetupWithTxs -> [TestTx]
allTxs TestSetupWithTxs
setup)
  snapshot1 <- atomically $ getSnapshot mempool1

  return $ withTestMempool (testSetup setup) $ \TestMempool {mempool :: forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool = Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool2} -> do
    [TestTx]
-> (TestTx
    -> m [MempoolAddTxResult
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))])
-> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (TestSetupWithTxs -> [TestTx]
allTxs TestSetupWithTxs
setup) ((TestTx
  -> m [MempoolAddTxResult
          (SimpleBlock
             SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))])
 -> m ())
-> (TestTx
    -> m [MempoolAddTxResult
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))])
-> m ()
forall a b. (a -> b) -> a -> b
$ \TestTx
tx -> Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> m [MempoolAddTxResult
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool2 [TestTx
tx]
    snapshot2 <- STM
  m
  (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (MempoolSnapshot
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> m (MempoolSnapshot
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
-> STM
     m
     (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a b. (a -> b) -> a -> b
$ Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> STM
     m
     (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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 => TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m prop)
-> Property
withTestMempool (TestSetupWithTxs -> TestSetup
testSetup TestSetupWithTxs
setup) ((forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool { Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool } -> do
      result <- Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> m [MempoolAddTxResult
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool (TestSetupWithTxs -> [TestTx]
allTxs TestSetupWithTxs
setup)
      return $ counterexample (ppTxs (txs setup)) $
        [ case res of
            MempoolTxAdded Validated TestTx
vtx        -> (Validated TestTx -> TestTx
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated TestTx
vtx, Bool
True)
            MempoolTxRejected TestTx
tx ApplyTxErr
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
_err -> (TestTx
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 => TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m prop)
-> Property
withTestMempool (TestSetupWithTxs -> TestSetup
testSetup TestSetupWithTxs
setup) ((forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool { Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool } -> do
      txsInMempoolBefore <- ((Validated TestTx, TicketNo, TheMeasure) -> Validated TestTx)
-> [(Validated TestTx, TicketNo, TheMeasure)] -> [Validated TestTx]
forall a b. (a -> b) -> [a] -> [b]
map (Validated TestTx, TicketNo, TheMeasure) -> Validated TestTx
(Validated TestTx, TicketNo,
 TxMeasure
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Validated TestTx
prjTx ([(Validated TestTx, TicketNo, TheMeasure)] -> [Validated TestTx])
-> (MempoolSnapshot
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> [(Validated TestTx, TicketNo, TheMeasure)])
-> MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [Validated TestTx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [(Validated TestTx, TicketNo, TheMeasure)]
MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [(Validated TestTx, TicketNo,
     TxMeasure
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxs (MempoolSnapshot
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> [Validated TestTx])
-> m (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m [Validated TestTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        STM
  m
  (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> STM
     m
     (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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 TestTx
txToRemove) =
    TestSetup
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m prop)
-> Property
withTestMempool TestSetup
testSetup ((forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool { Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool } -> do
      let Mempool { NonEmpty
  (GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m ()
removeTxsEvenIfValid :: NonEmpty
  (GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m ()
removeTxsEvenIfValid :: forall (m :: * -> *) blk.
Mempool m blk -> NonEmpty (GenTxId blk) -> m ()
removeTxsEvenIfValid, STM
  m
  (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
getSnapshot :: forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot :: STM
  m
  (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
getSnapshot } = Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool
      NonEmpty
  (GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m ()
removeTxsEvenIfValid (NonEmpty
   (GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> m ())
-> NonEmpty
     (GenTxId
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m ()
forall a b. (a -> b) -> a -> b
$ [GenTxId
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> NonEmpty
     (GenTxId
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [TestTx
-> GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall tx. HasTxId tx => tx -> TxId tx
txId TestTx
txToRemove]
      txsInMempoolAfter <- ((Validated TestTx, TicketNo, TheMeasure) -> Validated TestTx)
-> [(Validated TestTx, TicketNo, TheMeasure)] -> [Validated TestTx]
forall a b. (a -> b) -> [a] -> [b]
map (Validated TestTx, TicketNo, TheMeasure) -> Validated TestTx
(Validated TestTx, TicketNo,
 TxMeasure
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Validated TestTx
prjTx ([(Validated TestTx, TicketNo, TheMeasure)] -> [Validated TestTx])
-> (MempoolSnapshot
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> [(Validated TestTx, TicketNo, TheMeasure)])
-> MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [Validated TestTx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [(Validated TestTx, TicketNo, TheMeasure)]
MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [(Validated TestTx, TicketNo,
     TxMeasure
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxs (MempoolSnapshot
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> [Validated TestTx])
-> m (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m [Validated TestTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM
  m
  (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM
  m
  (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
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 TestTx
txsToRemove) =
  TestSetup
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m prop)
-> Property
withTestMempool TestSetup
testSetup ((forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool {mempool :: forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool = Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool1} -> do
  Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> NonEmpty
     (GenTxId
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m ()
forall (m :: * -> *) blk.
Mempool m blk -> NonEmpty (GenTxId blk) -> m ()
removeTxsEvenIfValid Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool1 (NonEmpty
   (GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> m ())
-> NonEmpty
     (GenTxId
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m ()
forall a b. (a -> b) -> a -> b
$ (TestTx
 -> GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> NonEmpty TestTx
-> NonEmpty
     (GenTxId
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map TestTx
-> GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall tx. HasTxId tx => tx -> TxId tx
txId NonEmpty TestTx
txsToRemove
  snapshot1 <- STM
  m
  (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> STM
     m
     (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool1)

  return $ withTestMempool testSetup $ \TestMempool {mempool :: forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool = Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool2} -> do
    NonEmpty
  (GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> (GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> m ())
-> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((TestTx
 -> GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> NonEmpty TestTx
-> NonEmpty
     (GenTxId
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map TestTx
-> GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall tx. HasTxId tx => tx -> TxId tx
txId NonEmpty TestTx
txsToRemove) (Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> NonEmpty
     (GenTxId
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m ()
forall (m :: * -> *) blk.
Mempool m blk -> NonEmpty (GenTxId blk) -> m ()
removeTxsEvenIfValid Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool2 (NonEmpty
   (GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> m ())
-> (GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> NonEmpty
         (GenTxId
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
-> GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenTxId
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> NonEmpty
     (GenTxId
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. a -> [a] -> NonEmpty a
NE.:| []))
    snapshot2 <- STM
  m
  (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> STM
     m
     (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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 => TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m prop)
-> Property
withTestMempool TestSetup
testSetup ((forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool{Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> STM
     m
     (TxMeasure
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (m :: * -> *) blk. Mempool m blk -> STM m (TxMeasure blk)
getCapacity Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool
      pure $ actualCapacity === expectedCapacity
  where
    MempoolCapacityBytesOverride ByteSize32
testCapacity = TestSetup -> MempoolCapacityBytesOverride
testMempoolCapOverride TestSetup
testSetup
    MempoolCapTestSetup (TestSetupWithTxs TestSetup
testSetup [(TestTx, 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 => TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m prop)
-> Property
withTestMempool (TestSetupWithTxs -> TestSetup
testSetup TestSetupWithTxs
setup) ((forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool m
testMempool -> do
      let TestMempool { Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool, m [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents :: m [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents :: forall (m :: * -> *).
TestMempool m
-> m [TraceEventMempool
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents } = TestMempool m
testMempool
      _ <- Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> m [MempoolAddTxResult
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool (TestSetupWithTxs -> [TestTx]
allTxs TestSetupWithTxs
setup)
      evs <- getTraceEvents
      return $ counterexample (ppTxs (txs setup)) $
        let addedTxs = (TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> Maybe TestTx)
-> [TraceEventMempool
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> [TestTx]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Maybe TestTx
isAddedTxsEvent [TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
evs
        in validTxs setup === addedTxs
  where
    isAddedTxsEvent :: TraceEventMempool TestBlock -> Maybe (GenTx TestBlock)
    isAddedTxsEvent :: TraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Maybe TestTx
isAddedTxsEvent (TraceMempoolAddedTx Validated TestTx
tx MempoolSize
_ MempoolSize
_) = TestTx -> Maybe TestTx
forall a. a -> Maybe a
Just (Validated TestTx -> TestTx
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated TestTx
tx)
    isAddedTxsEvent TraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
_                            = Maybe TestTx
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 => TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m prop)
-> Property
withTestMempool (TestSetupWithTxs -> TestSetup
testSetup TestSetupWithTxs
setup) ((forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool m
testMempool -> do
      let TestMempool { Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool, m [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents :: forall (m :: * -> *).
TestMempool m
-> m [TraceEventMempool
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents :: m [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents } = TestMempool m
testMempool
      _ <- Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> m [MempoolAddTxResult
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool (TestSetupWithTxs -> [TestTx]
allTxs TestSetupWithTxs
setup)
      evs <- getTraceEvents
      return $ counterexample (ppTxs (txs setup)) $
        let rejectedTxs = (TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> Maybe TestTx)
-> [TraceEventMempool
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> [TestTx]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Maybe TestTx
forall blk. TraceEventMempool blk -> Maybe (GenTx blk)
isRejectedTxEvent [TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
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
_ 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 => TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m prop)
-> Property
withTestMempool TestSetup
setup ((forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TestMempool m
testMempool -> do
      let TestMempool { Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool, m [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents :: forall (m :: * -> *).
TestMempool m
-> m [TraceEventMempool
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents :: m [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents, [TestTx]
-> STM
     m
     [Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ()]
addTxsToLedger :: [TestTx]
-> STM
     m
     [Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ()]
addTxsToLedger :: forall (m :: * -> *).
TestMempool m
-> [TestTx]
-> STM
     m
     [Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ()]
addTxsToLedger, STM
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
getCurrentLedger :: STM
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
getCurrentLedger :: forall (m :: * -> *).
TestMempool m
-> STM
     m
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
getCurrentLedger } = TestMempool m
testMempool
      MempoolSnapshot { snapshotTxs } <- STM
  m
  (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (MempoolSnapshot
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> m (MempoolSnapshot
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
-> STM
     m
     (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a b. (a -> b) -> a -> b
$ Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> STM
     m
     (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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 TestTx, TicketNo, TheMeasure) -> Validated TestTx)
-> [(Validated TestTx, TicketNo, TheMeasure)] -> [Validated TestTx]
forall a b. (a -> b) -> [a] -> [b]
map (Validated TestTx, TicketNo, TheMeasure) -> Validated TestTx
(Validated TestTx, TicketNo,
 TxMeasure
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Validated TestTx
prjTx [(Validated TestTx, TicketNo, TheMeasure)]
[(Validated TestTx, TicketNo,
  TxMeasure
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
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 $ syncWithLedger mempool

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

      -- Look at the trace to see which transactions actually got removed
      evs <- getTraceEvents
      let removedTxs = [[(TestTx,
   MockError
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]]
-> [(TestTx,
     MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(TestTx,
    MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]]
 -> [(TestTx,
      MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))])
-> [[(TestTx,
      MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]]
-> [(TestTx,
     MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
forall a b. (a -> b) -> a -> b
$ (TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> Maybe
      [(TestTx,
        MockError
          (SimpleBlock
             SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))])
-> [TraceEventMempool
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> [[(TestTx,
      MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Maybe
     [(TestTx,
       ApplyTxErr
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
TraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Maybe
     [(TestTx,
       MockError
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
isRemoveTxsEvent [TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
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
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
cfg = TestSetup
-> LedgerConfig
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg TestSetup
setup

    isRemoveTxsEvent :: TraceEventMempool TestBlock -> Maybe [(TestTx, TestTxError)]
    isRemoveTxsEvent :: TraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Maybe
     [(TestTx,
       ApplyTxErr
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
isRemoveTxsEvent (TraceMempoolRemoveTxs [(Validated TestTx,
  ApplyTxErr
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
txs MempoolSize
_) = [(TestTx,
  MockError
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
-> Maybe
     [(TestTx,
       MockError
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
forall a. a -> Maybe a
Just (((Validated TestTx,
  MockError
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> (TestTx,
     MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
-> [(Validated TestTx,
     MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
-> [(TestTx,
     MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
forall a b. (a -> b) -> [a] -> [b]
map ((Validated TestTx -> TestTx)
-> (Validated TestTx,
    MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> (TestTx,
    MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
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 TestTx -> TestTx
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated) [(Validated TestTx,
  ApplyTxErr
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
[(Validated TestTx,
  MockError
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
txs)
    isRemoveTxsEvent TraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
_                             = Maybe
  [(TestTx,
    ApplyTxErr
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
Maybe
  [(TestTx,
    MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
forall a. Maybe a
Nothing

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

prjTx ::
     (Validated (GenTx TestBlock), TicketNo, TxMeasure TestBlock)
  -> Validated (GenTx TestBlock)
prjTx :: (Validated TestTx, TicketNo,
 TxMeasure
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Validated TestTx
prjTx (Validated TestTx
a, TicketNo
_b, TxMeasure
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
_c) = Validated TestTx
a

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

data TestSetup = TestSetup
  { TestSetup
-> LedgerConfig
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg          :: LedgerConfig TestBlock
  , TestSetup
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
testLedgerState        :: LedgerState TestBlock ValuesMK
  , TestSetup -> [TestTx]
testInitialTxs         :: [TestTx]
    -- ^ These are all valid and will be the initial contents of the Mempool.
  , TestSetup -> MempoolCapacityBytesOverride
testMempoolCapOverride :: MempoolCapacityBytesOverride
  } 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 { [TestTx]
testInitialTxs :: TestSetup -> [TestTx]
testInitialTxs :: [TestTx]
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
<>
    ((TestTx -> String) -> [TestTx] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TestTx -> String
ppTestTxWithHash [TestTx]
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
$ (TestTx -> ByteSize32) -> [TestTx] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TestTx -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize ([TestTx] -> ByteSize32) -> [TestTx] -> ByteSize32
forall a b. (a -> b) -> a -> b
$ [TestTx]
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 :: TestTx -> String
ppTestTxWithHash TestTx
x = (Hash SHA256 Tx, TestTx) -> 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 (TestTx -> Tx
forall c ext. GenTx (SimpleBlock c ext) -> Tx
simpleGenTx TestTx
x) :: Hash SHA256 Tx, TestTx
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
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        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 = (TestTx -> ByteSize32) -> [TestTx] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TestTx -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize [TestTx]
txs2
        mpCap              = ByteSize32
initTxsSizeInBytes ByteSize32 -> ByteSize32 -> ByteSize32
forall a. Semigroup a => a -> a -> a
<> ByteSize32
extraCapacity
        testSetup = TestSetup
          { testLedgerCfg :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg          = LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerConfigNoSizeLimits
          , testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState        = LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
ledger1
          , testInitialTxs :: [TestTx]
testInitialTxs         = [TestTx]
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
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
genTestSetup Int
maxInitialTxs =
    Int
-> ByteSize32
-> Gen
     (TestSetup,
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
genTestSetupWithExtraCapacity Int
maxInitialTxs (Word32 -> ByteSize32
ByteSize32 Word32
0)

-- | Random 'MempoolCapacityBytesOverride'
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
    noOverride <- arbitrary
    let initialSize = (TestTx -> ByteSize32) -> [TestTx] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TestTx -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize ([TestTx] -> ByteSize32) -> [TestTx] -> ByteSize32
forall a b. (a -> b) -> a -> b
$ TestSetup -> [TestTx]
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
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg :: TestSetup
-> LedgerConfig
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg
                   , LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState :: TestSetup
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState
                   , [TestTx]
testInitialTxs :: TestSetup -> [TestTx]
testInitialTxs :: [TestTx]
testInitialTxs
                   , testMempoolCapOverride :: TestSetup -> MempoolCapacityBytesOverride
testMempoolCapOverride =
                       MempoolCapacityBytesOverride (ByteSize32 Word32
mpCap)
                   } =
    -- TODO we could shrink @testLedgerState@ too
    [ TestSetup { LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg
                , LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState
                , testInitialTxs :: [TestTx]
testInitialTxs = [TestTx]
testInitialTxs'
                , testMempoolCapOverride :: MempoolCapacityBytesOverride
testMempoolCapOverride =
                    ByteSize32 -> MempoolCapacityBytesOverride
MempoolCapacityBytesOverride ByteSize32
mpCap'
                }
    | let ByteSize32 Word32
initial = (TestTx -> ByteSize32) -> [TestTx] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TestTx -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize [TestTx]
testInitialTxs
          extraCap :: Word32
extraCap           = Word32
mpCap Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
initial
    , [TestTx]
testInitialTxs' <- (TestTx -> [TestTx]) -> [TestTx] -> [[TestTx]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([TestTx] -> TestTx -> [TestTx]
forall a b. a -> b -> a
const []) [TestTx]
testInitialTxs
    , Either
  (ApplyTxErr
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
-> Bool
forall a b. Either a b -> Bool
isRight (Either
   (ApplyTxErr
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   (LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
      ValuesMK)
 -> Bool)
-> Either
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
-> Bool
forall a b. (a -> b) -> a -> b
$ LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> [TestTx]
-> Either
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
txsAreValid LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState [TestTx]
testInitialTxs'
    , let mpCap' :: ByteSize32
mpCap' = (TestTx -> ByteSize32) -> [TestTx] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TestTx -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize [TestTx]
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
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg :: TestSetup
-> LedgerConfig
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg
                   , LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState :: TestSetup
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState
                   , [TestTx]
testInitialTxs :: TestSetup -> [TestTx]
testInitialTxs :: [TestTx]
testInitialTxs
                   , testMempoolCapOverride :: TestSetup -> MempoolCapacityBytesOverride
testMempoolCapOverride = MempoolCapacityBytesOverride
NoMempoolCapacityBytesOverride
                   } =
    -- TODO we could shrink @testLedgerState@ too
    [ TestSetup { LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg
                , LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState
                , testInitialTxs :: [TestTx]
testInitialTxs = [TestTx]
testInitialTxs'
                , testMempoolCapOverride :: MempoolCapacityBytesOverride
testMempoolCapOverride = MempoolCapacityBytesOverride
NoMempoolCapacityBytesOverride
                }
    | [TestTx]
testInitialTxs' <- (TestTx -> [TestTx]) -> [TestTx] -> [[TestTx]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([TestTx] -> TestTx -> [TestTx]
forall a b. a -> b -> a
const []) [TestTx]
testInitialTxs
    , Either
  (ApplyTxErr
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
-> Bool
forall a b. Either a b -> Bool
isRight (Either
   (ApplyTxErr
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   (LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
      ValuesMK)
 -> Bool)
-> Either
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
-> Bool
forall a b. (a -> b) -> a -> b
$ LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> [TestTx]
-> Either
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
txsAreValid LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState [TestTx]
testInitialTxs'
    ]

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

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

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

data TestSetupWithTxs = TestSetupWithTxs
  { TestSetupWithTxs -> TestSetup
testSetup :: TestSetup
  , TestSetupWithTxs -> [(TestTx, Bool)]
txs       :: [(TestTx, Bool)]
    -- ^ The 'Bool' indicates whether the transaction is valid
  } 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 :: [(TestTx, Bool)] -> String
ppTxs [(TestTx, 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
<>
    [ TestTx -> String
forall a. Condense a => a -> String
condense TestTx
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"
    | (TestTx
tx, Bool
valid) <- [(TestTx, Bool)]
txs]

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

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

invalidTxs :: TestSetupWithTxs -> [GenTx TestBlock]
invalidTxs :: TestSetupWithTxs -> [TestTx]
invalidTxs = ((TestTx, Bool) -> TestTx) -> [(TestTx, Bool)] -> [TestTx]
forall a b. (a -> b) -> [a] -> [b]
map (TestTx, Bool) -> TestTx
forall a b. (a, b) -> a
fst ([(TestTx, Bool)] -> [TestTx])
-> (TestSetupWithTxs -> [(TestTx, Bool)])
-> TestSetupWithTxs
-> [TestTx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TestTx, Bool) -> Bool) -> [(TestTx, Bool)] -> [(TestTx, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((TestTx, Bool) -> Bool) -> (TestTx, Bool) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestTx, Bool) -> Bool
forall a b. (a, b) -> b
snd) ([(TestTx, Bool)] -> [(TestTx, Bool)])
-> (TestSetupWithTxs -> [(TestTx, Bool)])
-> TestSetupWithTxs
-> [(TestTx, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetupWithTxs -> [(TestTx, 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     -> TestSetup -> Gen TestSetup
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return TestSetup
testSetup
      MempoolCapacityBytesOverride ByteSize32
mpCap -> do
        noOverride <- Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
        let initialSize = (TestTx -> ByteSize32) -> [TestTx] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TestTx -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize ([TestTx] -> ByteSize32) -> [TestTx] -> ByteSize32
forall a b. (a -> b) -> a -> b
$ TestSetup -> [TestTx]
testInitialTxs TestSetup
testSetup
            defaultCap  = ByteSize32
simpleBlockCapacity ByteSize32 -> ByteSize32 -> ByteSize32
forall a. Semigroup a => a -> a -> a
<> ByteSize32
simpleBlockCapacity
            newSize     =
                 ((TestTx, Bool) -> ByteSize32) -> [(TestTx, 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 (TestTx -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize (TestTx -> ByteSize32)
-> ((TestTx, Bool) -> TestTx) -> (TestTx, Bool) -> ByteSize32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestTx, Bool) -> TestTx
forall a b. (a, b) -> a
fst) (((TestTx, Bool) -> Bool) -> [(TestTx, Bool)] -> [(TestTx, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TestTx, Bool) -> Bool
forall a b. (a, b) -> b
snd [(TestTx, 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]
: ((TestTx, Bool) -> ByteSize32) -> [(TestTx, Bool)] -> [ByteSize32]
forall a b. (a -> b) -> [a] -> [b]
map (TestTx -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize (TestTx -> ByteSize32)
-> ((TestTx, Bool) -> TestTx) -> (TestTx, Bool) -> ByteSize32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestTx, Bool) -> TestTx
forall a b. (a, b) -> a
fst) (((TestTx, Bool) -> Bool) -> [(TestTx, Bool)] -> [(TestTx, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((TestTx, Bool) -> Bool) -> (TestTx, Bool) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestTx, Bool) -> Bool
forall a b. (a, b) -> b
snd) [(TestTx, Bool)]
txs))
        return testSetup {
              testMempoolCapOverride =
                if noOverride && initialSize <> newSize <= defaultCap
                then NoMempoolCapacityBytesOverride
                else MempoolCapacityBytesOverride $ mpCap <> newSize
            }
    let mempoolCap :: TheMeasure
        mempoolCap = LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> TickedLedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> MempoolCapacityBytesOverride
-> TxMeasure
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall blk (mk :: * -> * -> *).
LedgerSupportsMempool blk =>
LedgerConfig blk
-> TickedLedgerState blk mk
-> MempoolCapacityBytesOverride
-> TxMeasure blk
computeMempoolCapacity
          LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerConfigNoSizeLimits
          (LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
-> TickedLedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
forall c ext (mk :: * -> * -> *).
LedgerState (SimpleBlock c ext) mk
-> Ticked (LedgerState (SimpleBlock c ext)) mk
TickedSimpleLedgerState LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
ledger)
          (TestSetup -> MempoolCapacityBytesOverride
testMempoolCapOverride TestSetup
testSetup)


    largeInvalidTx <- genLargeInvalidTx mempoolCap
    let txs'        = (TestTx
largeInvalidTx, Bool
False) (TestTx, Bool) -> [(TestTx, Bool)] -> [(TestTx, Bool)]
forall a. a -> [a] -> [a]
: [(TestTx, 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, [(TestTx, Bool)]
txs :: TestSetupWithTxs -> [(TestTx, Bool)]
txs :: [(TestTx, Bool)]
txs } =
      [ TestSetupWithTxs { testSetup :: TestSetup
testSetup = TestSetup
testSetup', [(TestTx, Bool)]
txs :: [(TestTx, Bool)]
txs :: [(TestTx, 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 :: [(TestTx, Bool)]
txs = [(TestTx, Bool)]
txs' }
      | [(TestTx, Bool)]
txs' <- ([TestTx] -> [(TestTx, Bool)]) -> [[TestTx]] -> [[(TestTx, Bool)]]
forall a b. (a -> b) -> [a] -> [b]
map (((TestTx,
  Either
    (MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
    ())
 -> (TestTx, Bool))
-> [(TestTx,
     Either
       (MockError
          (SimpleBlock
             SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
       ())]
-> [(TestTx, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map ((Either
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   ()
 -> Bool)
-> (TestTx,
    Either
      (MockError
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
      ())
-> (TestTx, 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
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  ()
-> Bool
forall a b. Either a b -> Bool
isRight) ([(TestTx,
   Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     ())]
 -> [(TestTx, Bool)])
-> ([TestTx]
    -> [(TestTx,
         Either
           (MockError
              (SimpleBlock
                 SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
           ())])
-> [TestTx]
-> [(TestTx, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(TestTx,
   Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     ())],
 LedgerState
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
   ValuesMK)
-> [(TestTx,
     Either
       (MockError
          (SimpleBlock
             SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
       ())]
forall a b. (a, b) -> a
fst (([(TestTx,
    Either
      (MockError
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
      ())],
  LedgerState
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    ValuesMK)
 -> [(TestTx,
      Either
        (MockError
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())])
-> ([TestTx]
    -> ([(TestTx,
          Either
            (MockError
               (SimpleBlock
                  SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
            ())],
        LedgerState
          (SimpleBlock
             SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
          ValuesMK))
-> [TestTx]
-> [(TestTx,
     Either
       (MockError
          (SimpleBlock
             SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
       ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetup
-> [TestTx]
-> ([(TestTx,
      Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())],
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
      ValuesMK)
revalidate TestSetup
testSetup) ([[TestTx]] -> [[(TestTx, Bool)]])
-> ([(TestTx, Bool)] -> [[TestTx]])
-> [(TestTx, Bool)]
-> [[(TestTx, Bool)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                (TestTx -> [TestTx]) -> [TestTx] -> [[TestTx]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([TestTx] -> TestTx -> [TestTx]
forall a b. a -> b -> a
const []) ([TestTx] -> [[TestTx]])
-> ([(TestTx, Bool)] -> [TestTx]) -> [(TestTx, Bool)] -> [[TestTx]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                ((TestTx, Bool) -> TestTx) -> [(TestTx, Bool)] -> [TestTx]
forall a b. (a -> b) -> [a] -> [b]
map (TestTx, Bool) -> TestTx
forall a b. (a, b) -> a
fst ([(TestTx, Bool)] -> [[(TestTx, Bool)]])
-> [(TestTx, Bool)] -> [[(TestTx, Bool)]]
forall a b. (a -> b) -> a -> b
$ [(TestTx, Bool)]
txs ]

revalidate ::
     TestSetup
  -> [TestTx]
  -> ([(TestTx, Either TestTxError ())], LedgerState TestBlock ValuesMK)
revalidate :: TestSetup
-> [TestTx]
-> ([(TestTx,
      Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())],
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
      ValuesMK)
revalidate TestSetup { LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg :: TestSetup
-> LedgerConfig
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg, LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState :: TestSetup
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState, [TestTx]
testInitialTxs :: TestSetup -> [TestTx]
testInitialTxs :: [TestTx]
testInitialTxs } =
    LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> [TestTx]
-> ([(TestTx,
      Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())],
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
      ValuesMK)
validateTxs LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
initLedgerState
  where
    -- The LedgerState after adding the transactions initially in the mempool
    initLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
initLedgerState = (TestTx
 -> LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
      ValuesMK
 -> LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
      ValuesMK)
-> [TestTx]
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
forall a b. (a -> b -> b) -> [a] -> b -> b
repeatedly
      (\TestTx
tx LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
l -> HasCallStack =>
Except
  (ApplyTxErr
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
Except
  (ApplyTxErr
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
mustBeValid (LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> TestTx
-> Except
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
applyTxToLedger LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
l TestTx
tx))
      [TestTx]
testInitialTxs
      LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  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
. [TestTx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TestTx] -> Bool)
-> (TestSetupWithTxs -> [TestTx]) -> TestSetupWithTxs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetup -> [TestTx]
testInitialTxs (TestSetup -> [TestTx])
-> (TestSetupWithTxs -> TestSetup) -> TestSetupWithTxs -> [TestTx]
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 TestTx
_tx) =
    [ TestSetup -> TestTx -> TestSetupWithTxInMempool
TestSetupWithTxInMempool TestSetup
testSetup' TestTx
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
. [TestTx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TestTx] -> Bool) -> (TestSetup -> [TestTx]) -> TestSetup -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetup -> [TestTx]
testInitialTxs (TestSetup -> Bool) -> TestSetup -> Bool
forall a b. (a -> b) -> a -> b
$ TestSetup
testSetup'
    , TestTx
tx' <- TestSetup -> [TestTx]
testInitialTxs TestSetup
testSetup'
    ]

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
. [TestTx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TestTx] -> Bool)
-> (TestSetupWithTxs -> [TestTx]) -> TestSetupWithTxs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetup -> [TestTx]
testInitialTxs (TestSetup -> [TestTx])
-> (TestSetupWithTxs -> TestSetup) -> TestSetupWithTxs -> [TestTx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetupWithTxs -> TestSetup
testSetup)
    txs <- sublistOf (testInitialTxs testSetup)
    return $ TestSetupWithTxsInMempool testSetup txs

  -- TODO shrink

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
_ [TestTx]
txs) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [TestTx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestTx]
txs

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

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

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

data TestMempool m = TestMempool
  { -- | A mempool with random contents.
    --
    -- Starts out synced with the ledger.
    forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool          :: Mempool m 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 [TraceEventMempool
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents   :: m [TraceEventMempool TestBlock]

    -- | 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 -> m ()
eraseTraceEvents :: m ()

    -- | This function can be used to add transactions to the ledger/chain.
    --
    -- Remember to synchronise the mempool afterwards.
  , forall (m :: * -> *).
TestMempool m
-> [TestTx]
-> STM
     m
     [Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ()]
addTxsToLedger   :: [TestTx] -> STM m [Either TestTxError ()]

    -- | Return the current ledger.
  , forall (m :: * -> *).
TestMempool m
-> STM
     m
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
getCurrentLedger :: STM m (LedgerState TestBlock ValuesMK)
  }

-- 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.
withTestMempool ::
     forall prop. Testable prop
  => TestSetup
  -> (forall m. IOLike m => TestMempool m -> m prop)
  -> Property
withTestMempool :: forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m prop)
-> Property
withTestMempool setup :: TestSetup
setup@TestSetup {[TestTx]
LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
MempoolCapacityBytesOverride
testMempoolCapOverride :: TestSetup -> MempoolCapacityBytesOverride
testLedgerCfg :: TestSetup
-> LedgerConfig
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerState :: TestSetup
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
testInitialTxs :: TestSetup -> [TestTx]
testLedgerCfg :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testInitialTxs :: [TestTx]
testMempoolCapOverride :: MempoolCapacityBytesOverride
..} forall (m :: * -> *). IOLike 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 ([TestTx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestTx]
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 ([TestTx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestTx]
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 => m Property
setUpAndRun
  where
    isOverride :: MempoolCapacityBytesOverride -> Bool
isOverride (MempoolCapacityBytesOverride ByteSize32
_) = Bool
True
    isOverride MempoolCapacityBytesOverride
NoMempoolCapacityBytesOverride   = Bool
False

    setUpAndRun :: forall m. IOLike m => m Property
    setUpAndRun :: forall (m :: * -> *). IOLike m => m Property
setUpAndRun = do

      -- Set up the LedgerInterface
      varCurrentLedgerState <- LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
-> m (StrictTVar
        m
        (LedgerState
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
           ValuesMK))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState
      let ledgerInterface = LedgerInterface
            { getCurrentLedgerState :: STM
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     EmptyMK)
getCurrentLedgerState = LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     EmptyMK
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables (LedgerState
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
   ValuesMK
 -> LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
      EmptyMK)
-> STM
     m
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
-> STM
     m
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        EmptyMK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
-> STM
     m
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
varCurrentLedgerState
            , getLedgerTablesAtFor :: Point
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerTables
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     KeysMK
-> m (Maybe
        (LedgerTables
           (LedgerState
              (SimpleBlock
                 SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
           ValuesMK))
getLedgerTablesAtFor = \Point
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
pt LedgerTables
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  KeysMK
keys -> do
                st <- STM
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
-> m (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
      ValuesMK)
 -> m (LedgerState
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
         ValuesMK))
-> STM
     m
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
-> m (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
forall a b. (a -> b) -> a -> b
$ StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
-> STM
     m
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
varCurrentLedgerState
                if castPoint (getTip st) == pt
                  then pure $ Just $ restrictValues' st keys
                  else pure Nothing
            }

      -- Set up the Tracer
      varEvents <- uncheckedNewTVarM []
      -- TODO use IOSim's dynamicTracer
      let tracer = (TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> m ())
-> Tracer
     m
     (TraceEventMempool
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceEventMempool
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  -> m ())
 -> Tracer
      m
      (TraceEventMempool
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
-> (TraceEventMempool
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> m ())
-> Tracer
     m
     (TraceEventMempool
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a b. (a -> b) -> a -> b
$ \TraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> ([TraceEventMempool
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
    -> [TraceEventMempool
          (SimpleBlock
             SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))])
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar
  m
  [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
varEvents (TraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
evTraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TraceEventMempool
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> [TraceEventMempool
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall a. a -> [a] -> [a]
:)

      -- Open the mempool and add the initial transactions
      mempool <-
        openMempoolWithoutSyncThread
          ledgerInterface
          testLedgerCfg
          testMempoolCapOverride
          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
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
-> TestTx
-> STM
     m
     (Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())
addTxToLedger StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
varCurrentLedgerState TestTx
tx = do
      ledgerState <- StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
-> STM
     m
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
varCurrentLedgerState
      case runExcept (applyTxToLedger testLedgerCfg ledgerState tx) of
        Left  MockError
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
e            -> Either
  (MockError
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  ()
-> STM
     m
     (Either
        (MockError
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   ()
 -> STM
      m
      (Either
         (MockError
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
         ()))
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     ()
-> STM
     m
     (Either
        (MockError
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())
forall a b. (a -> b) -> a -> b
$ MockError
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     ()
forall a b. a -> Either a b
Left MockError
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
e
        Right LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
ledgerState' -> do
          StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
varCurrentLedgerState LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
ledgerState'
          Either
  (MockError
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  ()
-> STM
     m
     (Either
        (MockError
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   ()
 -> STM
      m
      (Either
         (MockError
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
         ()))
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     ()
-> STM
     m
     (Either
        (MockError
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())
forall a b. (a -> b) -> a -> b
$ ()
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     ()
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
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
-> [TestTx]
-> STM
     m
     [Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ()]
addTxsToLedger StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
varCurrentLedgerState [TestTx]
txs =
      (TestTx
 -> STM
      m
      (Either
         (MockError
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
         ()))
-> [TestTx]
-> STM
     m
     [Either
        (MockError
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ()]
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
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
-> TestTx
-> STM
     m
     (Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())
forall (m :: * -> *).
IOLike m =>
StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
-> TestTx
-> STM
     m
     (Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())
addTxToLedger StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
varCurrentLedgerState) [TestTx]
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
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
-> MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Property
checkMempoolValidity LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
ledgerState
                         MempoolSnapshot {
                             [(Validated TestTx, TicketNo,
  TxMeasure
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
snapshotTxs :: forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxs :: [(Validated TestTx, TicketNo,
  TxMeasure
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
snapshotTxs
                           , SlotNo
snapshotSlotNo :: forall blk. MempoolSnapshot blk -> SlotNo
snapshotSlotNo :: SlotNo
snapshotSlotNo
                           } =
        case Except
  (MockError
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (TickedLedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK)
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (TickedLedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
forall e a. Except e a -> Either e a
runExcept (Except
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   (TickedLedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
      ValuesMK)
 -> Either
      (MockError
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
      (TickedLedgerState
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
         ValuesMK))
-> Except
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (TickedLedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (TickedLedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
forall a b. (a -> b) -> a -> b
$ (TestTx
 -> TickedLedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
      ValuesMK
 -> Except
      (MockError
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
      (TickedLedgerState
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
         ValuesMK))
-> [TestTx]
-> TickedLedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> Except
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (TickedLedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m b) -> [a] -> b -> m b
repeatedlyM
               TestTx
-> TickedLedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> Except
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (TickedLedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
applyTx'
               [ Validated TestTx -> TestTx
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated TestTx
tx | (Validated TestTx
tx, TicketNo
_, TheMeasure
_) <- [(Validated TestTx, TicketNo, TheMeasure)]
[(Validated TestTx, TicketNo,
  TxMeasure
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
snapshotTxs ]
               (LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
-> TickedLedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
forall c ext (mk :: * -> * -> *).
LedgerState (SimpleBlock c ext) mk
-> Ticked (LedgerState (SimpleBlock c ext)) mk
TickedSimpleLedgerState LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
ledgerState) of
          Right TickedLedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
          Left  MockError
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
e -> String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (MockError
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> String
forall a. Show a => a -> String
mkErrMsg MockError
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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' :: TestTx
-> TickedLedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> Except
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (TickedLedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
applyTx' TestTx
tx TickedLedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
st = do
          st' <- LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> WhetherToIntervene
-> SlotNo
-> TestTx
-> TickedLedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> Except
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (TickedLedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        DiffMK,
      Validated TestTx)
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk ValuesMK
-> Except
     (ApplyTxErr blk)
     (TickedLedgerState blk DiffMK, Validated (GenTx blk))
applyTx LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg
                         WhetherToIntervene
DoNotIntervene
                         SlotNo
snapshotSlotNo
                         TestTx
tx
                         TickedLedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  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      = (TestTx -> ByteSize32) -> [TestTx] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TestTx -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize (TestSetup -> [TestTx]
testInitialTxs TestSetup
testSetup)
        capacityMinBound = ByteSize32
currentSize
        validTxsToAdd    = [TestTx
tx | (TestTx
tx, Bool
True) <- [(TestTx, 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
<> (TestTx -> ByteSize32) -> [TestTx] -> ByteSize32
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TestTx -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize [TestTx]
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
-------------------------------------------------------------------------------}

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 => TestMempool m -> m Property)
-> Property
forall prop.
Testable prop =>
TestSetup
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m prop)
-> Property
withTestMempool TestSetup
emptyTestSetup ((forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
 -> Property)
-> (forall (m :: * -> *). IOLike m => TestMempool m -> m Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \testMempool :: TestMempool m
testMempool@TestMempool { Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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 TestTx, TicketNo, TheMeasure) -> Validated TestTx)
-> [(Validated TestTx, TicketNo, TheMeasure)] -> [Validated TestTx]
forall a b. (a -> b) -> [a] -> [b]
map (Validated TestTx, TicketNo, TheMeasure) -> Validated TestTx
(Validated TestTx, TicketNo,
 TxMeasure
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Validated TestTx
prjTx ([(Validated TestTx, TicketNo, TheMeasure)] -> [Validated TestTx])
-> (MempoolSnapshot
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> [(Validated TestTx, TicketNo, TheMeasure)])
-> MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [Validated TestTx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [(Validated TestTx, TicketNo, TheMeasure)]
MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [(Validated TestTx, TicketNo,
     TxMeasure
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxs (MempoolSnapshot
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> [Validated TestTx])
-> m (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m [Validated TestTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                             STM
  m
  (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> STM
     m
     (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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 :: TicketAssignment
expectedAssignment = [Action] -> TicketAssignment
expectedTicketAssignment [Action]
actions

    emptyTestSetup :: TestSetup
emptyTestSetup = TestSetup
      { testLedgerCfg :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg          = LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerConfigNoSizeLimits
      , testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testLedgerState        = LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testInitLedger
      , testInitialTxs :: [TestTx]
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
1024Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
*Word32
1024Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
*Word32
1024
            -- There's no way this test will need more than a gibibyte.
      }

    lastOfMempoolRemoved :: [TestTx] -> Action -> Bool
lastOfMempoolRemoved [TestTx]
txsInMempool = \case
      AddTxs    [TestTx]
_   -> Bool
False
      RemoveTxs [TestTx]
txs -> [TestTx] -> TestTx
forall a. HasCallStack => [a] -> a
last [TestTx]
txsInMempool TestTx -> [TestTx] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TestTx]
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
  = AddTxs    [TestTx]
    -- ^ When part of 'Actions', all these transactions are valid.
  | RemoveTxs [TestTx]
    -- ^ When part of 'Actions', removing these transactions will not
    -- invalidate any other transactions.
  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] -> TicketAssignment
expectedTicketAssignment [Action]
actions =
    State TicketNo TicketAssignment -> TicketNo -> TicketAssignment
forall s a. State s a -> s -> a
evalState ((TicketAssignment -> Action -> State TicketNo TicketAssignment)
-> TicketAssignment -> [Action] -> State TicketNo TicketAssignment
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM TicketAssignment -> Action -> State TicketNo TicketAssignment
addMapping TicketAssignment
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 :: TicketAssignment -> Action -> State TicketNo TicketAssignment
addMapping TicketAssignment
mapping (RemoveTxs [TestTx]
_txs) = TicketAssignment -> State TicketNo TicketAssignment
forall a. a -> StateT TicketNo Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return TicketAssignment
mapping
    addMapping TicketAssignment
mapping (AddTxs     [TestTx]
txs) = do
      newMappings <- [TestTx]
-> (TestTx
    -> StateT
         TicketNo
         Identity
         (TicketNo,
          GenTxId
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
-> StateT
     TicketNo
     Identity
     [(TicketNo,
       GenTxId
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TestTx]
txs ((TestTx
  -> StateT
       TicketNo
       Identity
       (TicketNo,
        GenTxId
          (SimpleBlock
             SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
 -> StateT
      TicketNo
      Identity
      [(TicketNo,
        GenTxId
          (SimpleBlock
             SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))])
-> (TestTx
    -> StateT
         TicketNo
         Identity
         (TicketNo,
          GenTxId
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
-> StateT
     TicketNo
     Identity
     [(TicketNo,
       GenTxId
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
forall a b. (a -> b) -> a -> b
$ \TestTx
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 [TestTx]
txs -> do
      m [MempoolAddTxResult
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [MempoolAddTxResult
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
 -> m ())
-> m [MempoolAddTxResult
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> m ()
forall a b. (a -> b) -> a -> b
$ Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> m [MempoolAddTxResult
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool [TestTx]
txs
      allTraces <- (TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> Maybe
      (TraceEventMempool
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
-> m [TraceEventMempool
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall a.
(TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> Maybe a)
-> m [a]
expectTraceEvent TraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Maybe
     (TraceEventMempool
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. a -> Maybe a
Just
      let tracedAddedTxs = [ Validated TestTx
tx | TraceMempoolAddedTx Validated TestTx
tx MempoolSize
_ MempoolSize
_ <- [TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
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 [TestTx]
txs -> do
      let txs' :: NonEmpty
  (GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
txs' = [GenTxId
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> NonEmpty
     (GenTxId
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([GenTxId
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
 -> NonEmpty
      (GenTxId
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
-> [GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> NonEmpty
     (GenTxId
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a b. (a -> b) -> a -> b
$ (TestTx
 -> GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> [TestTx]
-> [GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall a b. (a -> b) -> [a] -> [b]
map TestTx
-> GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall tx. HasTxId tx => tx -> TxId tx
txId [TestTx]
txs
      Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> NonEmpty
     (GenTxId
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m ()
forall (m :: * -> *) blk.
Mempool m blk -> NonEmpty (GenTxId blk) -> m ()
removeTxsEvenIfValid Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool NonEmpty
  (GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
txs'
      tracedManuallyRemovedTxs <- (TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> Maybe
      (NonEmpty
         (GenTxId
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))))
-> m [NonEmpty
        (GenTxId
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
forall a.
(TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> Maybe a)
-> m [a]
expectTraceEvent ((TraceEventMempool
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  -> Maybe
       (NonEmpty
          (GenTxId
             (SimpleBlock
                SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))))
 -> m [NonEmpty
         (GenTxId
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))])
-> (TraceEventMempool
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> Maybe
         (NonEmpty
            (GenTxId
               (SimpleBlock
                  SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))))
-> m [NonEmpty
        (GenTxId
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
forall a b. (a -> b) -> a -> b
$ \case
        TraceMempoolManuallyRemovedTxs NonEmpty
  (GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
txIds [Validated TestTx]
_ MempoolSize
_ -> NonEmpty
  (GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Maybe
     (NonEmpty
        (GenTxId
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
forall a. a -> Maybe a
Just NonEmpty
  (GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
txIds
        TraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
_                                        -> Maybe
  (NonEmpty
     (GenTxId
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
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
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: forall (m :: * -> *).
TestMempool m
-> Mempool
     m
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool
      , m ()
eraseTraceEvents :: forall (m :: * -> *). TestMempool m -> m ()
eraseTraceEvents :: m ()
eraseTraceEvents
      , m [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents :: forall (m :: * -> *).
TestMempool m
-> m [TraceEventMempool
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents :: m [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents
      } = TestMempool m
testMempool

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

currentTicketAssignment :: IOLike m
                        => Mempool m TestBlock -> m TicketAssignment
currentTicketAssignment :: forall (m :: * -> *).
IOLike m =>
Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> m TicketAssignment
currentTicketAssignment Mempool { m (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
syncWithLedger :: forall (m :: * -> *) blk. Mempool m blk -> m (MempoolSnapshot blk)
syncWithLedger :: m (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
syncWithLedger } = do
    MempoolSnapshot { snapshotTxs } <- m (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
syncWithLedger
    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 ::
     Gen Int  -- ^ Generate the number of transactions to add
  -> Int      -- ^ How many actions
  -> Gen Actions
genActions :: Gen Int -> Int -> Gen Actions
genActions Gen Int
genNbToAdd = LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
-> [TestTx] -> [Action] -> Int -> Gen Actions
go LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
testInitLedger [TestTx]
forall a. Monoid a => a
mempty [Action]
forall a. Monoid a => a
mempty
  where
    cfg :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
cfg = LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
-> [TestTx] -> [Action] -> Int -> Gen Actions
go LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
ledger [TestTx]
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 ([TestTx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestTx]
txs)
            -- Remove a transaction (or multiple), but only if there are
            -- transactions to remove
          -> do
          tx <- [TestTx] -> Gen TestTx
forall a. HasCallStack => [a] -> Gen a
elements [TestTx]
txs
          let ((vTxs, iTxs), ledger') = first (List.partition (isRight . snd)) $
                validateTxs cfg testInitLedger (filter (/= tx) txs)
              txs'       = ((TestTx,
  Either
    (MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
    ())
 -> TestTx)
-> [(TestTx,
     Either
       (MockError
          (SimpleBlock
             SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
       ())]
-> [TestTx]
forall a b. (a -> b) -> [a] -> [b]
map (TestTx,
 Either
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   ())
-> TestTx
forall a b. (a, b) -> a
fst [(TestTx,
  Either
    (MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
    ())]
vTxs
              removedTxs = TestTx
tx TestTx -> [TestTx] -> [TestTx]
forall a. a -> [a] -> [a]
: ((TestTx,
  Either
    (MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
    ())
 -> TestTx)
-> [(TestTx,
     Either
       (MockError
          (SimpleBlock
             SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
       ())]
-> [TestTx]
forall a b. (a -> b) -> [a] -> [b]
map (TestTx,
 Either
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   ())
-> TestTx
forall a b. (a, b) -> a
fst [(TestTx,
  Either
    (MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
    ())]
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)