{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}

-- | Generate sequences of updates to model an evolving chain
module Test.Util.ChainUpdates (
    ChainUpdate (..)
  , UpdateBehavior (..)
  , genChainUpdates
  , toChainUpdates
    -- * Tests
  , prop_genChainUpdates
  ) where

import           Control.Monad (replicateM, replicateM_)
import           Control.Monad.State.Strict (MonadTrans, execStateT, get, lift,
                     modify)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Util.Condense (Condense (..))
import           Ouroboros.Network.Mock.Chain (Chain (Genesis))
import qualified Ouroboros.Network.Mock.Chain as Chain
import           Test.QuickCheck
import           Test.Util.TestBlock

data ChainUpdate =
    AddBlock TestBlock
    -- | Roll back to the given 'Point', and then /immediately/ roll
    -- forward by the given 'TestBlock's.
  | SwitchFork (Point TestBlock) [TestBlock]
  deriving stock (ChainUpdate -> ChainUpdate -> Bool
(ChainUpdate -> ChainUpdate -> Bool)
-> (ChainUpdate -> ChainUpdate -> Bool) -> Eq ChainUpdate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainUpdate -> ChainUpdate -> Bool
== :: ChainUpdate -> ChainUpdate -> Bool
$c/= :: ChainUpdate -> ChainUpdate -> Bool
/= :: ChainUpdate -> ChainUpdate -> Bool
Eq, Int -> ChainUpdate -> ShowS
[ChainUpdate] -> ShowS
ChainUpdate -> String
(Int -> ChainUpdate -> ShowS)
-> (ChainUpdate -> String)
-> ([ChainUpdate] -> ShowS)
-> Show ChainUpdate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainUpdate -> ShowS
showsPrec :: Int -> ChainUpdate -> ShowS
$cshow :: ChainUpdate -> String
show :: ChainUpdate -> String
$cshowList :: [ChainUpdate] -> ShowS
showList :: [ChainUpdate] -> ShowS
Show)

instance Condense ChainUpdate where
  condense :: ChainUpdate -> String
condense = \case
    AddBlock TestBlock
b -> String
"AddBlock " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TestBlock -> String
forall a. Condense a => a -> String
condense TestBlock
b
    SwitchFork Point TestBlock
p [TestBlock]
bs -> String
"SwitchFork <- " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Point TestBlock -> String
forall a. Condense a => a -> String
condense Point TestBlock
p String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" -> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
      [String] -> String
unwords ((TestBlock -> String) -> [TestBlock] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock -> String
forall a. Condense a => a -> String
condense [TestBlock]
bs)

toChainUpdates :: [ChainUpdate] -> [Chain.ChainUpdate TestBlock TestBlock]
toChainUpdates :: [ChainUpdate] -> [ChainUpdate TestBlock TestBlock]
toChainUpdates = (ChainUpdate -> [ChainUpdate TestBlock TestBlock])
-> [ChainUpdate] -> [ChainUpdate TestBlock TestBlock]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((ChainUpdate -> [ChainUpdate TestBlock TestBlock])
 -> [ChainUpdate] -> [ChainUpdate TestBlock TestBlock])
-> (ChainUpdate -> [ChainUpdate TestBlock TestBlock])
-> [ChainUpdate]
-> [ChainUpdate TestBlock TestBlock]
forall a b. (a -> b) -> a -> b
$ \case
    SwitchFork Point TestBlock
