module Test.Cardano.Network.Diffusion.Testnet.ChainedTxs
  ( ChainedPeerTxs (..)
  , tests
  ) where

import Data.Function (on)
import Data.List as List (foldl', nub, nubBy)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set

import Test.Ouroboros.Network.TxSubmission.Types (Tx (..), TxId)

import Test.QuickCheck
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)


-- | A randomly generated transaction forest distributed across two peers,
-- used by chain-integrity tests at the diffusion layer.
--
-- Each tx may carry a parent pointer ('getTxParent') to any earlier tx in
-- the forest, with some probability of having no parent at all. Invalidity
-- propagates down the chain at generation time: a descendant of an invalid
-- tx is itself generated as invalid, matching mainnet semantics where a tx
-- that consumes an invalid parent's output is itself invalid by construction.
--
-- Peer assignment reflects realistic mainnet conditions:
--
--   * Each peer carries a random subset of the forest (peers may lack txs
--     that, for example, were already included in an adopted block).
--   * Well-behaved peers (the common case) advertise their subset in
--     chain-topological order: parents before children.
--   * Adversarial or buggy peers (the occasional case) advertise in a
--     shuffled order to stress V2's handling of out-of-order streams.
--   * Every tx is carried by at least one /well-behaved/ peer so the full
--     forest is reachable via the reliable path, even when adversarial
--     peers misorder or mishandle their share.
data ChainedPeerTxs = ChainedPeerTxs {
    ChainedPeerTxs -> [Tx Int]
chainedTxsA :: [Tx TxId]
  , ChainedPeerTxs -> [Tx Int]
chainedTxsB :: [Tx TxId]
  }
  deriving Int -> ChainedPeerTxs -> ShowS
[ChainedPeerTxs] -> ShowS
ChainedPeerTxs -> String
(Int -> ChainedPeerTxs -> ShowS)
-> (ChainedPeerTxs -> String)
-> ([ChainedPeerTxs] -> ShowS)
-> Show ChainedPeerTxs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainedPeerTxs -> ShowS
showsPrec :: Int -> ChainedPeerTxs -> ShowS
$cshow :: ChainedPeerTxs -> String
show :: ChainedPeerTxs -> String
$cshowList :: [ChainedPeerTxs] -> ShowS
showList :: [ChainedPeerTxs] -> ShowS
Show

instance Arbitrary ChainedPeerTxs where
  arbitrary :: Gen ChainedPeerTxs
arbitrary = do
    chainLen <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
3, Int
15)
    chain    <- genChainedTxs chainLen
    perPeer  <- distributeAcrossPeers 2 chain
    case perPeer of
      [[Tx Int]
txsA, [Tx Int]
txsB] -> ChainedPeerTxs -> Gen ChainedPeerTxs
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Tx Int] -> [Tx Int] -> ChainedPeerTxs
ChainedPeerTxs [Tx Int]
txsA [Tx Int]
txsB)
      [[Tx Int]]
_            -> String -> Gen ChainedPeerTxs
forall a. HasCallStack => String -> a
error String
"ChainedPeerTxs: distributeAcrossPeers invariant broken"

  shrink :: ChainedPeerTxs -> [ChainedPeerTxs]
