{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Consensus.Genesis.Setup.GenChains
  ( GenesisTest (..)
  , IssueTestBlock (..)
  , genChains
  , genChainsWithExtraHonestPeers
  ) where

import Cardano.Ledger.BaseTypes (nonZeroOr)
import Cardano.Slotting.Time (slotLengthFromSec)
import Control.Monad (replicateM)
import qualified Control.Monad.Except as Exn
import Data.List as List (foldl')
import Data.Proxy (Proxy (..))
import Data.Time.Clock (DiffTime)
import qualified Data.Vector.Unboxed as Vector
import Data.Word (Word8)
import Ouroboros.Consensus.Block.Abstract hiding (Header)
import Ouroboros.Consensus.Protocol.Abstract
  ( SecurityParam (SecurityParam)
  )
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Protocol.Limits (shortWait)
import qualified Test.Consensus.BlockTree as BT
import Test.Consensus.PointSchedule
import Test.Ouroboros.Consensus.ChainGenerator.Adversarial
  ( genPrefixBlockCount
  )
import qualified Test.Ouroboros.Consensus.ChainGenerator.Adversarial as A
import Test.Ouroboros.Consensus.ChainGenerator.Counting
  ( Count (Count)
  , getVector
  )
import Test.Ouroboros.Consensus.ChainGenerator.Honest
  ( ChainSchema (ChainSchema)
  , HonestRecipe (..)
  )
import qualified Test.Ouroboros.Consensus.ChainGenerator.Honest as H
import Test.Ouroboros.Consensus.ChainGenerator.Params
import Test.Ouroboros.Consensus.ChainGenerator.Slot (S)
import qualified Test.Ouroboros.Consensus.ChainGenerator.Slot as S
import Test.Ouroboros.Consensus.QuickCheck.Extras
  ( unsafeMapSuchThatJust
  )
import qualified Test.QuickCheck as QC
import Test.QuickCheck.Random (QCGen)
import Test.Util.Orphans.IOLike ()
import Test.Util.TestBlock (TestBlock, TestBlockWith (..))
import qualified Test.Util.TestBlock as TB

-- | Random generator for an honest chain recipe and schema.
genHonestChainSchema :: QC.Gen (Asc, H.HonestRecipe, H.SomeHonestChainSchema)
genHonestChainSchema :: Gen (Asc, HonestRecipe, SomeHonestChainSchema)
genHonestChainSchema = do
  asc <- Gen Asc
genAsc
  honestRecipe <- H.genHonestRecipe

  H.SomeCheckedHonestRecipe Proxy Proxy honestRecipe' <-
    case Exn.runExcept $ H.checkHonestRecipe honestRecipe of
      Left NoSuchHonestChainSchema
exn -> [Char] -> Gen SomeCheckedHonestRecipe
forall a. HasCallStack => [Char] -> a
error ([Char] -> Gen SomeCheckedHonestRecipe)
-> [Char] -> Gen SomeCheckedHonestRecipe
forall a b. (a -> b) -> a -> b
$ [Char]
"impossible! " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (HonestRecipe, NoSuchHonestChainSchema) -> [Char]
forall a. Show a => a -> [Char]
show (HonestRecipe
honestRecipe, NoSuchHonestChainSchema
exn)
      Right SomeCheckedHonestRecipe
honestRecipe' -> SomeCheckedHonestRecipe -> Gen SomeCheckedHonestRecipe
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeCheckedHonestRecipe
honestRecipe'
  (seed :: QCGen) <- QC.arbitrary
  let schema = Maybe Asc
-> CheckedHonestRecipe base hon -> QCGen -> ChainSchema base hon
forall base hon g.
RandomGen g =>
Maybe Asc
-> CheckedHonestRecipe base hon -> g -> ChainSchema base hon
H.uniformTheHonestChain (Asc -> Maybe Asc
forall a. a -> Maybe a
Just Asc
asc) CheckedHonestRecipe base hon
honestRecipe' QCGen
seed

  pure (asc, honestRecipe, H.SomeHonestChainSchema Proxy Proxy schema)

-- | Random generator for one alternative chain schema forking off a given
-- honest chain schema. The alternative chain schema is returned as the pair of
-- a block number (representing the common prefix block count) on the honest
-- chain schema and a list of active slots.
--
-- REVIEW: Use 'BlockNo' instead of 'Int'?
genAlternativeChainSchema :: (H.HonestRecipe, H.ChainSchema base hon) -> QC.Gen (Int, [S])
genAlternativeChainSchema :: forall base hon.
(HonestRecipe, ChainSchema base hon) -> Gen (Int, [S])
genAlternativeChainSchema (HonestRecipe
testRecipeH, ChainSchema base hon
arHonest) =
  Gen (Maybe (Int, [S])) -> Gen (Int, [S])
forall a. Gen (Maybe a) -> Gen a
unsafeMapSuchThatJust (Gen (Maybe (Int, [S])) -> Gen (Int, [S]))
-> Gen (Maybe (Int, [S])) -> Gen (Int, [S])
forall a b. (a -> b) -> a -> b
$ do
    let H.HonestRecipe Kcp
kcp Scg
scg Delta
delta Len
_len = HonestRecipe
testRecipeH

    (seedPrefix :: QCGen) <- Gen QCGen
forall a. Arbitrary a => Gen a
QC.arbitrary
    let arPrefix = HonestRecipe
-> QCGen -> ChainSchema base hon -> Var hon 'ActiveSlotE
forall g base hon.
RandomGen g =>
HonestRecipe -> g -> ChainSchema base hon -> Var hon 'ActiveSlotE
genPrefixBlockCount HonestRecipe
testRecipeH QCGen
seedPrefix ChainSchema base hon
arHonest

    let testRecipeA =
          A.AdversarialRecipe
            { Var hon 'ActiveSlotE
arPrefix :: Var hon 'ActiveSlotE
arPrefix :: Var hon 'ActiveSlotE
A.arPrefix
            , arParams :: (Kcp, Scg, Delta)
A.arParams = (Kcp
kcp, Scg
scg, Delta
delta)
            , ChainSchema base hon
arHonest :: ChainSchema base hon
arHonest :: ChainSchema base hon
A.arHonest
            }

    alternativeAsc <- ascFromBits <$> QC.choose (1 :: Word8, maxBound - 1)

    case Exn.runExcept $ A.checkAdversarialRecipe testRecipeA of
      Left NoSuchAdversarialChainSchema
e -> case NoSuchAdversarialChainSchema
e of
        NoSuchAdversarialChainSchema
A.NoSuchAdversarialBlock -> Maybe (Int, [S]) -> Gen (Maybe (Int, [S]))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Int, [S])
forall a. Maybe a
Nothing
        NoSuchAdversarialChainSchema
A.NoSuchCompetitor -> [Char] -> Gen (Maybe (Int, [S]))
forall a. HasCallStack => [Char] -> a
error ([Char] -> Gen (Maybe (Int, [S])))
-> [Char] -> Gen (Maybe (Int, [S]))
forall a b. (a -> b) -> a -> b
$ [Char]
"impossible! " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> NoSuchAdversarialChainSchema -> [Char]
forall a. Show a => a -> [Char]
show NoSuchAdversarialChainSchema
e
        NoSuchAdversarialChainSchema
A.NoSuchIntersection -> [Char] -> Gen (Maybe (Int, [S]))
forall a. HasCallStack => [Char] -> a
error ([Char] -> Gen (Maybe (Int, [S])))
-> [Char] -> Gen (Maybe (Int, [S]))
forall a b. (a -> b) -> a -> b
$ [Char]
"impossible! " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> NoSuchAdversarialChainSchema -> [Char]
forall a. Show a => a -> [Char]
show NoSuchAdversarialChainSchema
e
      Right (A.SomeCheckedAdversarialRecipe Proxy adv
_ CheckedAdversarialRecipe base hon adv
testRecipeA'') -> do
        let Count Int
prefixCount = Var hon 'ActiveSlotE
arPrefix
        (seed :: QCGen) <- Gen QCGen
forall a. Arbitrary a => Gen a
QC.arbitrary
        let H.ChainSchema _ v = A.uniformAdversarialChain (Just alternativeAsc) testRecipeA'' seed
        pure $ Just (prefixCount, Vector.toList (getVector v))

genChains :: (HasHeader blk, IssueTestBlock blk) => QC.Gen Word -> QC.Gen (GenesisTest blk ())
genChains :: forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
genChains = Gen Word -> Gen Word -> Gen (GenesisTest blk ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen Word -> Gen (GenesisTest blk ())
genChainsWithExtraHonestPeers (Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
0)

-- | Random generator for a block tree. The block tree contains one trunk (the
-- “honest” chain) and as many branches as given as a parameter (the
-- “alternative” chains or “bad” chains). For instance, one such tree could be
-- graphically represented as:
--
--     slots:    1  2  3  4  5  6  7  8  9
--     trunk: O─────1──2──3──4─────5──6──7
--                     │           ╰─────6
--                     ╰─────3──4─────5
-- For now, the @extraHonestPeers@ generator is only used to fill the GenesisTest field.
-- However, in the future it could also be used to generate "short forks" near the tip of the trunk.
genChainsWithExtraHonestPeers ::
  forall blk.
  (HasHeader blk, IssueTestBlock blk) =>
  -- | Number of extra honest peers
  QC.Gen Word ->
  -- | Number of forks
  QC.Gen Word ->
  QC.Gen (GenesisTest blk ())
genChainsWithExtraHonestPeers :: forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen Word -> Gen (GenesisTest blk ())
genChainsWithExtraHonestPeers Gen Word
genNumExtraHonest Gen Word
genNumForks = do
  (_, honestRecipe, someHonestChainSchema) <- Gen (Asc, HonestRecipe, SomeHonestChainSchema)
genHonestChainSchema

  H.SomeHonestChainSchema _ _ honestChainSchema <- pure someHonestChainSchema
  let ChainSchema _ vH = honestChainSchema
      slotsH = Vector S -> [S]
forall a. Unbox a => Vector a -> [a]
Vector.toList (Vector hon 'SlotE S -> Vector S
forall {k1} {k2} (base :: k1) (elem :: k2) a.
Vector base elem a -> Vector a
getVector Vector hon 'SlotE S
vH)
      -- blocks for the good chain in reversed order
      goodBlocks = [blk] -> [S] -> Int -> [blk]
mkTestBlocks [] [S]
slotsH Int
0
      goodChain = [blk] -> AnchoredFragment blk
mkTestFragment [blk]
goodBlocks
      HonestRecipe (Kcp kcp) (Scg scg) delta _len = honestRecipe

  numForks <- genNumForks
  gtExtraHonestPeers <- genNumExtraHonest
  alternativeChainSchemas <-
    replicateM (fromIntegral numForks) (genAlternativeChainSchema (honestRecipe, honestChainSchema))
  pure $
    GenesisTest
      { gtSecurityParam =
          SecurityParam $
            -- As long as `genKSD` generates a `k` that is > 0, this won't lead to an ErrorCall.
            nonZeroOr (fromIntegral kcp) $
              error "Generated Kcp was zero. Cannot construct a NonZero value for the SecurityParam."
      , gtGenesisWindow = GenesisWindow (fromIntegral scg)
      , gtForecastRange = ForecastRange (fromIntegral scg) -- REVIEW: Do we want to generate those randomly?
      , gtDelay = delta
      , gtSlotLength = slotLengthFromSec 20
      , gtChainSyncTimeouts = chainSyncTimeouts
      , gtBlockFetchTimeouts = blockFetchTimeouts
      , gtLoPBucketParams = LoPBucketParams{lbpCapacity = 50, lbpRate = 10}
      , -- These values give little enough leeway (5s) so that some adversaries get disconnected
        -- by the LoP during the stalling attack test. Maybe we should design a way to override
        -- those values for individual tests?
        -- Also, we might want to generate these randomly.
        gtCSJParams = CSJParams $ fromIntegral scg
      , -- The generated alternative chains (branches added to the @goodChain@)
        -- can end up having the same /common prefix count/, meaning they fork
        -- at the same block. Note that the assigned fork number has no relation
        -- with the order in which the branching happens, rather it is just a
        -- means to tag branches.
        gtBlockTree =
          List.foldl' (flip BT.addBranch') (BT.mkTrunk goodChain) $
            zipWith (genAdversarialFragment goodBlocks) [1 ..] alternativeChainSchemas
      , gtExtraHonestPeers
      , gtSchedule = ()
      }
 where
  genAdversarialFragment :: [blk] -> Int -> (Int, [S]) -> AnchoredFragment blk
  genAdversarialFragment :: [blk] -> Int -> (Int, [S]) -> AnchoredFragment blk
genAdversarialFragment [blk]
goodBlocks Int
forkNo (Int
prefixCount, [S]
slotsA) =
    [blk] -> AnchoredFragment blk
mkTestFragment ([blk] -> [S] -> Int -> [blk]
mkTestBlocks [blk]
prefix [S]
slotsA Int
forkNo)
   where
    -- blocks in the common prefix in reversed order
    prefix :: [blk]
prefix = Int -> [blk] -> [blk]
forall a. Int -> [a] -> [a]
drop ([blk] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [blk]
goodBlocks Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
prefixCount) [blk]
goodBlocks

  mkTestFragment :: [blk] -> AnchoredFragment blk
  mkTestFragment :: [blk] -> AnchoredFragment blk
mkTestFragment =
    Anchor blk -> [blk] -> AnchoredFragment blk
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AF.fromNewestFirst Anchor blk
forall block. Anchor block
AF.AnchorGenesis

  -- Cons new blocks acoording to the given active block schema
  -- and mark the first with the corresponding fork number; the
  -- next blocks get a zero fork number.
  mkTestBlocks :: [blk] -> [S] -> Int -> [blk]
  mkTestBlocks :: [blk] -> [S] -> Int -> [blk]
mkTestBlocks [blk]
pre [S]
active Int
forkNo =
    ([blk], SlotNo) -> [blk]
forall a b. (a, b) -> a
fst ((([blk], SlotNo) -> S -> ([blk], SlotNo))
-> ([blk], SlotNo) -> [S] -> ([blk], SlotNo)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ([blk], SlotNo) -> S -> ([blk], SlotNo)
folder ([], SlotNo
0) [S]
active)
   where
    folder :: ([blk], SlotNo) -> S -> ([blk], SlotNo)
    folder :: ([blk], SlotNo) -> S -> ([blk], SlotNo)
folder ([blk]
chain, SlotNo
inc) S
s
      | Proxy 'NotInverted -> S -> Bool
forall (pol :: Pol) (proxy :: Pol -> *).
POL pol =>
proxy pol -> S -> Bool
forall (proxy :: Pol -> *). proxy 'NotInverted -> S -> Bool
S.test Proxy 'NotInverted
S.notInverted S
s = (SlotNo -> [blk] -> [blk]
issue SlotNo
inc [blk]
chain, SlotNo
0)
      | Bool
otherwise = ([blk]
chain, SlotNo
inc SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1)
    issue :: SlotNo -> [blk] -> [blk]
    issue :: SlotNo -> [blk] -> [blk]
issue SlotNo
inc (blk
h : [blk]
t) = Maybe Int -> SlotNo -> blk -> blk
forall blk. IssueTestBlock blk => Maybe Int -> SlotNo -> blk -> blk
issueSuccessorBlock Maybe Int
forall a. Maybe a
Nothing SlotNo
inc blk
h blk -> [blk] -> [blk]
forall a. a -> [a] -> [a]
: blk
h blk -> [blk] -> [blk]
forall a. a -> [a] -> [a]
: [blk]
t
    issue SlotNo
inc [] =
      case [blk]
pre of
        [] -> [Int -> SlotNo -> blk
forall blk. IssueTestBlock blk => Int -> SlotNo -> blk
issueFirstBlock Int
forkNo SlotNo
inc]
        (blk
h : [blk]
t) -> Maybe Int -> SlotNo -> blk -> blk
forall blk. IssueTestBlock blk => Maybe Int -> SlotNo -> blk -> blk
issueSuccessorBlock (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
forkNo) SlotNo
inc blk
h blk -> [blk] -> [blk]
forall a. a -> [a] -> [a]
: blk
h blk -> [blk] -> [blk]
forall a. a -> [a] -> [a]
: [blk]
t

-- | Class of block types for which we can issue blocks for a test.
class IssueTestBlock blk where
  issueFirstBlock ::
    -- | The fork number
    Int ->
    -- | The /relative number of slots elapsed/ since the parent block was
    -- issued, NOT the desired slot number of the block itself.
    SlotNo ->
    blk
  issueSuccessorBlock ::
    -- | A new fork number, or 'Nothing' if it should be on the same
    -- branch as its parent.
    Maybe Int ->
    -- | The /relative number of slots elapsed/ since the parent block was
    -- issued, NOT the desired slot number of the block itself.
    SlotNo ->
    blk ->
    blk

instance IssueTestBlock TestBlock where
  issueFirstBlock :: Int -> SlotNo -> TestBlock
issueFirstBlock Int
fork SlotNo
slot =
    SlotNo -> TestBlock -> TestBlock
incSlot SlotNo
slot ((Word64 -> TestBlock
TB.firstBlock (Word64 -> TestBlock) -> Word64 -> TestBlock
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fork){tbSlot = 0})
  issueSuccessorBlock :: Maybe Int -> SlotNo -> TestBlock -> TestBlock
issueSuccessorBlock Maybe Int
fork SlotNo
slot TestBlock
blk =
    SlotNo -> TestBlock -> TestBlock
incSlot SlotNo
slot (TestBlock -> TestBlock) -> TestBlock -> TestBlock
forall a b. (a -> b) -> a -> b
$
      (Word64 -> Word64) -> TestBlock -> TestBlock
TB.modifyFork ((Word64 -> Word64)
-> (Int -> Word64 -> Word64) -> Maybe Int -> Word64 -> Word64
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word64 -> Word64
forall a. a -> a
id (Word64 -> Word64 -> Word64
forall a b. a -> b -> a
const (Word64 -> Word64 -> Word64)
-> (Int -> Word64) -> Int -> Word64 -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Maybe Int
fork) (TestBlock -> TestBlock) -> TestBlock -> TestBlock
forall a b. (a -> b) -> a -> b
$
        TestBlock -> TestBlock
TB.successorBlock TestBlock
blk

-- | Increment the slot number on a 'TestBlock'.
incSlot :: SlotNo -> TestBlock -> TestBlock
incSlot :: SlotNo -> TestBlock -> TestBlock
incSlot SlotNo
s TestBlock
tb = TestBlock
tb{tbSlot = tbSlot tb + s}

chainSyncTimeouts :: ChainSyncTimeout
chainSyncTimeouts :: ChainSyncTimeout
chainSyncTimeouts =
  ChainSyncTimeout
    { Maybe DiffTime
canAwaitTimeout :: Maybe DiffTime
canAwaitTimeout :: Maybe DiffTime
canAwaitTimeout
    , Maybe DiffTime
intersectTimeout :: Maybe DiffTime
intersectTimeout :: Maybe DiffTime
intersectTimeout
    , Maybe DiffTime
mustReplyTimeout :: Maybe DiffTime
mustReplyTimeout :: Maybe DiffTime
mustReplyTimeout
    , Maybe DiffTime
idleTimeout :: Maybe DiffTime
idleTimeout :: Maybe DiffTime
idleTimeout
    }
 where
  canAwaitTimeout :: Maybe DiffTime
  canAwaitTimeout :: Maybe DiffTime
canAwaitTimeout = Maybe DiffTime
shortWait
  intersectTimeout :: Maybe DiffTime
  intersectTimeout :: Maybe DiffTime
intersectTimeout = Maybe DiffTime
shortWait
  idleTimeout :: Maybe DiffTime
  -- \| The default from 'Ouroboros.Consensus.Node.stdChainSyncTimeout' is
  -- 3673s, which is virtually infinite, so let us make it actually infinite
  -- for our test environment.
  idleTimeout :: Maybe DiffTime
idleTimeout = Maybe DiffTime
forall a. Maybe a
Nothing
  -- \| The 'mustReplyTimeout' must be disabled in our context, because the
  -- chains are finite, and therefore an honest peer can only serve it all,
  -- then send 'MsgAwaitReply' (therefore entering 'StMustReply'), and then
  -- stall forever, and it must not be killed for it.
  --
  -- Note that this allows the adversaries to stall us forever in that same
  -- situation. However, that peer is only allowed to send 'MsgAwaitReply'
  -- when they have served their tip, which leaves them fully vulnerable to
  -- the Genesis Density Disconnection (GDD) logic. A bug related to this
  -- disabled timeout is in fact either a bug in the GDD or in the tests.
  mustReplyTimeout :: Maybe DiffTime
  mustReplyTimeout :: Maybe DiffTime
mustReplyTimeout = Maybe DiffTime
forall a. Maybe a
Nothing

blockFetchTimeouts :: BlockFetchTimeout
blockFetchTimeouts :: BlockFetchTimeout
blockFetchTimeouts =
  BlockFetchTimeout
    { busyTimeout :: Maybe DiffTime
busyTimeout = DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just DiffTime
60
    , streamingTimeout :: Maybe DiffTime
streamingTimeout = DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just DiffTime
60
    }