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

module Test.Consensus.Genesis.Setup.GenChains (
    GenesisTest (..)
  , 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.ChainSync.Codec
                     (ChainSyncTimeout (..))
import           Ouroboros.Network.Protocol.Limits (shortWait)
import qualified Test.Consensus.BlockTree as BT
import           Test.Consensus.PointSchedule
import qualified Test.Ouroboros.Consensus.ChainGenerator.Adversarial as A
import           Test.Ouroboros.Consensus.ChainGenerator.Adversarial
                     (genPrefixBlockCount)
import           Test.Ouroboros.Consensus.ChainGenerator.Counting
                     (Count (Count), getVector)
import qualified Test.Ouroboros.Consensus.ChainGenerator.Honest as H
import           Test.Ouroboros.Consensus.ChainGenerator.Honest
                     (ChainSchema (ChainSchema), HonestRecipe (..))
import           Test.Ouroboros.Consensus.ChainGenerator.Params
import qualified Test.Ouroboros.Consensus.ChainGenerator.Slot as S
import           Test.Ouroboros.Consensus.ChainGenerator.Slot (S)
import qualified Test.QuickCheck as QC
import           Test.QuickCheck.Extras (unsafeMapSuchThatJust)
import           Test.QuickCheck.Random (QCGen)
import           Test.Util.Orphans.IOLike ()
import           Test.Util.TestBlock hiding (blockTree)

-- | 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 slot number on the honest chain schema and a list of active slots.
--
-- REVIEW: Use 'SlotNo' 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 :: QC.Gen Word -> QC.Gen (GenesisTest TestBlock ())
genChains :: Gen Word -> Gen (GenesisTest TestBlock ())
genChains  = Gen Word -> Gen Word -> Gen (GenesisTest TestBlock ())
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 :: QC.Gen Word -> QC.Gen Word -> QC.Gen (GenesisTest TestBlock ())
genChainsWithExtraHonestPeers :: Gen Word -> Gen Word -> Gen (GenesisTest TestBlock ())
genChainsWithExtraHonestPeers Gen Word
genNumExtraHonest Gen Word
genNumForks = do
  (_, honestRecipe, someHonestChainSchema) <- Gen (Asc, HonestRecipe, SomeHonestChainSchema)
genHonestChainSchema

  H.SomeHonestChainSchema _ _ honestChainSchema <- pure someHonestChainSchema
  let ChainSchema _ vH = honestChainSchema
      goodChain = [TestBlock] -> AnchoredFragment TestBlock
mkTestFragment [TestBlock]
goodBlocks
      -- blocks for the good chain in reversed order
      goodBlocks = [TestBlock] -> [S] -> Int -> [TestBlock]
mkTestBlocks [] [S]
slotsH Int
0
      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)
      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,
    gtBlockTree = List.foldl' (flip BT.addBranch') (BT.mkTrunk goodChain) $ zipWith (genAdversarialFragment goodBlocks) [1..] alternativeChainSchemas,
    gtExtraHonestPeers,
    gtSchedule = ()
    }

  where
    genAdversarialFragment :: [TestBlock] -> Int -> (Int, [S]) -> AnchoredFragment TestBlock
    genAdversarialFragment :: [TestBlock] -> Int -> (Int, [S]) -> AnchoredFragment TestBlock
genAdversarialFragment [TestBlock]
goodBlocks Int
forkNo (Int
prefixCount, [S]
slotsA)
      = [TestBlock] -> AnchoredFragment TestBlock
mkTestFragment ([TestBlock] -> [S] -> Int -> [TestBlock]
mkTestBlocks [TestBlock]
prefix [S]
slotsA Int
forkNo)
      where
        -- blocks in the common prefix in reversed order
        prefix :: [TestBlock]
prefix = Int -> [TestBlock] -> [TestBlock]
forall a. Int -> [a] -> [a]
drop ([TestBlock] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestBlock]
goodBlocks Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
prefixCount) [TestBlock]
goodBlocks

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

    mkTestBlocks :: [TestBlock] -> [S] -> Int -> [TestBlock]
    mkTestBlocks :: [TestBlock] -> [S] -> Int -> [TestBlock]
mkTestBlocks [TestBlock]
pre [S]
active Int
forkNo =
      ([TestBlock], SlotNo) -> [TestBlock]
forall a b. (a, b) -> a
fst ((([TestBlock], SlotNo) -> S -> ([TestBlock], SlotNo))
-> ([TestBlock], SlotNo) -> [S] -> ([TestBlock], 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' ([TestBlock], SlotNo) -> S -> ([TestBlock], SlotNo)
folder ([], SlotNo
0) [S]
active)
      where
        folder :: ([TestBlock], SlotNo) -> S -> ([TestBlock], SlotNo)
folder ([TestBlock]
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 -> [TestBlock] -> [TestBlock]
issue SlotNo
inc [TestBlock]
chain, SlotNo
0)
                              | Bool
otherwise = ([TestBlock]
chain, SlotNo
inc SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1)
        issue :: SlotNo -> [TestBlock] -> [TestBlock]
issue SlotNo
inc (TestBlock
h : [TestBlock]
t) = SlotNo -> TestBlock -> TestBlock
incSlot SlotNo
inc (TestBlock -> TestBlock
successorBlock TestBlock
h) TestBlock -> [TestBlock] -> [TestBlock]
forall a. a -> [a] -> [a]
: TestBlock
h TestBlock -> [TestBlock] -> [TestBlock]
forall a. a -> [a] -> [a]
: [TestBlock]
t
        issue SlotNo
inc [] | [] <- [TestBlock]
pre = [SlotNo -> TestBlock -> TestBlock
incSlot SlotNo
inc ((Word64 -> TestBlock
firstBlock (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
forkNo)) {tbSlot = 0})]
                     | TestBlock
h : [TestBlock]
t <- [TestBlock]
pre = SlotNo -> TestBlock -> TestBlock
incSlot SlotNo
inc ((Word64 -> Word64) -> TestBlock -> TestBlock
modifyFork (Word64 -> Word64 -> Word64
forall a b. a -> b -> a
const (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
forkNo)) (TestBlock -> TestBlock
successorBlock TestBlock
h)) TestBlock -> [TestBlock] -> [TestBlock]
forall a. a -> [a] -> [a]
: TestBlock
h TestBlock -> [TestBlock] -> [TestBlock]
forall a. a -> [a] -> [a]
: [TestBlock]
t

    incSlot :: SlotNo -> TestBlock -> TestBlock
    incSlot :: SlotNo -> TestBlock -> TestBlock
incSlot SlotNo
n TestBlock
b = TestBlock
b { tbSlot = tbSlot b + n }

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
    }