{-# LANGUAGE DataKinds      #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies   #-}
{-# LANGUAGE TypeOperators  #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module Test.ChainProducerState
  ( ChainProducerStateTest (..)
  , ChainProducerStateForkTest (..)
  , tests
  ) where

import Data.List (unfoldr)
import Data.Map qualified as Map

import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck

import Ouroboros.Network.Block (HasHeader, genesisPoint, pointSlot)
import Ouroboros.Network.Mock.Chain (Chain, ChainUpdate (..), Point (..),
           headPoint, pointOnChain)
import Ouroboros.Network.Mock.Chain qualified as Chain
import Ouroboros.Network.Mock.ConcreteBlock (Block)
import Ouroboros.Network.Mock.ProducerState

import Test.ChainGenerators (TestBlockChain (..), TestBlockChainAndUpdates (..),
           TestChainFork (..), mkRollbackPoint)

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup TestName
"ChainProducerState"
  [ TestName -> [TestTree] -> TestTree
testGroup TestName
"Test Arbitrary instances"
    [ TestName -> (ChainProducerStateForkTest -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"ChainProducerStateForkTest's generator"
                   ChainProducerStateForkTest -> Bool
prop_arbitrary_ChainProducerStateForkTest
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"ChainProducerStateForkTest's shrinker"
                   (Int -> (ChainProducerStateForkTest -> Bool) -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
25 ChainProducerStateForkTest -> Bool
prop_shrink_ChainProducerStateForkTest)
    ]
  , TestName -> (ChainProducerStateTest -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"check initial follower state" ChainProducerStateTest -> Bool
prop_init_lookup
  , TestName -> (ChainProducerStateTest -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"check second follower state"  ChainProducerStateTest -> Bool
prop_init_next_lookup
  , TestName -> (ChainProducerStateTest -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"check follower state after updateFollower" ChainProducerStateTest -> Bool
prop_update_lookup
  , TestName -> (ChainProducerStateTest -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"check follower state after updateFollower2" ChainProducerStateTest -> Bool
prop_update_next_lookup
  , TestName -> (TestBlockChainAndUpdates -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"producer syncronise (1)" TestBlockChainAndUpdates -> Bool
prop_producer_sync1
  , TestName
-> (TestBlockChainAndUpdates -> [Bool] -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"producer syncronise (2)" TestBlockChainAndUpdates -> [Bool] -> Bool
prop_producer_sync2
  , TestName -> (ChainProducerStateForkTest -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"switch fork" ChainProducerStateForkTest -> Bool
prop_switchFork
  ]

--
-- Properties
--

-- | Check that followers start in the expected state, at the right point and
-- in the rollback state.
--
prop_init_lookup :: ChainProducerStateTest -> Bool
prop_init_lookup :: ChainProducerStateTest -> Bool
prop_init_lookup (ChainProducerStateTest ChainProducerState Block
c Int
_ Point Block
p) =
    let (ChainProducerState Block
c', Int
rid) = Point Block
-> ChainProducerState Block -> (ChainProducerState Block, Int)
forall block.
HasHeader block =>
Point block
-> ChainProducerState block -> (ChainProducerState block, Int)
initFollower Point Block
p ChainProducerState Block
c in
    ChainProducerState Block -> Int -> FollowerState Block
forall block.
ChainProducerState block -> Int -> FollowerState block
lookupFollower ChainProducerState Block
c' Int
rid FollowerState Block -> FollowerState Block -> Bool
forall a. Eq a => a -> a -> Bool
== Point Block -> FollowerNext -> FollowerState Block
forall block. Point block -> FollowerNext -> FollowerState block
FollowerState Point Block
p FollowerNext
FollowerBackTo

-- | As above but check that when we move the follower on by one, from the
-- rollback state, they stay at the same point but are now in the forward state.
--
prop_init_next_lookup :: ChainProducerStateTest -> Bool
prop_init_next_lookup :: ChainProducerStateTest -> Bool
prop_init_next_lookup (ChainProducerStateTest ChainProducerState Block
c Int
_ Point Block
p) =
    let (ChainProducerState Block
c', Int
rid)     = Point Block
-> ChainProducerState Block -> (ChainProducerState Block, Int)
forall block.
HasHeader block =>
Point block
-> ChainProducerState block -> (ChainProducerState block, Int)
initFollower Point Block
p ChainProducerState Block
c
        Just (ChainUpdate Block Block
u, ChainProducerState Block
c'') = Int
-> ChainProducerState Block
-> Maybe (ChainUpdate Block Block, ChainProducerState Block)
forall block.
HasHeader block =>
Int
-> ChainProducerState block
-> Maybe (ChainUpdate block block, ChainProducerState block)
followerInstruction Int
rid ChainProducerState Block
c'
    in ChainUpdate Block Block
u ChainUpdate Block Block -> ChainUpdate Block Block -> Bool
forall a. Eq a => a -> a -> Bool
== Point Block -> ChainUpdate Block Block
forall {k} (block :: k) a. Point block -> ChainUpdate block a
RollBack Point Block
p
    Bool -> Bool -> Bool
&& ChainProducerState Block -> Int -> FollowerState Block
forall block.
ChainProducerState block -> Int -> FollowerState block
lookupFollower ChainProducerState Block
c'' Int
rid FollowerState Block -> FollowerState Block -> Bool
forall a. Eq a => a -> a -> Bool
== Point Block -> FollowerNext -> FollowerState Block
forall block. Point block -> FollowerNext -> FollowerState block
FollowerState Point Block
p FollowerNext
FollowerForwardFrom

-- | Check that after moving the follower point that the follower is in the
-- expected state, at the right point and in the rollback state.
--
prop_update_lookup :: ChainProducerStateTest -> Bool
prop_update_lookup :: ChainProducerStateTest -> Bool
prop_update_lookup (ChainProducerStateTest ChainProducerState Block
c Int
rid Point Block
p) =
    let c' :: ChainProducerState Block
c' = Int
-> Point Block
-> ChainProducerState Block
-> ChainProducerState Block
forall block.
HasHeader block =>
Int
-> Point block
-> ChainProducerState block
-> ChainProducerState block
updateFollower Int
rid Point Block
p ChainProducerState Block
c in
    ChainProducerState Block -> Int -> FollowerState Block
forall block.
ChainProducerState block -> Int -> FollowerState block
lookupFollower ChainProducerState Block
c' Int
rid FollowerState Block -> FollowerState Block -> Bool
forall a. Eq a => a -> a -> Bool
== Point Block -> FollowerNext -> FollowerState Block
forall block. Point block -> FollowerNext -> FollowerState block
FollowerState Point Block
p FollowerNext
FollowerBackTo

-- | As above but check that when we move the follower on by one, from the
-- rollback state, they stay at the same point but are now in the forward state.
--
prop_update_next_lookup :: ChainProducerStateTest -> Bool
prop_update_next_lookup :: ChainProducerStateTest -> Bool
prop_update_next_lookup (ChainProducerStateTest ChainProducerState Block
c Int
rid Point Block
p) =
    let c' :: ChainProducerState Block
c'            = Int
-> Point Block
-> ChainProducerState Block
-> ChainProducerState Block
forall block.
HasHeader block =>
Int
-> Point block
-> ChainProducerState block
-> ChainProducerState block
updateFollower Int
rid Point Block
p ChainProducerState Block
c
        Just (ChainUpdate Block Block
u, ChainProducerState Block
c'') = Int
-> ChainProducerState Block
-> Maybe (ChainUpdate Block Block, ChainProducerState Block)
forall block.
HasHeader block =>
Int
-> ChainProducerState block
-> Maybe (ChainUpdate block block, ChainProducerState block)
followerInstruction Int
rid ChainProducerState Block
c'
    in ChainUpdate Block Block
u ChainUpdate Block Block -> ChainUpdate Block Block -> Bool
forall a. Eq a => a -> a -> Bool
== Point Block -> ChainUpdate Block Block
forall {k} (block :: k) a. Point block -> ChainUpdate block a
RollBack Point Block
p
    Bool -> Bool -> Bool
&& ChainProducerState Block -> Int -> FollowerState Block
forall block.
ChainProducerState block -> Int -> FollowerState block
lookupFollower ChainProducerState Block
c'' Int
rid FollowerState Block -> FollowerState Block -> Bool
forall a. Eq a => a -> a -> Bool
== Point Block -> FollowerNext -> FollowerState Block
forall block. Point block -> FollowerNext -> FollowerState block
FollowerState Point Block
p FollowerNext
FollowerForwardFrom

-- | This says that if we take a chain producer and apply a bunch of updates
-- and initialise a consumer to the producer's initial chain, then by
-- applying update instructions from the producer to the consumer then the
-- consumer ends up in the same final state.
--
-- The limitation of this test is that it applies all the updates to the
-- producer first and then syncronises without changing the producer.
--
prop_producer_sync1 :: TestBlockChainAndUpdates -> Bool
prop_producer_sync1 :: TestBlockChainAndUpdates -> Bool
prop_producer_sync1 (TestBlockChainAndUpdates Chain Block
c [ChainUpdate Block Block]
us) =
    let producer0 :: ChainProducerState Block
producer0        = Chain Block -> ChainProducerState Block
forall block. Chain block -> ChainProducerState block
initChainProducerState Chain Block
c
        (ChainProducerState Block
producer1, Int
rid) = Point Block
-> ChainProducerState Block -> (ChainProducerState Block, Int)
forall block.
HasHeader block =>
Point block
-> ChainProducerState block -> (ChainProducerState block, Int)
initFollower (Chain Block -> Point Block
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint Chain Block
c) ChainProducerState Block
producer0
        Just ChainProducerState Block
producer    = [ChainUpdate Block Block]
-> ChainProducerState Block -> Maybe (ChainProducerState Block)
forall block block'.
(HasHeader block, HeaderHash block ~ HeaderHash block') =>
[ChainUpdate block' block]
-> ChainProducerState block -> Maybe (ChainProducerState block)
applyChainUpdates [ChainUpdate Block Block]
us ChainProducerState Block
producer1

        consumer0 :: Chain Block
consumer0        = Chain Block
c
        consumerUpdates :: [ChainUpdate Block Block]
consumerUpdates  = Int -> ChainProducerState Block -> [ChainUpdate Block Block]
forall {block}.
HasHeader block =>
Int -> ChainProducerState block -> [ChainUpdate block block]
iterateFollowerUntilDone Int
rid ChainProducerState Block
producer
        Just Chain Block
consumer    = [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]
consumerUpdates Chain Block
consumer0
     in
        Chain Block
consumer Chain Block -> Chain Block -> Bool
forall a. Eq a => a -> a -> Bool
== ChainProducerState Block -> Chain Block
forall block. ChainProducerState block -> Chain block
producerChain ChainProducerState Block
producer
  where
    iterateFollowerUntilDone :: Int -> ChainProducerState block -> [ChainUpdate block block]
iterateFollowerUntilDone Int
rid = (ChainProducerState block
 -> Maybe (ChainUpdate block block, ChainProducerState block))
-> ChainProducerState block -> [ChainUpdate block block]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (Int
-> ChainProducerState block
-> Maybe (ChainUpdate block block, ChainProducerState block)
forall block.
HasHeader block =>
Int
-> ChainProducerState block
-> Maybe (ChainUpdate block block, ChainProducerState block)
followerInstruction Int
rid)

-- | A variation on 'prop_producer_sync1' where we take an arbitrary
-- interleaving of applying changes to the producer and doing syncronisation
-- steps between the producer and consumer.
--
prop_producer_sync2 :: TestBlockChainAndUpdates -> [Bool] -> Bool
prop_producer_sync2 :: TestBlockChainAndUpdates -> [Bool] -> Bool
prop_producer_sync2 (TestBlockChainAndUpdates Chain Block
chain0 [ChainUpdate Block Block]
us0) [Bool]
choices =
    let producer0 :: ChainProducerState Block
producer0        = Chain Block -> ChainProducerState Block
forall block. Chain block -> ChainProducerState block
initChainProducerState Chain Block
chain0
        (ChainProducerState Block
producer1, Int
rid) = Point Block
-> ChainProducerState Block -> (ChainProducerState Block, Int)
forall block.
HasHeader block =>
Point block
-> ChainProducerState block -> (ChainProducerState block, Int)
initFollower (Chain Block -> Point Block
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint Chain Block
chain0) ChainProducerState Block
producer0

        consumer0 :: Chain Block
consumer0        = Chain Block
chain0
        (ChainProducerState Block
producer,
         Chain Block
consumer)       = Int
-> ChainProducerState Block
-> Chain Block
-> [Bool]
-> [ChainUpdate Block Block]
-> (ChainProducerState Block, Chain Block)
go Int
rid ChainProducerState Block
producer1 Chain Block
consumer0 [Bool]
choices [ChainUpdate Block Block]
us0
     in Chain Block
consumer Chain Block -> Chain Block -> Bool
forall a. Eq a => a -> a -> Bool
== ChainProducerState Block -> Chain Block
forall block. ChainProducerState block -> Chain block
producerChain ChainProducerState Block
producer
  where
    -- apply update to producer
    go :: Int
       -> ChainProducerState Block
       -> Chain Block
       -> [Bool]
       -> [ChainUpdate Block Block]
       -> (ChainProducerState Block, Chain Block)
    go :: Int
-> ChainProducerState Block
-> Chain Block
-> [Bool]
-> [ChainUpdate Block Block]
-> (ChainProducerState Block, Chain Block)
go Int
rid ChainProducerState Block
p Chain Block
c (Bool
False:[Bool]
bs) (ChainUpdate Block Block
u:[ChainUpdate Block Block]
us) =
      let Just ChainProducerState Block
p' = ChainUpdate Block Block
-> ChainProducerState Block -> Maybe (ChainProducerState Block)
forall block block'.
(HasHeader block, HeaderHash block ~ HeaderHash block') =>
ChainUpdate block' block
-> ChainProducerState block -> Maybe (ChainProducerState block)
applyChainUpdate ChainUpdate Block Block
u ChainProducerState Block
p
       in Int
-> ChainProducerState Block
-> Chain Block
-> [Bool]
-> [ChainUpdate Block Block]
-> (ChainProducerState Block, Chain Block)
go Int
rid ChainProducerState Block
p' Chain Block
c [Bool]
bs [ChainUpdate Block Block]
us

    -- all producer updates are done
    go Int
rid ChainProducerState Block
p Chain Block
c (Bool
False:[Bool]
_bs) [] = Int
-> ChainProducerState Block
-> Chain Block
-> [Bool]
-> [ChainUpdate Block Block]
-> (ChainProducerState Block, Chain Block)
go Int
rid ChainProducerState Block
p Chain Block
c [] []

    -- apply update to consumer
    go Int
rid ChainProducerState Block
p Chain Block
c (Bool
True:[Bool]
bs) [ChainUpdate Block Block]
us =
      case Int
-> ChainProducerState Block
-> Maybe (ChainUpdate Block Block, ChainProducerState Block)
forall block.
HasHeader block =>
Int
-> ChainProducerState block
-> Maybe (ChainUpdate block block, ChainProducerState block)
followerInstruction Int
rid ChainProducerState Block
p of
        Maybe (ChainUpdate Block Block, ChainProducerState Block)
Nothing      -> Int
-> ChainProducerState Block
-> Chain Block
-> [Bool]
-> [ChainUpdate Block Block]
-> (ChainProducerState Block, Chain Block)
go Int
rid ChainProducerState Block
p  Chain Block
c  [Bool]
bs [ChainUpdate Block Block]
us
        Just (ChainUpdate Block Block
u, ChainProducerState Block
p') -> Int
-> ChainProducerState Block
-> Chain Block
-> [Bool]
-> [ChainUpdate Block Block]
-> (ChainProducerState Block, Chain Block)
go Int
rid ChainProducerState Block
p' Chain Block
c' [Bool]
bs [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

    -- producer is not changing, just run consumer
    go Int
rid ChainProducerState Block
p Chain Block
c [] [ChainUpdate Block Block]
_ =
      case Int
-> ChainProducerState Block
-> Maybe (ChainUpdate Block Block, ChainProducerState Block)
forall block.
HasHeader block =>
Int
-> ChainProducerState block
-> Maybe (ChainUpdate block block, ChainProducerState block)
followerInstruction Int
rid ChainProducerState Block
p of
        Maybe (ChainUpdate Block Block, ChainProducerState Block)
Nothing      -> (ChainProducerState Block
p, Chain Block
c)
        Just (ChainUpdate Block Block
u, ChainProducerState Block
p') -> Int
-> ChainProducerState Block
-> Chain Block
-> [Bool]
-> [ChainUpdate Block Block]
-> (ChainProducerState Block, Chain Block)
go Int
rid ChainProducerState Block
p' Chain Block
c' [] []
          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

prop_switchFork :: ChainProducerStateForkTest -> Bool
prop_switchFork :: ChainProducerStateForkTest -> Bool
prop_switchFork (ChainProducerStateForkTest ChainProducerState Block
cps Chain Block
f) =
  let cps' :: ChainProducerState Block
cps' = Chain Block -> ChainProducerState Block -> ChainProducerState Block
forall block.
HasHeader block =>
Chain block -> ChainProducerState block -> ChainProducerState block
switchFork Chain Block
f ChainProducerState Block
cps
  in
      ChainProducerState Block -> Bool
forall block.
HasFullHeader block =>
ChainProducerState block -> Bool
invChainProducerState ChainProducerState Block
cps'
      Bool -> Bool -> Bool
&& ((FollowerState Block, FollowerState Block) -> Bool)
-> [(FollowerState Block, FollowerState Block)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
        ((FollowerState Block -> FollowerState Block -> Bool)
-> (FollowerState Block, FollowerState Block) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FollowerState Block -> FollowerState Block -> Bool
forall block.
HasHeader block =>
FollowerState block -> FollowerState block -> Bool
followerInv)
        ([FollowerState Block]
-> [FollowerState Block]
-> [(FollowerState Block, FollowerState Block)]
forall a b. [a] -> [b] -> [(a, b)]
zip (ChainProducerState Block -> [FollowerState Block]
forall block. ChainProducerState block -> [FollowerState block]
followerStates ChainProducerState Block
cps) (ChainProducerState Block -> [FollowerState Block]
forall block. ChainProducerState block -> [FollowerState block]
followerStates ChainProducerState Block
cps'))
  where
    followerInv :: HasHeader block
                => FollowerState block -> FollowerState block -> Bool
    followerInv :: forall block.
HasHeader block =>
FollowerState block -> FollowerState block -> Bool
followerInv FollowerState block
fs FollowerState block
fs'
      -- points only move backward
       = Point block -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (FollowerState block -> Point block
forall block. FollowerState block -> Point block
followerPoint FollowerState block
fs') 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 (FollowerState block -> Point block
forall block. FollowerState block -> Point block
followerPoint FollowerState block
fs)
      -- if follower's point moves back, `followerNext` is changed to `FollowerBackTo`
      Bool -> Bool -> Bool
&& ((Point block -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (FollowerState block -> Point block
forall block. FollowerState block -> Point block
followerPoint FollowerState block
fs') 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 (FollowerState block -> Point block
forall block. FollowerState block -> Point block
followerPoint FollowerState block
fs)) Bool -> Bool -> Bool
`implies` (FollowerState block -> FollowerNext
forall block. FollowerState block -> FollowerNext
followerNext FollowerState block
fs' FollowerNext -> FollowerNext -> Bool
forall a. Eq a => a -> a -> Bool
== FollowerNext
FollowerBackTo))
      -- if follower's point is not changed, also next instruction is not changed
      Bool -> Bool -> Bool
&& ((FollowerState block -> Point block
forall block. FollowerState block -> Point block
followerPoint FollowerState block
fs' Point block -> Point block -> Bool
forall a. Eq a => a -> a -> Bool
== FollowerState block -> Point block
forall block. FollowerState block -> Point block
followerPoint FollowerState block
fs) Bool -> Bool -> Bool
`implies` (FollowerState block -> FollowerNext
forall block. FollowerState block -> FollowerNext
followerNext FollowerState block
fs' FollowerNext -> FollowerNext -> Bool
forall a. Eq a => a -> a -> Bool
== FollowerState block -> FollowerNext
forall block. FollowerState block -> FollowerNext
followerNext FollowerState block
fs))

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

    followerStates :: ChainProducerState block -> [FollowerState block]
    followerStates :: forall block. ChainProducerState block -> [FollowerState block]
followerStates = ((Int, FollowerState block) -> FollowerState block)
-> [(Int, FollowerState block)] -> [FollowerState block]
forall a b. (a -> b) -> [a] -> [b]
map (Int, FollowerState block) -> FollowerState block
forall a b. (a, b) -> b
snd ([(Int, FollowerState block)] -> [FollowerState block])
-> (ChainProducerState block -> [(Int, FollowerState block)])
-> ChainProducerState block
-> [FollowerState block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int (FollowerState block) -> [(Int, FollowerState block)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map Int (FollowerState block) -> [(Int, FollowerState block)])
-> (ChainProducerState block -> Map Int (FollowerState block))
-> ChainProducerState block
-> [(Int, FollowerState block)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainProducerState block -> Map Int (FollowerState block)
forall block. ChainProducerState block -> FollowerStates block
chainFollowers

--
-- Generators
--

data ChainProducerStateTest
    = ChainProducerStateTest
        (ChainProducerState Block) -- ^ producer state with a single follower
        FollowerId                 -- ^ follower's id
        (Point Block)              -- ^ intersection point of the follower
  deriving Int -> ChainProducerStateTest -> ShowS
[ChainProducerStateTest] -> ShowS
ChainProducerStateTest -> TestName
(Int -> ChainProducerStateTest -> ShowS)
-> (ChainProducerStateTest -> TestName)
-> ([ChainProducerStateTest] -> ShowS)
-> Show ChainProducerStateTest
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainProducerStateTest -> ShowS
showsPrec :: Int -> ChainProducerStateTest -> ShowS
$cshow :: ChainProducerStateTest -> TestName
show :: ChainProducerStateTest -> TestName
$cshowList :: [ChainProducerStateTest] -> ShowS
showList :: [ChainProducerStateTest] -> ShowS
Show

genFollowerState :: Int   -- ^ length of the chain
                 -> Chain Block
                 -> Gen (FollowerState Block)
genFollowerState :: Int -> Chain Block -> Gen (FollowerState Block)
genFollowerState Int
n Chain Block
c = do
    followerPoint <- [(Int, Gen (Point Block))] -> Gen (Point Block)
forall a. [(Int, Gen a)] -> Gen a
frequency
      [ (Int
2, 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
headPoint Chain Block
c))
      , (Int
2, 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
c Int
n))
      , (Int
8, Chain Block -> Int -> Point Block
forall block. HasHeader block => Chain block -> Int -> Point block
mkRollbackPoint Chain Block
c (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 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
      ]
    followerNext <- oneof
      [ return FollowerForwardFrom
      , return FollowerBackTo
      ]
    return $ FollowerState{followerPoint, followerNext}

instance Arbitrary ChainProducerStateTest where
  arbitrary :: Gen ChainProducerStateTest
arbitrary = do
    TestBlockChain c <- Gen TestBlockChain
forall a. Arbitrary a => Gen a
arbitrary
    let n = Chain Block -> Int
forall block. Chain block -> Int
Chain.length Chain Block
c
    rs <- Map.fromList . zip [0..] <$> listOf1 (genFollowerState n c)
    rid <- choose (0, length rs - 1)
    p <- if n == 0
         then return genesisPoint
         else mkRollbackPoint c <$> choose (0, n)
    return (ChainProducerStateTest (ChainProducerState c rs (length rs)) rid p)

data ChainProducerStateForkTest
    = ChainProducerStateForkTest
        (ChainProducerState Block) -- ^ chain producer state
        (Chain Block)              -- ^ fork of the producer's chain
  deriving Int -> ChainProducerStateForkTest -> ShowS
[ChainProducerStateForkTest] -> ShowS
ChainProducerStateForkTest -> TestName
(Int -> ChainProducerStateForkTest -> ShowS)
-> (ChainProducerStateForkTest -> TestName)
-> ([ChainProducerStateForkTest] -> ShowS)
-> Show ChainProducerStateForkTest
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainProducerStateForkTest -> ShowS
showsPrec :: Int -> ChainProducerStateForkTest -> ShowS
$cshow :: ChainProducerStateForkTest -> TestName
show :: ChainProducerStateForkTest -> TestName
$cshowList :: [ChainProducerStateForkTest] -> ShowS
showList :: [ChainProducerStateForkTest] -> ShowS
Show

instance Arbitrary ChainProducerStateForkTest where
  arbitrary :: Gen ChainProducerStateForkTest
arbitrary = do
    TestChainFork _ c f <- Gen TestChainFork
forall a. Arbitrary a => Gen a
arbitrary
    let l = Chain Block -> Int
forall block. Chain block -> Int
Chain.length Chain Block
c
    rs <- Map.fromList . zip [0..] <$> listOf (genFollowerState l c)
    return $ ChainProducerStateForkTest (ChainProducerState c rs (length rs)) f

  shrink :: ChainProducerStateForkTest -> [ChainProducerStateForkTest]
shrink (ChainProducerStateForkTest (ChainProducerState Chain Block
c Map Int (FollowerState Block)
rs Int
nr) Chain Block
f)
    -- shrink followers
     = [ ChainProducerState Block
-> Chain Block -> ChainProducerStateForkTest
ChainProducerStateForkTest (Chain Block
-> Map Int (FollowerState Block) -> Int -> ChainProducerState Block
forall block.
Chain block
-> FollowerStates block -> Int -> ChainProducerState block
ChainProducerState Chain Block
c Map Int (FollowerState Block)
rs' Int
nr) Chain Block
f
       | Map Int (FollowerState Block)
rs' <- ([(Int, FollowerState Block)] -> Map Int (FollowerState Block))
-> [[(Int, FollowerState Block)]]
-> [Map Int (FollowerState Block)]
forall a b. (a -> b) -> [a] -> [b]
map [(Int, FollowerState Block)] -> Map Int (FollowerState Block)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([[(Int, FollowerState Block)]] -> [Map Int (FollowerState Block)])
-> (Map Int (FollowerState Block)
    -> [[(Int, FollowerState Block)]])
-> Map Int (FollowerState Block)
-> [Map Int (FollowerState Block)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, FollowerState Block) -> [(Int, FollowerState Block)])
-> [(Int, FollowerState Block)] -> [[(Int, FollowerState Block)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([(Int, FollowerState Block)]
-> (Int, FollowerState Block) -> [(Int, FollowerState Block)]
forall a b. a -> b -> a
const []) ([(Int, FollowerState Block)] -> [[(Int, FollowerState Block)]])
-> (Map Int (FollowerState Block) -> [(Int, FollowerState Block)])
-> Map Int (FollowerState Block)
-> [[(Int, FollowerState Block)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int (FollowerState Block) -> [(Int, FollowerState Block)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Int (FollowerState Block) -> [Map Int (FollowerState Block)])
-> Map Int (FollowerState Block) -> [Map Int (FollowerState Block)]
forall a b. (a -> b) -> a -> b
$ Map Int (FollowerState Block)
rs
       ]
    -- shrink the fork chain
    [ChainProducerStateForkTest]
-> [ChainProducerStateForkTest] -> [ChainProducerStateForkTest]
forall a. [a] -> [a] -> [a]
++ [ ChainProducerState Block
-> Chain Block -> ChainProducerStateForkTest
ChainProducerStateForkTest (Chain Block
-> Map Int (FollowerState Block) -> Int -> ChainProducerState Block
forall block.
Chain block
-> FollowerStates block -> Int -> ChainProducerState block
ChainProducerState Chain Block
c Map Int (FollowerState Block)
rs Int
nr) Chain Block
f'
       | TestBlockChain Chain Block
f' <- TestBlockChain -> [TestBlockChain]
forall a. Arbitrary a => a -> [a]
shrink (Chain Block -> TestBlockChain
TestBlockChain Chain Block
f)
       ]
    -- shrink chain and fix up followers
    [ChainProducerStateForkTest]
-> [ChainProducerStateForkTest] -> [ChainProducerStateForkTest]
forall a. [a] -> [a] -> [a]
++ [ ChainProducerState Block
-> Chain Block -> ChainProducerStateForkTest
ChainProducerStateForkTest (Chain Block
-> Map Int (FollowerState Block) -> Int -> ChainProducerState Block
forall block.
Chain block
-> FollowerStates block -> Int -> ChainProducerState block
ChainProducerState Chain Block
c' (Chain Block -> FollowerState Block -> FollowerState Block
fixupFollowerPointer Chain Block
c' (FollowerState Block -> FollowerState Block)
-> Map Int (FollowerState Block) -> Map Int (FollowerState Block)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Int (FollowerState Block)
rs) Int
nr) Chain Block
f
       | TestBlockChain Chain Block
c' <- TestBlockChain -> [TestBlockChain]
forall a. Arbitrary a => a -> [a]
shrink (Chain Block -> TestBlockChain
TestBlockChain Chain Block
c)
       ]
    where
      fixupFollowerPointer :: Chain Block -> FollowerState Block -> FollowerState Block
      fixupFollowerPointer :: Chain Block -> FollowerState Block -> FollowerState Block
fixupFollowerPointer Chain Block
c' fs :: FollowerState Block
fs@FollowerState{Point Block
followerPoint :: forall block. FollowerState block -> Point block
followerPoint :: Point Block
followerPoint} =
        if Point Block -> Chain Block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
pointOnChain Point Block
followerPoint Chain Block
c'
          then FollowerState Block
fs
          else FollowerState Block
fs { followerPoint = headPoint c' }

prop_arbitrary_ChainProducerStateForkTest :: ChainProducerStateForkTest -> Bool
prop_arbitrary_ChainProducerStateForkTest :: ChainProducerStateForkTest -> Bool
prop_arbitrary_ChainProducerStateForkTest (ChainProducerStateForkTest ChainProducerState Block
c Chain Block
f) =
    ChainProducerState Block -> Bool
forall block.
HasFullHeader block =>
ChainProducerState block -> Bool
invChainProducerState ChainProducerState Block
c Bool -> Bool -> Bool
&& Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain Block
f

prop_shrink_ChainProducerStateForkTest :: ChainProducerStateForkTest -> Bool
prop_shrink_ChainProducerStateForkTest :: ChainProducerStateForkTest -> Bool
prop_shrink_ChainProducerStateForkTest ChainProducerStateForkTest
c =
    [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ ChainProducerState Block -> Bool
forall block.
HasFullHeader block =>
ChainProducerState block -> Bool
invChainProducerState ChainProducerState Block
c' Bool -> Bool -> Bool
&& Chain Block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
Chain.valid Chain Block
f
        | ChainProducerStateForkTest ChainProducerState Block
c' Chain Block
f <- ChainProducerStateForkTest -> [ChainProducerStateForkTest]
forall a. Arbitrary a => a -> [a]
shrink ChainProducerStateForkTest
c
        ]