pt [TestBlock]
bs -> Point TestBlock -> ChainUpdate TestBlock TestBlock
forall {k} (block :: k) a. Point block -> ChainUpdate block a
Chain.RollBack Point TestBlock
pt ChainUpdate TestBlock TestBlock
-> [ChainUpdate TestBlock TestBlock]
-> [ChainUpdate TestBlock TestBlock]
forall a. a -> [a] -> [a]
: (TestBlock -> ChainUpdate TestBlock TestBlock)
-> [TestBlock] -> [ChainUpdate TestBlock TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock -> ChainUpdate TestBlock TestBlock
forall {k} (block :: k) a. a -> ChainUpdate block a
Chain.AddBlock [TestBlock]
bs
    AddBlock TestBlock
b       -> TestBlock -> ChainUpdate TestBlock TestBlock
forall {k} (block :: k) a. a -> ChainUpdate block a
Chain.AddBlock TestBlock
b  ChainUpdate TestBlock TestBlock
-> [ChainUpdate TestBlock TestBlock]
-> [ChainUpdate TestBlock TestBlock]
forall a. a -> [a] -> [a]
: []

{-------------------------------------------------------------------------------
  Generating ChainUpdates
-------------------------------------------------------------------------------}

-- | We need some state to generate @ChainUpdate@s
data ChainUpdateState = ChainUpdateState
  { ChainUpdateState -> Chain TestBlock
cusCurrentChain :: !(Chain TestBlock)
    -- ^ The current chain, obtained by applying all the 'cusUpdates' in reverse
    -- order.
  , ChainUpdateState -> [ChainUpdate]
cusUpdates      :: ![ChainUpdate]
    -- ^ The updates that have been generated so far, in reverse order: the
    -- first update in the list is the last update to apply.
  } deriving stock (Int -> ChainUpdateState -> ShowS
[ChainUpdateState] -> ShowS
ChainUpdateState -> String
(Int -> ChainUpdateState -> ShowS)
-> (ChainUpdateState -> String)
-> ([ChainUpdateState] -> ShowS)
-> Show ChainUpdateState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainUpdateState -> ShowS
showsPrec :: Int -> ChainUpdateState -> ShowS
$cshow :: ChainUpdateState -> String
show :: ChainUpdateState -> String
$cshowList :: [ChainUpdateState] -> ShowS
showList :: [ChainUpdateState] -> ShowS
Show)

emptyUpdateState :: ChainUpdateState
emptyUpdateState :: ChainUpdateState
emptyUpdateState = ChainUpdateState
  { cusCurrentChain :: Chain TestBlock
cusCurrentChain = Chain TestBlock
forall block. Chain block
Genesis
  , cusUpdates :: [ChainUpdate]
cusUpdates      = []
  }

getChainUpdates :: ChainUpdateState -> [ChainUpdate]
getChainUpdates :: ChainUpdateState -> [ChainUpdate]
getChainUpdates = [ChainUpdate] -> [ChainUpdate]
forall a. [a] -> [a]
reverse ([ChainUpdate] -> [ChainUpdate])
-> (ChainUpdateState -> [ChainUpdate])
-> ChainUpdateState
-> [ChainUpdate]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainUpdateState -> [ChainUpdate]
cusUpdates

-- | Different strategies how to generate a sequence of 'ChainUpdate's.
data UpdateBehavior =
    -- | Chain updates tracking the selected chain of an honest node. In
    -- particular, this includes:
    --
    --  * All blocks involved are valid.
    --  * Every 'ChainUpdate' improves the chain.
    SelectedChainBehavior
  | -- | Chain updates tracking the tentative chain of an honest node (in the
    -- context of diffusion pipelining). This is similiar to
    -- 'SelectedChainBehavior', but allows for the following sequence of
    -- 'ChainUpdates':
    --
    --  1. @'AddBlock' blk@ for @blk@ invalid
    --  2. @'SwitchFork' (prevPoint blk) [blk']@ where @blk'@ is preferable to
    --     @blk@.
    TentativeChainBehavior
  deriving stock (Int -> UpdateBehavior -> ShowS
[UpdateBehavior] -> ShowS
UpdateBehavior -> String
(Int -> UpdateBehavior -> ShowS)
-> (UpdateBehavior -> String)
-> ([UpdateBehavior] -> ShowS)
-> Show UpdateBehavior
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UpdateBehavior -> ShowS
showsPrec :: Int -> UpdateBehavior -> ShowS
$cshow :: UpdateBehavior -> String
show :: UpdateBehavior -> String
$cshowList :: [UpdateBehavior] -> ShowS
showList :: [UpdateBehavior] -> ShowS
Show, UpdateBehavior -> UpdateBehavior -> Bool
(UpdateBehavior -> UpdateBehavior -> Bool)
-> (UpdateBehavior -> UpdateBehavior -> Bool) -> Eq UpdateBehavior
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UpdateBehavior -> UpdateBehavior -> Bool
== :: UpdateBehavior -> UpdateBehavior -> Bool
$c/= :: UpdateBehavior -> UpdateBehavior -> Bool
/= :: UpdateBehavior -> UpdateBehavior -> Bool
Eq, Int -> UpdateBehavior
UpdateBehavior -> Int
UpdateBehavior -> [UpdateBehavior]
UpdateBehavior -> UpdateBehavior
UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
UpdateBehavior
-> UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
(UpdateBehavior -> UpdateBehavior)
-> (UpdateBehavior -> UpdateBehavior)
-> (Int -> UpdateBehavior)
-> (UpdateBehavior -> Int)
-> (UpdateBehavior -> [UpdateBehavior])
-> (UpdateBehavior -> UpdateBehavior -> [UpdateBehavior])
-> (UpdateBehavior -> UpdateBehavior -> [UpdateBehavior])
-> (UpdateBehavior
    -> UpdateBehavior -> UpdateBehavior -> [UpdateBehavior])
-> Enum UpdateBehavior
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: UpdateBehavior -> UpdateBehavior
succ :: UpdateBehavior -> UpdateBehavior
$cpred :: UpdateBehavior -> UpdateBehavior
pred :: UpdateBehavior -> UpdateBehavior
$ctoEnum :: Int -> UpdateBehavior
toEnum :: Int -> UpdateBehavior
$cfromEnum :: UpdateBehavior -> Int
fromEnum :: UpdateBehavior -> Int
$cenumFrom :: UpdateBehavior -> [UpdateBehavior]
enumFrom :: UpdateBehavior -> [UpdateBehavior]
$cenumFromThen :: UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
enumFromThen :: UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
$cenumFromTo :: UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
enumFromTo :: UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
$cenumFromThenTo :: UpdateBehavior
-> UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
enumFromThenTo :: UpdateBehavior
-> UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
Enum, UpdateBehavior
UpdateBehavior -> UpdateBehavior -> Bounded UpdateBehavior
forall a. a -> a -> Bounded a
$cminBound :: UpdateBehavior
minBound :: UpdateBehavior
$cmaxBound :: UpdateBehavior
maxBound :: UpdateBehavior
Bounded)

genChainUpdates ::
     UpdateBehavior
  -> SecurityParam
  -> Int  -- ^ The number of updates to generate
  -> Gen [ChainUpdate]
genChainUpdates :: UpdateBehavior -> SecurityParam -> Int -> Gen [ChainUpdate]
genChainUpdates UpdateBehavior
updateBehavior SecurityParam
securityParam Int
n =
        ChainUpdateState -> [ChainUpdate]
getChainUpdates
    (ChainUpdateState -> [ChainUpdate])
-> Gen ChainUpdateState -> Gen [ChainUpdate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UpdateBehavior
-> SecurityParam -> Int -> ChainUpdateState -> Gen ChainUpdateState
genChainUpdateState UpdateBehavior
updateBehavior SecurityParam
securityParam Int
n ChainUpdateState
emptyUpdateState

genChainUpdateState ::
     UpdateBehavior
  -> SecurityParam
  -> Int
  -> ChainUpdateState
  -> Gen ChainUpdateState
genChainUpdateState :: UpdateBehavior
-> SecurityParam -> Int -> ChainUpdateState -> Gen ChainUpdateState
genChainUpdateState UpdateBehavior
updateBehavior SecurityParam
securityParam Int
n =
    StateT ChainUpdateState Gen ()
-> ChainUpdateState -> Gen ChainUpdateState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Int
-> StateT ChainUpdateState Gen () -> StateT ChainUpdateState Gen ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
n StateT ChainUpdateState Gen ()
genChainUpdate)
  where
    -- Modify the state
    addUpdate :: ChainUpdate -> ChainUpdateState -> ChainUpdateState
addUpdate ChainUpdate
u ChainUpdateState
cus = ChainUpdateState
cus { cusUpdates = u : cusUpdates cus }
    setChain :: Chain TestBlock -> ChainUpdateState -> ChainUpdateState
setChain  Chain TestBlock
c ChainUpdateState
cus = ChainUpdateState
cus { cusCurrentChain = c }

    k :: Int
k = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ SecurityParam -> Word64
maxRollbacks SecurityParam
securityParam

    genChainUpdate :: StateT ChainUpdateState Gen ()
genChainUpdate = do
      ChainUpdateState { cusCurrentChain :: ChainUpdateState -> Chain TestBlock
cusCurrentChain = Chain TestBlock
chain } <- StateT ChainUpdateState Gen ChainUpdateState
forall s (m :: * -> *). MonadState s m => m s
get
      let genValid :: StateT ChainUpdateState Gen ()
genValid =
            [(Int, StateT ChainUpdateState Gen ())]
-> StateT ChainUpdateState Gen ()
forall (t :: (* -> *) -> * -> *) a.
(MonadTrans t, Monad (t Gen)) =>
[(Int, t Gen a)] -> t Gen a
frequency'
              [ (Int
3, Validity -> StateT ChainUpdateState Gen ()
forall {t :: (* -> *) -> * -> *}.
(MonadState ChainUpdateState (t Gen), MonadTrans t) =>
Validity -> t Gen ()
genAddBlock Validity
Valid)
              , ( if Chain TestBlock -> Bool
forall block. Chain block -> Bool
Chain.null Chain TestBlock
chain then Int
0 else Int
1
                , Gen Int -> StateT ChainUpdateState Gen ()
forall {t :: (* -> *) -> * -> *}.
(MonadState ChainUpdateState (t Gen), MonadTrans t) =>
Gen Int -> t Gen ()
genSwitchFork ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
k))
                )
              ]
      [(Int, StateT ChainUpdateState Gen ())]
