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

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

import           Cardano.Slotting.Time (SlotLength, getSlotLength,
                     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, secondsToDiffTime)
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
asc <- Gen Asc
genAsc
  HonestRecipe
honestRecipe <- Gen HonestRecipe
H.genHonestRecipe

  H.SomeCheckedHonestRecipe Proxy base
Proxy Proxy hon
Proxy CheckedHonestRecipe base hon
honestRecipe' <-
    case Except NoSuchHonestChainSchema SomeCheckedHonestRecipe
-> Either NoSuchHonestChainSchema SomeCheckedHonestRecipe
forall e a. Except e a -> Either e a
Exn.runExcept (Except NoSuchHonestChainSchema SomeCheckedHonestRecipe
 -> Either NoSuchHonestChainSchema SomeCheckedHonestRecipe)
-> Except NoSuchHonestChainSchema SomeCheckedHonestRecipe
-> Either NoSuchHonestChainSchema SomeCheckedHonestRecipe
forall a b. (a -> b) -> a -> b
$ HonestRecipe
-> Except NoSuchHonestChainSchema SomeCheckedHonestRecipe
H.checkHonestRecipe HonestRecipe
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'
  (QCGen
seed :: QCGen) <- Gen QCGen
forall a. Arbitrary a => Gen a
QC.arbitrary
  let schema :: ChainSchema base hon
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

  (Asc, HonestRecipe, SomeHonestChainSchema)
-> Gen (Asc, HonestRecipe, SomeHonestChainSchema)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Asc
asc, HonestRecipe
honestRecipe, Proxy base
-> Proxy hon -> ChainSchema base hon -> SomeHonestChainSchema
forall base hon.
Proxy base
-> Proxy hon -> ChainSchema base hon -> SomeHonestChainSchema
H.SomeHonestChainSchema Proxy base
forall {k} (t :: k). Proxy t
Proxy Proxy hon
forall {k} (t :: k). Proxy t
Proxy ChainSchema base hon
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

    (QCGen
seedPrefix :: QCGen) <- Gen QCGen
forall a. Arbitrary a => Gen a
QC.arbitrary
    let arPrefix :: Var hon 'ActiveSlotE
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 :: AdversarialRecipe base hon
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
    }

    Asc
alternativeAsc <- Word8 -> Asc
forall w. (Enum w, FiniteBits w) => w -> Asc
ascFromBits (Word8 -> Asc) -> Gen Word8 -> Gen Asc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8, Word8) -> Gen Word8
forall a. Random a => (a, a) -> Gen a
QC.choose (Word8
1 :: Word8, Word8
forall a. Bounded a => a
maxBound Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
1)

    case Except
  NoSuchAdversarialChainSchema
  (SomeCheckedAdversarialRecipe base hon)
-> Either
     NoSuchAdversarialChainSchema
     (SomeCheckedAdversarialRecipe base hon)
forall e a. Except e a -> Either e a
Exn.runExcept (Except
   NoSuchAdversarialChainSchema
   (SomeCheckedAdversarialRecipe base hon)
 -> Either
      NoSuchAdversarialChainSchema
      (SomeCheckedAdversarialRecipe base hon))
-> Except
     NoSuchAdversarialChainSchema
     (SomeCheckedAdversarialRecipe base hon)
-> Either
     NoSuchAdversarialChainSchema
     (SomeCheckedAdversarialRecipe base hon)
forall a b. (a -> b) -> a -> b
$ AdversarialRecipe base hon
-> Except
     NoSuchAdversarialChainSchema
     (SomeCheckedAdversarialRecipe base hon)
forall base hon.
AdversarialRecipe base hon
-> Except
     NoSuchAdversarialChainSchema
     (SomeCheckedAdversarialRecipe base hon)
A.checkAdversarialRecipe AdversarialRecipe base hon
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
        (QCGen
seed :: QCGen) <- Gen QCGen
forall a. Arbitrary a => Gen a
QC.arbitrary
        let H.ChainSchema Contains 'SlotE base adv
