{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE TypeApplications #-}

module Test.Consensus.Mempool.Util (
    TestBlock
  , TestTx
  , TestTxError
  , TestTxId
  , TheMeasure
  , applyTxToLedger
  , genInvalidTx
  , genLargeInvalidTx
  , genTxs
  , genValidTx
  , genValidTxs
  , mkTestLedgerConfig
  , mustBeValid
  , testInitLedger
  , testLedgerConfigNoSizeLimits
  , txIsValid
  ) where

import           Cardano.Binary (Encoding, toCBOR)
import           Cardano.Crypto.Hash
import           Cardano.Ledger.BaseTypes (knownNonZeroBounded)
import           Cardano.Slotting.Slot
import           Control.Exception (assert)
import           Control.Monad (guard)
import           Control.Monad.Except (Except)
import           Control.Monad.Trans.Except (runExcept)
import           Data.Either (isRight)
import           Data.List (nub)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Set (Set)
import qualified Data.Set as Set
import           GHC.Stack
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 hiding (TxIn, TxOut)
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Ledger.Tables.Utils
import           Ouroboros.Consensus.Mock.Ledger hiding (TxId)
import           Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..))
import           Ouroboros.Consensus.Protocol.BFT
import           Ouroboros.Consensus.Util (safeMaximumOn)
import           Test.Crypto.Hash ()
import           Test.QuickCheck
import           Test.Util.Orphans.IOLike ()

type TestBlock = SimpleBftBlock SimpleMockCrypto BftMockCrypto

type TestTx = GenTx TestBlock

type TestTxId = TxId TestTx

type TestTxError = ApplyTxErr TestBlock

type TheMeasure = IgnoringOverflow ByteSize32

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

