{-# LANGUAGE CPP               #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE TypeOperators     #-}

{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
#if __GLASGOW_HASKELL__ >= 908
{-# OPTIONS_GHC -Wno-x-partial #-}
#endif

-- | Arbitrary generators for chains, headers and blocks
--
module Test.ChainGenerators
  ( -- * Arbitrary chains generators
    -- These generators are used to test various scenarios that require
    -- a chain: e.g. appending a block to chain, arbitrary updates
    -- (rollforwards \/ backwards), chain forks.
    TestAddBlock (..)
  , TestBlockChainAndUpdates (..)
  , TestBlockChain (..)
  , TestHeaderChain (..)
  , TestChainAndPoint (..)
  , TestChainAndRange (..)
  , TestChainAndPoints (..)
  , TestChainFork (..)
    -- * Utility functions
  , genNonNegative
  , genSlotGap
  , addSlotGap
  , genChainAnchor
  , mkPartialBlock
  , mkRollbackPoint
    -- * Tests of the generators
  , tests
  ) where

import Data.ByteString.Char8 qualified as BSC
import Data.List qualified as L
import Data.Maybe (catMaybes, listToMaybe)

import Ouroboros.Network.AnchoredFragment (Anchor (..))
import Ouroboros.Network.AnchoredFragment qualified as AF
import Ouroboros.Network.Block
import Ouroboros.Network.Mock.Chain (Chain (..))
import Ouroboros.Network.Mock.Chain qualified as Chain
import Ouroboros.Network.Mock.ConcreteBlock
import Ouroboros.Network.Point (WithOrigin (..), block, blockPointHash,
           blockPointSlot, fromWithOrigin, origin)
import Ouroboros.Network.Protocol.BlockFetch.Type (ChainRange (..))

import Data.List (scanl')
import Test.Cardano.Slotting.Arbitrary ()
import Test.QuickCheck
import Test.QuickCheck.Instances.ByteString ()
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)


--
-- The tests for the generators themselves
--

tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"Chain"
  [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"arbitrary for TestBlockChain" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
    -- It's important we don't generate too many trivial test cases here
    -- so check the coverage to enforce it.
                 (TestBlockChain -> Property) -> Property
forall prop. Testable prop => prop -> Property
checkCoverage TestBlockChain -> Property
prop_arbitrary_TestBlockChain
  , TestName -> (TestBlockChain -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink for TestBlockChain"     TestBlockChain -> Bool
prop_shrink_TestBlockChain

  , TestName -> (TestHeaderChain -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"arbitrary for TestHeaderChain" TestHeaderChain -> Bool
prop_arbitrary_TestHeaderChain
  , TestName -> (TestHeaderChain -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink for TestHeaderChain"    TestHeaderChain -> Bool
prop_shrink_TestHeaderChain

  , TestName -> (TestAddBlock -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"arbitrary for TestAddBlock" TestAddBlock -> Bool
prop_arbitrary_TestAddBlock
  , TestName -> (TestAddBlock -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink for TestAddBlock"    TestAddBlock -> Bool
prop_shrink_TestAddBlock

  , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"arbitrary for TestBlockChainAndUpdates" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
    -- Same deal here applies here with generating trivial test cases.
                 (TestBlockChainAndUpdates -> Property) -> Property
forall prop. Testable prop => prop -> Property
checkCoverage TestBlockChainAndUpdates -> Property
prop_arbitrary_TestBlockChainAndUpdates

  , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"arbitrary for TestChainAndPoint" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
                                     (TestChainAndPoint -> Property) -> Property
forall prop. Testable prop => prop -> Property
checkCoverage TestChainAndPoint -> Property
prop_arbitrary_TestChainAndPoint
  , TestName -> (TestChainAndPoint -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink for TestChainAndPoint"    TestChainAndPoint -> Bool
prop_shrink_TestChainAndPoint

  , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"arbitrary for TestChainAndRange" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
                                     (TestChainAndRange -> Property) -> Property
forall prop. Testable prop => prop -> Property
checkCoverage TestChainAndRange -> Property
prop_arbitrary_TestChainAndRange
  , TestName -> (TestChainAndRange -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink for TestChainAndRange"    TestChainAndRange -> Bool
prop_shrink_TestChainAndRange

  , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"arbitrary for TestChainAndPoints" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
                                      (TestChainAndPoints -> Property) -> Property
forall prop. Testable prop => prop -> Property
checkCoverage TestChainAndPoints -> Property
prop_arbitrary_TestChainAndPoints
  , TestName -> (TestChainAndPoints -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink for TestChainAndPoints"    TestChainAndPoints -> Bool
prop_shrink_TestChainAndPoints

  , TestName -> (TestChainFork -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"arbitrary for TestChainFork" TestChainFork -> Bool
prop_arbitrary_TestChainFork
  , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink for TestChainFork"
                             ((Int -> Int) -> (TestChainFork -> Bool) -> Property
forall prop. Testable prop => (Int -> Int) -> prop -> Property
mapSize (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
40) TestChainFork -> Bool
prop_shrink_TestChainFork)
  ]


instance Arbitrary BlockNo where
  arbitrary :: Gen BlockNo
arbitrary = Word64 -> BlockNo
BlockNo (Word64 -> BlockNo) -> Gen Word64 -> Gen BlockNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                ((Positive Word64 -> Word64
forall a. Positive a -> a
getPositive (Positive Word64 -> Word64) -> Gen (Positive Word64) -> Gen Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Positive Word64)
forall a. Arbitrary a => Gen a
arbitrary)
                   Gen Word64 -> (Word64 -> Bool) -> Gen Word64
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat`
                 (\Word64
n -> Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
forall a. Bounded a => a
maxBound Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
2Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
32 :: Int)))
               -- need some room, we're assuming we'll never wrap around 64bits

  shrink :: BlockNo -> [BlockNo]
shrink (BlockNo Word64
n) = [ Word64 -> BlockNo
BlockNo Word64
n' | Word64
n' <- Word64 -> [Word64]
forall a. Arbitrary a => a -> [a]
shrink Word64
n, Word64
n' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0 ]

instance Arbitrary ConcreteHeaderHash where
  arbitrary :: Gen ConcreteHeaderHash
arbitrary = Int -> ConcreteHeaderHash
HeaderHash (Int -> ConcreteHeaderHash) -> Gen Int -> Gen ConcreteHeaderHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
arbitrary

instance Arbitrary (Point BlockHeader) where
  arbitrary :: Gen (Point BlockHeader)
arbitrary =
      -- Sometimes pick the genesis point
      [(Int, Gen (Point BlockHeader))] -> Gen (Point BlockHeader)
forall a. [(Int, Gen a)] -> Gen a
frequency [ (Int
1, Point BlockHeader -> Gen (Point BlockHeader)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WithOrigin (Block SlotNo (HeaderHash BlockHeader))
-> Point BlockHeader
forall {k} (block :: k).
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point WithOrigin (Block SlotNo (HeaderHash BlockHeader))
WithOrigin (Block SlotNo ConcreteHeaderHash)
forall t. WithOrigin t
Origin))
                , (Int
4, WithOrigin (Block SlotNo (HeaderHash BlockHeader))
-> Point BlockHeader
WithOrigin (Block SlotNo ConcreteHeaderHash) -> Point BlockHeader
forall {k} (block :: k).
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point (WithOrigin (Block SlotNo ConcreteHeaderHash) -> Point BlockHeader)
-> Gen (WithOrigin (Block SlotNo ConcreteHeaderHash))
-> Gen (Point BlockHeader)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SlotNo
-> ConcreteHeaderHash
-> WithOrigin (Block SlotNo ConcreteHeaderHash)
forall slot hash. slot -> hash -> WithOrigin (Block slot hash)
block (SlotNo
 -> ConcreteHeaderHash
 -> WithOrigin (Block SlotNo ConcreteHeaderHash))
-> Gen SlotNo
-> Gen
     (ConcreteHeaderHash
      -> WithOrigin (Block SlotNo ConcreteHeaderHash))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SlotNo
forall a. Arbitrary a => Gen a
arbitrary Gen
  (ConcreteHeaderHash
   -> WithOrigin (Block SlotNo ConcreteHeaderHash))
-> Gen ConcreteHeaderHash
-> Gen (WithOrigin (Block SlotNo ConcreteHeaderHash))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ConcreteHeaderHash
forall a. Arbitrary a => Gen a
arbitrary)) ]
  shrink :: Point BlockHeader -> [Point BlockHeader]
shrink (Point WithOrigin (Block SlotNo (HeaderHash BlockHeader))
Origin)   = []
  shrink (Point (At Block SlotNo (HeaderHash BlockHeader)
blk)) =
      WithOrigin (Block SlotNo (HeaderHash BlockHeader))
-> Point BlockHeader
forall {k} (block :: k).
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point WithOrigin (Block SlotNo (HeaderHash BlockHeader))
WithOrigin (Block SlotNo ConcreteHeaderHash)
forall t. WithOrigin t
origin
    Point BlockHeader -> [Point BlockHeader] -> [Point BlockHeader]
forall a. a -> [a] -> [a]
: [ WithOrigin (Block SlotNo (HeaderHash BlockHeader))
-> Point BlockHeader
forall {k} (block :: k).
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point (SlotNo
-> ConcreteHeaderHash
-> WithOrigin (Block SlotNo ConcreteHeaderHash)
forall slot hash. slot -> hash -> WithOrigin (Block slot hash)
block SlotNo
s' ConcreteHeaderHash
h') | (SlotNo
s', ConcreteHeaderHash
h') <- (SlotNo, ConcreteHeaderHash) -> [(SlotNo, ConcreteHeaderHash)]
forall a. Arbitrary a => a -> [a]
shrink (SlotNo
s, ConcreteHeaderHash
h), SlotNo
s SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> Word64 -> SlotNo
SlotNo Word64
0 ]
    where
    h :: ConcreteHeaderHash
h = Block SlotNo ConcreteHeaderHash -> ConcreteHeaderHash
forall slot hash. Block slot hash -> hash
blockPointHash Block SlotNo (HeaderHash BlockHeader)
Block SlotNo ConcreteHeaderHash
blk
    s :: SlotNo
s = Block SlotNo ConcreteHeaderHash -> SlotNo
forall slot hash. Block slot hash -> slot
blockPointSlot Block SlotNo (HeaderHash BlockHeader)
Block SlotNo ConcreteHeaderHash
blk

instance Arbitrary (Point Block) where
  arbitrary :: Gen (Point Block)
arbitrary = (Point BlockHeader -> Point Block
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint :: Point BlockHeader -> Point Block) (Point BlockHeader -> Point Block)
-> Gen (Point BlockHeader) -> Gen (Point Block)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Point BlockHeader)
forall a. Arbitrary a => Gen a
arbitrary

  shrink :: Point Block -> [Point Block]
shrink = (Point BlockHeader -> Point Block)
-> [Point BlockHeader] -> [Point Block]
forall a b. (a -> b) -> [a] -> [b]
map (Point BlockHeader -> Point Block
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint :: Point BlockHeader -> Point Block)
         ([Point BlockHeader] -> [Point Block])
-> (Point Block -> [Point BlockHeader])
-> Point Block
-> [Point Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point BlockHeader -> [Point BlockHeader]
forall a. Arbitrary a => a -> [a]
shrink
         (Point BlockHeader -> [Point BlockHeader])
-> (Point Block -> Point BlockHeader)
-> Point Block
-> [Point BlockHeader]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.     (Point Block -> Point BlockHeader
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint :: Point Block -> Point BlockHeader)

instance Arbitrary (ChainRange (Point Block)) where
  arbitrary :: Gen (ChainRange (Point Block))
arbitrary = do
    low  <- Gen (Point Block)
forall a. Arbitrary a => Gen a
arbitrary
    high <- arbitrary `suchThat` (\Point Block
high -> Point Block -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point Block
low WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= Point Block -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point Block
high)
    return (ChainRange low high)

  shrink :: ChainRange (Point Block) -> [ChainRange (Point Block)]
shrink (ChainRange Point Block
low Point Block
high) = [ Point Block -> Point Block -> ChainRange (Point Block)
forall point. point -> point -> ChainRange point
ChainRange Point Block
low' Point Block
high'
                                 | (Point Block
low', Point Block
high') <- (Point Block, Point Block) -> [(Point Block, Point Block)]
forall a. Arbitrary a => a -> [a]
shrink (Point Block
low, Point Block
high)
                                 , Point Block -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point Block
low WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= Point Block -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point Block
high ]

instance Arbitrary BlockBody where
    arbitrary :: Gen BlockBody
arbitrary =
      ByteString -> BlockBody
BlockBody (ByteString -> BlockBody) -> Gen ByteString -> Gen BlockBody
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        -- Sometimes pick a common block so some are equal
        [(Int, Gen ByteString)] -> Gen ByteString
forall a. [(Int, Gen a)] -> Gen a
frequency [ (Int
1, ByteString -> Gen ByteString
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Gen ByteString) -> ByteString -> Gen ByteString
forall a b. (a -> b) -> a -> b
$ TestName -> ByteString
BSC.pack TestName
"EMPTY")
                  , (Int
4, TestName -> ByteString
BSC.pack (TestName -> ByteString) -> Gen TestName -> Gen ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Char -> Gen TestName
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
4 ((Char, Char) -> Gen Char
forall a. Random a => (a, a) -> Gen a
choose (Char
'A', Char
'Z'))) ]
    -- probably no need for shrink, the content is arbitrary and opaque
    -- if we add one, it might be to shrink to an empty block

instance Arbitrary Block where
    arbitrary :: Gen Block
arbitrary = do
      body    <- Gen BlockBody
forall a. Arbitrary a => Gen a
arbitrary
      slotGap <- genSlotGap
      anchor  <- genChainAnchor
      let slot = Int -> WithOrigin SlotNo -> SlotNo
addSlotGap Int
slotGap (Anchor Block -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
AF.anchorToSlotNo Anchor Block
anchor)
          b    = Anchor Block -> Block -> Block
forall block.
(HeaderHash block ~ HeaderHash BlockHeader) =>
Anchor block -> Block -> Block
fixupBlock Anchor Block
anchor (SlotNo -> BlockBody -> Block
mkPartialBlock SlotNo
slot BlockBody
body)
      return b

genSlotGap :: Gen Int
genSlotGap :: Gen Int
genSlotGap = [(Int, Gen Int)] -> Gen Int
forall a. [(Int, Gen a)] -> Gen a
frequency
    [ (Int
25, Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1)
      -- EBBs have the same SlotNo as the block after it, so the gap is 0 in
      -- that case.
    , (Int
5,  Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0)
    , (Int
5,  Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
2)
    , (Int
1,  Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
3)
    ]

-- | Special case: adding a 0-sized gap to 'Origin' results in @'SlotNo' 0@, not
-- 'Origin'. We do this because we use the result of this function to create a
-- block, and blocks must have a slot number.
addSlotGap :: Int -> WithOrigin SlotNo -> SlotNo
addSlotGap :: Int -> WithOrigin SlotNo -> SlotNo
addSlotGap Int
0 WithOrigin SlotNo
Origin          = Word64 -> SlotNo
SlotNo Word64
0
addSlotGap Int
g WithOrigin SlotNo
Origin          = Word64 -> SlotNo
SlotNo (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
g Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)
addSlotGap Int
g (At (SlotNo Word64
n)) = Word64 -> SlotNo
SlotNo (Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
g)

-- | A starting anchor for a chain fragment: either the 'AnchorGenesis' or
-- an arbitrary anchor
--
genChainAnchor :: Gen (Anchor Block)
genChainAnchor :: Gen (Anchor Block)
genChainAnchor = [Gen (Anchor Block)] -> Gen (Anchor Block)
forall a. [Gen a] -> Gen a
oneof [ Anchor Block -> Gen (Anchor Block)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Anchor Block
forall block. Anchor block
AnchorGenesis, Gen (Anchor Block)
genArbitraryChainAnchor ]

genArbitraryChainAnchor :: Gen (Anchor Block)
genArbitraryChainAnchor :: Gen (Anchor Block)
genArbitraryChainAnchor = SlotNo -> HeaderHash Block -> BlockNo -> Anchor Block
SlotNo -> ConcreteHeaderHash -> BlockNo -> Anchor Block
forall block. SlotNo -> HeaderHash block -> BlockNo -> Anchor block
Anchor (SlotNo -> ConcreteHeaderHash -> BlockNo -> Anchor Block)
-> Gen SlotNo
-> Gen (ConcreteHeaderHash -> BlockNo -> Anchor Block)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SlotNo
forall a. Arbitrary a => Gen a
arbitrary Gen (ConcreteHeaderHash -> BlockNo -> Anchor Block)
-> Gen ConcreteHeaderHash -> Gen (BlockNo -> Anchor Block)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ConcreteHeaderHash
forall a. Arbitrary a => Gen a
arbitrary Gen (BlockNo -> Anchor Block) -> Gen BlockNo -> Gen (Anchor Block)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen BlockNo
forall a. Arbitrary a => Gen a
arbitrary

instance Arbitrary BlockHeader where
    arbitrary :: Gen BlockHeader
arbitrary = Block -> BlockHeader
blockHeader (Block -> BlockHeader) -> Gen Block -> Gen BlockHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Block
forall a. Arbitrary a => Gen a
arbitrary

-- We provide CoArbitrary instances, for (Block -> _) functions
-- We use default implementations using generics.
instance CoArbitrary Block
instance CoArbitrary BlockHeader
instance CoArbitrary SlotNo
instance CoArbitrary BlockNo
instance CoArbitrary BodyHash
instance CoArbitrary BlockBody
instance CoArbitrary (ChainHash BlockHeader)
instance CoArbitrary ConcreteHeaderHash

-- | The 'NonNegative' generator produces a large proportion of 0s, so we use
-- this one instead for now.
--
-- https://github.com/nick8325/quickcheck/issues/229
--
genNonNegative :: Gen Int
genNonNegative :: Gen Int
genNonNegative = (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 -> Int) -> Gen (Small Int) -> Gen Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Small Int)
forall a. Arbitrary a => Gen a
arbitrary) Gen Int -> (Int -> Bool) -> Gen Int
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0)

--
-- Generators for chains
--

-- | A test generator for a valid chain of blocks.
--
newtype TestBlockChain = TestBlockChain { TestBlockChain -> Chain Block
getTestBlockChain :: Chain Block }
    deriving (TestBlockChain -> TestBlockChain -> Bool
(TestBlockChain -> TestBlockChain -> Bool)
-> (TestBlockChain -> TestBlockChain -> Bool) -> Eq TestBlockChain
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestBlockChain -> TestBlockChain -> Bool
== :: TestBlockChain -> TestBlockChain -> Bool
$c/= :: TestBlockChain -> TestBlockChain -> Bool
/= :: TestBlockChain -> TestBlockChain -> Bool
Eq, Int -> TestBlockChain -> ShowS
[TestBlockChain] -> ShowS
TestBlockChain -> TestName
(Int -> TestBlockChain -> ShowS)
-> (TestBlockChain -> TestName)
-> ([TestBlockChain] -> ShowS)
-> Show TestBlockChain
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestBlockChain -> ShowS
showsPrec :: Int -> TestBlockChain -> ShowS
$cshow :: TestBlockChain -> TestName
show :: TestBlockChain -> TestName
$cshowList :: [TestBlockChain] -> ShowS
showList :: [TestBlockChain] -> ShowS
Show)

-- | A test generator for a valid chain of block headers.
--
newtype TestHeaderChain = TestHeaderChain (Chain BlockHeader)
    deriving (TestHeaderChain -> TestHeaderChain -> Bool
(TestHeaderChain -> TestHeaderChain -> Bool)
-> (TestHeaderChain -> TestHeaderChain -> Bool)
-> Eq TestHeaderChain
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestHeaderChain -> TestHeaderChain -> Bool
== :: TestHeaderChain -> TestHeaderChain -> Bool
$c/= :: TestHeaderChain -> TestHeaderChain -> Bool
/= :: TestHeaderChain -> TestHeaderChain -> Bool
Eq, Int -> TestHeaderChain -> ShowS
[TestHeaderChain] -> ShowS
TestHeaderChain -> TestName
(Int -> TestHeaderChain -> ShowS)
-> (TestHeaderChain -> TestName)
-> ([TestHeaderChain] -> ShowS)
-> Show TestHeaderChain
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestHeaderChain -> ShowS
showsPrec :: Int -> TestHeaderChain -> ShowS
$cshow :: TestHeaderChain -> TestName
show :: TestHeaderChain -> TestName
$cshowList :: [TestHeaderChain] -> ShowS
showList :: [TestHeaderChain] -> ShowS
Show)

instance Arbitrary TestBlockChain where
    arbitrary :: Gen TestBlockChain
arbitrary = do
        n <- Gen Int
genNonNegative
        bodies <- vector n
        slots  <- mkSlots <$> vectorOf n genSlotGap
        let chain = [(SlotNo, BlockBody)] -> Chain Block
mkChain ([SlotNo] -> [BlockBody] -> [(SlotNo, BlockBody)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SlotNo]
slots [BlockBody]
bodies)
        return (TestBlockChain chain)
      where
        mkSlots :: [Int] -> [SlotNo]
        mkSlots :: [Int] -> [SlotNo]
mkSlots = (Int -> SlotNo) -> [Int] -> [SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map Int -> SlotNo
forall a. Enum a => Int -> a
toEnum ([Int] -> [SlotNo]) -> ([Int] -> [Int]) -> [Int] -> [SlotNo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. HasCallStack => [a] -> [a]
tail ([Int] -> [Int]) -> ([Int] -> [Int]) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl' Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0

    shrink :: TestBlockChain -> [TestBlockChain]
shrink (TestBlockChain Chain Block
c) =
        [ Chain Block -> TestBlockChain
TestBlockChain ((Anchor Block -> Block -> Block) -> [Block] -> Chain Block
forall b. HasFullHeader b => (Anchor b -> b -> b) -> [b] -> Chain b
fixupChain Anchor Block -> Block -> Block
forall block.
(HeaderHash block ~ HeaderHash BlockHeader) =>
Anchor block -> Block -> Block
fixupBlock [Block]
c')
        | [Block]
c' <- (Block -> [Block]) -> [Block] -> [[Block]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([Block] -> Block -> [Block]
forall a b. a -> b -> a
const []) (Chain Block -> [Block]
forall block. Chain block -> [block]
Chain.toNewestFirst Chain Block
c) ]

instance Arbitrary TestHeaderChain where
    arbitrary :: Gen TestHeaderChain
arbitrary = do
        TestBlockChain chain <- Gen TestBlockChain
forall a. Arbitrary a => Gen a
arbitrary
        let headerchain = (Block -> BlockHeader) -> Chain Block -> Chain BlockHeader
forall a b. (a -> b) -> Chain a -> Chain b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Block -> BlockHeader
blockHeader Chain Block
chain
        return (TestHeaderChain headerchain)

    shrink :: TestHeaderChain -> [TestHeaderChain]
shrink (TestHeaderChain Chain BlockHeader
c) =
        [ Chain BlockHeader -> TestHeaderChain
TestHeaderChain ((Anchor BlockHeader -> BlockHeader -> BlockHeader)
-> [BlockHeader] -> Chain BlockHeader
forall b. HasFullHeader b => (Anchor b -> b -> b) -> [b] -> Chain b
fixupChain Anchor BlockHeader -> BlockHeader -> BlockHeader
forall block.
(HeaderHash block ~ HeaderHash BlockHeader) =>
Anchor block -> BlockHeader -> BlockHeader
fixupBlockHeader [BlockHeader]
c')
        | [BlockHeader]
c' <- (BlockHeader -> [BlockHeader]) -> [BlockHeader] -> [[BlockHeader]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([BlockHeader] -> BlockHeader -> [BlockHeader]
forall a b. a -> b -> a
const []) (Chain BlockHeader -> [BlockHeader]
forall block. Chain block -> [block]
Chain.toNewestFirst Chain BlockHeader
c) ]

prop_arbitrary_TestBlockChain :: TestBlockChain -> Property
prop_arbitrary_TestBlockChain :: TestBlockChain -> Property
prop_arbitrary_TestBlockChain (TestBlockChain Chain Block
c) =
    -- check we get some but not too many zero-length chains
    Double -> Bool -> TestName -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover Double
95   (Bool -> Bool
not (Chain Block -> Bool
forall block. Chain block -> Bool
Chain.null Chain Block
c)) TestName
"non-null" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Double -> Bool -> TestName -> Bool -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover Double
1.5       (Chain Block -> Bool
forall block. Chain block -> Bool
Chain.null Chain Block
c)  TestName
"null"     (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
    Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain Block
c

prop_arbitrary_TestHeaderChain :: TestHeaderChain -> Bool
prop_arbitrary_TestHeaderChain :: TestHeaderChain -> Bool
prop_arbitrary_TestHeaderChain (TestHeaderChain Chain BlockHeader
c) =
    Chain BlockHeader -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain BlockHeader
c

prop_shrink_TestBlockChain :: TestBlockChain -> Bool
prop_shrink_TestBlockChain :: TestBlockChain -> Bool
prop_shrink_TestBlockChain TestBlockChain
c =
    [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain Block
c' | TestBlockChain Chain Block
c' <- TestBlockChain -> [TestBlockChain]
forall a. Arbitrary a => a -> [a]
shrink TestBlockChain
c ]

prop_shrink_TestHeaderChain :: TestHeaderChain -> Bool
prop_shrink_TestHeaderChain :: TestHeaderChain -> Bool
prop_shrink_TestHeaderChain TestHeaderChain
c =
    [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Chain BlockHeader -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain BlockHeader
c' | TestHeaderChain Chain BlockHeader
c' <- TestHeaderChain -> [TestHeaderChain]
forall a. Arbitrary a => a -> [a]
shrink TestHeaderChain
c ]


--
-- Generator for chain and single block
--

-- | A test generator for a chain and a block that can be appended to it.
--
data TestAddBlock = TestAddBlock (Chain Block) Block
  deriving Int -> TestAddBlock -> ShowS
[TestAddBlock] -> ShowS
TestAddBlock -> TestName
(Int -> TestAddBlock -> ShowS)
-> (TestAddBlock -> TestName)
-> ([TestAddBlock] -> ShowS)
-> Show TestAddBlock
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestAddBlock -> ShowS
showsPrec :: Int -> TestAddBlock -> ShowS
$cshow :: TestAddBlock -> TestName
show :: TestAddBlock -> TestName
$cshowList :: [TestAddBlock] -> ShowS
showList :: [TestAddBlock] -> ShowS
Show

instance Arbitrary TestAddBlock where
  arbitrary :: Gen TestAddBlock
arbitrary = do
    TestBlockChain chain <- Gen TestBlockChain
forall a. Arbitrary a => Gen a
arbitrary
    blk <- genAddBlock chain
    return (TestAddBlock chain blk)

  shrink :: TestAddBlock -> [TestAddBlock]
shrink (TestAddBlock Chain Block
c Block
b) =
    [ Chain Block -> Block -> TestAddBlock
TestAddBlock Chain Block
c' Block
b'
    | TestBlockChain Chain Block
c' <- TestBlockChain -> [TestBlockChain]
forall a. Arbitrary a => a -> [a]
shrink (Chain Block -> TestBlockChain
TestBlockChain Chain Block
c)
    , let b' :: Block
b' = Anchor Block -> Block -> Block
forall block.
(HeaderHash block ~ HeaderHash BlockHeader) =>
Anchor block -> Block -> Block
fixupBlock (Chain Block -> Anchor Block
forall block. HasHeader block => Chain block -> Anchor block
Chain.headAnchor Chain Block
c') Block
b
    ]

genAddBlock :: (HasHeader block, HeaderHash block ~ ConcreteHeaderHash)
            => Chain block -> Gen Block
genAddBlock :: forall block.
(HasHeader block, HeaderHash block ~ ConcreteHeaderHash) =>
Chain block -> Gen Block
genAddBlock Chain block
chain = do
    slotGap <- Gen Int
genSlotGap
    body    <- arbitrary
    let nextSlotNo = Int -> WithOrigin SlotNo -> SlotNo
addSlotGap Int
slotGap (Chain block -> WithOrigin SlotNo
forall block. HasHeader block => Chain block -> WithOrigin SlotNo
Chain.headSlot Chain block
chain)
        pb = SlotNo -> BlockBody -> Block
mkPartialBlock SlotNo
nextSlotNo BlockBody
body
        b  = Anchor block -> Block -> Block
forall block.
(HeaderHash block ~ HeaderHash BlockHeader) =>
Anchor block -> Block -> Block
fixupBlock (Chain block -> Anchor block
forall block. HasHeader block => Chain block -> Anchor block
Chain.headAnchor Chain block
chain) Block
pb
    return b

prop_arbitrary_TestAddBlock :: TestAddBlock -> Bool
prop_arbitrary_TestAddBlock :: TestAddBlock -> Bool
prop_arbitrary_TestAddBlock (TestAddBlock Chain Block
c Block
b) =
    Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid (Chain Block
c Chain Block -> Block -> Chain Block
forall block. Chain block -> block -> Chain block
:> Block
b)

prop_shrink_TestAddBlock :: TestAddBlock -> Bool
prop_shrink_TestAddBlock :: TestAddBlock -> Bool
prop_shrink_TestAddBlock TestAddBlock
t =
    [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid (Chain Block
c Chain Block -> Block -> Chain Block
forall block. Chain block -> block -> Chain block
:> Block
b) | TestAddBlock Chain Block
c Block
b <- TestAddBlock -> [TestAddBlock]
forall a. Arbitrary a => a -> [a]
shrink TestAddBlock
t ]


--
-- Generator for chain updates
--

-- | The Ouroboros K paramater. This is also the maximum rollback length.
--
k :: Int
k :: Int
k = Int
5

-- | A test generator for a chain and a sequence of updates that can be applied
-- to it.
--
data TestBlockChainAndUpdates =
       TestBlockChainAndUpdates (Chain Block) [ChainUpdate Block Block]
  deriving Int -> TestBlockChainAndUpdates -> ShowS
[TestBlockChainAndUpdates] -> ShowS
TestBlockChainAndUpdates -> TestName
(Int -> TestBlockChainAndUpdates -> ShowS)
-> (TestBlockChainAndUpdates -> TestName)
-> ([TestBlockChainAndUpdates] -> ShowS)
-> Show TestBlockChainAndUpdates
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestBlockChainAndUpdates -> ShowS
showsPrec :: Int -> TestBlockChainAndUpdates -> ShowS
$cshow :: TestBlockChainAndUpdates -> TestName
show :: TestBlockChainAndUpdates -> TestName
$cshowList :: [TestBlockChainAndUpdates] -> ShowS
showList :: [TestBlockChainAndUpdates] -> ShowS
Show

instance Arbitrary TestBlockChainAndUpdates where
  arbitrary :: Gen TestBlockChainAndUpdates
arbitrary = do
    TestBlockChain chain <- Gen TestBlockChain
forall a. Arbitrary a => Gen a
arbitrary
    m <- genNonNegative
    updates <- genChainUpdates chain m
    return (TestBlockChainAndUpdates chain updates)

genChainUpdate :: Chain Block
               -> Gen (ChainUpdate Block Block)
genChainUpdate :: Chain Block -> Gen (ChainUpdate Block Block)
genChainUpdate Chain Block
chain =
    [(Int, Gen (ChainUpdate Block Block))]
-> Gen (ChainUpdate Block Block)
forall a. [(Int, Gen a)] -> Gen a
frequency ([(Int, Gen (ChainUpdate Block Block))]
 -> Gen (ChainUpdate Block Block))
-> [(Int, Gen (ChainUpdate Block Block))]
-> Gen (ChainUpdate Block Block)
forall a b. (a -> b) -> a -> b
$
      -- To ensure we make progress on average w must ensure the weight of
      -- adding one block is more than the expected rollback length. If we
      -- used expectedRollbackLength then we would on average make no
      -- progress. We slightly arbitrarily weight 2:1 for forward progress.
      [ (Int
expectedRollbackLength Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2, Block -> ChainUpdate Block Block
forall {k} (block :: k) a. a -> ChainUpdate block a
AddBlock (Block -> ChainUpdate Block Block)
-> Gen Block -> Gen (ChainUpdate Block Block)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chain Block -> Gen Block
forall block.
(HasHeader block, HeaderHash block ~ ConcreteHeaderHash) =>
Chain block -> Gen Block
genAddBlock Chain Block
chain) ]
   [(Int, Gen (ChainUpdate Block Block))]
-> [(Int, Gen (ChainUpdate Block Block))]
-> [(Int, Gen (ChainUpdate Block Block))]
forall a. [a] -> [a] -> [a]
++ Int
-> [(Int, Gen (ChainUpdate Block Block))]
-> [(Int, Gen (ChainUpdate Block Block))]
forall a. Int -> [a] -> [a]
L.take (Chain Block -> Int
forall block. Chain block -> Int
Chain.length Chain Block
chain)
        [ (Int
freq, ChainUpdate Block Block -> Gen (ChainUpdate Block Block)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Point Block -> ChainUpdate Block Block
forall {k} (block :: k) a. Point block -> ChainUpdate block a
RollBack (Chain Block -> Int -> Point Block
forall block. HasHeader block => Chain block -> Int -> Point block
mkRollbackPoint Chain Block
chain Int
len)))
        | (Int
freq, Int
len) <- [(Int, Int)]
rollbackLengthDistribution
        ]
  where
    -- This is the un-normalised expected value since the 'frequency'
    -- combinator normalises everything anyway.
    expectedRollbackLength :: Int
    expectedRollbackLength :: Int
expectedRollbackLength =
        [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Int
freq Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n | (Int
freq, Int
n) <- [(Int, Int)]
rollbackLengthDistribution ]

    rollbackLengthDistribution :: [(Int,Int)]
    rollbackLengthDistribution :: [(Int, Int)]
rollbackLengthDistribution =
      (Int
1, Int
0) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:
      [ let freq :: Int
freq = (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
n); len :: Int
len = Int
n
         in (Int
freq, Int
len)
      | Int
n <- [Int
1..Int
k] ]

mkRollbackPoint :: HasHeader block => Chain block -> Int -> Point block
mkRollbackPoint :: forall block. HasHeader block => Chain block -> Int -> Point block
mkRollbackPoint Chain block
chain Int
n = Chain block -> Point block
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint (Chain block -> Point block) -> Chain block -> Point block
forall a b. (a -> b) -> a -> b
$ Int -> Chain block -> Chain block
forall block. Int -> Chain block -> Chain block
Chain.drop Int
n Chain block
chain

genChainUpdates :: Chain Block
                -> Int
                -> Gen [ChainUpdate Block Block]
genChainUpdates :: Chain Block -> Int -> Gen [ChainUpdate Block Block]
genChainUpdates Chain Block
_     Int
0 = [ChainUpdate Block Block] -> Gen [ChainUpdate Block Block]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return []
genChainUpdates Chain Block
chain Int
n = do
    update  <- Chain Block -> Gen (ChainUpdate Block Block)
genChainUpdate Chain Block
chain
    let Just chain' = Chain.applyChainUpdate update chain
    updates <- genChainUpdates chain' (n-1)
    return (update : updates)

prop_arbitrary_TestBlockChainAndUpdates :: TestBlockChainAndUpdates -> Property
prop_arbitrary_TestBlockChainAndUpdates :: TestBlockChainAndUpdates -> Property
prop_arbitrary_TestBlockChainAndUpdates (TestBlockChainAndUpdates Chain Block
c [ChainUpdate Block Block]
us) =
    Double -> Bool -> TestName -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover Double
1.5 (     [ChainUpdate Block Block] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ChainUpdate Block Block]
us ) TestName
"empty updates"     (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Double -> Bool -> TestName -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover Double
95  (Bool -> Bool
not ([ChainUpdate Block Block] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ChainUpdate Block Block]
us)) TestName
"non-empty updates" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"ChainUpdate" ((ChainUpdate Block Block -> TestName)
-> [ChainUpdate Block Block] -> [TestName]
forall a b. (a -> b) -> [a] -> [b]
map ChainUpdate Block Block -> TestName
forall {block} {a}. ChainUpdate block a -> TestName
updateKind [ChainUpdate Block Block]
us) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    TestName -> [TestName] -> Bool -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"Growth" [Int -> TestName
forall {a}. (Integral a, Show a) => a -> TestName
hist (Chain Block -> [ChainUpdate Block Block] -> Int
forall block.
HasHeader block =>
Chain block -> [ChainUpdate block block] -> Int
countChainUpdateNetProgress Chain Block
c [ChainUpdate Block Block]
us)] (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$

    Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain Block
c
 Bool -> Bool -> Bool
&& case [ChainUpdate Block Block] -> Chain Block -> Maybe (Chain Block)
forall block.
HasHeader block =>
[ChainUpdate block block] -> Chain block -> Maybe (Chain block)
Chain.applyChainUpdates [ChainUpdate Block Block]
us Chain Block
c of
      Maybe (Chain Block)
Nothing -> Bool
False
      Just Chain Block
c' -> Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain Block
c'
  where
    hist :: a -> TestName
hist a
n = a -> TestName
forall a. Show a => a -> TestName
show a
lower TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
" to " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> TestName
forall a. Show a => a -> TestName
show a
upper
      where
        lower :: a
lower = (a
n a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
10)     a -> a -> a
forall a. Num a => a -> a -> a
* a
10
        upper :: a
upper = (a
n a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
10 a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) a -> a -> a
forall a. Num a => a -> a -> a
* a
10 a -> a -> a
forall a. Num a => a -> a -> a
- a
1

    updateKind :: ChainUpdate block a -> TestName
updateKind AddBlock{} = TestName
"AddBlock"
    updateKind RollBack{} = TestName
"RollBack"

-- | Count the number of blocks forward - the number of blocks backward.
--
countChainUpdateNetProgress :: HasHeader block
                            => Chain block
                            -> [ChainUpdate block block]
                            -> Int
countChainUpdateNetProgress :: forall block.
HasHeader block =>
Chain block -> [ChainUpdate block block] -> Int
countChainUpdateNetProgress = Int -> Chain block -> [ChainUpdate block block] -> Int
forall {block}.
HasHeader block =>
Int -> Chain block -> [ChainUpdate block block] -> Int
go Int
0
  where
    go :: Int -> Chain block -> [ChainUpdate block block] -> Int
go Int
n Chain block
_c []     = Int
n
    go Int
n Chain block
c  (ChainUpdate block block
u:[ChainUpdate block block]
us) = Int -> Chain block -> [ChainUpdate block block] -> Int
go Int
n' Chain block
c' [ChainUpdate block block]
us
      where
        Just Chain block
c' = ChainUpdate block block -> Chain block -> Maybe (Chain block)
forall block.
HasHeader block =>
ChainUpdate block block -> Chain block -> Maybe (Chain block)
Chain.applyChainUpdate ChainUpdate block block
u Chain block
c
        n' :: Int
n'      = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ BlockNo -> Int
forall a. Enum a => a -> Int
fromEnum (BlockNo -> WithOrigin BlockNo -> BlockNo
forall t. t -> WithOrigin t -> t
fromWithOrigin BlockNo
0 (Chain block -> WithOrigin BlockNo
forall block. HasHeader block => Chain block -> WithOrigin BlockNo
Chain.headBlockNo Chain block
c'))
                    Int -> Int -> Int
forall a. Num a => a -> a -> a
- BlockNo -> Int
forall a. Enum a => a -> Int
fromEnum (BlockNo -> WithOrigin BlockNo -> BlockNo
forall t. t -> WithOrigin t -> t
fromWithOrigin BlockNo
0 (Chain block -> WithOrigin BlockNo
forall block. HasHeader block => Chain block -> WithOrigin BlockNo
Chain.headBlockNo Chain block
c))


--
-- Generator for chain and single point on the chain
--

-- | A test generator for a chain and a points. In most cases the point is
-- on the chain, but it also covers at least 5% of cases where the point is
-- not on the chain.
--
data TestChainAndPoint = TestChainAndPoint (Chain Block) (Point Block)
  deriving Int -> TestChainAndPoint -> ShowS
[TestChainAndPoint] -> ShowS
TestChainAndPoint -> TestName
(Int -> TestChainAndPoint -> ShowS)
-> (TestChainAndPoint -> TestName)
-> ([TestChainAndPoint] -> ShowS)
-> Show TestChainAndPoint
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestChainAndPoint -> ShowS
showsPrec :: Int -> TestChainAndPoint -> ShowS
$cshow :: TestChainAndPoint -> TestName
show :: TestChainAndPoint -> TestName
$cshowList :: [TestChainAndPoint] -> ShowS
showList :: [TestChainAndPoint] -> ShowS
Show

instance Arbitrary TestChainAndPoint where
  arbitrary :: Gen TestChainAndPoint
arbitrary = do
    TestBlockChain chain <- Gen TestBlockChain
forall a. Arbitrary a => Gen a
arbitrary
    -- either choose point from the chain or a few off the chain!
    point <- frequency [ (10, genPointOnChain chain), (1, arbitrary) ]
    return (TestChainAndPoint chain point)

  shrink :: TestChainAndPoint -> [TestChainAndPoint]
shrink (TestChainAndPoint Chain Block
c Point Block
p) =
    [ Chain Block -> Point Block -> TestChainAndPoint
TestChainAndPoint Chain Block
c' (if Point Block
p Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
`Chain.pointOnChain` Chain Block
c then Chain Block -> Point Block -> Point Block
forall block.
HasHeader block =>
Chain block -> Point block -> Point block
fixupPoint Chain Block
c' Point Block
p else Point Block
p)
    | TestBlockChain Chain Block
c' <- TestBlockChain -> [TestBlockChain]
forall a. Arbitrary a => a -> [a]
shrink (Chain Block -> TestBlockChain
TestBlockChain Chain Block
c) ]

genPointOnChain :: HasHeader block => Chain block -> Gen (Point block)
genPointOnChain :: forall block. HasHeader block => Chain block -> Gen (Point block)
genPointOnChain Chain block
chain =
    [(Int, Gen (Point block))] -> Gen (Point block)
forall a. [(Int, Gen a)] -> Gen a
frequency
      [ (Int
1, Point block -> Gen (Point block)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Chain block -> Point block
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint Chain block
chain))
      , (Int
1, Point block -> Gen (Point block)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Chain block -> Int -> Point block
forall block. HasHeader block => Chain block -> Int -> Point block
mkRollbackPoint Chain block
chain Int
len))
      , (Int
8, Chain block -> Int -> Point block
forall block. HasHeader block => Chain block -> Int -> Point block
mkRollbackPoint Chain block
chain (Int -> Point block) -> Gen Int -> Gen (Point block)
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
1, Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
      ]
  where
    len :: Int
len = Chain block -> Int
forall block. Chain block -> Int
Chain.length Chain block
chain

fixupPoint :: HasHeader block => Chain block -> Point block -> Point block
fixupPoint :: forall block.
HasHeader block =>
Chain block -> Point block -> Point block
fixupPoint Chain block
c Point block
GenesisPoint         = Chain block -> Point block
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint Chain block
c
fixupPoint Chain block
c (BlockPoint SlotNo
bslot HeaderHash block
_) =
  case (block -> Bool) -> [block] -> Maybe block
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
bslot) (SlotNo -> Bool) -> (block -> SlotNo) -> block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. block -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot) (Chain block -> [block]
forall block. Chain block -> [block]
Chain.chainToList Chain block
c) of
    Just block
b  -> block -> Point block
forall block. HasHeader block => block -> Point block
Chain.blockPoint block
b
    Maybe block
Nothing -> Chain block -> Point block
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint Chain block
c

prop_arbitrary_TestChainAndPoint :: TestChainAndPoint -> Property
prop_arbitrary_TestChainAndPoint :: TestChainAndPoint -> Property
prop_arbitrary_TestChainAndPoint (TestChainAndPoint Chain Block
c Point Block
p) =
  let onChain :: Bool
onChain = Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
Chain.pointOnChain Point Block
p Chain Block
c in
  Double -> Bool -> TestName -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover  Double
85 Bool
onChain       TestName
"point on chain" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  Double -> Bool -> TestName -> Bool -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover   Double
5 (Bool -> Bool
not Bool
onChain) TestName
"point not on chain" (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
    Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain Block
c

prop_shrink_TestChainAndPoint :: TestChainAndPoint -> Bool
prop_shrink_TestChainAndPoint :: TestChainAndPoint -> Bool
prop_shrink_TestChainAndPoint cp :: TestChainAndPoint
cp@(TestChainAndPoint Chain Block
c Point Block
_) =
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [     Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain Block
c'
        Bool -> Bool -> Bool
&& (Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
Chain.pointOnChain Point Block
p Chain Block
c Bool -> Bool -> Bool
`implies` Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
Chain.pointOnChain Point Block
p Chain Block
c')
      | TestChainAndPoint Chain Block
c' Point Block
p <- TestChainAndPoint -> [TestChainAndPoint]
forall a. Arbitrary a => a -> [a]
shrink TestChainAndPoint
cp ]

implies :: Bool -> Bool -> Bool
Bool
a implies :: Bool -> Bool -> Bool
`implies` Bool
b = Bool -> Bool
not Bool
a Bool -> Bool -> Bool
|| Bool
b

infix 1 `implies`


--
-- Generator for chain and range on the chain
--

-- | A test generator for a chain and a range defined by a pair of points.
-- In most cases the range is on the chain, but it also covers at least 5% of
-- cases where the point is not on the chain.
--
data TestChainAndRange = TestChainAndRange (Chain Block) (Point Block) (Point Block)
  deriving Int -> TestChainAndRange -> ShowS
[TestChainAndRange] -> ShowS
TestChainAndRange -> TestName
(Int -> TestChainAndRange -> ShowS)
-> (TestChainAndRange -> TestName)
-> ([TestChainAndRange] -> ShowS)
-> Show TestChainAndRange
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestChainAndRange -> ShowS
showsPrec :: Int -> TestChainAndRange -> ShowS
$cshow :: TestChainAndRange -> TestName
show :: TestChainAndRange -> TestName
$cshowList :: [TestChainAndRange] -> ShowS
showList :: [TestChainAndRange] -> ShowS
Show

instance Arbitrary TestChainAndRange where
  arbitrary :: Gen TestChainAndRange
arbitrary = do
    TestBlockChain chain <- Gen TestBlockChain
forall a. Arbitrary a => Gen a
arbitrary
    -- either choose range from the chain or a few off the chain!
    (point1, point2) <- frequency [ (10, genRangeOnChain chain)
                                  , (1, (,) <$> arbitrary <*> arbitrary) ]
    return (TestChainAndRange chain point1 point2)

  shrink :: TestChainAndRange -> [TestChainAndRange]
shrink (TestChainAndRange Chain Block
c Point Block
p1 Point Block
p2) =
    [ Chain Block -> Point Block -> Point Block -> TestChainAndRange
TestChainAndRange
        Chain Block
c'
        (if Point Block
p1 Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
`Chain.pointOnChain` Chain Block
c then Chain Block -> Point Block -> Point Block
forall block.
HasHeader block =>
Chain block -> Point block -> Point block
fixupPoint Chain Block
c' Point Block
p1 else Point Block
p1)
        (if Point Block
p2 Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
`Chain.pointOnChain` Chain Block
c then Chain Block -> Point Block -> Point Block
forall block.
HasHeader block =>
Chain block -> Point block -> Point block
fixupPoint Chain Block
c' Point Block
p2 else Point Block
p2)
    | TestBlockChain Chain Block
c' <- TestBlockChain -> [TestBlockChain]
forall a. Arbitrary a => a -> [a]
shrink (Chain Block -> TestBlockChain
TestBlockChain Chain Block
c) ]

genRangeOnChain :: HasHeader block
                => Chain block
                -> Gen (Point block, Point block)
genRangeOnChain :: forall block.
HasHeader block =>
Chain block -> Gen (Point block, Point block)
genRangeOnChain Chain block
chain = do
    point1 <- Chain block -> Gen (Point block)
forall block. HasHeader block => Chain block -> Gen (Point block)
genPointOnChain Chain block
chain
    let Just point1Depth = (\Chain block
c -> Chain block -> Int
forall block. Chain block -> Int
Chain.length Chain block
chain Int -> Int -> Int
forall a. Num a => a -> a -> a
- Chain block -> Int
forall block. Chain block -> Int
Chain.length Chain block
c) <$>
                           Chain.rollback point1 chain
    point2 <- frequency $
        [ (1, return (Chain.headPoint chain))
        , (1, return (mkRollbackPoint chain point1Depth))
        , (8, mkRollbackPoint chain <$> choose (0, point1Depth))
        ]
    return (point1, point2)

prop_arbitrary_TestChainAndRange :: TestChainAndRange -> Property
prop_arbitrary_TestChainAndRange :: TestChainAndRange -> Property
prop_arbitrary_TestChainAndRange (TestChainAndRange Chain Block
c Point Block
p1 Point Block
p2) =
  let onChain :: Bool
onChain = Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
Chain.pointOnChain Point Block
p1 Chain Block
c Bool -> Bool -> Bool
&& Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
Chain.pointOnChain Point Block
p2 Chain Block
c in
  Double -> Bool -> TestName -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover Double
85 Bool
onChain               TestName
"points on chain" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  Double -> Bool -> TestName -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover  Double
5 (Bool
onChain Bool -> Bool -> Bool
&& Point Block
p1 Point Block -> Point Block -> Bool
forall a. Eq a => a -> a -> Bool
== Point Block
p2) TestName
"empty range" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  Double -> Bool -> TestName -> Bool -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover  Double
5 (Bool -> Bool
not Bool
onChain)         TestName
"points not on chain" (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
    Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain Block
c
 Bool -> Bool -> Bool
&& Bool
onChain Bool -> Bool -> Bool
`implies` Point Block -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point Block
p2 WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= Point Block -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point Block
p1

prop_shrink_TestChainAndRange :: TestChainAndRange -> Bool
prop_shrink_TestChainAndRange :: TestChainAndRange -> Bool
prop_shrink_TestChainAndRange cp :: TestChainAndRange
cp@(TestChainAndRange Chain Block
c Point Block
_ Point Block
_) =
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [    Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain Block
c'
        Bool -> Bool -> Bool
&& (Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
Chain.pointOnChain Point Block
p1 Chain Block
c Bool -> Bool -> Bool
&& Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
Chain.pointOnChain Point Block
p2 Chain Block
c
            Bool -> Bool -> Bool
`implies`
            Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
Chain.pointOnChain Point Block
p1 Chain Block
c' Bool -> Bool -> Bool
&& Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
Chain.pointOnChain Point Block
p2 Chain Block
c')
      | TestChainAndRange Chain Block
c' Point Block
p1 Point Block
p2 <- TestChainAndRange -> [TestChainAndRange]
forall a. Arbitrary a => a -> [a]
shrink TestChainAndRange
cp ]


-- | A test generator for a chain and a list of points, some of which may not be
-- on the chain.  Only 50% of the blocks are selected, one fifth of selected
-- ones are not on the chain.  Points which come from the chain are given in the
-- newest to oldest order, but the intermediate points which are not in the
-- chain might break the order.
--
data TestChainAndPoints = TestChainAndPoints (Chain Block) [Point Block]
  deriving Int -> TestChainAndPoints -> ShowS
[TestChainAndPoints] -> ShowS
TestChainAndPoints -> TestName
(Int -> TestChainAndPoints -> ShowS)
-> (TestChainAndPoints -> TestName)
-> ([TestChainAndPoints] -> ShowS)
-> Show TestChainAndPoints
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestChainAndPoints -> ShowS
showsPrec :: Int -> TestChainAndPoints -> ShowS
$cshow :: TestChainAndPoints -> TestName
show :: TestChainAndPoints -> TestName
$cshowList :: [TestChainAndPoints] -> ShowS
showList :: [TestChainAndPoints] -> ShowS
Show

instance Arbitrary TestChainAndPoints where
  arbitrary :: Gen TestChainAndPoints
arbitrary = do
    TestBlockChain chain <- Gen TestBlockChain
forall a. Arbitrary a => Gen a
arbitrary
    let fn a
p = [(Int, Gen (Maybe a))] -> Gen (Maybe a)
forall a. [(Int, Gen a)] -> Gen a
frequency
          [ (Int
4, Maybe a -> Gen (Maybe a)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> Gen (Maybe a)) -> Maybe a -> Gen (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
p)
          , (Int
1, a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Gen a -> Gen (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary)
          , (Int
5, Maybe a -> Gen (Maybe a)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing)
          ]
        points = (Block -> Point Block) -> [Block] -> [Point Block]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Point Block
forall block. HasHeader block => block -> Point block
Chain.blockPoint (Chain Block -> [Block]
forall block. Chain block -> [block]
Chain.chainToList Chain Block
chain)
                  [Point Block] -> [Point Block] -> [Point Block]
forall a. [a] -> [a] -> [a]
++ [Point Block
forall {k} (block :: k). Point block
genesisPoint]
    points' <- catMaybes <$> mapM fn points
    return $ TestChainAndPoints chain points'

  shrink :: TestChainAndPoints -> [TestChainAndPoints]
shrink (TestChainAndPoints Chain Block
chain [Point Block]
points) =
    [ Chain Block -> [Point Block] -> TestChainAndPoints
TestChainAndPoints Chain Block
chain' [Point Block]
points'
    | TestBlockChain Chain Block
chain' <- TestBlockChain -> [TestBlockChain]
forall a. Arbitrary a => a -> [a]
shrink (Chain Block -> TestBlockChain
TestBlockChain Chain Block
chain)
      -- Leave only points that are on the @chain'@ or the ones that where not on the
      -- original @chain@.
    , let points' :: [Point Block]
points' = (Point Block -> Bool) -> [Point Block] -> [Point Block]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Point Block
p ->        Point Block
p Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
`Chain.pointOnChain` Chain Block
chain'
                                 Bool -> Bool -> Bool
|| Bool -> Bool
not (Point Block
p Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
`Chain.pointOnChain` Chain Block
chain)) [Point Block]
points
    ] [TestChainAndPoints]
-> [TestChainAndPoints] -> [TestChainAndPoints]
forall a. [a] -> [a] -> [a]
++
    [ Chain Block -> [Point Block] -> TestChainAndPoints
TestChainAndPoints Chain Block
chain [Point Block]
points'
    | [Point Block]
points' <- (Point Block -> [Point Block]) -> [Point Block] -> [[Point Block]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList Point Block -> [Point Block]
forall a. a -> [a]
shrinkNothing [Point Block]
points
    ]

prop_arbitrary_TestChainAndPoints :: TestChainAndPoints -> Property
prop_arbitrary_TestChainAndPoints :: TestChainAndPoints -> Property
prop_arbitrary_TestChainAndPoints (TestChainAndPoints Chain Block
c [Point Block]
ps) =
  Double -> Bool -> TestName -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover Double
85 ((Point Block -> Bool) -> [Point Block] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
`Chain.pointOnChain` Chain Block
c) [Point Block]
ps)       TestName
"any points on chain"     (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  Double -> Bool -> TestName -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover Double
65 (Bool -> Bool
not ((Point Block -> Bool) -> [Point Block] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
`Chain.pointOnChain` Chain Block
c) [Point Block]
ps)) TestName
"not all points on chain" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  Double -> Bool -> TestName -> Bool -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover Double
90 (Bool -> Bool
not ([Point Block] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Point Block]
ps))                         TestName
"some points"             (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
    Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain Block
c

prop_shrink_TestChainAndPoints :: TestChainAndPoints -> Bool
prop_shrink_TestChainAndPoints :: TestChainAndPoints -> Bool
prop_shrink_TestChainAndPoints cps :: TestChainAndPoints
cps@(TestChainAndPoints Chain Block
c [Point Block]
_) =
  -- can't really say much about the points without duplicating the logic above
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [    Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain Block
c'
        Bool -> Bool -> Bool
&& (Point Block -> Bool) -> [Point Block] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Point Block
p ->      Point Block
p Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
`Chain.pointOnChain` Chain Block
c'
                   Bool -> Bool -> Bool
|| Bool -> Bool
not (Point Block
p Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
`Chain.pointOnChain` Chain Block
c)) [Point Block]
ps'
      | TestChainAndPoints Chain Block
c' [Point Block]
ps' <- TestChainAndPoints -> [TestChainAndPoints]
forall a. Arbitrary a => a -> [a]
shrink TestChainAndPoints
cps ]


--
-- Generator for chain forks sharing a common prefix
--

-- | A test generator for two chains sharing a common prefix.
--
data TestChainFork = TestChainFork (Chain Block) -- common prefix
                                   (Chain Block) -- left fork
                                   (Chain Block) -- right fork

instance Show TestChainFork where
  show :: TestChainFork -> TestName
show (TestChainFork Chain Block
c Chain Block
f1 Chain Block
f2)
    = let nl :: TestName
nl  = TestName
"\n    "
          nnl :: TestName
nnl = TestName
"\n" TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
nl
      in TestName
"TestChainFork" TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
nl TestName -> ShowS
forall a. [a] -> [a] -> [a]
++
      TestName -> (Block -> TestName) -> Chain Block -> TestName
forall block.
TestName -> (block -> TestName) -> Chain block -> TestName
Chain.prettyPrintChain TestName
nl Block -> TestName
forall a. Show a => a -> TestName
show Chain Block
c  TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
nnl TestName -> ShowS
forall a. [a] -> [a] -> [a]
++
      TestName -> (Block -> TestName) -> Chain Block -> TestName
forall block.
TestName -> (block -> TestName) -> Chain block -> TestName
Chain.prettyPrintChain TestName
nl Block -> TestName
forall a. Show a => a -> TestName
show Chain Block
f1 TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
nnl TestName -> ShowS
forall a. [a] -> [a] -> [a]
++
      TestName -> (Block -> TestName) -> Chain Block -> TestName
forall block.
TestName -> (block -> TestName) -> Chain block -> TestName
Chain.prettyPrintChain TestName
nl Block -> TestName
forall a. Show a => a -> TestName
show Chain Block
f2

instance Arbitrary TestChainFork where
  arbitrary :: Gen TestChainFork
arbitrary = do
    TestBlockChain chain <- Gen TestBlockChain
forall a. Arbitrary a => Gen a
arbitrary
    -- at least 5% of forks should be equal
    equalChains <- frequency [(1, pure True), (19, pure False)]
    if equalChains
      then return (TestChainFork chain chain chain)
      else do
        l <- genNonNegative
        r <- genNonNegative
        chainL <- genAddBlocks l chain Nothing
        let exL = Int -> [Block] -> [Block]
forall a. Int -> [a] -> [a]
L.drop (Chain Block -> Int
forall block. Chain block -> Int
Chain.length Chain Block
chain) (Chain Block -> [Block]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain Block
chainL)
        chainR <- genAddBlocks r chain (listToMaybe exL)
        return (TestChainFork chain chainL chainR)

    where
      genAddBlocks :: Int
                   -> Chain Block
                   -> Maybe Block
                   -> Gen (Chain Block)
      genAddBlocks :: Int -> Chain Block -> Maybe Block -> Gen (Chain Block)
genAddBlocks Int
0 Chain Block
c Maybe Block
_       = Chain Block -> Gen (Chain Block)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Chain Block
c
      genAddBlocks Int
n Chain Block
c Maybe Block
Nothing = do
          b <- Chain Block -> Gen Block
forall block.
(HasHeader block, HeaderHash block ~ ConcreteHeaderHash) =>
Chain block -> Gen Block
genAddBlock Chain Block
c
          genAddBlocks (n-1) (Chain.addBlock b c) Nothing

      -- But we want to avoid the extensions starting off equal which would
      -- mean the longest common prefix was not the declared common prefix.
      -- So we optionally take the first block to avoid and use that in the
      -- second fork we generate.
      genAddBlocks Int
n Chain Block
c (Just Block
forbiddenBlock) = do
          b <- Chain Block -> Gen Block
forall block.
(HasHeader block, HeaderHash block ~ ConcreteHeaderHash) =>
Chain block -> Gen Block
genAddBlock Chain Block
c Gen Block -> (Block -> Bool) -> Gen Block
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Block -> Block -> Bool
forall a. Eq a => a -> a -> Bool
/= Block
forbiddenBlock)
          genAddBlocks (n-1) (Chain.addBlock b c) Nothing


  shrink :: TestChainFork -> [TestChainFork]
shrink (TestChainFork Chain Block
common Chain Block
l Chain Block
r) =
        -- shrink the common prefix
      [ Chain Block -> Chain Block -> Chain Block -> TestChainFork
TestChainFork ((Anchor Block -> Block -> Block) -> [Block] -> Chain Block
forall b. HasFullHeader b => (Anchor b -> b -> b) -> [b] -> Chain b
fixupChain Anchor Block -> Block -> Block
forall block.
(HeaderHash block ~ HeaderHash BlockHeader) =>
Anchor block -> Block -> Block
fixupBlock [Block]
common')
                      ((Anchor Block -> Block -> Block) -> [Block] -> Chain Block
forall b. HasFullHeader b => (Anchor b -> b -> b) -> [b] -> Chain b
fixupChain Anchor Block -> Block -> Block
forall block.
(HeaderHash block ~ HeaderHash BlockHeader) =>
Anchor block -> Block -> Block
fixupBlock ([Block]
exl [Block] -> [Block] -> [Block]
forall a. [a] -> [a] -> [a]
++ [Block]
common'))
                      ((Anchor Block -> Block -> Block) -> [Block] -> Chain Block
forall b. HasFullHeader b => (Anchor b -> b -> b) -> [b] -> Chain b
fixupChain Anchor Block -> Block -> Block
forall block.
(HeaderHash block ~ HeaderHash BlockHeader) =>
Anchor block -> Block -> Block
fixupBlock ([Block]
exr [Block] -> [Block] -> [Block]
forall a. [a] -> [a] -> [a]
++ [Block]
common'))
      | let exl :: [Block]
exl = Chain Block -> Chain Block -> [Block]
extensionFragment Chain Block
common Chain Block
l
            exr :: [Block]
exr = Chain Block -> Chain Block -> [Block]
extensionFragment Chain Block
common Chain Block
r
      , [Block]
common' <- (Block -> [Block]) -> [Block] -> [[Block]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([Block] -> Block -> [Block]
forall a b. a -> b -> a
const []) (Chain Block -> [Block]
forall block. Chain block -> [block]
Chain.toNewestFirst Chain Block
common)
      ]
        -- shrink the left fork
   [TestChainFork] -> [TestChainFork] -> [TestChainFork]
forall a. [a] -> [a] -> [a]
++ [ Chain Block -> Chain Block -> Chain Block -> TestChainFork
TestChainFork Chain Block
common Chain Block
l' Chain Block
r
      | let exl :: [Block]
exl = Chain Block -> Chain Block -> [Block]
extensionFragment Chain Block
common Chain Block
l
      , [Block]
exl' <- (Block -> [Block]) -> [Block] -> [[Block]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([Block] -> Block -> [Block]
forall a b. a -> b -> a
const []) [Block]
exl
      , let l' :: Chain Block
l' = (Anchor Block -> Block -> Block) -> [Block] -> Chain Block
forall b. HasFullHeader b => (Anchor b -> b -> b) -> [b] -> Chain b
fixupChain Anchor Block -> Block -> Block
forall block.
(HeaderHash block ~ HeaderHash BlockHeader) =>
Anchor block -> Block -> Block
fixupBlock ([Block]
exl' [Block] -> [Block] -> [Block]
forall a. [a] -> [a] -> [a]
++ Chain Block -> [Block]
forall block. Chain block -> [block]
Chain.toNewestFirst Chain Block
common)
      , Chain Block -> Chain Block -> Bool
isLongestCommonPrefix Chain Block
l' Chain Block
r
      ]
        -- shrink the right fork
   [TestChainFork] -> [TestChainFork] -> [TestChainFork]
forall a. [a] -> [a] -> [a]
++ [ Chain Block -> Chain Block -> Chain Block -> TestChainFork
TestChainFork Chain Block
common Chain Block
l Chain Block
r'
      | let exr :: [Block]
exr = Chain Block -> Chain Block -> [Block]
extensionFragment Chain Block
common Chain Block
r
      , [Block]
exr' <- (Block -> [Block]) -> [Block] -> [[Block]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([Block] -> Block -> [Block]
forall a b. a -> b -> a
const []) [Block]
exr
      , let r' :: Chain Block
r' = (Anchor Block -> Block -> Block) -> [Block] -> Chain Block
forall b. HasFullHeader b => (Anchor b -> b -> b) -> [b] -> Chain b
fixupChain Anchor Block -> Block -> Block
forall block.
(HeaderHash block ~ HeaderHash BlockHeader) =>
Anchor block -> Block -> Block
fixupBlock ([Block]
exr' [Block] -> [Block] -> [Block]
forall a. [a] -> [a] -> [a]
++ Chain Block -> [Block]
forall block. Chain block -> [block]
Chain.toNewestFirst Chain Block
common)
      , Chain Block -> Chain Block -> Bool
isLongestCommonPrefix Chain Block
l Chain Block
r'
      ]
    where
      extensionFragment :: Chain Block -> Chain Block -> [Block]
      extensionFragment :: Chain Block -> Chain Block -> [Block]
extensionFragment Chain Block
c = [Block] -> [Block]
forall a. [a] -> [a]
reverse ([Block] -> [Block])
-> (Chain Block -> [Block]) -> Chain Block -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Block] -> [Block]
forall a. Int -> [a] -> [a]
L.drop (Chain Block -> Int
forall block. Chain block -> Int
Chain.length Chain Block
c) ([Block] -> [Block])
-> (Chain Block -> [Block]) -> Chain Block -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain Block -> [Block]
forall block. Chain block -> [block]
Chain.toOldestFirst

      -- Need to make sure that when we shrink that we don't make the longest
      -- common prefix be a strict extension of the original common prefix.
      isLongestCommonPrefix :: Chain Block -> Chain Block -> Bool
isLongestCommonPrefix Chain Block
l' Chain Block
r' =
        case (Int -> [Block] -> [Block]
forall a. Int -> [a] -> [a]
L.drop (Chain Block -> Int
forall block. Chain block -> Int
Chain.length Chain Block
common) (Chain Block -> [Block]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain Block
l'),
              Int -> [Block] -> [Block]
forall a. Int -> [a] -> [a]
L.drop (Chain Block -> Int
forall block. Chain block -> Int
Chain.length Chain Block
common) (Chain Block -> [Block]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain Block
r')) of
          (Block
lhead : [Block]
_, Block
rhead : [Block]
_) -> Block
lhead Block -> Block -> Bool
forall a. Eq a => a -> a -> Bool
/= Block
rhead
          ([Block], [Block])
_                      -> Bool
True


prop_arbitrary_TestChainFork :: TestChainFork -> Bool
prop_arbitrary_TestChainFork :: TestChainFork -> Bool
prop_arbitrary_TestChainFork (TestChainFork Chain Block
c Chain Block
l Chain Block
r) =
    Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain Block
c Bool -> Bool -> Bool
&& Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain Block
l Bool -> Bool -> Bool
&& Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain Block
r
 Bool -> Bool -> Bool
&& Chain Block
c Chain Block -> Chain Block -> Bool
forall block. Eq block => Chain block -> Chain block -> Bool
`Chain.isPrefixOf` Chain Block
l
 Bool -> Bool -> Bool
&& Chain Block
c Chain Block -> Chain Block -> Bool
forall block. Eq block => Chain block -> Chain block -> Bool
`Chain.isPrefixOf` Chain Block
r
    -- And c is not just a common prefix, but the maximum common prefix
 Bool -> Bool -> Bool
&& case (Int -> [Block] -> [Block]
forall a. Int -> [a] -> [a]
L.drop (Chain Block -> Int
forall block. Chain block -> Int
Chain.length Chain Block
c) (Chain Block -> [Block]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain Block
l),
          Int -> [Block] -> [Block]
forall a. Int -> [a] -> [a]
L.drop (Chain Block -> Int
forall block. Chain block -> Int
Chain.length Chain Block
c) (Chain Block -> [Block]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain Block
r)) of
      (Block
lhead : [Block]
_, Block
rhead : [Block]
_) -> Block
lhead Block -> Block -> Bool
forall a. Eq a => a -> a -> Bool
/= Block
rhead
      ([Block], [Block])
_                      -> Bool
True


prop_shrink_TestChainFork :: TestChainFork -> Bool
prop_shrink_TestChainFork :: TestChainFork -> Bool
prop_shrink_TestChainFork TestChainFork
forks =
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [    TestChainFork -> Bool
prop_arbitrary_TestChainFork TestChainFork
forks'
        Bool -> Bool -> Bool
&& TestChainFork -> Int
measure TestChainFork
forks' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
mforks
      | let mforks :: Int
mforks = TestChainFork -> Int
measure TestChainFork
forks
      , TestChainFork
forks' <- TestChainFork -> [TestChainFork]
forall a. Arbitrary a => a -> [a]
shrink TestChainFork
forks ]
  where
    measure :: TestChainFork -> Int
measure (TestChainFork Chain Block
c Chain Block
l Chain Block
r) = Chain Block -> Int
forall block. Chain block -> Int
Chain.length Chain Block
c
                                  Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Chain Block -> Int
forall block. Chain block -> Int
Chain.length Chain Block
l
                                  Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Chain Block -> Int
forall block. Chain block -> Int
Chain.length Chain Block
r