_ Vector adv 'SlotE S
v = Maybe Asc
-> CheckedAdversarialRecipe base hon adv
-> QCGen
-> ChainSchema base adv
forall g base hon adv.
RandomGen g =>
Maybe Asc
-> CheckedAdversarialRecipe base hon adv
-> g
-> ChainSchema base adv
A.uniformAdversarialChain (Asc -> Maybe Asc
forall a. a -> Maybe a
Just Asc
alternativeAsc) CheckedAdversarialRecipe base hon adv
testRecipeA'' QCGen
seed
        Maybe (Int, [S]) -> Gen (Maybe (Int, [S]))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Int, [S]) -> Gen (Maybe (Int, [S])))
-> Maybe (Int, [S]) -> Gen (Maybe (Int, [S]))
forall a b. (a -> b) -> a -> b
$ (Int, [S]) -> Maybe (Int, [S])
forall a. a -> Maybe a
Just (Int
prefixCount, Vector S -> [S]
forall a. Unbox a => Vector a -> [a]
Vector.toList (Vector adv 'SlotE S -> Vector S
forall {k1} {k2} (base :: k1) (elem :: k2) a.
Vector base elem a -> Vector a
getVector Vector adv 'SlotE S
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
  (Asc
asc, HonestRecipe
honestRecipe, SomeHonestChainSchema
someHonestChainSchema) <- Gen (Asc, HonestRecipe, SomeHonestChainSchema)
genHonestChainSchema

  H.SomeHonestChainSchema Proxy base
_ Proxy hon
_ ChainSchema base hon
honestChainSchema <- SomeHonestChainSchema -> Gen SomeHonestChainSchema
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeHonestChainSchema
someHonestChainSchema
  let ChainSchema Contains 'SlotE base hon
_ Vector hon 'SlotE S
vH = ChainSchema base hon
honestChainSchema
      goodChain :: AnchoredFragment TestBlock
goodChain = [TestBlock] -> AnchoredFragment TestBlock
mkTestFragment [TestBlock]
goodBlocks
      -- blocks for the good chain in reversed order
      goodBlocks :: [TestBlock]
goodBlocks = [TestBlock] -> [S] -> Int -> [TestBlock]
mkTestBlocks [] [S]
slotsH Int
0
      slotsH :: [S]
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 Int
kcp) (Scg Int
scg) Delta
delta Len
_len = HonestRecipe
honestRecipe

  Word
numForks <- Gen Word
genNumForks
  Word
gtExtraHonestPeers <- Gen Word
genNumExtraHonest
  [(Int, [S])]
alternativeChainSchemas <- Int -> Gen (Int, [S]) -> Gen [(Int, [S])]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
numForks) ((HonestRecipe, ChainSchema base hon) -> Gen (Int, [S])
forall base hon.
(HonestRecipe, ChainSchema base hon) -> Gen (Int, [S])
genAlternativeChainSchema (HonestRecipe
honestRecipe, ChainSchema base hon
honestChainSchema))
  GenesisTest TestBlock () -> Gen (GenesisTest TestBlock ())
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenesisTest TestBlock () -> Gen (GenesisTest TestBlock ()))
-> GenesisTest TestBlock () -> Gen (GenesisTest TestBlock ())
forall a b. (a -> b) -> a -> b
$ GenesisTest {
    $sel:gtSecurityParam:GenesisTest :: SecurityParam
gtSecurityParam = Word64 -> SecurityParam
SecurityParam (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
kcp),
    $sel:gtGenesisWindow:GenesisTest :: GenesisWindow
gtGenesisWindow = Word64 -> GenesisWindow
GenesisWindow (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
scg),
    $sel:gtForecastRange:GenesisTest :: ForecastRange
gtForecastRange = Word64 -> ForecastRange
ForecastRange (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
scg), -- REVIEW: Do we want to generate those randomly?
    $sel:gtDelay:GenesisTest :: Delta
gtDelay = Delta
delta,
    SlotLength
gtSlotLength :: SlotLength
$sel:gtSlotLength:GenesisTest :: SlotLength
gtSlotLength,
    $sel:gtChainSyncTimeouts:GenesisTest :: ChainSyncTimeout
gtChainSyncTimeouts = SlotLength -> Asc -> ChainSyncTimeout
chainSyncTimeouts SlotLength
gtSlotLength Asc
asc,
    $sel:gtBlockFetchTimeouts:GenesisTest :: BlockFetchTimeout
gtBlockFetchTimeouts = BlockFetchTimeout
blockFetchTimeouts,
    $sel:gtLoPBucketParams:GenesisTest :: LoPBucketParams
gtLoPBucketParams = LoPBucketParams { $sel:lbpCapacity:LoPBucketParams :: Integer
lbpCapacity = Integer
100_000, $sel:lbpRate:LoPBucketParams :: Rational
lbpRate = Rational
1_000 },
    -- ^ REVIEW: Do we want to generate those randomly? For now, the chosen
    -- values carry no special meaning. Someone needs to think about what values
    -- would make for interesting tests.
    $sel:gtCSJParams:GenesisTest :: CSJParams
gtCSJParams = SlotNo -> CSJParams
CSJParams (SlotNo -> CSJParams) -> SlotNo -> CSJParams
forall a b. (a -> b) -> a -> b
$ Int -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
scg,
    $sel:gtBlockTree:GenesisTest :: BlockTree TestBlock
gtBlockTree = (BlockTree TestBlock
 -> AnchoredFragment TestBlock -> BlockTree TestBlock)
-> BlockTree TestBlock
-> [AnchoredFragment TestBlock]
-> BlockTree TestBlock
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((AnchoredFragment TestBlock
 -> BlockTree TestBlock -> BlockTree TestBlock)
-> BlockTree TestBlock
-> AnchoredFragment TestBlock
-> BlockTree TestBlock
forall a b c. (a -> b -> c) -> b -> a -> c
flip AnchoredFragment TestBlock
-> BlockTree TestBlock -> BlockTree TestBlock
forall blk.
HasHeader blk =>
AnchoredFragment blk -> BlockTree blk -> BlockTree blk
BT.addBranch') (AnchoredFragment TestBlock -> BlockTree TestBlock
forall blk. AnchoredFragment blk -> BlockTree blk
BT.mkTrunk AnchoredFragment TestBlock
goodChain) ([AnchoredFragment TestBlock] -> BlockTree TestBlock)
-> [AnchoredFragment TestBlock] -> BlockTree TestBlock
forall a b. (a -> b) -> a -> b
$ (Int -> (Int, [S]) -> AnchoredFragment TestBlock)
-> [Int] -> [(Int, [S])] -> [AnchoredFragment TestBlock]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ([TestBlock] -> Int -> (Int, [S]) -> AnchoredFragment TestBlock
genAdversarialFragment [TestBlock]
goodBlocks) [Int
1..] [(Int, [S])]
alternativeChainSchemas,
    Word
gtExtraHonestPeers :: Word
$sel:gtExtraHonestPeers:GenesisTest :: Word
gtExtraHonestPeers,
    $sel:gtSchedule:GenesisTest :: ()
gtSchedule = ()
    }

  where
    gtSlotLength :: SlotLength
