{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
module Test.Util.ChainUpdates (
ChainUpdate (..)
, UpdateBehavior (..)
, genChainUpdates
, toChainUpdates
, prop_genChainUpdates
) where
import Cardano.Ledger.BaseTypes (unNonZero)
import Control.Monad (replicateM, replicateM_)
import Control.Monad.State.Strict (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.QuickCheck (frequency')
import Test.Util.TestBlock
data ChainUpdate =
AddBlock TestBlock
| 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]
: []
data ChainUpdateState = ChainUpdateState
{ ChainUpdateState -> Chain TestBlock
cusCurrentChain :: !(Chain TestBlock)
, ChainUpdateState -> [ChainUpdate]
cusUpdates :: ![ChainUpdate]
} 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
data UpdateBehavior =
SelectedChainBehavior
|
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
-> 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
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
$ NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (NonZero Word64 -> Word64) -> NonZero Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ SecurityParam -> NonZero Word64
maxRollbacks SecurityParam
securityParam
genChainUpdate :: StateT ChainUpdateState Gen ()
genChainUpdate = do
ChainUpdateState { cusCurrentChain = chain } <- StateT ChainUpdateState Gen ChainUpdateState
forall s (m :: * -> *). MonadState s m => m s
get
let 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))
)
]
frequency' $
(5, replicateM_ 2 genValid) :
[ (1, genInvalidBlock) | updateBehavior == TentativeChainBehavior ]
genBlockToAdd :: Validity -> t Gen TestBlock
genBlockToAdd Validity
validity = do
ChainUpdateState { cusCurrentChain = chain } <- t Gen ChainUpdateState
forall s (m :: * -> *). MonadState s m => m s
get
block <- lift $ case Chain.head 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
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
return
. modifyFork (const forkNo)
. setValidity
$ successorBlock curHead
modify $ setChain (Chain.addBlock block chain)
return 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))
]
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
block <- Validity -> t Gen TestBlock
forall {t :: (* -> *) -> * -> *}.
(MonadState ChainUpdateState (t Gen), MonadTrans t) =>
Validity -> t Gen TestBlock
genBlockToAdd Validity
validity
modify $ addUpdate (AddBlock block)
genSwitchFork :: Gen Int -> t Gen ()
genSwitchFork Gen Int
genRollBackBlocks = do
ChainUpdateState { cusCurrentChain = chain } <- t Gen ChainUpdateState
forall s (m :: * -> *). MonadState s m => m s
get
rollBackBlocks <- lift genRollBackBlocks
let chain' = Int -> Chain TestBlock -> Chain TestBlock
forall block. Int -> Chain block -> Chain block
Chain.drop Int
rollBackBlocks Chain TestBlock
chain
modify $ setChain chain'
blocks <- replicateM rollBackBlocks (genBlockToAdd Valid)
modify $ addUpdate (SwitchFork (Chain.headPoint chain') 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)
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
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)
genChainUpdateState behavior securityParam n emptyUpdateState