{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# 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 (Encoding, toCBOR)
import           Cardano.Crypto.Hash
import           Control.Exception (assert)
import           Control.Monad (foldM, forM, forM_, guard, void)
import           Control.Monad.Except (Except, runExcept)
import           Control.Monad.IOSim (runSimOrThrow)
import           Control.Monad.State (State, evalState, get, modify)
import           Control.Tracer (Tracer (..))
import           Data.Bifunctor (first, second)
import           Data.Either (isRight)
import           Data.List as List (foldl', isSuffixOf, nub, partition, sortOn)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (mapMaybe)
import           Data.Semigroup (stimes)
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Word (Word32)
import           GHC.Stack (HasCallStack)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime
import           Ouroboros.Consensus.Config.SecurityParam
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Mempool
import           Ouroboros.Consensus.Mempool.TxSeq as TxSeq
import           Ouroboros.Consensus.Mock.Ledger hiding (TxId)
import           Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..))
import           Ouroboros.Consensus.Protocol.BFT
import           Ouroboros.Consensus.Util (repeatedly, repeatedlyM,
                     safeMaximumOn, (.:))
import           Ouroboros.Consensus.Util.Condense (condense)
import           Ouroboros.Consensus.Util.IOLike
import           Test.Crypto.Hash ()
import           Test.QuickCheck hiding (elements)
import           Test.Tasty (TestTree, testGroup)
import           Test.Tasty.QuickCheck (testProperty)
import           Test.Util.Orphans.IOLike ()
import           Test.Util.QuickCheck (elements)

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 -> (TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"snapshotTxs == snapshotTxsAfter zeroIdx" 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 -> (MempoolCapTestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"result of getCapacity"                   MempoolCapTestSetup -> Property
prop_Mempool_getCapacity
  --   , testProperty "Mempool capacity implementation"         prop_Mempool_Capacity
  -- FIXME: we should add an issue to test this aspect somehow.
  , String -> (TestSetupWithTxs -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Added valid transactions are traced"     TestSetupWithTxs -> Property
prop_Mempool_TraceValidTxs
  , String -> (TestSetupWithTxs -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Rejected invalid txs are traced"         TestSetupWithTxs -> Property
prop_Mempool_TraceRejectedTxs
  , String -> (TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Removed invalid txs are traced"          TestSetup -> Property
prop_Mempool_TraceRemovedTxs
  , String -> (Actions -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"idx consistency"                         Actions -> Property
prop_Mempool_idx_consistency
  , String -> (TestSetupWithTxInMempool -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"removeTxs"                               TestSetupWithTxInMempool -> Property
prop_Mempool_removeTxs
  , String -> (TestSetupWithTxsInMempool -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"removeTxs [..] == forM [..] removeTxs"   TestSetupWithTxsInMempool -> Property
prop_Mempool_semigroup_removeTxs
  ]

type TheMeasure = IgnoringOverflow ByteSize32

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

-- | Test that @snapshotTxs == snapshotTxsAfter zeroIdx@.
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 { [(Validated TestTx, TicketNo, ByteSize32)]
snapshotTxs :: [(Validated TestTx, TicketNo, ByteSize32)]
snapshotTxs :: forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxs, TicketNo -> [(Validated TestTx, TicketNo, ByteSize32)]
snapshotTxsAfter :: TicketNo -> [(Validated TestTx, TicketNo, ByteSize32)]
snapshotTxsAfter :: forall blk.
MempoolSnapshot blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo, ByteSize32)]
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
      Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ [(Validated TestTx, TicketNo, ByteSize32)]
snapshotTxs [(Validated TestTx, TicketNo, ByteSize32)]
-> [(Validated TestTx, TicketNo, ByteSize32)] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TicketNo -> [(Validated TestTx, TicketNo, ByteSize32)]
snapshotTxsAfter TicketNo
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
      [MempoolAddTxResult
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
_ <- 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 { [(Validated TestTx, TicketNo, ByteSize32)]
snapshotTxs :: forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxs :: [(Validated TestTx, TicketNo, ByteSize32)]
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
      Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([(TestTx, Bool)] -> String
ppTxs (TestSetupWithTxs -> [(TestTx, Bool)]
txs TestSetupWithTxs
setup)) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
        TestSetupWithTxs -> [TestTx]
validTxs TestSetupWithTxs
setup [TestTx] -> [TestTx] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` ((Validated TestTx, TicketNo, ByteSize32) -> TestTx)
-> [(Validated TestTx, TicketNo, ByteSize32)] -> [TestTx]
forall a b. (a -> b) -> [a] -> [b]
map (Validated TestTx -> TestTx
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated (Validated TestTx -> TestTx)
-> ((Validated TestTx, TicketNo, ByteSize32) -> Validated TestTx)
-> (Validated TestTx, TicketNo, ByteSize32)
-> TestTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validated TestTx, TicketNo, ByteSize32) -> Validated TestTx
prjTx) [(Validated TestTx, TicketNo, ByteSize32)]
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
  [MempoolAddTxResult
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
_ <- 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)
  MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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 (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))
mempool1

  Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ 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))
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]
    MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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

    Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
      (String
"Transactions after adding in one go: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [(Validated TestTx, TicketNo, ByteSize32)] -> String
forall a. Show a => a -> String
show (MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [(Validated TestTx, TicketNo, ByteSize32)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxs MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
snapshot1)
       String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nTransactions after adding one by one: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [(Validated TestTx, TicketNo, ByteSize32)] -> String
forall a. Show a => a -> String
show (MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [(Validated TestTx, TicketNo, ByteSize32)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxs MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
snapshot2)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [(Validated TestTx, TicketNo, ByteSize32)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxs MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
snapshot1 [(Validated TestTx, TicketNo, ByteSize32)]
-> [(Validated TestTx, TicketNo, ByteSize32)] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [(Validated TestTx, TicketNo, ByteSize32)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxs MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
snapshot2 Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
        MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> MempoolSize
forall blk. MempoolSnapshot blk -> MempoolSize
snapshotMempoolSize MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
snapshot1 MempoolSize -> MempoolSize -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> MempoolSize
forall blk. MempoolSnapshot blk -> MempoolSize
snapshotMempoolSize MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
snapshot2 Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
        MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> SlotNo
forall blk. MempoolSnapshot blk -> SlotNo
snapshotSlotNo MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
snapshot1 SlotNo -> SlotNo -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> SlotNo
forall blk. MempoolSnapshot blk -> SlotNo
snapshotSlotNo MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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
      [MempoolAddTxResult
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
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)
      Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([(TestTx, Bool)] -> String
ppTxs (TestSetupWithTxs -> [(TestTx, Bool)]
txs TestSetupWithTxs
setup)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        [ case MempoolAddTxResult
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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)
        | MempoolAddTxResult
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
res <- [MempoolAddTxResult
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
result
        ] [(TestTx, Bool)] -> [(TestTx, Bool)] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TestSetupWithTxs -> [(TestTx, Bool)]
txs TestSetupWithTxs
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
      [Validated TestTx]
txsInMempoolBefore <- ((Validated TestTx, TicketNo, ByteSize32) -> Validated TestTx)
-> [(Validated TestTx, TicketNo, ByteSize32)] -> [Validated TestTx]
forall a b. (a -> b) -> [a] -> [b]
map (Validated TestTx, TicketNo, ByteSize32) -> Validated TestTx
prjTx ([(Validated TestTx, TicketNo, ByteSize32)] -> [Validated TestTx])
-> (MempoolSnapshot
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> [(Validated TestTx, TicketNo, ByteSize32)])
-> 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, ByteSize32)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
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)
      [MempoolAddTxResult
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
_ <- 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)
      [Validated TestTx]
txsInMempoolAfter <- ((Validated TestTx, TicketNo, ByteSize32) -> Validated TestTx)
-> [(Validated TestTx, TicketNo, ByteSize32)] -> [Validated TestTx]
forall a b. (a -> b) -> [a] -> [b]
map (Validated TestTx, TicketNo, ByteSize32) -> Validated TestTx
prjTx ([(Validated TestTx, TicketNo, ByteSize32)] -> [Validated TestTx])
-> (MempoolSnapshot
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> [(Validated TestTx, TicketNo, ByteSize32)])
-> 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, ByteSize32)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
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)
      Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([(TestTx, Bool)] -> String
ppTxs (TestSetupWithTxs -> [(TestTx, Bool)]
txs TestSetupWithTxs
setup)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
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.
        [ (Validated TestTx -> TestTx
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated TestTx
txInMempool TestTx -> [TestTx] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TestSetupWithTxs -> [TestTx]
validTxs TestSetupWithTxs
setup) Bool -> Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Bool
True
        | Validated TestTx
txInMempool <- [Validated TestTx]
txsInMempoolAfter
        , Validated TestTx
txInMempool Validated TestTx -> [Validated TestTx] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Validated TestTx]
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 { [GenTxId
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> m ()
removeTxs :: [GenTxId
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> m ()
removeTxs :: forall (m :: * -> *) blk. Mempool m blk -> [GenTxId blk] -> m ()
removeTxs, 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
      [GenTxId
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> m ()
removeTxs [TestTx
-> GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall tx. HasTxId tx => tx -> TxId tx
txId TestTx
txToRemove]
      [Validated TestTx]
txsInMempoolAfter <- ((Validated TestTx, TicketNo, ByteSize32) -> Validated TestTx)
-> [(Validated TestTx, TicketNo, ByteSize32)] -> [Validated TestTx]
forall a b. (a -> b) -> [a] -> [b]
map (Validated TestTx, TicketNo, ByteSize32) -> Validated TestTx
prjTx ([(Validated TestTx, TicketNo, ByteSize32)] -> [Validated TestTx])
-> (MempoolSnapshot
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> [(Validated TestTx, TicketNo, ByteSize32)])
-> 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, ByteSize32)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
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
      Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
        (String
"Transactions in the mempool after removing (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
         TestTx -> String
forall a. Show a => a -> String
show TestTx
txToRemove String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"): " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Validated TestTx] -> String
forall a. Show a => a -> String
show [Validated TestTx]
txsInMempoolAfter)
        (TestTx
txToRemove TestTx -> [TestTx] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (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]
txsInMempoolAfter)

-- | Test that both removing transactions one by one and removing them in one go
-- produce the same result.
prop_Mempool_semigroup_removeTxs :: TestSetupWithTxsInMempool -> Property
prop_Mempool_semigroup_removeTxs :: TestSetupWithTxsInMempool -> Property
prop_Mempool_semigroup_removeTxs (TestSetupWithTxsInMempool TestSetup
testSetup [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))
-> [GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> m ()
forall (m :: * -> *) blk. Mempool m blk -> [GenTxId blk] -> m ()
removeTxs Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool1 ([GenTxId
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
 -> m ())
-> [GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> m ()
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]
txsToRemove
  MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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)

  Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ 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))
mempool2} -> do
    [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)))
-> [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]
txsToRemove) (Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> m ()
forall (m :: * -> *) blk. Mempool m blk -> [GenTxId blk] -> m ()
removeTxs Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool2 ([GenTxId
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
 -> m ())
-> (GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> [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))]
-> [GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall a. a -> [a] -> [a]
:[]))
    MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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)

    Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
      (String
"Transactions after removing in one go: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [(Validated TestTx, TicketNo, ByteSize32)] -> String
forall a. Show a => a -> String
show (MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [(Validated TestTx, TicketNo, ByteSize32)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxs MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
snapshot1)
       String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nTransactions after removing one by one: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [(Validated TestTx, TicketNo, ByteSize32)] -> String
forall a. Show a => a -> String
show (MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [(Validated TestTx, TicketNo, ByteSize32)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxs MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
snapshot2)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [(Validated TestTx, TicketNo, ByteSize32)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxs MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
snapshot1 [(Validated TestTx, TicketNo, ByteSize32)]
-> [(Validated TestTx, TicketNo, ByteSize32)] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [(Validated TestTx, TicketNo, ByteSize32)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxs MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
snapshot2 Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
        MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> MempoolSize
forall blk. MempoolSnapshot blk -> MempoolSize
snapshotMempoolSize MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
snapshot1 MempoolSize -> MempoolSize -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> MempoolSize
forall blk. MempoolSnapshot blk -> MempoolSize
snapshotMempoolSize MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
snapshot2 Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
        MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> SlotNo
forall blk. MempoolSnapshot blk -> SlotNo
snapshotSlotNo MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
snapshot1 SlotNo -> SlotNo -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> SlotNo
forall blk. MempoolSnapshot blk -> SlotNo
snapshotSlotNo MempoolSnapshot
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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 ByteSize32
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
      Property -> m Property
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ ByteSize32
actualCapacity ByteSize32 -> ByteSize32 -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ByteSize32
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
      [MempoolAddTxResult
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
_ <- 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)
      [TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
evs <- m [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents
      Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([(TestTx, Bool)] -> String
ppTxs (TestSetupWithTxs -> [(TestTx, Bool)]
txs TestSetupWithTxs
setup)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        let addedTxs :: [TestTx]
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 TestSetupWithTxs -> [TestTx]
validTxs TestSetupWithTxs
setup [TestTx] -> [TestTx] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [TestTx]
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
      [MempoolAddTxResult
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
_ <- 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)
      [TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
evs <- m [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents
      Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([(TestTx, Bool)] -> String
ppTxs (TestSetupWithTxs -> [(TestTx, Bool)]
txs TestSetupWithTxs
setup)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        let rejectedTxs :: [TestTx]
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 TestSetupWithTxs -> [TestTx]
invalidTxs TestSetupWithTxs
setup [TestTx] -> [TestTx] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [TestTx]
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)))
getCurrentLedger :: STM
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
getCurrentLedger :: forall (m :: * -> *).
TestMempool m
-> STM
     m
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
getCurrentLedger } = TestMempool m
testMempool
      MempoolSnapshot { [(Validated TestTx, TicketNo, ByteSize32)]
snapshotTxs :: forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxs :: [(Validated TestTx, TicketNo, ByteSize32)]
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]
txsInMempool = ((Validated TestTx, TicketNo, ByteSize32) -> Validated TestTx)
-> [(Validated TestTx, TicketNo, ByteSize32)] -> [Validated TestTx]
forall a b. (a -> b) -> [a] -> [b]
map (Validated TestTx, TicketNo, ByteSize32) -> Validated TestTx
prjTx [(Validated TestTx, TicketNo, ByteSize32)]
snapshotTxs
      [Either
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   ()]
errs <- STM
  m
  [Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     ()]
-> m [Either
        (MockError
           (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
   [Either
      (MockError
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
      ()]
 -> m [Either
         (MockError
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
         ()])
-> STM
     m
     [Either
        (MockError
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ()]
-> m [Either
        (MockError
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ()]
forall a b. (a -> b) -> a -> b
$ [TestTx]
-> STM
     m
     [Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ()]
addTxsToLedger ((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)

      -- Sync the mempool with the ledger. Now some of the transactions in the
      -- mempool should have been removed.
      m (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (MempoolSnapshot
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> m ())
-> m (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m ()
forall a b. (a -> b) -> a -> b
$ Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> m (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (m :: * -> *) blk. Mempool m blk -> m (MempoolSnapshot blk)
syncWithLedger Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool

      -- Predict which transactions should have been removed
      LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
curLedger <- STM
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m (LedgerState
        (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
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
getCurrentLedger
      let expected :: [(TestTx,
  ApplyTxErr
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
expected = LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> [(TestTx,
     ApplyTxErr
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
expectedToBeRemoved LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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
      [TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
evs <- m [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents
      let removedTxs :: [(TestTx,
  MockError
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
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.
      Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m 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,
  MockError
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TestTx,
  MockError
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
removedTxs)) String
"Removed some transactions" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        (Either
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   ()
 -> Either
      (MockError
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
      ())
-> [Either
      (MockError
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
      ()]
-> [Either
      (MockError
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
      ()]
forall a b. (a -> b) -> [a] -> [b]
map (Either
  (MockError
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  ()
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     ()
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     ()
forall a b. a -> b -> a
const (()
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     ()
forall a b. b -> Either a b
Right ())) [Either
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   ()]
errs [Either
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   ()]
-> [Either
      (MockError
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
      ()]
-> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [Either
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   ()]
errs Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
        ((TestTx,
  MockError
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> TestTx)
-> [(TestTx,
     MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
-> [(TestTx,
     MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (TestTx,
 MockError
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> TestTx
forall a b. (a, b) -> a
fst [(TestTx,
  ApplyTxErr
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
[(TestTx,
  MockError
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
expected [(TestTx,
  MockError
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
-> [(TestTx,
     MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
-> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ((TestTx,
  MockError
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> TestTx)
-> [(TestTx,
     MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
-> [(TestTx,
     MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (TestTx,
 MockError
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> TestTx
forall a b. (a, b) -> a
fst [(TestTx,
  MockError
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
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 -> [TestTx] -> [(TestTx, TestTxError)]
    expectedToBeRemoved :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> [(TestTx,
     ApplyTxErr
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
expectedToBeRemoved LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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)))
-> [(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)))
 -> [(TestTx,
      Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())])
-> ([(TestTx,
      Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())],
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> [(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))
-> [TestTx]
-> ([(TestTx,
      Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())],
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
validateTxs LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
cfg LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledgerState [TestTx]
txsInMempool
      ]

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

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

type TestBlock = SimpleBftBlock SimpleMockCrypto BftMockCrypto

type TestTx = GenTx TestBlock

type TestTxId = TxId TestTx

type TestTxError = ApplyTxErr TestBlock

-- There are 5 (core)nodes and each gets 1000.
testInitLedger :: LedgerState TestBlock
testInitLedger :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testInitLedger = AddrDist
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall c ext. AddrDist -> LedgerState (SimpleBlock c ext)
genesisSimpleLedgerState (AddrDist
 -> LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> AddrDist
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall a b. (a -> b) -> a -> b
$ NumCoreNodes -> AddrDist
mkAddrDist (Word64 -> NumCoreNodes
NumCoreNodes Word64
5)

-- | Test config
--
-- (We don't really care about most of these values here)
mkTestLedgerConfig :: MockConfig -> LedgerConfig TestBlock
mkTestLedgerConfig :: MockConfig
-> LedgerConfig
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mkTestLedgerConfig MockConfig
mockCfg = SimpleLedgerConfig {
      simpleMockLedgerConfig :: MockLedgerConfig
  SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)
simpleMockLedgerConfig = ()
    , simpleLedgerEraParams :: EraParams
simpleLedgerEraParams  =
        SecurityParam -> SlotLength -> EraParams
HardFork.defaultEraParams
          (Word64 -> SecurityParam
SecurityParam Word64
4)
          (Integer -> SlotLength
slotLengthFromSec Integer
20)
    , simpleLedgerMockConfig :: MockConfig
simpleLedgerMockConfig = MockConfig
mockCfg
    }

testLedgerConfigNoSizeLimits :: LedgerConfig TestBlock
testLedgerConfigNoSizeLimits :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerConfigNoSizeLimits = MockConfig
-> LedgerConfig
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mkTestLedgerConfig MockConfig
defaultMockConfig

data TestSetup = TestSetup
  { TestSetup
-> LedgerConfig
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg          :: LedgerConfig TestBlock
  , TestSetup
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerState        :: LedgerState TestBlock
  , 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)
genTestSetupWithExtraCapacity :: Int
-> ByteSize32
-> Gen
     (TestSetup,
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
genTestSetupWithExtraCapacity Int
maxInitialTxs ByteSize32
extraCapacity = do
    Int
ledgerSize   <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
maxInitialTxs)
    Int
nbInitialTxs <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
maxInitialTxs)
    ([TestTx]
_txs1,  LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger1) <- Int
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     ([TestTx],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
genValidTxs Int
ledgerSize LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testInitLedger
    ( [TestTx]
txs2,  LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger2) <- Int
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     ([TestTx],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
genValidTxs Int
nbInitialTxs LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger1
    let initTxsSizeInBytes :: ByteSize32
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
mpCap              = ByteSize32
initTxsSizeInBytes ByteSize32 -> ByteSize32 -> ByteSize32
forall a. Semigroup a => a -> a -> a
<> ByteSize32
extraCapacity
        testSetup :: TestSetup
testSetup = TestSetup
          { testLedgerCfg :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg          = LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerConfigNoSizeLimits
          , testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerState        = LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger1
          , testInitialTxs :: [TestTx]
testInitialTxs         = [TestTx]
txs2
          , testMempoolCapOverride :: MempoolCapacityBytesOverride
testMempoolCapOverride = ByteSize32 -> MempoolCapacityBytesOverride
MempoolCapacityBytesOverride ByteSize32
mpCap
          }
    (TestSetup,
 LedgerState
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Gen
     (TestSetup,
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (TestSetup
testSetup, LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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)
genTestSetup :: Int
-> Gen
     (TestSetup,
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
genTestSetup Int
maxInitialTxs =
    Int
-> ByteSize32
-> Gen
     (TestSetup,
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
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
    ByteSize32
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
testSetup <- (TestSetup,
 LedgerState
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> TestSetup
forall a b. (a, b) -> a
fst ((TestSetup,
  LedgerState
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> TestSetup)
-> Gen
     (TestSetup,
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Gen TestSetup
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ByteSize32
-> Gen
     (TestSetup,
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
genTestSetupWithExtraCapacity Int
n ByteSize32
extraCapacity
    Bool
noOverride <- Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
    let initialSize :: ByteSize32
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
defaultCap  = ByteSize32
simpleBlockCapacity ByteSize32 -> ByteSize32 -> ByteSize32
forall a. Semigroup a => a -> a -> a
<> ByteSize32
simpleBlockCapacity
    TestSetup -> Gen TestSetup
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (TestSetup -> Gen TestSetup) -> TestSetup -> Gen TestSetup
forall a b. (a -> b) -> a -> b
$
      if Bool
noOverride Bool -> Bool -> Bool
&& ByteSize32
initialSize ByteSize32 -> ByteSize32 -> Bool
forall a. Ord a => a -> a -> Bool
<= ByteSize32
defaultCap
      then TestSetup
testSetup { testMempoolCapOverride = NoMempoolCapacityBytesOverride }
      else TestSetup
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))
testLedgerState :: TestSetup
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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))
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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)))
-> Bool
forall a b. Either a b -> Bool
isRight (Either
   (ApplyTxErr
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   (LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> Bool)
-> Either
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Bool
forall a b. (a -> b) -> a -> b
$ LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> Either
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
txsAreValid LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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))
testLedgerState :: TestSetup
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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))
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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)))
-> Bool
forall a b. Either a b -> Bool
isRight (Either
   (ApplyTxErr
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   (LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> Bool)
-> Either
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Bool
forall a b. (a -> b) -> a -> b
$ LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> Either
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
txsAreValid LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerState [TestTx]
testInitialTxs'
    ]

-- | Generate a number of valid and invalid transactions and apply the valid
-- transactions to the given 'LedgerState'. The transactions along with a
-- 'Bool' indicating whether its valid ('True') or invalid ('False') and the
-- resulting 'LedgerState' are returned.
genTxs :: Int  -- ^ The number of transactions to generate
       -> LedgerState TestBlock
       -> Gen ([(TestTx, Bool)], LedgerState TestBlock)
genTxs :: Int
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     ([(TestTx, Bool)],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
genTxs = [(TestTx, Bool)]
-> Int
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     ([(TestTx, Bool)],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall {t}.
(Ord t, Num t) =>
[(TestTx, Bool)]
-> t
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     ([(TestTx, Bool)],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
go []
  where
    go :: [(TestTx, Bool)]
-> t
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     ([(TestTx, Bool)],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
go [(TestTx, Bool)]
txs t
n LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger
      | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = ([(TestTx, Bool)],
 LedgerState
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Gen
     ([(TestTx, Bool)],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(TestTx, Bool)] -> [(TestTx, Bool)]
forall a. [a] -> [a]
reverse [(TestTx, Bool)]
txs, LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger)
      | Bool
otherwise = do
          Bool
valid <- Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
          if Bool
valid
            then do
              (TestTx
validTx, LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger') <- LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     (TestTx,
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
genValidTx LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger
              [(TestTx, Bool)]
-> t
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     ([(TestTx, Bool)],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
go ((TestTx
validTx, Bool
True)(TestTx, Bool) -> [(TestTx, Bool)] -> [(TestTx, Bool)]
forall a. a -> [a] -> [a]
:[(TestTx, Bool)]
txs)    (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger'
            else do
              TestTx
invalidTx <- LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen TestTx
genInvalidTx LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger
              [(TestTx, Bool)]
-> t
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     ([(TestTx, Bool)],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
go ((TestTx
invalidTx, Bool
False)(TestTx, Bool) -> [(TestTx, Bool)] -> [(TestTx, Bool)]
forall a. a -> [a] -> [a]
:[(TestTx, Bool)]
txs) (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger

mustBeValid :: HasCallStack
            => Except TestTxError (LedgerState TestBlock)
            -> LedgerState TestBlock
mustBeValid :: HasCallStack =>
Except
  (ApplyTxErr
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mustBeValid Except
  (ApplyTxErr
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
ex = case Except
  (MockError
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall e a. Except e a -> Either e a
runExcept Except
  (ApplyTxErr
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
Except
  (MockError
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
ex of
  Left MockError
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
_       -> String
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall a. HasCallStack => String -> a
error String
"impossible"
  Right LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger -> LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger

txIsValid :: LedgerConfig TestBlock -> LedgerState TestBlock -> TestTx -> Bool
txIsValid :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> TestTx
-> Bool
txIsValid LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
cfg LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledgerState TestTx
tx =
    Either
  (MockError
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Bool
forall a b. Either a b -> Bool
isRight (Either
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   (LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> Bool)
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Bool
forall a b. (a -> b) -> a -> b
$ Except
  (ApplyTxErr
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Either
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall e a. Except e a -> Either e a
runExcept (Except
   (ApplyTxErr
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   (LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> Either
      (ApplyTxErr
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
      (LedgerState
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
-> Except
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Either
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a b. (a -> b) -> a -> b
$ LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> TestTx
-> Except
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
applyTxToLedger LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
cfg LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledgerState TestTx
tx

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

validateTxs ::
     LedgerConfig TestBlock
  -> LedgerState TestBlock
  -> [TestTx]
  -> ([(TestTx, Either TestTxError ())], LedgerState TestBlock)
validateTxs :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> ([(TestTx,
      Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())],
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
validateTxs LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
cfg = [(TestTx,
  Either
    (MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
    ())]
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> ([(TestTx,
      Either
        (MockError
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())],
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
go []
  where
    go :: [(TestTx,
  Either
    (MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
    ())]
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> ([(TestTx,
      Either
        (MockError
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())],
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
go [(TestTx,
  Either
    (MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
    ())]
revalidated LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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))
ledgerState)
      TestTx
tx:[TestTx]
txs' -> case Except
  (MockError
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall e a. Except e a -> Either e a
runExcept (LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> TestTx
-> Except
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
applyTxToLedger LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
cfg LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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))
-> [TestTx]
-> ([(TestTx,
      Either
        (MockError
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())],
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
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))
ledgerState  [TestTx]
txs'
        Right LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledgerState' -> [(TestTx,
  Either
    (MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
    ())]
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> ([(TestTx,
      Either
        (MockError
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())],
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
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))
ledgerState' [TestTx]
txs'

-- | Generate a number of valid transactions and apply these to the given
-- 'LedgerState'. The transactions and the resulting 'LedgerState' are
-- returned.
genValidTxs :: Int  -- ^ The number of valid transactions to generate
            -> LedgerState TestBlock
            -> Gen ([TestTx], LedgerState TestBlock)
genValidTxs :: Int
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     ([TestTx],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
genValidTxs = [TestTx]
-> Int
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     ([TestTx],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall {t}.
(Ord t, Num t) =>
[TestTx]
-> t
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     ([TestTx],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
go []
  where
    go :: [TestTx]
-> t
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     ([TestTx],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
go [TestTx]
txs t
n LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger
      | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = ([TestTx],
 LedgerState
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Gen
     ([TestTx],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TestTx] -> [TestTx]
forall a. [a] -> [a]
reverse [TestTx]
txs, LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger)
      | Bool
otherwise = do
          (TestTx
tx, LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger') <- LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     (TestTx,
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
genValidTx LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger
          [TestTx]
-> t
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     ([TestTx],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
go (TestTx
txTestTx -> [TestTx] -> [TestTx]
forall a. a -> [a] -> [a]
:[TestTx]
txs) (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger'

-- | Generate a valid transaction (but ignoring any per-tx size limits, see Note
-- [Transaction size limit]).
genValidTx :: LedgerState TestBlock -> Gen (TestTx, LedgerState TestBlock)
genValidTx :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     (TestTx,
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
genValidTx ledgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledgerState@(SimpleLedgerState MockState { mockUtxo :: forall blk. MockState blk -> Utxo
mockUtxo = Utxo
utxo }) = do
    -- Never let someone go broke, otherwise we risk concentrating all the
    -- wealth in one person. That would be problematic (for the society) but
    -- also because we wouldn't be able to generate any valid transactions
    -- anymore.

    let sender :: Addr
sender
          | Just (Addr
richest, Amount
_) <- ((Addr, Amount) -> Amount)
-> [(Addr, Amount)] -> Maybe (Addr, Amount)
forall b a. Ord b => (a -> b) -> [a] -> Maybe a
safeMaximumOn (Addr, Amount) -> Amount
forall a b. (a, b) -> b
snd ([(Addr, Amount)] -> Maybe (Addr, Amount))
-> [(Addr, Amount)] -> Maybe (Addr, Amount)
forall a b. (a -> b) -> a -> b
$ Map Addr Amount -> [(Addr, Amount)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Addr Amount -> [(Addr, Amount)])
-> Map Addr Amount -> [(Addr, Amount)]
forall a b. (a -> b) -> a -> b
$
            [Amount] -> Amount
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Amount] -> Amount)
-> ([(TxIn, Amount)] -> [Amount]) -> [(TxIn, Amount)] -> Amount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIn, Amount) -> Amount) -> [(TxIn, Amount)] -> [Amount]
forall a b. (a -> b) -> [a] -> [b]
map (TxIn, Amount) -> Amount
forall a b. (a, b) -> b
snd ([(TxIn, Amount)] -> Amount)
-> Map Addr [(TxIn, Amount)] -> Map Addr Amount
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Addr [(TxIn, Amount)]
peopleWithFunds
          = Addr
richest
          | Bool
otherwise
          = String -> Addr
forall a. HasCallStack => String -> a
error String
"no people with funds"

    Addr
recipient <- [Addr] -> Gen Addr
forall a. HasCallStack => [a] -> Gen a
elements ([Addr] -> Gen Addr) -> [Addr] -> Gen Addr
forall a b. (a -> b) -> a -> b
$ (Addr -> Bool) -> [Addr] -> [Addr]
forall a. (a -> Bool) -> [a] -> [a]
filter (Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
/= Addr
sender) ([Addr] -> [Addr]) -> [Addr] -> [Addr]
forall a b. (a -> b) -> a -> b
$ Map Addr [(TxIn, Amount)] -> [Addr]
forall k a. Map k a -> [k]
Map.keys Map Addr [(TxIn, Amount)]
peopleWithFunds
    let assets :: [(TxIn, Amount)]
assets  = Map Addr [(TxIn, Amount)]
peopleWithFunds Map Addr [(TxIn, Amount)] -> Addr -> [(TxIn, Amount)]
forall k a. Ord k => Map k a -> k -> a
Map.! Addr
sender
        fortune :: Amount
fortune = [Amount] -> Amount
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((TxIn, Amount) -> Amount) -> [(TxIn, Amount)] -> [Amount]
forall a b. (a -> b) -> [a] -> [b]
map (TxIn, Amount) -> Amount
forall a b. (a, b) -> b
snd [(TxIn, Amount)]
assets)
        ins :: Set TxIn
ins     = [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList ([TxIn] -> Set TxIn) -> [TxIn] -> Set TxIn
forall a b. (a -> b) -> a -> b
$ ((TxIn, Amount) -> TxIn) -> [(TxIn, Amount)] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
map (TxIn, Amount) -> TxIn
forall a b. (a, b) -> a
fst [(TxIn, Amount)]
assets

    -- At most spent half of someone's fortune
    Amount
amount <- (Amount, Amount) -> Gen Amount
forall a. Random a => (a, a) -> Gen a
choose (Amount
1, Amount
fortune Amount -> Amount -> Amount
forall a. Integral a => a -> a -> a
`div` Amount
2)
    let outRecipient :: (Addr, Amount)
outRecipient = (Addr
recipient, Amount
amount)
        outs :: [(Addr, Amount)]
outs
          | Amount
amount Amount -> Amount -> Bool
forall a. Eq a => a -> a -> Bool
== Amount
fortune
          = [(Addr, Amount)
outRecipient]
          | Bool
otherwise
          = [(Addr, Amount)
outRecipient, (Addr
sender, Amount
fortune Amount -> Amount -> Amount
forall a. Num a => a -> a -> a
- Amount
amount)]
        tx :: TestTx
tx = Tx -> TestTx
forall c ext. Tx -> GenTx (SimpleBlock c ext)
mkSimpleGenTx (Tx -> TestTx) -> Tx -> TestTx
forall a b. (a -> b) -> a -> b
$ Expiry -> Set TxIn -> [(Addr, Amount)] -> Tx
Tx Expiry
DoNotExpire Set TxIn
ins [(Addr, Amount)]
outs
    (TestTx,
 LedgerState
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Gen
     (TestTx,
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (TestTx
tx, HasCallStack =>
Except
  (ApplyTxErr
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
Except
  (ApplyTxErr
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mustBeValid (LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> TestTx
-> Except
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
applyTxToLedger LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerConfigNoSizeLimits LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledgerState TestTx
tx))
  where
    peopleWithFunds :: Map Addr [(TxIn, Amount)]
    peopleWithFunds :: Map Addr [(TxIn, Amount)]
peopleWithFunds = ([(TxIn, Amount)] -> [(TxIn, Amount)] -> [(TxIn, Amount)])
-> [Map Addr [(TxIn, Amount)]] -> Map Addr [(TxIn, Amount)]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith [(TxIn, Amount)] -> [(TxIn, Amount)] -> [(TxIn, Amount)]
forall a. Semigroup a => a -> a -> a
(<>)
      [ Addr -> [(TxIn, Amount)] -> Map Addr [(TxIn, Amount)]
forall k a. k -> a -> Map k a
Map.singleton Addr
addr [(TxIn
txIn, Amount
amount)]
      | (TxIn
txIn, (Addr
addr, Amount
amount)) <- Utxo -> [(TxIn, (Addr, Amount))]
forall k a. Map k a -> [(k, a)]
Map.toList Utxo
utxo
      ]

genInvalidTx :: LedgerState TestBlock -> Gen TestTx
genInvalidTx :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen TestTx
genInvalidTx ledgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledgerState@(SimpleLedgerState MockState { mockUtxo :: forall blk. MockState blk -> Utxo
mockUtxo = Utxo
utxo }) = do
    let peopleWithFunds :: [Addr]
peopleWithFunds = [Addr] -> [Addr]
forall a. Eq a => [a] -> [a]
nub ([Addr] -> [Addr]) -> [Addr] -> [Addr]
forall a b. (a -> b) -> a -> b
$ ((Addr, Amount) -> Addr) -> [(Addr, Amount)] -> [Addr]
forall a b. (a -> b) -> [a] -> [b]
map (Addr, Amount) -> Addr
forall a b. (a, b) -> a
fst ([(Addr, Amount)] -> [Addr]) -> [(Addr, Amount)] -> [Addr]
forall a b. (a -> b) -> a -> b
$ Utxo -> [(Addr, Amount)]
forall k a. Map k a -> [a]
Map.elems Utxo
utxo
    Addr
sender    <- [Addr] -> Gen Addr
forall a. HasCallStack => [a] -> Gen a
elements [Addr]
peopleWithFunds
    Addr
recipient <- [Addr] -> Gen Addr
forall a. HasCallStack => [a] -> Gen a
elements ([Addr] -> Gen Addr) -> [Addr] -> Gen Addr
forall a b. (a -> b) -> a -> b
$ (Addr -> Bool) -> [Addr] -> [Addr]
forall a. (a -> Bool) -> [a] -> [a]
filter (Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
/= Addr
sender) [Addr]
peopleWithFunds
    let assets :: [(TxIn, (Addr, Amount))]
assets = ((TxIn, (Addr, Amount)) -> Bool)
-> [(TxIn, (Addr, Amount))] -> [(TxIn, (Addr, Amount))]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(TxIn
_, (Addr
addr, Amount
_)) -> Addr
addr Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
sender) ([(TxIn, (Addr, Amount))] -> [(TxIn, (Addr, Amount))])
-> [(TxIn, (Addr, Amount))] -> [(TxIn, (Addr, Amount))]
forall a b. (a -> b) -> a -> b
$ Utxo -> [(TxIn, (Addr, Amount))]
forall k a. Map k a -> [(k, a)]
Map.toList Utxo
utxo
        ins :: Set TxIn
ins    = [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList ([TxIn] -> Set TxIn) -> [TxIn] -> Set TxIn
forall a b. (a -> b) -> a -> b
$ ((TxIn, (Addr, Amount)) -> TxIn)
-> [(TxIn, (Addr, Amount))] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
map (TxIn, (Addr, Amount)) -> TxIn
forall a b. (a, b) -> a
fst [(TxIn, (Addr, Amount))]
assets
    -- There is only 5 000 in 'testInitLedger', so any transaction spending
    -- more than 5 000 is invalid.
    Amount
amount <- (Amount, Amount) -> Gen Amount
forall a. Random a => (a, a) -> Gen a
choose (Amount
5_001, Amount
10_000)
    let outs :: [(Addr, Amount)]
outs = [(Addr
recipient, Amount
amount)]
        tx :: TestTx
tx   = Tx -> TestTx
forall c ext. Tx -> GenTx (SimpleBlock c ext)
mkSimpleGenTx (Tx -> TestTx) -> Tx -> TestTx
forall a b. (a -> b) -> a -> b
$ Expiry -> Set TxIn -> [(Addr, Amount)] -> Tx
Tx Expiry
DoNotExpire Set TxIn
ins [(Addr, Amount)]
outs
    TestTx -> Gen TestTx
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (TestTx -> Gen TestTx) -> TestTx -> Gen TestTx
forall a b. (a -> b) -> a -> b
$ Bool -> TestTx -> TestTx
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> TestTx
-> Bool
txIsValid LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerConfigNoSizeLimits LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledgerState TestTx
tx)) TestTx
tx

-- | Generate an invalid tx that is larger than the given measure.
genLargeInvalidTx :: TheMeasure -> Gen TestTx
genLargeInvalidTx :: TheMeasure -> Gen TestTx
genLargeInvalidTx (IgnoringOverflow ByteSize32
sz) = Set TxIn -> Gen TestTx
go Set TxIn
forall a. Set a
Set.empty
  where
    go :: Set TxIn -> Gen TestTx
go Set TxIn
ins = case Set TxIn -> Maybe TestTx
isLargeTx Set TxIn
ins of
        Just TestTx
tx -> TestTx -> Gen TestTx
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestTx
tx
        Maybe TestTx
Nothing -> do
          TxIn
newTxIn <- Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary
          Set TxIn -> Gen TestTx
go (TxIn -> Set TxIn -> Set TxIn
forall a. Ord a => a -> Set a -> Set a
Set.insert TxIn
newTxIn Set TxIn
ins)

    isLargeTx :: Set TxIn -> Maybe TestTx
    isLargeTx :: Set TxIn -> Maybe TestTx
isLargeTx Set TxIn
ins = do
        let outs :: [a]
outs = []
            tx :: TestTx
tx   = Tx -> TestTx
forall c ext. Tx -> GenTx (SimpleBlock c ext)
mkSimpleGenTx (Tx -> TestTx) -> Tx -> TestTx
forall a b. (a -> b) -> a -> b
$ Expiry -> Set TxIn -> [(Addr, Amount)] -> Tx
Tx Expiry
DoNotExpire Set TxIn
ins [(Addr, Amount)]
forall a. [a]
outs
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ TestTx -> ByteSize32
forall c ext. GenTx (SimpleBlock c ext) -> ByteSize32
genTxSize TestTx
tx ByteSize32 -> ByteSize32 -> Bool
forall a. Ord a => a -> a -> Bool
> ByteSize32
sz
        TestTx -> Maybe TestTx
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestTx
tx

-- | Apply a transaction to the ledger
--
-- We don't have blocks in this test, but transactions only. In this function
-- we pretend the transaction /is/ a block, apply it to the UTxO, and then
-- update the tip of the ledger state, incrementing the slot number and faking
-- a hash.
applyTxToLedger :: LedgerConfig TestBlock
                -> LedgerState TestBlock
                -> TestTx
                -> Except TestTxError (LedgerState TestBlock)
applyTxToLedger :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> TestTx
-> Except
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
applyTxToLedger LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
cfg (SimpleLedgerState MockState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mockState) TestTx
tx =
    MockState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mkNewLedgerState (MockState
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> ExceptT
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     Identity
     (MockState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Except
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MockConfig
-> SlotNo
-> TestTx
-> MockState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> ExceptT
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     Identity
     (MockState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a blk.
HasMockTxs a =>
MockConfig
-> SlotNo
-> a
-> MockState blk
-> Except (MockError blk) (MockState blk)
updateMockUTxO MockConfig
mockCfg SlotNo
dummy TestTx
tx MockState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mockState
  where
    mockCfg :: MockConfig
mockCfg = SimpleLedgerConfig
  SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)
-> MockConfig
forall c ext. SimpleLedgerConfig c ext -> MockConfig
simpleLedgerMockConfig LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
SimpleLedgerConfig
  SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)
cfg

    -- All expiries in this test are 'DoNotExpire', so the current time is
    -- irrelevant.
    dummy :: SlotNo
    dummy :: SlotNo
dummy = SlotNo
0

    mkNewLedgerState :: MockState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mkNewLedgerState MockState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mockState' =
      MockState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall c ext.
MockState (SimpleBlock c ext) -> LedgerState (SimpleBlock c ext)
SimpleLedgerState MockState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mockState' { mockTip = BlockPoint slot' hash' }

    slot' :: SlotNo
slot' = case Point
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (Point
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> WithOrigin SlotNo)
-> Point
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ MockState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Point
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall blk. MockState blk -> Point blk
mockTip MockState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mockState of
      WithOrigin SlotNo
Origin      -> SlotNo
0
      NotOrigin SlotNo
s -> SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
s

    -- A little trick to instantiate the phantom parameter of 'Hash' (and
    -- 'HeaderHash') with 'TestBlock' while actually hashing the slot number:
    -- use a custom serialiser to instantiate the phantom type parameter with
    -- @Header TestBlock@, but actually encode the slot number instead.
    hash' :: HeaderHash TestBlock
    hash' :: HeaderHash
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
hash' = (Header
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> Encoding)
-> Header
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Hash
     ShortHash
     (Header
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall h a. HashAlgorithm h => (a -> Encoding) -> a -> Hash h a
hashWithSerialiser Header
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Encoding
fakeEncodeHeader (String
-> Header
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall a. HasCallStack => String -> a
error String
"fake header")

    fakeEncodeHeader :: Header TestBlock -> Encoding
    fakeEncodeHeader :: Header
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Encoding
fakeEncodeHeader Header
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
_ = SlotNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR SlotNo
slot'

{-------------------------------------------------------------------------------
  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
    Int
nbTxs <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n)
    (TestSetup
testSetup, LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger)  <- Int
-> Gen
     (TestSetup,
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
genTestSetup Int
n
    ([(TestTx, Bool)]
txs,      LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
_ledger') <- Int
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     ([(TestTx, Bool)],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
genTxs Int
nbTxs LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger
    TestSetup
testSetup' <- case TestSetup -> MempoolCapacityBytesOverride
testMempoolCapOverride TestSetup
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
        Bool
noOverride <- Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
        let initialSize :: ByteSize32
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
defaultCap  = ByteSize32
simpleBlockCapacity ByteSize32 -> ByteSize32 -> ByteSize32
forall a. Semigroup a => a -> a -> a
<> ByteSize32
simpleBlockCapacity
            newSize :: ByteSize32
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))
        TestSetup -> Gen TestSetup
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return TestSetup
testSetup {
              testMempoolCapOverride =
                if noOverride && initialSize <> newSize <= defaultCap
                then NoMempoolCapacityBytesOverride
                else MempoolCapacityBytesOverride $ mpCap <> newSize
            }
    let mempoolCap :: TheMeasure
        mempoolCap :: TheMeasure
mempoolCap = LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> TickedLedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> MempoolCapacityBytesOverride
-> TxMeasure
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> TickedLedgerState blk
-> MempoolCapacityBytesOverride
-> TxMeasure blk
computeMempoolCapacity
          LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerConfigNoSizeLimits
          (LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> TickedLedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall c ext.
LedgerState (SimpleBlock c ext)
-> Ticked (LedgerState (SimpleBlock c ext))
TickedSimpleLedgerState LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger)
          (TestSetup -> MempoolCapacityBytesOverride
testMempoolCapOverride TestSetup
testSetup)


    TestTx
largeInvalidTx <- TheMeasure -> Gen TestTx
genLargeInvalidTx TheMeasure
mempoolCap
    let txs' :: [(TestTx, Bool)]
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'' = TestSetup
testSetup' { testLedgerCfg =
            (testLedgerCfg testSetup') { simpleLedgerMockConfig =
                MockConfig {
                    mockCfgMaxTxSize = Just (unIgnoringOverflow mempoolCap)
                  }
              }
          }

    TestSetupWithTxs -> Gen TestSetupWithTxs
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return TestSetupWithTxs { testSetup :: TestSetup
testSetup = TestSetup
testSetup'', txs :: [(TestTx, Bool)]
txs = [(TestTx, Bool)]
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)))
-> [(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)))
 -> [(TestTx,
      Either
        (MockError
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())])
-> ([TestTx]
    -> ([(TestTx,
          Either
            (MockError
               (SimpleBlock
                  SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
            ())],
        LedgerState
          (SimpleBlock
             SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
-> [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)))
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)
revalidate :: TestSetup
-> [TestTx]
-> ([(TestTx,
      Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())],
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
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))
testLedgerState :: TestSetup
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerState, [TestTx]
testInitialTxs :: TestSetup -> [TestTx]
testInitialTxs :: [TestTx]
testInitialTxs } =
    LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> ([(TestTx,
      Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())],
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
validateTxs LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
initLedgerState
  where
    -- The LedgerState after adding the transactions initially in the mempool
    initLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
initLedgerState = (TestTx
 -> LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> [TestTx]
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall a b. (a -> b -> b) -> [a] -> b -> b
repeatedly
      (\TestTx
tx LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
l -> HasCallStack =>
Except
  (ApplyTxErr
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
Except
  (ApplyTxErr
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mustBeValid (LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> TestTx
-> Except
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
applyTxToLedger LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
l TestTx
tx))
      [TestTx]
testInitialTxs
      LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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
testSetup :: TestSetupWithTxs -> TestSetup
testSetup :: TestSetup
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)
    TestTx
tx <- [TestTx] -> Gen TestTx
forall a. HasCallStack => [a] -> Gen a
elements (TestSetup -> [TestTx]
testInitialTxs TestSetup
testSetup)
    TestSetupWithTxInMempool -> Gen TestSetupWithTxInMempool
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (TestSetupWithTxInMempool -> Gen TestSetupWithTxInMempool)
-> TestSetupWithTxInMempool -> Gen TestSetupWithTxInMempool
forall a b. (a -> b) -> a -> b
$ TestSetup -> TestTx -> TestSetupWithTxInMempool
TestSetupWithTxInMempool TestSetup
testSetup TestTx
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
testSetup :: TestSetupWithTxs -> TestSetup
testSetup :: TestSetup
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)
    [TestTx]
txs <- [TestTx] -> Gen [TestTx]
forall a. [a] -> Gen [a]
sublistOf (TestSetup -> [TestTx]
testInitialTxs TestSetup
testSetup)
    TestSetupWithTxsInMempool -> Gen TestSetupWithTxsInMempool
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (TestSetupWithTxsInMempool -> Gen TestSetupWithTxsInMempool)
-> TestSetupWithTxsInMempool -> Gen TestSetupWithTxsInMempool
forall a b. (a -> b) -> a -> b
$ TestSetup -> [TestTx] -> TestSetupWithTxsInMempool
TestSetupWithTxsInMempool TestSetup
testSetup [TestTx]
txs

  -- TODO shrink

{-------------------------------------------------------------------------------
  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)))
getCurrentLedger :: STM m (LedgerState TestBlock)
  }

-- 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))
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))
testInitialTxs :: TestSetup -> [TestTx]
testLedgerCfg :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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
      StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
varCurrentLedgerState <- LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> m (StrictTVar
        m
        (LedgerState
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerState
      let ledgerInterface :: LedgerInterface
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledgerInterface = LedgerInterface
            { getCurrentLedgerState :: STM
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
getCurrentLedgerState = StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> STM
     m
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
varCurrentLedgerState
            }

      -- Set up the Tracer
      StrictTVar
  m
  [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
varEvents <- [TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> m (StrictTVar
        m
        [TraceEventMempool
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))])
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM []
      -- TODO use IOSim's dynamicTracer
      let tracer :: Tracer
  m
  (TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
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
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool <-
        LedgerInterface
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerConfig
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> MempoolCapacityBytesOverride
-> Tracer
     m
     (TraceEventMempool
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> m (Mempool
        m
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> m (Mempool m blk)
openMempoolWithoutSyncThread
          LedgerInterface
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledgerInterface
          LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg
          MempoolCapacityBytesOverride
testMempoolCapOverride
          Tracer
  m
  (TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
tracer
      [MempoolAddTxResult
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
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 [TestTx]
testInitialTxs
      -- the invalid transactions are reported in the same order they were
      -- added, so the first error is not the result of a cascade
      [m Any] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
        [ String -> m Any
forall a. HasCallStack => String -> a
error (String -> m Any) -> String -> m Any
forall a b. (a -> b) -> a -> b
$ String
"Invalid initial transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TestTx -> String
forall a. Condense a => a -> String
condense TestTx
invalidTx
        | MempoolTxRejected TestTx
invalidTx ApplyTxErr
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
_err <- [MempoolAddTxResult
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
result
        ]

      -- Clear the trace
      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))]
-> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar
  m
  [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
varEvents []

      -- Apply the property to the 'TestMempool' record
      Property
res <- prop -> Property
forall prop. Testable prop => prop -> Property
property (prop -> Property) -> m prop -> m Property
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestMempool m -> m prop
forall (m :: * -> *). IOLike m => TestMempool m -> m prop
prop TestMempool
        { Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool :: Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool
        , getTraceEvents :: m [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents   = STM
  m
  [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> m [TraceEventMempool
        (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
   [TraceEventMempool
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
 -> m [TraceEventMempool
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))])
-> STM
     m
     [TraceEventMempool
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> m [TraceEventMempool
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall a b. (a -> b) -> a -> b
$ [TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> [TraceEventMempool
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall a. [a] -> [a]
reverse ([TraceEventMempool
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
 -> [TraceEventMempool
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))])
-> STM
     m
     [TraceEventMempool
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> STM
     m
     [TraceEventMempool
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar
  m
  [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> STM
     m
     [TraceEventMempool
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m
  [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
varEvents
        , eraseTraceEvents :: m ()
eraseTraceEvents = 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))]
-> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar
  m
  [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
varEvents []
        , addTxsToLedger :: [TestTx]
-> STM
     m
     [Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ()]
addTxsToLedger   = StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> [TestTx]
-> STM
     m
     [Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ()]
forall (m :: * -> *).
IOLike m =>
StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> [TestTx]
-> STM
     m
     [Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ()]
addTxsToLedger StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
varCurrentLedgerState
        , getCurrentLedger :: STM
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
getCurrentLedger = StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> STM
     m
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
varCurrentLedgerState
        }
      Property
validContents <- STM m Property -> m Property
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Property -> m Property) -> STM m Property -> m Property
forall a b. (a -> b) -> a -> b
$
            LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Property
checkMempoolValidity
        (LedgerState
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> MempoolSnapshot
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> Property)
-> STM
     m
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> STM
     m
     (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
      -> Property)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> STM
     m
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
varCurrentLedgerState
        STM
  m
  (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
   -> Property)
-> STM
     m
     (MempoolSnapshot
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> STM m Property
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f 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
      Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ Property
res Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Property
validContents

    addTxToLedger :: forall m. IOLike m
                  => StrictTVar m (LedgerState TestBlock)
                  -> TestTx
                  -> STM m (Either TestTxError ())
    addTxToLedger :: forall (m :: * -> *).
IOLike m =>
StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> TestTx
-> STM
     m
     (Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())
addTxToLedger StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
varCurrentLedgerState TestTx
tx = do
      LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledgerState <- StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> STM
     m
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
varCurrentLedgerState
      case Except
  (MockError
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall e a. Except e a -> Either e a
runExcept (LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> TestTx
-> Except
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
applyTxToLedger LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledgerState TestTx
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))
ledgerState' -> do
          StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
varCurrentLedgerState LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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)
                   -> [TestTx]
                   -> STM m [(Either TestTxError ())]
    addTxsToLedger :: forall (m :: * -> *).
IOLike m =>
StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> [TestTx]
-> STM
     m
     [Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ()]
addTxsToLedger StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
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)))
-> TestTx
-> STM
     m
     (Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())
forall (m :: * -> *).
IOLike m =>
StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> TestTx
-> STM
     m
     (Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())
addTxToLedger StrictTVar
  m
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
varCurrentLedgerState) [TestTx]
txs

    -- | Check whether the transactions in the 'MempoolSnapshot' are valid
    -- w.r.t. the current ledger state.
    checkMempoolValidity :: LedgerState TestBlock
                         -> MempoolSnapshot TestBlock
                         -> Property
    checkMempoolValidity :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Property
checkMempoolValidity LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledgerState
                         MempoolSnapshot {
                             [(Validated TestTx, TicketNo, ByteSize32)]
snapshotTxs :: forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxs :: [(Validated TestTx, TicketNo, ByteSize32)]
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)))
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (TickedLedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall e a. Except e a -> Either e a
runExcept (Except
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   (TickedLedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> Either
      (MockError
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
      (TickedLedgerState
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
-> Except
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (TickedLedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (TickedLedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a b. (a -> b) -> a -> b
$ (TestTx
 -> TickedLedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> Except
      (MockError
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
      (TickedLedgerState
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
-> [TestTx]
-> TickedLedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Except
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (TickedLedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m b) -> [a] -> b -> m b
repeatedlyM
               (((TickedLedgerState
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)),
  Validated TestTx)
 -> TickedLedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> ExceptT
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     Identity
     (TickedLedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)),
      Validated TestTx)
-> Except
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (TickedLedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a b.
(a -> b)
-> ExceptT
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     Identity
     a
-> ExceptT
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     Identity
     b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TickedLedgerState
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)),
 Validated TestTx)
-> TickedLedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall a b. (a, b) -> a
fst (ExceptT
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   Identity
   (TickedLedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)),
    Validated TestTx)
 -> Except
      (MockError
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
      (TickedLedgerState
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
-> (TestTx
    -> TickedLedgerState
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> ExceptT
         (MockError
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
         Identity
         (TickedLedgerState
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)),
          Validated TestTx))
-> TestTx
-> TickedLedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Except
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (TickedLedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall y z x0 x1. (y -> z) -> (x0 -> x1 -> y) -> x0 -> x1 -> z
.: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> WhetherToIntervene
-> SlotNo
-> TestTx
-> TickedLedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Except
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     (TickedLedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)),
      Validated TestTx)
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk
-> Except
     (ApplyTxErr blk) (TickedLedgerState blk, Validated (GenTx blk))
applyTx LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testLedgerCfg WhetherToIntervene
DoNotIntervene SlotNo
snapshotSlotNo)
               [TestTx]
txs
               (LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> TickedLedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall c ext.
LedgerState (SimpleBlock c ext)
-> Ticked (LedgerState (SimpleBlock c ext))
TickedSimpleLedgerState LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledgerState) of
          Right TickedLedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
_ -> 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
        txs :: [TestTx]
txs = ((Validated TestTx, TicketNo, ByteSize32) -> TestTx)
-> [(Validated TestTx, TicketNo, ByteSize32)] -> [TestTx]
forall a b. (a -> b) -> [a] -> [b]
map (Validated TestTx -> TestTx
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated (Validated TestTx -> TestTx)
-> ((Validated TestTx, TicketNo, ByteSize32) -> Validated TestTx)
-> (Validated TestTx, TicketNo, ByteSize32)
-> TestTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validated TestTx, TicketNo, ByteSize32) -> Validated TestTx
prjTx) [(Validated TestTx, TicketNo, ByteSize32)]
snapshotTxs
        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
testSetupWithTxs@TestSetupWithTxs { TestSetup
testSetup :: TestSetupWithTxs -> TestSetup
testSetup :: TestSetup
testSetup, [(TestTx, Bool)]
txs :: TestSetupWithTxs -> [(TestTx, Bool)]
txs :: [(TestTx, Bool)]
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 :: ByteSize32
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
capacityMinBound = ByteSize32
currentSize
        validTxsToAdd :: [TestTx]
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
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

    Word32
capacity <- (Word32, Word32) -> Gen Word32
forall a. Random a => (a, a) -> Gen a
choose
      ( ByteSize32 -> Word32
unByteSize32 ByteSize32
capacityMinBound
      , ByteSize32 -> Word32
unByteSize32 ByteSize32
capacityMaxBound
      )
    let testSetup' :: TestSetup
testSetup' = TestSetup
testSetup {
            testMempoolCapOverride =
                MempoolCapacityBytesOverride
              $ ByteSize32
              $ capacity
          }
    MempoolCapTestSetup -> Gen MempoolCapTestSetup
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (MempoolCapTestSetup -> Gen MempoolCapTestSetup)
-> MempoolCapTestSetup -> Gen MempoolCapTestSetup
forall a b. (a -> b) -> a -> b
$ TestSetupWithTxs -> MempoolCapTestSetup
MempoolCapTestSetup TestSetupWithTxs
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, ByteSize32
_byteSize) <- TxSeq TheMeasure Int -> [(Int, TicketNo, ByteSize32)]
forall sz tx.
HasByteSize sz =>
TxSeq sz tx -> [(tx, TicketNo, ByteSize32)]
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
    [Word32]
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
totalTxsSize = [Word32] -> Word32
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Word32]
txSizes
    Word32
txSizeToSplitOn <- [(Int, Gen Word32)] -> Gen Word32
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
1, Word32 -> Gen Word32
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
0)
      , (Int
7, (Word32, Word32) -> Gen Word32
forall a. Random a => (a, a) -> Gen a
choose (Word32
0, Word32
totalTxsSize))
      , (Int
1, Word32 -> Gen Word32
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
totalTxsSize)
      , (Int
1, (Word32, Word32) -> Gen Word32
forall a. Random a => (a, a) -> Gen a
choose (Word32
totalTxsSize Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1, Word32
totalTxsSize Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1000))
      ]
    TxSizeSplitTestSetup -> Gen TxSizeSplitTestSetup
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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]
txSizes
      , 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
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
        [Validated TestTx]
txsInMempool      <- ((Validated TestTx, TicketNo, ByteSize32) -> Validated TestTx)
-> [(Validated TestTx, TicketNo, ByteSize32)] -> [Validated TestTx]
forall a b. (a -> b) -> [a] -> [b]
map (Validated TestTx, TicketNo, ByteSize32) -> Validated TestTx
prjTx ([(Validated TestTx, TicketNo, ByteSize32)] -> [Validated TestTx])
-> (MempoolSnapshot
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> [(Validated TestTx, TicketNo, ByteSize32)])
-> 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, ByteSize32)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
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)
        Property
actionProp        <- TestMempool m -> Action -> m Property
forall (m :: * -> *).
IOLike m =>
TestMempool m -> Action -> m Property
executeAction TestMempool m
testMempool Action
action
        TicketAssignment
currentAssignment <- Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> m TicketAssignment
forall (m :: * -> *).
IOLike m =>
Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> m TicketAssignment
currentTicketAssignment Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool
        Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$
          --  #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.
          Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify
            (TicketAssignment -> Bool
forall k a. Map k a -> Bool
Map.null TicketAssignment
currentAssignment)
            String
"Mempool became empty" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          -- #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.
          Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify
            ([TestTx] -> Action -> Bool
lastOfMempoolRemoved ((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) Action
action)
            String
"The last transaction in the mempool is removed" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          Property
actionProp Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
          TicketAssignment
currentAssignment TicketAssignment -> TicketAssignment -> Property
forall {k} {a}.
(Ord k, Show k, Show a, Eq a) =>
Map k a -> Map k a -> Property
`isConsistentWith` TicketAssignment
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))
testLedgerState        = LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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
      [(TicketNo,
  GenTxId
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
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
        TicketNo
nextTicketNo <- StateT TicketNo Identity TicketNo
forall s (m :: * -> *). MonadState s m => m s
get
        (TicketNo -> TicketNo) -> StateT TicketNo Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify TicketNo -> TicketNo
forall a. Enum a => a -> a
succ
        (TicketNo,
 GenTxId
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> StateT
     TicketNo
     Identity
     (TicketNo,
      GenTxId
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a. a -> StateT TicketNo Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (TicketNo
nextTicketNo, TestTx
-> GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall tx. HasTxId tx => tx -> TxId tx
txId TestTx
tx)
      TicketAssignment -> State TicketNo TicketAssignment
forall a. a -> StateT TicketNo Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (TicketAssignment -> State TicketNo TicketAssignment)
-> TicketAssignment -> State TicketNo TicketAssignment
forall a b. (a -> b) -> a -> b
$ TicketAssignment -> TicketAssignment -> TicketAssignment
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union TicketAssignment
mapping ([(TicketNo,
  GenTxId
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
-> TicketAssignment
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TicketNo,
  GenTxId
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
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
      [Validated TestTx]
tracedAddedTxs <- (TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> Maybe (Validated TestTx))
-> m [Validated TestTx]
forall a.
(TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> Maybe a)
-> m [a]
expectTraceEvent ((TraceEventMempool
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  -> Maybe (Validated TestTx))
 -> m [Validated TestTx])
-> (TraceEventMempool
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> Maybe (Validated TestTx))
-> m [Validated TestTx]
forall a b. (a -> b) -> a -> b
$ \case
        TraceMempoolAddedTx Validated TestTx
tx MempoolSize
_ MempoolSize
_ -> Validated TestTx -> Maybe (Validated TestTx)
forall a. a -> Maybe a
Just Validated TestTx
tx
        TraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
_                          -> Maybe (Validated TestTx)
forall a. Maybe a
Nothing
      Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ if (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]
tracedAddedTxs [TestTx] -> [TestTx] -> Bool
forall a. Eq a => a -> a -> Bool
== [TestTx]
txs
        then Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
        else String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
          (String
"Expected TraceMempoolAddedTx events for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [TestTx] -> String
forall a. Condense a => a -> String
condense [TestTx]
txs String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
           String
" but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [TestTx] -> String
forall a. Condense a => a -> String
condense ((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]
tracedAddedTxs))
          Bool
False

    RemoveTxs [TestTx]
txs -> do
      Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> m ()
forall (m :: * -> *) blk. Mempool m blk -> [GenTxId blk] -> m ()
removeTxs Mempool
  m
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mempool ((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)
      [[GenTxId
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]]
tracedManuallyRemovedTxs <- (TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> Maybe
      [GenTxId
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))])
-> m [[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
       [GenTxId
          (SimpleBlock
             SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))])
 -> m [[GenTxId
          (SimpleBlock
             SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]])
-> (TraceEventMempool
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> Maybe
         [GenTxId
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))])
-> m [[GenTxId
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]]
forall a b. (a -> b) -> a -> b
$ \case
        TraceMempoolManuallyRemovedTxs [GenTxId
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
txIds [Validated TestTx]
_ MempoolSize
_ -> [GenTxId
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> Maybe
     [GenTxId
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall a. a -> Maybe a
Just [GenTxId
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
txIds
        TraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
_                                        -> Maybe
  [GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall a. Maybe a
Nothing
      Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ if [[GenTxId
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]]
-> [GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[GenTxId
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]]
tracedManuallyRemovedTxs [GenTxId
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> [GenTxId
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> Bool
forall a. Eq a => a -> a -> Bool
== (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
        then Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
        else String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
          (String
"Expected a TraceMempoolManuallyRemovedTxs event for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
           [TestTx] -> String
forall a. Condense a => a -> String
condense [TestTx]
txs String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
           [[GenTxId
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]]
-> String
forall a. Condense a => a -> String
condense [[GenTxId
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]]
tracedManuallyRemovedTxs)
          Bool
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
      [TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
evs <- m [TraceEventMempool
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
getTraceEvents
      m ()
eraseTraceEvents
      [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ (TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> Maybe a)
-> [TraceEventMempool
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
-> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TraceEventMempool
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Maybe a
extractor [TraceEventMempool
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))]
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 { [(Validated TestTx, TicketNo, ByteSize32)]
snapshotTxs :: forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxs :: [(Validated TestTx, TicketNo, ByteSize32)]
snapshotTxs } <- m (MempoolSnapshot
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
syncWithLedger
    TicketAssignment -> m TicketAssignment
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TicketAssignment -> m TicketAssignment)
-> TicketAssignment -> m TicketAssignment
forall a b. (a -> b) -> a -> b
$ [(TicketNo,
  GenTxId
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))]
-> TicketAssignment
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (TicketNo
ticketNo, TestTx
-> GenTxId
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall tx. HasTxId tx => tx -> TxId tx
txId (Validated TestTx -> TestTx
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated TestTx
tx))
      | (Validated TestTx
tx, TicketNo
ticketNo, ByteSize32
_byteSize) <- [(Validated TestTx, TicketNo, ByteSize32)]
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))
-> [TestTx] -> [Action] -> Int -> Gen Actions
go LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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
          -- ^ 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))
-> [TestTx] -> [Action] -> Int -> Gen Actions
go LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
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
          TestTx
tx <- [TestTx] -> Gen TestTx
forall a. HasCallStack => [a] -> Gen a
elements [TestTx]
txs
          let (([(TestTx,
  Either
    (MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
    ())]
vTxs, [(TestTx,
  Either
    (MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
    ())]
iTxs), LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger') = ([(TestTx,
   Either
     (ApplyTxErr
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     ())]
 -> ([(TestTx,
       Either
         (MockError
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
         ())],
     [(TestTx,
       Either
         (MockError
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
         ())]))
-> ([(TestTx,
      Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())],
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> (([(TestTx,
       Either
         (MockError
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
         ())],
     [(TestTx,
       Either
         (MockError
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
         ())]),
    LedgerState
      (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 (((TestTx,
  Either
    (MockError
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
    ())
 -> Bool)
-> [(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 -> Bool) -> [a] -> ([a], [a])
partition (Either
  (MockError
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  ()
-> Bool
forall a b. Either a b -> Bool
isRight (Either
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   ()
 -> Bool)
-> ((TestTx,
     Either
       (MockError
          (SimpleBlock
             SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
       ())
    -> Either
         (MockError
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
         ())
-> (TestTx,
    Either
      (MockError
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
      ())
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestTx,
 Either
   (MockError
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
   ())
-> Either
     (MockError
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     ()
forall a b. (a, b) -> b
snd)) (([(TestTx,
    Either
      (ApplyTxErr
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
      ())],
  LedgerState
    (SimpleBlock
       SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
 -> (([(TestTx,
        Either
          (MockError
             (SimpleBlock
                SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
          ())],
      [(TestTx,
        Either
          (MockError
             (SimpleBlock
                SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
          ())]),
     LedgerState
       (SimpleBlock
          SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))))
-> ([(TestTx,
      Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())],
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
-> (([(TestTx,
       Either
         (MockError
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
         ())],
     [(TestTx,
       Either
         (MockError
            (SimpleBlock
               SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
         ())]),
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
forall a b. (a -> b) -> a -> b
$
                LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx]
-> ([(TestTx,
      Either
        (ApplyTxErr
           (SimpleBlock
              SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
        ())],
    LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
validateTxs LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
SimpleLedgerConfig
  SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)
cfg LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
testInitLedger ((TestTx -> Bool) -> [TestTx] -> [TestTx]
forall a. (a -> Bool) -> [a] -> [a]
filter (TestTx -> TestTx -> Bool
forall a. Eq a => a -> a -> Bool
/= TestTx
tx) [TestTx]
txs)
              txs' :: [TestTx]
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]
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
          LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx] -> [Action] -> Int -> Gen Actions
go LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger' [TestTx]
txs' ([TestTx] -> Action
RemoveTxs [TestTx]
removedTxsAction -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:[Action]
actions) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        Bool
_ -> do
          Int
nbToAdd <- Gen Int
genNbToAdd
          ([TestTx]
txs', LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger') <- Int
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> Gen
     ([TestTx],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
genValidTxs Int
nbToAdd LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger
          LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> [TestTx] -> [Action] -> Int -> Gen Actions
go LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
ledger' ([TestTx]
txs' [TestTx] -> [TestTx] -> [TestTx]
forall a. Semigroup a => a -> a -> a
<> [TestTx]
txs) ([TestTx] -> Action
AddTxs [TestTx]
txs'Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:[Action]
actions) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)