-> StateT ChainUpdateState Gen ()
forall (t :: (* -> *) -> * -> *) a.
(MonadTrans t, Monad (t Gen)) =>
[(Int, t Gen a)] -> t Gen a
frequency' ([(Int, StateT ChainUpdateState Gen ())]
 -> StateT ChainUpdateState Gen ())
-> [(Int, StateT ChainUpdateState Gen ())]
-> StateT ChainUpdateState Gen ()
forall a b. (a -> b) -> a -> b
$
        (Int
5, Int
-> StateT ChainUpdateState Gen () -> StateT ChainUpdateState Gen ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
2 StateT ChainUpdateState Gen ()
genValid) (Int, StateT ChainUpdateState Gen ())
-> [(Int, StateT ChainUpdateState Gen ())]
-> [(Int, StateT ChainUpdateState Gen ())]
forall a. a -> [a] -> [a]
:
        [ (Int
1, StateT ChainUpdateState Gen ()
genInvalidBlock) | UpdateBehavior
updateBehavior UpdateBehavior -> UpdateBehavior -> Bool
forall a. Eq a => a -> a -> Bool
== UpdateBehavior
TentativeChainBehavior ]

    genBlockToAdd :: Validity -> t Gen TestBlock
genBlockToAdd Validity
validity = do
        ChainUpdateState { cusCurrentChain :: ChainUpdateState -> Chain TestBlock
cusCurrentChain = Chain TestBlock
chain } <- t Gen ChainUpdateState
forall s (m :: * -> *). MonadState s m => m s
get
        TestBlock