shrink (ChainedPeerTxs [Tx Int]
txsA [Tx Int]
txsB) =
    [ [Tx Int] -> [Tx Int] -> ChainedPeerTxs
ChainedPeerTxs ([Tx Int] -> [Tx Int]
dropDoomed [Tx Int]
txsA) ([Tx Int] -> [Tx Int]
dropDoomed [Tx Int]
txsB)
    | Int
tid <- [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ((Tx Int -> Int) -> [Tx Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Tx Int -> Int
forall txid. Tx txid -> txid
getTxId ([Tx Int]
txsA [Tx Int] -> [Tx Int] -> [Tx Int]
forall a. [a] -> [a] -> [a]
++ [Tx Int]
txsB))
    , let doomed :: Set Int
doomed    = Int -> [Tx Int] -> Set Int
transitiveDescendants Int
tid ([Tx Int]
txsA [Tx Int] -> [Tx Int] -> [Tx Int]
forall a. [a] -> [a] -> [a]
++ [Tx Int]
txsB)
          dropDoomed :: [Tx Int] -> [Tx Int]
dropDoomed = (Tx Int -> Bool) -> [Tx Int] -> [Tx Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Tx Int
t -> Tx Int -> Int
forall txid. Tx txid -> txid
getTxId Tx Int
t Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Int
doomed)
    ]
    where
      -- | All txids reachable as descendants of @root@, including @root@
      -- itself. Used so that dropping a parent also drops every
      -- transitive child, avoiding dangling parent pointers in the
      -- shrunken value.
      transitiveDescendants :: TxId -> [Tx TxId] -> Set TxId
      transitiveDescendants :: Int -> [Tx Int] -> Set Int
transitiveDescendants Int
root [Tx Int]
txs =
        let children :: Int -> [Int]
children Int
p = [ Tx Int -> Int
forall txid. Tx txid -> txid
getTxId Tx Int
t | Tx Int
t <- [Tx Int]
txs, Tx Int -> Maybe Int
forall txid. Tx txid -> Maybe txid
getTxParent Tx Int
t Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just Int
p ]
            go :: Set Int -> Int -> Set Int
go Set Int
acc Int
p
              | Int
p Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
acc = Set Int
acc
              | Bool
otherwise          = (Set Int -> Int -> Set Int) -> Set Int -> [Int] -> Set 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' Set Int -> Int -> Set Int
go (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
Set.insert Int
p Set Int
acc) (Int -> [Int]
children Int
p) in
        Set Int -> Int -> Set Int
go Set Int
forall a. Set a
Set.empty Int
root


-- | Generate a forest of @n@ transactions.
--
-- Tx 0 has no parent. Each subsequent tx picks its parent uniformly from
-- @{Nothing}@ unioned with the ids of earlier txs, weighted so a parent
-- link is more common than no parent. Invalidity is propagated: if the
-- parent is invalid, the tx is also invalid regardless of its own drawn
-- validity.
genChainedTxs :: Int -> Gen [Tx TxId]
genChainedTxs :: Int -> Gen [Tx Int]
genChainedTxs Int
n = Int -> Map Int Bool -> [Tx Int] -> Gen [Tx Int]
go Int
0 Map Int Bool
forall k a. Map k a
Map.empty []
  where
    baseId :: TxId
    baseId :: Int
baseId = Int
1

    go :: Int -> Map TxId Bool -> [Tx TxId] -> Gen [Tx TxId]
    go :: Int -> Map Int Bool -> [Tx Int] -> Gen [Tx Int]
go Int
i Map Int Bool
validMap [Tx Int]
acc
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = [Tx Int] -> Gen [Tx Int]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Tx Int] -> [Tx Int]
forall a. [a] -> [a]
reverse [Tx Int]
acc)
      | Bool
otherwise = do
          let txid :: Int
txid = Int
baseId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i
          parent <- if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                      then Maybe Int -> Gen (Maybe Int)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
                      else [(Int, Gen (Maybe Int))] -> Gen (Maybe Int)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
                             [ (Int
1, Maybe Int -> Gen (Maybe Int)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing)
                             , (Int
3, Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Int -> Int) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
baseId Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Maybe Int) -> Gen Int -> Gen (Maybe Int)
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
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
                             ]
          ownValid <- frequency [ (3, return True), (1, return False) ]
          size     <- chooseEnum (0, 1024)
          let parentValid    = Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Map Int Bool
validMap Map Int Bool -> Int -> Bool
forall k a. Ord k => Map k a -> k -> a
Map.!) Maybe Int
parent
              effectiveValid = Bool
