Add type `BlockSeq`.
A `BlockSeq` is sequence of blocks that starts at a given block height and slot number.
A `BlockSeq` is sequence of blocks that starts at a given block height and slot number.
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{- HLINT ignore "Move brackets to avoid $" -}
module Cardano.Wallet.Primitive.ModelSpec
( spec
import Cardano.Wallet.Primitive.Types.Address
( Address (..) )
import Cardano.Wallet.Primitive.Types.Address.Gen
( Parity (..), addressParity )
( Parity (..), addressParity, genAddress )
import Cardano.Wallet.Primitive.Types.Coin
( Coin (..) )
import Cardano.Wallet.Primitive.Types.Coin.Gen
, shrinkTxIn
, shrinkTxOut
)
import Cardano.Wallet.Primitive.Types.TxSeq
( TxSeq )
import Cardano.Wallet.Primitive.Types.TxSeq.Gen
( ShrinkableTxSeq, genTxSeq, getTxSeq, shrinkTxSeq )
import Cardano.Wallet.Primitive.Types.UTxO
( UTxO (..), balance, dom, excluding, filterByAddress, restrictedTo )
import Cardano.Wallet.Primitive.Types.UTxO.Gen
( genUTxO, shrinkUTxO )
import Cardano.Wallet.Util
( ShowFmt (..), invariant )
import Control.Applicative
( ZipList (..) )
import Control.DeepSeq
( NFData (..) )
import Control.Monad
( foldM, guard )
( filterM, foldM, guard )
import Control.Monad.Trans.State.Strict
( State, evalState, execState, runState, state )
import Data.Delta
( Word32, Word64 )
import Fmt
( Buildable, blockListF, pretty )
import Generics.SOP
( NP (..) )
import GHC.Generics
( Generic )
import Test.Hspec
, scale
, shrinkIntegral
, shrinkList
, shrinkMap
, shrinkMapBy
, shrinkNothing
, vector
, (===)
)
import Test.QuickCheck.Extra
( chooseNatural, report, verify )
( chooseNatural
, genericRoundRobinShrink
, report
, verify
, (<:>)
, (<@>)
)
import Test.QuickCheck.Instances.ByteString
()
import qualified Cardano.Wallet.Primitive.Types.Coin as Coin
import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
import qualified Cardano.Wallet.Primitive.Types.TxSeq as TxSeq
import qualified Cardano.Wallet.Primitive.Types.UTxO as UTxO
import qualified Data.ByteString as BS
import qualified Data.Foldable as F
F.toList (collateralOutput tx)
| otherwise =
outputs tx
--------------------------------------------------------------------------------
-- Generating and shrinking arbitrary sequences of blocks
--------------------------------------------------------------------------------
-- | A sequence of blocks that starts at a given block height and slot number.
--
-- Values of this type model a sequence of state transitions affecting the
-- global UTxO set:
--
-- @
-- global_utxo_0 -> block_0_1 ->
-- global_utxo_1 -> block_1_2 ->
-- ...
-- global_utxo_i -> block_i_j ->
-- global_utxo_j
-- @
--
-- In turn, each block contains a series of transactions that each affect the
-- global UTxO set. The effect of applying a single block to the global UTxO
-- set is equivalent to applying all of the contained transactions in order
-- to the global UTxO set.
--
-- In general, only a subset of transactions within a block sequence will be
-- relevant to a particular wallet, and only a subset of entries within each
-- successive iteration of the global UTxO set will be relevant to that wallet.
--
-- Values of 'BlockSeq' are more convenient to generate and shrink than values
-- of 'BlockData', but can easily be transformed into values of 'BlockData' in
-- order to test properties of the 'applyBlocks' function.
--
-- Usage:
--
-- 1. Use function 'genBlockSeq' to generate a 'BlockSeq' value.
-- 2. Use function 'blockSeqToBlockData' to convert a 'BlockSeq' value to a
-- value of 'BlockData' suitable for use with the 'applyBlocks' function.
-- 3. Use function 'shrinkBlockSeq' to shrink to a minimal counterexample.
--
data BlockSeq = BlockSeq
{ initialBlockHeight
:: Quantity "block" Word32
, initialSlotNo
:: SlotNo
, shrinkableTxSeq
:: ShrinkableTxSeq
}
deriving (Eq, Generic, Show)
instance Arbitrary BlockSeq where
arbitrary = genBlockSeq
shrink = shrinkBlockSeq
genBlockSeq :: Gen BlockSeq
genBlockSeq = BlockSeq
<$> fmap toEnum (choose (0, 100))
<*> fmap toEnum (choose (0, 100))
<*> genTxSeq genUTxO genAddress
shrinkBlockSeq :: BlockSeq -> [BlockSeq]
shrinkBlockSeq = genericRoundRobinShrink
<@> shrinkMap toEnum fromEnum
<:> shrinkMap toEnum fromEnum
<:> shrinkTxSeq
<:> Nil
-- | Converts a 'BlockSeq' to a value of 'BlockData' that is suitable for use
-- with the 'applyBlocks' function.
--
-- This function fills every slot with exactly one block, leaving no gaps.
--
blockSeqToBlockData :: BlockSeq -> BlockData m addr tx state
blockSeqToBlockData = List . blockSeqToBlockList
where
blockSeqToBlockList :: BlockSeq -> NonEmpty Block
blockSeqToBlockList blockSeq =
NE.fromList $ getZipList $ makeBlock
<$> ZipList (enumFrom $ blockSeq & initialBlockHeight)
<*> ZipList (enumFrom $ blockSeq & initialSlotNo)
<*> ZipList (NE.toList $ TxSeq.toTxGroupList txSeq)
where
txSeq :: TxSeq
txSeq = blockSeqToTxSeq blockSeq
-- Makes a block using dummy values for fields that are not relevant
-- to our expectations of 'applyBlocks'.
--
makeBlock :: Quantity "block" Word32 -> SlotNo -> [Tx] -> Block
makeBlock blockHeight slotNo transactions = Block
{ header = BlockHeader
{ blockHeight
, slotNo
, headerHash = Hash ""
, parentHeaderHash = Nothing
}
, transactions
, delegations = []
}
-- | Retrieves the head UTxO of a block sequence.
--
-- The head UTxO represents the initial state of the /global/ UTxO set before
-- any of the blocks in the given block sequence are applied.
--
blockSeqHeadUTxO :: BlockSeq -> UTxO
blockSeqHeadUTxO = TxSeq.headUTxO . blockSeqToTxSeq
-- | Retrieves the last UTxO of a block sequence.
--
-- The last UTxO represents the final state of the /global/ UTxO set after
-- all of the blocks in the given block sequence have been applied.
--
blockSeqLastUTxO :: BlockSeq -> UTxO
blockSeqLastUTxO = TxSeq.lastUTxO . blockSeqToTxSeq
-- | Retrieves, from a block sequence, the complete list of transactions that
-- are expected to be relevant to a particular wallet.
This made another flaky test run which was otherwise intractable to analyse (https://github.com/input-output-hk/hydra/actions/runs/6784142783/job/18439856584?pr=1156) to a simple case which highlight IgnoredInitTx was also the issue as fixed in the previous commit.
A flaky test run was discovering this and we seemingly had forgotten to add this schema when introducing the IgnoredInitTx constructor.
otherwise it fails due to NOT NULL contraint.
Fixes #348
Fixes #347
Fixes #412
Fixes #347
Fixes #348
Fixes #347
From https://github.com/input-output-hk/ouroboros-network at ff2331f0d254944f7c375078e6a3eb8e4f8770db
From https://github.com/input-output-hk/ouroboros-network at ff2331f0d254944f7c375078e6a3eb8e4f8770db