block <- Gen TestBlock -> t Gen TestBlock
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen TestBlock -> t Gen TestBlock)
-> Gen TestBlock -> t Gen TestBlock
forall a b. (a -> b) -> a -> b
$ case Chain TestBlock -> Maybe TestBlock
forall b. Chain b -> Maybe b
Chain.head Chain TestBlock
chain of
          Maybe TestBlock
Nothing      -> TestBlock -> TestBlock
forall {ptype}. TestBlockWith ptype -> TestBlockWith ptype
setValidity (TestBlock -> TestBlock)
-> (Word64 -> TestBlock) -> Word64 -> TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> TestBlock
firstBlock (Word64 -> TestBlock) -> Gen Word64 -> Gen TestBlock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
genForkNo
          Just TestBlock
curHead -> do
            Word64
forkNo <- case Validity
validity of
              Validity
Valid   ->  Gen Word64
genForkNo
              Validity
Invalid -> Word64 -> Gen Word64
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
3
            TestBlock -> Gen TestBlock
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return
              (TestBlock -> Gen TestBlock)
-> (TestBlock -> TestBlock) -> TestBlock -> Gen TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Word64) -> TestBlock -> TestBlock
modifyFork (Word64 -> Word64 -> Word64
forall a b. a -> b -> a
const Word64
forkNo)
              (TestBlock -> TestBlock)