ownValid Bool -> Bool -> Bool
&& Bool
parentValid
              tx = Tx
                { getTxId :: Int
getTxId      = Int
txid
                , getTxSize :: SizeInBytes
getTxSize    = SizeInBytes
size
                , getTxAdvSize :: SizeInBytes
getTxAdvSize = SizeInBytes
size
                , getTxValid :: Bool
getTxValid   = Bool
effectiveValid
                , getTxParent :: Maybe Int
getTxParent  = Maybe Int
parent
                }
          go (i + 1) (Map.insert txid effectiveValid validMap) (tx : acc)


-- | Per-peer behaviour selected up front so chain-coverage constraints
-- can be satisfied against the well-behaved subset before any lists are
-- emitted.
data PeerBehaviour = WellBehaved | Adversarial
  deriving (PeerBehaviour -> PeerBehaviour -> Bool
(PeerBehaviour -> PeerBehaviour -> Bool)
-> (PeerBehaviour -> PeerBehaviour -> Bool) -> Eq PeerBehaviour
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PeerBehaviour -> PeerBehaviour -> Bool
== :: PeerBehaviour -> PeerBehaviour -> Bool
$c/= :: PeerBehaviour -> PeerBehaviour -> Bool
/= :: PeerBehaviour -> PeerBehaviour -> Bool
Eq, Int -> PeerBehaviour -> ShowS
[PeerBehaviour] -> ShowS
PeerBehaviour -> String
(Int -> PeerBehaviour -> ShowS)
-> (PeerBehaviour -> String)
-> ([PeerBehaviour] -> ShowS)
-> Show PeerBehaviour
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PeerBehaviour -> ShowS
showsPrec :: Int -> PeerBehaviour -> ShowS
$cshow :: PeerBehaviour -> String
show :: PeerBehaviour -> String
$cshowList :: [PeerBehaviour] -> ShowS
showList :: [PeerBehaviour] -> ShowS
Show)

-- | Distribute a forest across @peerCount@ peers.
--
-- Each peer is classified as well-behaved (advertises in chain-topological
-- order, the common case) or adversarial (advertises in a shuffled order,
-- the occasional case).  To keep the property invariant clean, every tx
-- is guaranteed to be carried by at least one /well-behaved/ peer:
-- adversarial peers add noise and races but cannot singly strand a tx.  At
-- least one peer is always well-behaved.
--
-- Adversarial peers may duplicate txs already carried by well-behaved
-- peers; this exercises V2's cross-peer retry path when an adversarial
-- peer's out-of-order delivery causes a rejection.
distributeAcrossPeers :: Int -> [Tx TxId] -> Gen [[Tx TxId]]
distributeAcrossPeers :: Int -> [Tx Int] -> Gen [[Tx Int]]
distributeAcrossPeers Int
peerCount [Tx Int]
chain = do
  behaviours <- [PeerBehaviour] -> [PeerBehaviour]