-- | Test config
--
-- (We don't really care about 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
          (NonZero Word64 -> SecurityParam
SecurityParam (forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @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

-- | 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 ValuesMK
       -> Gen ([(TestTx, Bool)], LedgerState TestBlock ValuesMK)
genTxs :: Int
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> Gen
     ([(TestTx, Bool)],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
genTxs = [(TestTx, Bool)]
-> Int
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> Gen
     ([(TestTx, Bool)],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
forall {t}.
(Ord t, Num t) =>
[(TestTx, Bool)]
-> t
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> Gen
     ([(TestTx, Bool)],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
go []
  where
    go :: [(TestTx, Bool)]
-> t
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> Gen
     ([(TestTx, Bool)],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
go [(TestTx, Bool)]
txs t
n LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
ledger
      | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = ([(TestTx, Bool)],
 LedgerState
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
   ValuesMK)
-> Gen
     ([(TestTx, Bool)],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
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))
  ValuesMK
ledger)
      | Bool
otherwise = do
          valid <- Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
          if valid
            then do
              (validTx, ledger') <- genValidTx ledger
              go ((validTx, True):txs)    (n - 1) ledger'
            else do
              invalidTx <- genInvalidTx ledger
              go ((invalidTx, False):txs) (n - 1) ledger

-- | 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 ValuesMK
            -> Gen ([TestTx], LedgerState TestBlock ValuesMK)
genValidTxs :: Int
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> Gen
     ([TestTx],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
genValidTxs = [TestTx]
-> Int
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> Gen
     ([TestTx],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
forall {t}.
(Ord t, Num t) =>
[TestTx]
-> t
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> Gen
     ([TestTx],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
go []
  where
    go :: [TestTx]
-> t
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> Gen
     ([TestTx],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
go [TestTx]
txs t
n LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
ledger
      | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = ([TestTx],
 LedgerState
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
   ValuesMK)
-> Gen
     ([TestTx],
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
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))
  ValuesMK
ledger)
      | Bool
otherwise = do
          (tx, ledger') <- LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
-> Gen
     (TestTx,
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
genValidTx LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
ledger
          go (tx:txs) (n - 1) ledger'

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

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

-- | Generate a valid transaction (but ignoring any per-tx size limits, see Note
-- [Transaction size limit]).
genValidTx :: LedgerState TestBlock ValuesMK -> Gen (TestTx, LedgerState TestBlock ValuesMK)
genValidTx :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
-> Gen
     (TestTx,
      LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
genValidTx ledgerState :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
ledgerState@(SimpleLedgerState MockState {} (LedgerTables (ValuesMK Map TxIn TxOut
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
_) <- (TxOut -> Amount) -> [TxOut] -> Maybe TxOut
forall b a. Ord b => (a -> b) -> [a] -> Maybe a
safeMaximumOn TxOut -> Amount
forall a b. (a, b) -> b
snd ([TxOut] -> Maybe TxOut) -> [TxOut] -> Maybe TxOut
forall a b. (a -> b) -> a -> b
$ Map Addr Amount -> [TxOut]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Addr Amount -> [TxOut]) -> Map Addr Amount -> [TxOut]
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
          = [Char] -> Addr
forall a. HasCallStack => [Char] -> a
error [Char]
"no people with funds"

    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  = 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] -> 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     = [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 <- choose (1, fortune `div` 2)
    let outRecipient = (Addr
recipient, Amount
amount)
        outs
          | Amount
amount Amount -> Amount -> Bool
forall a. Eq a => a -> a -> Bool
== Amount
fortune
          = [TxOut
outRecipient]
          | Bool
otherwise
          = [TxOut
outRecipient, (Addr
sender, Amount
fortune Amount -> Amount -> Amount
forall a. Num a => a -> a -> a
- Amount
amount)]
        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 -> [TxOut] -> Tx
Tx Expiry
DoNotExpire Set TxIn
ins [TxOut]
outs
    return (tx, mustBeValid (applyTxToLedger testLedgerConfigNoSizeLimits ledgerState 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)) <- Map TxIn TxOut -> [(TxIn, TxOut)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn TxOut
utxo
      ]

genInvalidTx :: LedgerState TestBlock ValuesMK -> Gen TestTx
genInvalidTx :: LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
-> Gen TestTx
genInvalidTx LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
ledgerState = 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
$ (TxOut -> Addr) -> [TxOut] -> [Addr]
forall a b. (a -> b) -> [a] -> [b]
map TxOut -> Addr
forall a b. (a, b) -> a
fst ([TxOut] -> [Addr]) -> [TxOut] -> [Addr]
forall a b. (a -> b) -> a -> b
$ Map TxIn TxOut -> [TxOut]
forall k a. Map k a -> [a]
Map.elems Map TxIn TxOut
utxo
    sender    <- [Addr] -> Gen Addr
forall a. HasCallStack => [a] -> Gen a
elements [Addr]
peopleWithFunds
    recipient <- elements $ filter (/= sender) peopleWithFunds
    let assets = ((TxIn, TxOut) -> Bool) -> [(TxIn, TxOut)] -> [(TxIn, TxOut)]
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, TxOut)] -> [(TxIn, TxOut)])
-> [(TxIn, TxOut)] -> [(TxIn, TxOut)]
forall a b. (a -> b) -> a -> b
$ Map TxIn TxOut -> [(TxIn, TxOut)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn TxOut
utxo
        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, TxOut) -> TxIn) -> [(TxIn, TxOut)] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
map (TxIn, TxOut) -> TxIn
forall a b. (a, b) -> a
fst [(TxIn, TxOut)]
assets
    -- There is only 5 000 in 'testInitLedger', so any transaction spending
    -- more than 5 000 is invalid.
    amount <- choose (5_001, 10_000)
    let outs = [(Addr
recipient, Amount
amount)]
        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 -> [TxOut] -> Tx
Tx Expiry
DoNotExpire Set TxIn
ins [TxOut]
outs
    return $ assert (not (txIsValid testLedgerConfigNoSizeLimits ledgerState tx)) tx

  where
    SimpleLedgerState {
      simpleLedgerTables :: forall c ext (mk :: MapKind).
LedgerState (SimpleBlock c ext) mk
-> LedgerTables (LedgerState (SimpleBlock c ext)) mk
simpleLedgerTables = LedgerTables (ValuesMK Map TxIn TxOut
utxo)
    } = LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
ledgerState

-- | 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
          newTxIn <- Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary
          go (Set.insert newTxIn 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 -> [TxOut] -> Tx
Tx Expiry
DoNotExpire Set TxIn
ins [TxOut]
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 ValuesMK
                -> TestTx
                -> Except TestTxError (LedgerState TestBlock ValuesMK)
applyTxToLedger :: LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
-> TestTx
-> Except
     TestTxError
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
        ValuesMK)
applyTxToLedger LedgerConfig
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
cfg LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
st TestTx
tx =
    let SimpleLedgerState MockState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mockState LedgerTables
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  EmptyMK
_ = LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     EmptyMK
forall (l :: LedgerStateKind).
CanStowLedgerTables l =>
l ValuesMK -> l EmptyMK
stowLedgerTables LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
st in
    LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  EmptyMK
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
forall (l :: LedgerStateKind).
CanStowLedgerTables l =>
l EmptyMK -> l ValuesMK
unstowLedgerTables (LedgerState
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
   EmptyMK
 -> LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
      ValuesMK)
-> (MockState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
    -> LedgerState
         (SimpleBlock
            SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
         EmptyMK)
-> MockState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     ValuesMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     EmptyMK
mkNewLedgerState (MockState
   (SimpleBlock
      SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
 -> LedgerState
      (SimpleBlock
         SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
      ValuesMK)
-> 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))
        ValuesMK)
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))
     EmptyMK
mkNewLedgerState MockState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mockState' =
      MockState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
-> LedgerTables
     (LedgerState
        (SimpleBlock
           SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
     EmptyMK
-> LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
     EmptyMK
forall c ext (mk :: MapKind).
MockState (SimpleBlock c ext)
-> LedgerTables (LedgerState (SimpleBlock c ext)) mk
-> LedgerState (SimpleBlock c ext) mk
SimpleLedgerState MockState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
mockState' { mockTip = BlockPoint slot' hash' } LedgerTables
  (LedgerState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto)))
  EmptyMK
forall (mk :: MapKind) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables

    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 (LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
-> MockState
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall c ext (mk :: MapKind).
LedgerState (SimpleBlock c ext) mk -> MockState (SimpleBlock c ext)
simpleLedgerState LedgerState
  (SimpleBlock
     SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
  ValuesMK
st) 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 ([Char]
-> Header
     (SimpleBlock
        SimpleMockCrypto (SimpleBftExt SimpleMockCrypto BftMockCrypto))
forall a. HasCallStack => [Char] -> a
error [Char]
"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'