-> (TestBlock -> TestBlock) -> TestBlock -> TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> TestBlock
forall {ptype}. TestBlockWith ptype -> TestBlockWith ptype
setValidity
              (TestBlock -> Gen TestBlock) -> TestBlock -> Gen TestBlock
forall a b. (a -> b) -> a -> b
$ TestBlock -> TestBlock
successorBlock TestBlock
curHead
        (ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ChainUpdateState -> ChainUpdateState) -> t Gen ())
-> (ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall a b. (a -> b) -> a -> b
$ Chain TestBlock -> ChainUpdateState -> ChainUpdateState
setChain (TestBlock -> Chain TestBlock -> Chain TestBlock
forall block.
HasHeader block =>
block -> Chain block -> Chain block
Chain.addBlock TestBlock
block Chain TestBlock
chain)
        TestBlock -> t Gen TestBlock
forall a. a -> t Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return TestBlock
block
      where
        setValidity :: TestBlockWith ptype -> TestBlockWith ptype
setValidity TestBlockWith ptype
b = TestBlockWith ptype
b { tbValid = validity }
        genForkNo :: Gen Word64
genForkNo = case Validity
validity of
          Validity
Valid -> [(Int, Gen Word64)] -> Gen Word64
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
            [ (Int
1, Word64 -> Gen Word64
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Word64
0)
            , (Int
1, (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
2))
            ]
          -- Blocks with equal hashes have to have equal validity, so we reserve
          -- a specific ForkNo for invalid blocks to ensure this.
          Validity
Invalid -> Word64 -> Gen Word64
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
3

    genAddBlock :: Validity -> t Gen ()
genAddBlock Validity
validity = do
      TestBlock
block <- Validity -> t Gen TestBlock
forall {t :: (* -> *) -> * -> *}.
(MonadState ChainUpdateState (t Gen), MonadTrans t) =>
Validity -> t Gen TestBlock
genBlockToAdd Validity
validity
      (ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ChainUpdateState -> ChainUpdateState) -> t Gen ())
-> (ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall a b. (a -> b) -> a -> b
$ ChainUpdate -> ChainUpdateState -> ChainUpdateState
addUpdate (TestBlock -> ChainUpdate
AddBlock TestBlock
block)

    genSwitchFork :: Gen Int -> t Gen ()
genSwitchFork Gen Int
genRollBackBlocks = do
      ChainUpdateState { cusCurrentChain :: ChainUpdateState -> Chain TestBlock
cusCurrentChain = Chain TestBlock
chain } <- t Gen ChainUpdateState
forall s (m :: * -> *). MonadState s m => m s
get
      Int
rollBackBlocks <- Gen Int -> t Gen Int
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
genRollBackBlocks
      let chain' :: Chain TestBlock
chain' = Int -> Chain TestBlock -> Chain TestBlock
forall block. Int -> Chain block -> Chain block
Chain.drop Int
rollBackBlocks Chain TestBlock
chain
      (ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ChainUpdateState -> ChainUpdateState) -> t Gen ())
-> (ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall a b. (a -> b) -> a -> b
$ Chain TestBlock -> ChainUpdateState -> ChainUpdateState
setChain Chain TestBlock
chain'
      [TestBlock]
blocks <- Int -> t Gen TestBlock -> t Gen [TestBlock]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
rollBackBlocks (Validity -> t Gen TestBlock
forall {t :: (* -> *) -> * -> *}.
(MonadState ChainUpdateState (t Gen), MonadTrans t) =>
Validity -> t Gen TestBlock
genBlockToAdd Validity
Valid)
      (ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ChainUpdateState -> ChainUpdateState) -> t Gen ())