ensureSomeWellBehaved ([PeerBehaviour] -> [PeerBehaviour])
-> Gen [PeerBehaviour] -> Gen [PeerBehaviour]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                  Int -> Gen PeerBehaviour -> Gen [PeerBehaviour]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
peerCount
                    ([(Int, Gen PeerBehaviour)] -> Gen PeerBehaviour
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [ (Int
4, PeerBehaviour -> Gen PeerBehaviour
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PeerBehaviour
WellBehaved)
                               , (Int
1, PeerBehaviour -> Gen PeerBehaviour
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PeerBehaviour
Adversarial) ])

  subsets <- vectorOf peerCount (sublistOf chain)

  let wellBehavedIxs =
        [ Int
i | (Int
i, PeerBehaviour
WellBehaved) <- [Int] -> [PeerBehaviour] -> [(Int, PeerBehaviour)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [PeerBehaviour]
behaviours ]
      wellBehavedCov =
        [Set Int] -> Set Int
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
          [ [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ((Tx Int -> Int) -> [Tx Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Tx Int -> Int
forall txid. Tx txid -> txid
getTxId ([[Tx Int]]
subsets [[Tx Int]] -> Int -> [Tx Int]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i))
          | Int
i <- [Int]
wellBehavedIxs ]
      uncovered =
        [ Tx Int
t | Tx Int
t <- [Tx Int]
chain, Tx Int -> Int
forall txid. Tx txid -> txid
getTxId Tx Int
t Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Int
wellBehavedCov ]
  additions <- traverse
                 (\Tx Int
t -> do i <- [Int] -> Gen Int
forall a. HasCallStack => [a] -> Gen a
elements [Int]
wellBehavedIxs; pure (i, t))
                 uncovered

  let subsetsWithCoverage :: [[Tx TxId]]
      subsetsWithCoverage =
        (Int -> [Tx Int] -> [Tx Int]) -> [Int] -> [[Tx Int]] -> [[Tx Int]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
          (\Int
i [Tx Int]
base -> [Tx Int]
base [Tx Int] -> [Tx Int] -> [Tx Int]
forall a. [a] -> [a] -> [a]
++ [ Tx Int
t | (Int
p, Tx Int
t) <- [(Int, Tx Int)]
additions, Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i ])
          [Int
0 .. Int
peerCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
          [[Tx Int]]
subsets

      inChainOrder :: Set TxId -> [Tx TxId]
      inChainOrder Set Int
peerSet =
        (Tx Int -> Bool) -> [Tx Int] -> [Tx Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Tx Int
t -> Tx Int -> Int
forall txid. Tx txid -> txid
getTxId Tx Int
t Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
peerSet) [Tx Int]
chain

  traverse
    (\(PeerBehaviour
b, [Tx Int]
s) -> case PeerBehaviour
b of
        PeerBehaviour
WellBehaved -> [Tx Int] -> Gen [Tx Int]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set Int -> [Tx Int]
inChainOrder ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ((Tx Int -> Int) -> [Tx Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Tx Int -> Int
forall txid. Tx txid -> txid
getTxId [Tx Int]
s)))
        PeerBehaviour
Adversarial -> [Tx Int] -> Gen [Tx Int]
forall a. [a] -> Gen [a]
shuffle [Tx Int]
s)
    (zip behaviours subsetsWithCoverage)
  where
    ensureSomeWellBehaved :: [PeerBehaviour] -> [PeerBehaviour]
ensureSomeWellBehaved [PeerBehaviour]
bs
      | PeerBehaviour
WellBehaved PeerBehaviour -> [PeerBehaviour] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PeerBehaviour]
bs = [PeerBehaviour]
bs
      | Bool
otherwise             = PeerBehaviour
WellBehaved PeerBehaviour -> [PeerBehaviour] -> [PeerBehaviour]
forall a. a -> [a] -> [a]
: Int -> [PeerBehaviour] -> [PeerBehaviour]
forall a. Int -> [a] -> [a]
drop Int
1 [PeerBehaviour]
bs


--
-- Meta-tests: verify generator and shrinker invariants.
--

-- | Every parent pointer in the combined peer lists resolves to a tx that
-- also appears somewhere in the union. No dangling parents.
prop_parentsResolvable :: ChainedPeerTxs -> Bool
prop_parentsResolvable :: ChainedPeerTxs -> Bool
prop_parentsResolvable (ChainedPeerTxs [Tx Int]
txsA [Tx Int]
txsB) =
  let ids :: Set Int
ids     = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ((Tx Int -> Int) -> [Tx Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Tx Int -> Int
forall txid. Tx txid -> txid
getTxId ([Tx Int]
txsA [Tx Int] -> [Tx Int] -> [Tx Int]
forall a. [a] -> [a] -> [a]
++ [Tx Int]
txsB))
      parents :: [Int]
parents = [ Int
p | Tx Int
t <- [Tx Int]
txsA [Tx Int] -> [Tx Int] -> [Tx Int]
forall a. [a] -> [a] -> [a]
++ [Tx Int]
txsB, Just Int
p <- [Tx Int -> Maybe Int
forall txid. Tx txid -> Maybe txid
getTxParent Tx Int
t] ] in
  (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
ids) [Int]
parents

-- | Invalidity propagates along the dependency chain: if a tx's parent is
-- present in the union and invalid, the tx itself must be invalid too.
prop_invalidityPropagates :: ChainedPeerTxs -> Bool
prop_invalidityPropagates :: ChainedPeerTxs -> Bool
prop_invalidityPropagates (ChainedPeerTxs [Tx Int]
txsA [Tx Int]
txsB) =
  let allTxs :: [Tx Int]
allTxs = (Tx Int -> Tx Int -> Bool) -> [Tx Int] -> [Tx Int]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int -> Int -> Bool) -> (Tx Int -> Int) -> Tx Int -> Tx Int -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Tx Int -> Int
forall txid. Tx txid -> txid
getTxId) ([Tx Int]
txsA [Tx Int] -> [Tx Int] -> [Tx Int]
forall a. [a] -> [a] -> [a]
++ [Tx Int]
txsB)
      txMap :: Map Int (Tx Int)
txMap  = [(Int, Tx Int)] -> Map Int (Tx Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Tx Int -> Int
forall txid. Tx txid -> txid
getTxId Tx Int
t, Tx Int
t) | Tx Int
t <- [Tx Int]
allTxs] in
  (Tx Int -> Bool) -> [Tx Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Tx Int
t -> case Tx Int -> Maybe Int
forall txid. Tx txid -> Maybe txid
getTxParent Tx Int
t of
               Maybe Int
Nothing -> Bool
True
               Just Int
p  -> case Int -> Map Int (Tx Int) -> Maybe (Tx Int)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
p Map Int (Tx Int)
txMap of
                 Maybe (Tx Int)
Nothing -> Bool
True
                 Just Tx Int
pt -> Tx Int -> Bool
forall txid. Tx txid -> Bool
getTxValid Tx Int
pt Bool -> Bool -> Bool
|| Bool -> Bool
not (Tx Int -> Bool
forall txid. Tx txid -> Bool
getTxValid Tx Int
t))
                         -- not (getTxValid pt) => not (getTxValid t)
      [Tx Int]
allTxs

-- | At least one peer's tx list is in chain-topological order (parents
-- before children), and the union of all such peers' txids covers every
-- tx in the value. This is the external face of the "every tx is carried
-- by at least one well-behaved peer" guarantee from
-- 'distributeAcrossPeers': adversarial peers may exist and misorder, but
-- the full forest is always reachable via the chain-ordered subset.
prop_wellBehavedCoverage :: ChainedPeerTxs -> Property
prop_wellBehavedCoverage :: ChainedPeerTxs -> Property
prop_wellBehavedCoverage (ChainedPeerTxs [Tx Int]
txsA [Tx Int]
txsB) =
  let allIds :: Set Int
