{-# 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 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
  | -- | 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 ->
  -- | The number of updates to generate
  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
  -- 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
$ 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))
          ]
      -- 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
    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)

-- | 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
    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