-> (ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall a b. (a -> b) -> a -> b
$ ChainUpdate -> ChainUpdateState -> ChainUpdateState
addUpdate (Point TestBlock -> [TestBlock] -> ChainUpdate
SwitchFork (Chain TestBlock -> Point TestBlock
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint Chain TestBlock
chain') [TestBlock]
blocks)

    genInvalidBlock :: StateT ChainUpdateState Gen ()
genInvalidBlock = do
      Validity -> StateT ChainUpdateState Gen ()
forall {t :: (* -> *) -> * -> *}.
(MonadState ChainUpdateState (t Gen), MonadTrans t) =>
Validity -> t Gen ()
genAddBlock Validity
Invalid
      Gen Int -> StateT ChainUpdateState Gen ()
forall {t :: (* -> *) -> * -> *}.
(MonadState ChainUpdateState (t Gen), MonadTrans t) =>
Gen Int -> t Gen ()
genSwitchFork (Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1)

-- | Variant of 'frequency' that allows for transformers of 'Gen'
frequency' :: (MonadTrans t, Monad (t Gen)) => [(Int, t Gen a)] -> t Gen a
frequency' :: forall (t :: (* -> *) -> * -> *) a.
(MonadTrans t, Monad (t Gen)) =>
[(Int, t Gen a)] -> t Gen a
frequency' [] = String -> t Gen a
forall a. HasCallStack => String -> a
error String
"frequency' used with empty list"
frequency' [(Int, t Gen a)]
xs0 = Gen Int -> t Gen Int
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
tot)) t Gen Int -> (Int -> t Gen a) -> t Gen a
forall a b. t Gen a -> (a -> t Gen b) -> t Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int -> [(Int, t Gen a)] -> t Gen a
forall {t} {b}. (Ord t, Num t) => t -> [(t, b)] -> b
`pick` [(Int, t Gen a)]
xs0)
  where
    tot :: Int
tot = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((Int, t Gen a) -> Int) -> [(Int, t Gen a)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, t Gen a) -> Int
forall a b. (a, b) -> a
fst [(Int, t Gen a)]
xs0)

    pick :: t -> [(t, b)] -> b
pick t
n ((t
k,b
x):[(t, b)]
xs)
      | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
k    = b
x
      | Bool
otherwise = t -> [(t, b)] -> b
pick (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
k) [(t, b)]
xs
    pick t
_ [(t, b)]
_  = String -> b
forall a. HasCallStack => String -> a
error String
"pick used with empty list"

-- | Test that applying the generated updates gives us the same chain
-- as @cusCurrentChain@.
prop_genChainUpdates :: SecurityParam -> Int -> Property
prop_genChainUpdates :: SecurityParam -> Int -> Property
prop_genChainUpdates SecurityParam
securityParam Int
n =
    Gen ChainUpdateState -> (ChainUpdateState -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen ChainUpdateState
genCUS ((ChainUpdateState -> Property) -> Property)
-> (ChainUpdateState -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ChainUpdateState
cus ->
      [ChainUpdate TestBlock TestBlock]
-> Chain TestBlock -> Maybe (Chain TestBlock)
forall block.
HasHeader block =>
[ChainUpdate block block] -> Chain block -> Maybe (Chain block)
Chain.applyChainUpdates ([ChainUpdate] -> [ChainUpdate TestBlock TestBlock]
toChainUpdates (ChainUpdateState -> [ChainUpdate]
getChainUpdates ChainUpdateState
cus)) Chain TestBlock
forall block. Chain block
Genesis Maybe (Chain TestBlock) -> Maybe (Chain TestBlock) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
===
      Chain TestBlock -> Maybe (Chain TestBlock)
forall a. a -> Maybe a
Just (ChainUpdateState -> Chain TestBlock
cusCurrentChain ChainUpdateState
cus)
  where
    genCUS :: Gen ChainUpdateState
genCUS = do
      UpdateBehavior
behavior <- (UpdateBehavior, UpdateBehavior) -> Gen UpdateBehavior
forall a. Enum a => (a, a) -> Gen a
chooseEnum (UpdateBehavior
forall a. Bounded a => a
minBound, UpdateBehavior
forall a. Bounded a => a
maxBound)
      UpdateBehavior
-> SecurityParam -> Int -> ChainUpdateState -> Gen ChainUpdateState
genChainUpdateState UpdateBehavior
behavior SecurityParam
securityParam Int
n ChainUpdateState
emptyUpdateState