allIds          = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ((Tx Int -> Int) -> [Tx Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Tx Int -> Int
forall txid. Tx txid -> txid
getTxId ([Tx Int]
txsA [Tx Int] -> [Tx Int] -> [Tx Int]
forall a. [a] -> [a] -> [a]
++ [Tx Int]
txsB))
      chainOrdered :: [[Tx Int]]
chainOrdered    = ([Tx Int] -> Bool) -> [[Tx Int]] -> [[Tx Int]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Tx Int] -> Bool
isChainOrdered [[Tx Int]
txsA, [Tx Int]
txsB]
      coverage :: Set Int
coverage        = [Set Int] -> Set Int
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
                          [ [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ((Tx Int -> Int) -> [Tx Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Tx Int -> Int
forall txid. Tx txid -> txid
getTxId [Tx Int]
txs) | [Tx Int]
txs <- [[Tx Int]]
chainOrdered ] in
  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"peer A: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Tx Int] -> String
forall a. Show a => a -> String
show [Tx Int]
txsA)
   (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"peer B: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Tx Int] -> String
forall a. Show a => a -> String
show [Tx Int]
txsB)
   (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"chain-ordered peers: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([[Tx Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Tx Int]]
chainOrdered))
   (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"coverage: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show (Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
coverage))
   (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"all ids: "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show (Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
allIds))
   (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Bool
not ([[Tx Int]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Tx Int]]
chainOrdered) Bool -> Bool -> Bool
&& Set Int
coverage Set Int -> Set Int -> Bool
forall a. Eq a => a -> a -> Bool
== Set Int
allIds)
  where
    isChainOrdered :: [Tx TxId] -> Bool
    isChainOrdered :: [Tx Int] -> Bool