gtSlotLength = Integer -> SlotLength
slotLengthFromSec Integer
20

    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 ::
  SlotLength ->
  Asc ->
  ChainSyncTimeout
chainSyncTimeouts :: SlotLength -> Asc -> ChainSyncTimeout
chainSyncTimeouts SlotLength
t Asc
f =
  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
    idleTimeout :: Maybe DiffTime
idleTimeout = DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just DiffTime
3673 -- taken from Ouroboros.Consensus.Node.stdChainSyncTimeout
    -- | The following timeout is derived from the average length of a streak of
    -- empty slots. If the probability of the election of a leader is @f@ and
    -- @Y@ is a probability, then a streak of empty slots will be shorter than
    -- @log (1 - Y) / log (1 - f)@ with probability @Y@. Main net nodes pick a
    -- random value for @Y@ between 99.9% and 99.999%. For our use case, we
    -- choose the tightest bound of 99.9%.
    mustReplyTimeout :: Maybe DiffTime
    mustReplyTimeout :: Maybe DiffTime
mustReplyTimeout =
      DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just (DiffTime -> Maybe DiffTime) -> DiffTime -> Maybe DiffTime
forall a b. (a -> b) -> a -> b
$
        Integer -> DiffTime
secondsToDiffTime (Integer -> DiffTime) -> Integer -> DiffTime
forall a b. (a -> b) -> a -> b
$
          Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$
            NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (SlotLength -> NominalDiffTime
getSlotLength SlotLength
t)
              Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
log (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.999)
              Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double -> Double
forall a. Floating a => a -> a
log (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Asc -> Double
ascVal Asc
f)

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