isChainOrdered [Tx Int]
txs =
      let positions :: Map Int Int
positions = [(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Tx Int -> Int) -> [Tx Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Tx Int -> Int
forall txid. Tx txid -> txid
getTxId [Tx Int]
txs) [(Int
0 :: Int) ..]) in
      (Tx Int -> Bool) -> [Tx Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Tx Int
t -> case Tx Int -> Maybe Int
forall txid. Tx txid -> Maybe txid
getTxParent Tx Int
t of
                   Maybe Int
Nothing -> Bool
True
                   Just Int
p  -> case Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
p Map Int Int
positions of
                     Maybe Int
Nothing   -> Bool
True
                     Just Int
ppos -> Int
ppos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Map Int Int
positions Map Int Int -> Int -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! Tx Int -> Int
forall txid. Tx txid -> txid
getTxId Tx Int
t)
          [Tx Int]
txs


-- | Every shrink of a value satisfies the same structural invariants as
-- a freshly generated one.
prop_shrinkPreservesInvariants :: ChainedPeerTxs -> Property
prop_shrinkPreservesInvariants :: ChainedPeerTxs -> Property
prop_shrinkPreservesInvariants ChainedPeerTxs
cpt =
  [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
    [ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"shrunk: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ChainedPeerTxs -> String
forall a. Show a => a -> String
show ChainedPeerTxs
s) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
           ChainedPeerTxs -> Bool
prop_parentsResolvable ChainedPeerTxs
s
      Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. ChainedPeerTxs -> Bool
prop_invalidityPropagates ChainedPeerTxs
s
      Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. ChainedPeerTxs -> Property
prop_wellBehavedCoverage ChainedPeerTxs
s
    | ChainedPeerTxs
s <- ChainedPeerTxs -> [ChainedPeerTxs]
forall a. Arbitrary a => a -> [a]
shrink ChainedPeerTxs
cpt
    ]

-- | Each shrink strictly reduces the total tx count so shrinking converges.
prop_shrinkMakesProgress :: ChainedPeerTxs -> Property
prop_shrinkMakesProgress :: ChainedPeerTxs -> Property
prop_shrinkMakesProgress ChainedPeerTxs
cpt =
  let size :: ChainedPeerTxs -> Int
size (ChainedPeerTxs [Tx Int]
a [Tx Int]
b) = [Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
b
      origSize :: Int
origSize                  = ChainedPeerTxs -> Int
size ChainedPeerTxs
cpt in
  [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
    [ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"shrunk: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ChainedPeerTxs -> String
forall a. Show a => a -> String
show ChainedPeerTxs
s) (ChainedPeerTxs -> Int
size ChainedPeerTxs
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
origSize)
    | ChainedPeerTxs
s <- ChainedPeerTxs -> [ChainedPeerTxs]
forall a. Arbitrary a => a -> [a]
shrink ChainedPeerTxs
cpt
    ]

tests :: TestTree
tests :: TestTree
tests = String -> [TestTree] -> TestTree
testGroup String
"ChainedTxs"
  [ String -> (ChainedPeerTxs -> Bool) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"parents resolvable"          ChainedPeerTxs -> Bool
prop_parentsResolvable
  , String -> (ChainedPeerTxs -> Bool) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"invalidity propagates"       ChainedPeerTxs -> Bool
prop_invalidityPropagates
  , String -> (ChainedPeerTxs -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"well-behaved coverage"       ChainedPeerTxs -> Property
prop_wellBehavedCoverage
  , String -> (ChainedPeerTxs -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"shrink preserves invariants" ChainedPeerTxs -> Property
prop_shrinkPreservesInvariants
  , String -> (ChainedPeerTxs -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"shrink makes progress"       ChainedPeerTxs -> Property
prop_shrinkMakesProgress
  ]