{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Data types and generators for point schedules.
--
-- Each generator takes a set of 'AnchoredFragment's corresponding to the tested
-- peers' chains, and converts them to a point schedule consisting of a sequence
-- of 'NodeState's, each of which is associated with a single peer.
--
-- When a schedule is executed in a test, each tick is processed in order.
-- The peer associated with the current tick is considered "active", which means that
-- its ChainSync server is allowed to continue processing messages, while all the other
-- peers' servers suspend operation by blocking on a concurrency primitive.
-- The state in the current tick determines the actions that the peer is allowed to perform,
-- and once it fulfills the state's criteria, it yields control back to the scheduler,
-- who then activates the next tick's peer.
module Test.Consensus.PointSchedule
  ( BlockFetchTimeout (..)
  , CSJParams (..)
  , DowntimeParams (..)
  , ForecastRange (..)
  , GenesisTest (..)
  , GenesisTestFull
  , GenesisWindow (..)
  , LoPBucketParams (..)
  , PeerSchedule
  , PointSchedule (..)
  , PointsGeneratorParams (..)
  , RunGenesisTestResult (..)
  , enrichedWith
  , ensureScheduleDuration
  , genesisNodeState
  , longRangeAttack
  , peerSchedulesBlocks
  , peerStates
  , peersStates
  , peersStatesRelative
  , prettyGenesisTest
  , prettyPointSchedule
  , stToGen
  , uniformPoints
  ) where

import Cardano.Ledger.BaseTypes (unNonZero)
import Cardano.Slotting.Time (SlotLength)
import Control.Monad (replicateM)
import Control.Monad.Class.MonadTime.SI
  ( Time (Time)
  , addTime
  , diffTime
  )
import Control.Monad.ST (ST)
import Data.Bifunctor (first)
import Data.Functor (($>))
import Data.List (mapAccumL, partition, scanl')
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Data.Time (DiffTime)
import Data.Word (Word64)
import Ouroboros.Consensus.Block.Abstract (withOriginToMaybe)
import Ouroboros.Consensus.Ledger.SupportsProtocol
  ( GenesisWindow (..)
  )
import Ouroboros.Consensus.Network.NodeToNode (ChainSyncTimeout (..))
import Ouroboros.Consensus.Protocol.Abstract
  ( SecurityParam (SecurityParam)
  , maxRollbacks
  )
import Ouroboros.Consensus.Util.Condense
  ( CondenseList (..)
  , PaddingDirection (..)
  , condenseListWithPadding
  )
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Block (SlotNo (..), blockSlot)
import Ouroboros.Network.Point (withOrigin)
import System.Random.Stateful (STGenM, StatefulGen, runSTGen_)
import qualified System.Random.Stateful as Random
import Test.Consensus.BlockTree
  ( BlockTree (..)
  , BlockTreeBranch (..)
  , allFragments
  , prettyBlockTree
  )
import Test.Consensus.PeerSimulator.StateView (StateView)
import Test.Consensus.PointSchedule.NodeState
  ( NodeState (..)
  , genesisNodeState
  )
import Test.Consensus.PointSchedule.Peers
  ( Peer (..)
  , PeerId
  , Peers (..)
  , getPeerIds
  , peers'
  , peersList
  )
import Test.Consensus.PointSchedule.SinglePeer
  ( IsTrunk (IsBranch, IsTrunk)
  , PeerScheduleParams (..)
  , SchedulePoint (..)
  , defaultPeerScheduleParams
  , mergeOn
  , peerScheduleFromTipPoints
  , schedulePointToBlock
  )
import Test.Consensus.PointSchedule.SinglePeer.Indices
  ( uniformRMDiffTime
  )
import Test.Ouroboros.Consensus.ChainGenerator.Params (Delta (Delta))
import Test.QuickCheck (Gen, arbitrary)
import Test.QuickCheck.Random (QCGen)
import Test.Util.TersePrinting (terseFragment)
import Test.Util.TestBlock (TestBlock)
import Text.Printf (printf)

prettyPointSchedule ::
  forall blk.
  CondenseList (NodeState blk) =>
  PointSchedule blk ->
  [String]
prettyPointSchedule :: forall blk.
CondenseList (NodeState blk) =>
PointSchedule blk -> [String]
prettyPointSchedule ps :: PointSchedule blk
ps@PointSchedule{[PeerId]
psStartOrder :: [PeerId]
psStartOrder :: forall blk. PointSchedule blk -> [PeerId]
psStartOrder, Time
psMinEndTime :: Time
psMinEndTime :: forall blk. PointSchedule blk -> Time
psMinEndTime} =
  []
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"psSchedule ="
       ]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ( (String -> String -> String -> String)
-> [String] -> [String] -> [String] -> [String]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3
           ( \String
number String
time String
peerState ->
               String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
number String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
peerState String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" @ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
time
           )
           (PaddingDirection -> [Int] -> [String]
forall a. Condense a => PaddingDirection -> [a] -> [String]
condenseListWithPadding PaddingDirection
PadLeft ([Int] -> [String]) -> [Int] -> [String]
forall a b. (a -> b) -> a -> b
$ (Int, (Time, Peer (NodeState blk))) -> Int
forall a b. (a, b) -> a
fst ((Int, (Time, Peer (NodeState blk))) -> Int)
-> [(Int, (Time, Peer (NodeState blk)))] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, (Time, Peer (NodeState blk)))]
numberedPeersStates)
           (Time -> String
showDT (Time -> String)
-> ((Int, (Time, Peer (NodeState blk))) -> Time)
-> (Int, (Time, Peer (NodeState blk)))
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, Peer (NodeState blk)) -> Time
forall a b. (a, b) -> a
fst ((Time, Peer (NodeState blk)) -> Time)
-> ((Int, (Time, Peer (NodeState blk)))
    -> (Time, Peer (NodeState blk)))
-> (Int, (Time, Peer (NodeState blk)))
-> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, (Time, Peer (NodeState blk))) -> (Time, Peer (NodeState blk))
forall a b. (a, b) -> b
snd ((Int, (Time, Peer (NodeState blk))) -> String)
-> [(Int, (Time, Peer (NodeState blk)))] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, (Time, Peer (NodeState blk)))]
numberedPeersStates)
           ([Peer (NodeState blk)] -> [String]
forall a. CondenseList a => [a] -> [String]
condenseList ([Peer (NodeState blk)] -> [String])
-> [Peer (NodeState blk)] -> [String]
forall a b. (a -> b) -> a -> b
$ ((Time, Peer (NodeState blk)) -> Peer (NodeState blk)
forall a b. (a, b) -> b
snd ((Time, Peer (NodeState blk)) -> Peer (NodeState blk))
-> ((Int, (Time, Peer (NodeState blk)))
    -> (Time, Peer (NodeState blk)))
-> (Int, (Time, Peer (NodeState blk)))
-> Peer (NodeState blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, (Time, Peer (NodeState blk))) -> (Time, Peer (NodeState blk))
forall a b. (a, b) -> b
snd) ((Int, (Time, Peer (NodeState blk))) -> Peer (NodeState blk))
-> [(Int, (Time, Peer (NodeState blk)))] -> [Peer (NodeState blk)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, (Time, Peer (NodeState blk)))]
numberedPeersStates)
       )
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"psStartOrder = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [PeerId] -> String
forall a. Show a => a -> String
show [PeerId]
psStartOrder
       , String
"psMinEndTime = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Time -> String
forall a. Show a => a -> String
show Time
psMinEndTime
       ]
 where
  numberedPeersStates :: [(Int, (Time, Peer (NodeState blk)))]
  numberedPeersStates :: [(Int, (Time, Peer (NodeState blk)))]
numberedPeersStates = [Int]
-> [(Time, Peer (NodeState blk))]
-> [(Int, (Time, Peer (NodeState blk)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (PointSchedule blk -> [(Time, Peer (NodeState blk))]
forall blk. PointSchedule blk -> [(Time, Peer (NodeState blk))]
peersStates PointSchedule blk
ps)

  showDT :: Time -> String
  showDT :: Time -> String
showDT (Time DiffTime
dt) = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.6f" (DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
dt :: Double)

----------------------------------------------------------------------------------------------------
-- Conversion to 'PointSchedule'
----------------------------------------------------------------------------------------------------

-- | Convert a @SinglePeer@ schedule to a 'NodeState' schedule.
--
-- Accumulates the new points in each tick into the previous state, starting with a set of all
-- 'Origin' points.
--
-- Finally, drops the first state, since all points being 'Origin' (in particular the tip) has no
-- useful effects in the simulator, but it could set the tip in the GDD governor to 'Origin', which
-- causes slow nodes to be disconnected right away.
--
-- TODO Remove dropping the first state in favor of better GDD logic
peerStates :: Peer (PeerSchedule blk) -> [(Time, Peer (NodeState blk))]
peerStates :: forall blk.
Peer (PeerSchedule blk) -> [(Time, Peer (NodeState blk))]
peerStates Peer{PeerId
name :: PeerId
name :: forall a. Peer a -> PeerId
name, value :: forall a. Peer a -> a
value = PeerSchedule blk
schedulePoints} =
  Int
-> [(Time, Peer (NodeState blk))] -> [(Time, Peer (NodeState blk))]
forall a. Int -> [a] -> [a]
drop Int
1 ([Time] -> [Peer (NodeState blk)] -> [(Time, Peer (NodeState blk))]
forall a b. [a] -> [b] -> [(a, b)]
zip (DiffTime -> Time
Time DiffTime
0 Time -> [Time] -> [Time]
forall a. a -> [a] -> [a]
: [Time]
times) (PeerId -> NodeState blk -> Peer (NodeState blk)
forall a. PeerId -> a -> Peer a
Peer PeerId
name (NodeState blk -> Peer (NodeState blk))
-> [NodeState blk] -> [Peer (NodeState blk)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NodeState blk -> SchedulePoint blk -> NodeState blk)
-> NodeState blk -> [SchedulePoint blk] -> [NodeState blk]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl' NodeState blk -> SchedulePoint blk -> NodeState blk
forall {blk}. NodeState blk -> SchedulePoint blk -> NodeState blk
modPoint NodeState blk
forall blk. NodeState blk
genesisNodeState [SchedulePoint blk]
points))
 where
  modPoint :: NodeState blk -> SchedulePoint blk -> NodeState blk
modPoint NodeState blk
z = \case
    ScheduleTipPoint WithOrigin blk
nsTip -> NodeState blk
z{nsTip}
    ScheduleHeaderPoint WithOrigin blk
nsHeader -> NodeState blk
z{nsHeader}
    ScheduleBlockPoint WithOrigin blk
nsBlock -> NodeState blk
z{nsBlock}

  ([Time]
times, [SchedulePoint blk]
points) = PeerSchedule blk -> ([Time], [SchedulePoint blk])
forall a b. [(a, b)] -> ([a], [b])
unzip PeerSchedule blk
schedulePoints

-- | Convert several @SinglePeer@ schedules to a common 'NodeState' schedule.
--
-- The resulting schedule contains all the peers. Items are sorted by time.
peersStates :: PointSchedule blk -> [(Time, Peer (NodeState blk))]
peersStates :: forall blk. PointSchedule blk -> [(Time, Peer (NodeState blk))]
peersStates PointSchedule{Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule :: forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule} =
  ([(Time, Peer (NodeState blk))]
 -> [(Time, Peer (NodeState blk))]
 -> [(Time, Peer (NodeState blk))])
-> [(Time, Peer (NodeState blk))]
-> [[(Time, Peer (NodeState blk))]]
-> [(Time, Peer (NodeState blk))]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (((Time, Peer (NodeState blk)) -> Time)
-> [(Time, Peer (NodeState blk))]
-> [(Time, Peer (NodeState blk))]
-> [(Time, Peer (NodeState blk))]
forall b a. Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn (Time, Peer (NodeState blk)) -> Time
forall a b. (a, b) -> a
fst) [] (Peer (PeerSchedule blk) -> [(Time, Peer (NodeState blk))]
forall blk.
Peer (PeerSchedule blk) -> [(Time, Peer (NodeState blk))]
peerStates (Peer (PeerSchedule blk) -> [(Time, Peer (NodeState blk))])
-> [Peer (PeerSchedule blk)] -> [[(Time, Peer (NodeState blk))]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Peers (PeerSchedule blk) -> [Peer (PeerSchedule blk)]
forall a. Peers a -> [Peer a]
peersList Peers (PeerSchedule blk)
psSchedule)

-- | Same as 'peersStates' but returns the duration of a state instead of the
-- absolute time at which it starts holding.
peersStatesRelative :: PointSchedule blk -> [(DiffTime, Peer (NodeState blk))]
peersStatesRelative :: forall blk. PointSchedule blk -> [(DiffTime, Peer (NodeState blk))]
peersStatesRelative PointSchedule blk
peers =
  let ([Time]
starts, [Peer (NodeState blk)]
states) = [(Time, Peer (NodeState blk))] -> ([Time], [Peer (NodeState blk)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Time, Peer (NodeState blk))]
 -> ([Time], [Peer (NodeState blk)]))
-> [(Time, Peer (NodeState blk))]
-> ([Time], [Peer (NodeState blk)])
forall a b. (a -> b) -> a -> b
$ PointSchedule blk -> [(Time, Peer (NodeState blk))]
forall blk. PointSchedule blk -> [(Time, Peer (NodeState blk))]
peersStates PointSchedule blk
peers
      durations :: [DiffTime]
durations = (Time, [DiffTime]) -> [DiffTime]
forall a b. (a, b) -> b
snd ((Time -> Time -> (Time, DiffTime))
-> Time -> [Time] -> (Time, [DiffTime])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (\Time
prev Time
start -> (Time
start, Time -> Time -> DiffTime
diffTime Time
start Time
prev)) (DiffTime -> Time
Time DiffTime
0) (Int -> [Time] -> [Time]
forall a. Int -> [a] -> [a]
drop Int
1 [Time]
starts)) [DiffTime] -> [DiffTime] -> [DiffTime]
forall a. [a] -> [a] -> [a]
++ [DiffTime
0.1]
   in [DiffTime]
-> [Peer (NodeState blk)] -> [(DiffTime, Peer (NodeState blk))]
forall a b. [a] -> [b] -> [(a, b)]
zip [DiffTime]
durations [Peer (NodeState blk)]
states

type PeerSchedule blk = [(Time, SchedulePoint blk)]

-- | List of all blocks appearing in the schedule.
peerScheduleBlocks :: (PeerSchedule blk) -> [blk]
peerScheduleBlocks :: forall blk. PeerSchedule blk -> [blk]
peerScheduleBlocks = ((Time, SchedulePoint blk) -> Maybe blk)
-> [(Time, SchedulePoint blk)] -> [blk]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (WithOrigin blk -> Maybe blk
forall t. WithOrigin t -> Maybe t
withOriginToMaybe (WithOrigin blk -> Maybe blk)
-> ((Time, SchedulePoint blk) -> WithOrigin blk)
-> (Time, SchedulePoint blk)
-> Maybe blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchedulePoint blk -> WithOrigin blk
forall blk. SchedulePoint blk -> WithOrigin blk
schedulePointToBlock (SchedulePoint blk -> WithOrigin blk)
-> ((Time, SchedulePoint blk) -> SchedulePoint blk)
-> (Time, SchedulePoint blk)
-> WithOrigin blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, SchedulePoint blk) -> SchedulePoint blk
forall a b. (a, b) -> b
snd)

data PointSchedule blk = PointSchedule
  { forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
  -- ^ The actual point schedule
  , forall blk. PointSchedule blk -> [PeerId]
psStartOrder :: [PeerId]
  -- ^ The order in which the peers start and connect to the node under test.
  -- The peers that are absent from 'psSchedule' are ignored; the peers from
  -- 'psSchedule' that are absent of 'psStartOrder' are started in the end in
  -- the order of 'PeerId'.
  , forall blk. PointSchedule blk -> Time
psMinEndTime :: Time
  -- ^ Minimum duration for the simulation of this point schedule.
  -- If no point in the schedule is larger than 'psMinEndTime',
  -- the simulation will still run until this time is reached.
  }

-- | List of all blocks appearing in the schedules.
peerSchedulesBlocks :: Peers (PeerSchedule blk) -> [blk]
peerSchedulesBlocks :: forall blk. Peers (PeerSchedule blk) -> [blk]
peerSchedulesBlocks = (Peer (PeerSchedule blk) -> [blk])
-> [Peer (PeerSchedule blk)] -> [blk]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PeerSchedule blk -> [blk]
forall blk. PeerSchedule blk -> [blk]
peerScheduleBlocks (PeerSchedule blk -> [blk])
-> (Peer (PeerSchedule blk) -> PeerSchedule blk)
-> Peer (PeerSchedule blk)
-> [blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peer (PeerSchedule blk) -> PeerSchedule blk
forall a. Peer a -> a
value) ([Peer (PeerSchedule blk)] -> [blk])
-> (Peers (PeerSchedule blk) -> [Peer (PeerSchedule blk)])
-> Peers (PeerSchedule blk)
-> [blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peers (PeerSchedule blk) -> [Peer (PeerSchedule blk)]
forall a. Peers a -> [Peer a]
peersList

----------------------------------------------------------------------------------------------------
-- Schedule generators
----------------------------------------------------------------------------------------------------

-- | Produce a schedule similar to @Frequencies (Peers 1 [10])@, using the new @SinglePeer@
-- generator.
--
-- We hardcode the two schedules to use the latest block as the initial tip point.
-- The honest peer gets a substantially larger (and disconnected) delay interval to ensure
-- that k+1 blocks are sent fast enough to trigger selection of a fork.
longRangeAttack ::
  (StatefulGen g m, AF.HasHeader blk) =>
  BlockTree blk ->
  g ->
  m (PointSchedule blk)
longRangeAttack :: forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
BlockTree blk -> g -> m (PointSchedule blk)
longRangeAttack BlockTree{AnchoredFragment blk
btTrunk :: AnchoredFragment blk
btTrunk :: forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk, btBranches :: forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches = [BlockTreeBranch blk
branch]} g
g = do
  honest <- g
-> PeerScheduleParams
-> [(IsTrunk, [Int])]
-> AnchoredFragment blk
-> [AnchoredFragment blk]
-> m [(Time, SchedulePoint blk)]
forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
g
-> PeerScheduleParams
-> [(IsTrunk, [Int])]
-> AnchoredFragment blk
-> [AnchoredFragment blk]
-> m [(Time, SchedulePoint blk)]
peerScheduleFromTipPoints g
g PeerScheduleParams
honParams [(IsTrunk
IsTrunk, [AnchoredFragment blk -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment blk
btTrunk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1])] AnchoredFragment blk
btTrunk []
  adv <-
    peerScheduleFromTipPoints
      g
      advParams
      [(IsBranch, [AF.length (btbFull branch) - 1])]
      btTrunk
      [btbFull branch]
  pure $
    shiftPointSchedule $
      PointSchedule
        { psSchedule = peers' [honest] [adv]
        , psStartOrder = []
        , psMinEndTime = Time 0
        }
 where
  honParams :: PeerScheduleParams
honParams = PeerScheduleParams
defaultPeerScheduleParams{pspHeaderDelayInterval = (0.3, 0.4)}
  advParams :: PeerScheduleParams
advParams = PeerScheduleParams
defaultPeerScheduleParams{pspTipDelayInterval = (0, 0.1)}
longRangeAttack BlockTree blk
_ g
_ =
  String -> m (PointSchedule blk)
forall a. HasCallStack => String -> a
error String
"longRangeAttack can only deal with single adversary"

data PointsGeneratorParams = PointsGeneratorParams
  { PointsGeneratorParams -> Int
pgpExtraHonestPeers :: Int
  , PointsGeneratorParams -> DowntimeParams
pgpDowntime :: DowntimeParams
  }

data DowntimeParams = NoDowntime | DowntimeWithSecurityParam SecurityParam

uniformPoints ::
  (StatefulGen g m, AF.HasHeader blk) =>
  PointsGeneratorParams ->
  BlockTree blk ->
  g ->
  m (PointSchedule blk)
uniformPoints :: forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
PointsGeneratorParams
-> BlockTree blk -> g -> m (PointSchedule blk)
uniformPoints PointsGeneratorParams{Int
pgpExtraHonestPeers :: PointsGeneratorParams -> Int
pgpExtraHonestPeers :: Int
pgpExtraHonestPeers, DowntimeParams
pgpDowntime :: PointsGeneratorParams -> DowntimeParams
pgpDowntime :: DowntimeParams
pgpDowntime} BlockTree blk
bt =
  (PointSchedule blk -> PointSchedule blk)
-> m (PointSchedule blk) -> m (PointSchedule blk)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PointSchedule blk -> PointSchedule blk
forall blk. PointSchedule blk -> PointSchedule blk
shiftPointSchedule (m (PointSchedule blk) -> m (PointSchedule blk))
-> (g -> m (PointSchedule blk)) -> g -> m (PointSchedule blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. case DowntimeParams
pgpDowntime of
    DowntimeParams
NoDowntime ->
      Int -> BlockTree blk -> g -> m (PointSchedule blk)
forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
Int -> BlockTree blk -> g -> m (PointSchedule blk)
uniformPointsWithExtraHonestPeers Int
pgpExtraHonestPeers BlockTree blk
bt
    DowntimeWithSecurityParam SecurityParam
k ->
      Int -> SecurityParam -> BlockTree blk -> g -> m (PointSchedule blk)
forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
Int -> SecurityParam -> BlockTree blk -> g -> m (PointSchedule blk)
uniformPointsWithExtraHonestPeersAndDowntime Int
pgpExtraHonestPeers SecurityParam
k BlockTree blk
bt

-- | Shifts all tick start times so that the first tip point is announced at
-- the very beginning of the test, keeping the relative delays of the schedule
-- intact.
--
-- This is a measure to make the long range attack test work, since that
-- relies on the honest node sending headers later than the adversary, which
-- is not possible if the adversary's first tip point is delayed by 20 or
-- more seconds due to being in a later slot.
shiftPointSchedule :: PointSchedule blk -> PointSchedule blk
shiftPointSchedule :: forall blk. PointSchedule blk -> PointSchedule blk
shiftPointSchedule PointSchedule blk
s = PointSchedule blk
s{psSchedule = shiftPeerSchedule <$> psSchedule s}
 where
  shiftPeerSchedule :: PeerSchedule blk -> PeerSchedule blk
  shiftPeerSchedule :: forall blk. PeerSchedule blk -> PeerSchedule blk
shiftPeerSchedule PeerSchedule blk
times = ((Time, SchedulePoint blk) -> (Time, SchedulePoint blk))
-> PeerSchedule blk -> PeerSchedule blk
forall a b. (a -> b) -> [a] -> [b]
map ((Time -> Time)
-> (Time, SchedulePoint blk) -> (Time, SchedulePoint blk)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Time -> Time
shiftTime) PeerSchedule blk
times
   where
    shiftTime :: Time -> Time
    shiftTime :: Time -> Time
shiftTime Time
t = DiffTime -> Time -> Time
addTime (-DiffTime
firstTipOffset) Time
t

    firstTipOffset :: DiffTime
    firstTipOffset :: DiffTime
firstTipOffset = case PeerSchedule blk
times of [] -> DiffTime
0; ((Time DiffTime
dt, SchedulePoint blk
_) : PeerSchedule blk
_) -> DiffTime
dt

-- | Generate a schedule in which the trunk is served by @pgpExtraHonestPeers + 1@ peers,
-- and extra branches are served by one peer each, using a single tip point,
-- without specifically assigned delay intervals like in 'newLongRangeAttack'.
--
-- Include rollbacks in a percentage of adversaries, in which case that peer uses two branchs.
uniformPointsWithExtraHonestPeers ::
  forall g m blk.
  (StatefulGen g m, AF.HasHeader blk) =>
  Int ->
  BlockTree blk ->
  g ->
  m (PointSchedule blk)
uniformPointsWithExtraHonestPeers :: forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
Int -> BlockTree blk -> g -> m (PointSchedule blk)
uniformPointsWithExtraHonestPeers
  Int
extraHonestPeers
  BlockTree{AnchoredFragment blk
btTrunk :: forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk :: AnchoredFragment blk
btTrunk, [BlockTreeBranch blk]
btBranches :: forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches :: [BlockTreeBranch blk]
btBranches}
  g
g =
    do
      honestTip0 <- AnchoredFragment blk -> m Int
forall {f :: * -> *} {v} {a} {b}.
(Applicative f, Anchorable v a b) =>
AnchoredSeq v a b -> f Int
firstTip AnchoredFragment blk
btTrunk
      honests <-
        replicateM (extraHonestPeers + 1) $
          mkSchedule [(IsTrunk, [honestTip0 .. AF.length btTrunk - 1])] []
      advs <- takeBranches btBranches
      let psSchedule = [[(Time, SchedulePoint blk)]]
-> [[(Time, SchedulePoint blk)]]
-> Peers [(Time, SchedulePoint blk)]
forall a. [a] -> [a] -> Peers a
peers' [[(Time, SchedulePoint blk)]]
honests [[(Time, SchedulePoint blk)]]
advs
      psStartOrder <- shuffle (getPeerIds psSchedule)
      pure $ PointSchedule{psSchedule, psStartOrder, psMinEndTime = Time 0}
   where
    takeBranches :: [BlockTreeBranch blk] -> m [[(Time, SchedulePoint blk)]]
takeBranches = \case
      [] -> [[(Time, SchedulePoint blk)]] -> m [[(Time, SchedulePoint blk)]]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      [BlockTreeBranch blk
b] -> [(Time, SchedulePoint blk)] -> [[(Time, SchedulePoint blk)]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Time, SchedulePoint blk)] -> [[(Time, SchedulePoint blk)]])
-> m [(Time, SchedulePoint blk)] -> m [[(Time, SchedulePoint blk)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockTreeBranch blk -> m [(Time, SchedulePoint blk)]
withoutRollback BlockTreeBranch blk
b
      BlockTreeBranch blk
b1 : BlockTreeBranch blk
b2 : [BlockTreeBranch blk]
branches -> do
        a <- g -> m Double
forall g (m :: * -> *). StatefulGen g m => g -> m Double
Random.uniformDouble01M g
g
        if a < rollbackProb
          then do
            this <- withRollback b1 b2
            rest <- takeBranches branches
            pure (this : rest)
          else do
            this <- withoutRollback b1
            rest <- takeBranches (b2 : branches)
            pure (this : rest)

    withoutRollback :: BlockTreeBranch blk -> m [(Time, SchedulePoint blk)]
withoutRollback BlockTreeBranch blk
branch = do
      tips <- BlockTreeBranch blk -> m [(IsTrunk, [Int])]
forall {m :: * -> *} {b}.
(Monad m, HasHeader b) =>
BlockTreeBranch b -> m [(IsTrunk, [Int])]
mkTips BlockTreeBranch blk
branch
      mkSchedule tips [btbSuffix branch]

    withRollback :: BlockTreeBranch blk
-> BlockTreeBranch blk -> m [(Time, SchedulePoint blk)]
withRollback BlockTreeBranch blk
b1 BlockTreeBranch blk
b2 = do
      firstTips <- BlockTreeBranch blk -> m [(IsTrunk, [Int])]
forall {m :: * -> *} {b}.
(Monad m, HasHeader b) =>
BlockTreeBranch b -> m [(IsTrunk, [Int])]
mkTips BlockTreeBranch blk
b1
      let secondTips = [AnchoredFragment blk -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length (BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix BlockTreeBranch blk
b2) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
      mkSchedule (firstTips ++ [(IsBranch, secondTips)]) [btbSuffix b1, btbSuffix b2]

    mkSchedule :: [(IsTrunk, [Int])]
-> [AnchoredFragment blk] -> m [(Time, SchedulePoint blk)]
mkSchedule [(IsTrunk, [Int])]
tips [AnchoredFragment blk]
branches = do
      params <- m PeerScheduleParams
mkParams
      peerScheduleFromTipPoints g params tips btTrunk branches

    mkTips :: BlockTreeBranch b -> m [(IsTrunk, [Int])]
mkTips BlockTreeBranch b
branch = do
      tip0 <- AnchoredSeq (WithOrigin SlotNo) (Anchor b) b -> m Int
forall {f :: * -> *} {v} {a} {b}.
(Applicative f, Anchorable v a b) =>
AnchoredSeq v a b -> f Int
firstTip (BlockTreeBranch b -> AnchoredSeq (WithOrigin SlotNo) (Anchor b) b
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull BlockTreeBranch b
branch)
      let (pre, post) = partition (< firstSuffixBlock) [tip0 .. lastBlock]
      pure ((if null pre then [] else [(IsTrunk, pre)]) ++ [(IsBranch, (shift <$> post))])
     where
      shift :: Int -> Int
shift Int
i = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstSuffixBlock
      firstSuffixBlock :: Int
firstSuffixBlock = Int
lastBlock Int -> Int -> Int
forall a. Num a => a -> a -> a
- AnchoredSeq (WithOrigin SlotNo) (Anchor b) b -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length (BlockTreeBranch b -> AnchoredSeq (WithOrigin SlotNo) (Anchor b) b
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix BlockTreeBranch b
branch) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      lastBlock :: Int
lastBlock = AnchoredSeq (WithOrigin SlotNo) (Anchor b) b -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredSeq (WithOrigin SlotNo) (Anchor b) b
full Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      full :: AnchoredSeq (WithOrigin SlotNo) (Anchor b) b
full = BlockTreeBranch b -> AnchoredSeq (WithOrigin SlotNo) (Anchor b) b
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull BlockTreeBranch b
branch

    firstTip :: AnchoredSeq v a b -> f Int
firstTip AnchoredSeq v a b
frag = Int -> f Int
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnchoredSeq v a b -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredSeq v a b
frag Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

    mkParams :: m PeerScheduleParams
mkParams = do
      tipL <- (DiffTime, DiffTime) -> g -> m DiffTime
forall g (m :: * -> *).
StatefulGen g m =>
(DiffTime, DiffTime) -> g -> m DiffTime
uniformRMDiffTime (DiffTime
0, DiffTime
0.5) g
g
      tipU <- uniformRMDiffTime (1, 2) g
      headerL <- uniformRMDiffTime (0.018, 0.03) g
      headerU <- uniformRMDiffTime (0.021, 0.04) g
      pure
        defaultPeerScheduleParams
          { pspTipDelayInterval = (tipL, tipU)
          , pspHeaderDelayInterval = (headerL, headerU)
          }

    rollbackProb :: Double
rollbackProb = Double
0.2

    -- Inefficient implementation, but sufficient for small lists.
    shuffle :: [a] -> m [a]
    shuffle :: forall a. [a] -> m [a]
shuffle [] = [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    shuffle [a]
xs = do
      i <- (Int, Int) -> g -> m Int
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *). StatefulGen g m => (Int, Int) -> g -> m Int
Random.uniformRM (Int
0, [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) g
g
      let x = [a]
xs [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
          xs' = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
i [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [a]
xs
      (x :) <$> shuffle xs'

minusClamp :: (Ord a, Num a) => a -> a -> a
minusClamp :: forall a. (Ord a, Num a) => a -> a -> a
minusClamp a
a a
b
  | a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
b = a
0
  | Bool
otherwise = a
a a -> a -> a
forall a. Num a => a -> a -> a
- a
b

zipPadN :: forall a. [[a]] -> [[Maybe a]]
zipPadN :: forall a. [[a]] -> [[Maybe a]]
zipPadN =
  [[Maybe a]] -> [[a]] -> [[Maybe a]]
forall {a}. [[Maybe a]] -> [[a]] -> [[Maybe a]]
spin []
 where
  spin :: [[Maybe a]] -> [[a]] -> [[Maybe a]]
spin [[Maybe a]]
acc [[a]]
as
    | ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[a]]
as =
        [[Maybe a]] -> [[Maybe a]]
forall a. [a] -> [a]
reverse [[Maybe a]]
acc
    | let ([Maybe a]
h, [[a]]
t) = [(Maybe a, [a])] -> ([Maybe a], [[a]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([a] -> (Maybe a, [a])
forall {a}. [a] -> (Maybe a, [a])
takeNext ([a] -> (Maybe a, [a])) -> [[a]] -> [(Maybe a, [a])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[a]]
as) =
        [[Maybe a]] -> [[a]] -> [[Maybe a]]
spin ([Maybe a]
h [Maybe a] -> [[Maybe a]] -> [[Maybe a]]
forall a. a -> [a] -> [a]
: [[Maybe a]]
acc) [[a]]
t

  takeNext :: [a] -> (Maybe a, [a])
takeNext = \case
    [] -> (Maybe a
forall a. Maybe a
Nothing, [])
    a
h : [a]
t -> (a -> Maybe a
forall a. a -> Maybe a
Just a
h, [a]
t)

isTip :: SchedulePoint blk -> Bool
isTip :: forall blk. SchedulePoint blk -> Bool
isTip = \case
  ScheduleTipPoint WithOrigin blk
_ -> Bool
True
  SchedulePoint blk
_ -> Bool
False

tipTimes :: [(Time, SchedulePoint blk)] -> [Time]
tipTimes :: forall blk. [(Time, SchedulePoint blk)] -> [Time]
tipTimes =
  ((Time, SchedulePoint blk) -> Time)
-> [(Time, SchedulePoint blk)] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Time, SchedulePoint blk) -> Time
forall a b. (a, b) -> a
fst ([(Time, SchedulePoint blk)] -> [Time])
-> ([(Time, SchedulePoint blk)] -> [(Time, SchedulePoint blk)])
-> [(Time, SchedulePoint blk)]
-> [Time]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Time, SchedulePoint blk) -> Bool)
-> [(Time, SchedulePoint blk)] -> [(Time, SchedulePoint blk)]
forall a. (a -> Bool) -> [a] -> [a]
filter (SchedulePoint blk -> Bool
forall blk. SchedulePoint blk -> Bool
isTip (SchedulePoint blk -> Bool)
-> ((Time, SchedulePoint blk) -> SchedulePoint blk)
-> (Time, SchedulePoint blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, SchedulePoint blk) -> SchedulePoint blk
forall a b. (a, b) -> b
snd)

bumpTips :: [Time] -> [(Time, SchedulePoint blk)] -> [(Time, SchedulePoint blk)]
bumpTips :: forall blk.
[Time]
-> [(Time, SchedulePoint blk)] -> [(Time, SchedulePoint blk)]
bumpTips [Time]
tips =
  ([Time], [(Time, SchedulePoint blk)])
-> [(Time, SchedulePoint blk)]
forall a b. (a, b) -> b
snd (([Time], [(Time, SchedulePoint blk)])
 -> [(Time, SchedulePoint blk)])
-> ([(Time, SchedulePoint blk)]
    -> ([Time], [(Time, SchedulePoint blk)]))
-> [(Time, SchedulePoint blk)]
-> [(Time, SchedulePoint blk)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Time]
 -> (Time, SchedulePoint blk)
 -> ([Time], (Time, SchedulePoint blk)))
-> [Time]
-> [(Time, SchedulePoint blk)]
-> ([Time], [(Time, SchedulePoint blk)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL [Time]
-> (Time, SchedulePoint blk) -> ([Time], (Time, SchedulePoint blk))
forall {a} {blk}.
[a] -> (a, SchedulePoint blk) -> ([a], (a, SchedulePoint blk))
step [Time]
tips
 where
  step :: [a] -> (a, SchedulePoint blk) -> ([a], (a, SchedulePoint blk))
step (a
t0 : [a]
tn) (a
_, SchedulePoint blk
p)
    | SchedulePoint blk -> Bool
forall blk. SchedulePoint blk -> Bool
isTip SchedulePoint blk
p =
        ([a]
tn, (a
t0, SchedulePoint blk
p))
  step [a]
ts (a, SchedulePoint blk)
a = ([a]
ts, (a, SchedulePoint blk)
a)

syncTips ::
  [[(Time, SchedulePoint blk)]] ->
  [[(Time, SchedulePoint blk)]] ->
  ([[(Time, SchedulePoint blk)]], [[(Time, SchedulePoint blk)]])
syncTips :: forall blk.
[[(Time, SchedulePoint blk)]]
-> [[(Time, SchedulePoint blk)]]
-> ([[(Time, SchedulePoint blk)]], [[(Time, SchedulePoint blk)]])
syncTips [[(Time, SchedulePoint blk)]]
honests [[(Time, SchedulePoint blk)]]
advs =
  ([(Time, SchedulePoint blk)] -> [(Time, SchedulePoint blk)]
forall blk. PeerSchedule blk -> PeerSchedule blk
bump ([(Time, SchedulePoint blk)] -> [(Time, SchedulePoint blk)])
-> [[(Time, SchedulePoint blk)]] -> [[(Time, SchedulePoint blk)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(Time, SchedulePoint blk)]]
honests, [(Time, SchedulePoint blk)] -> [(Time, SchedulePoint blk)]
forall blk. PeerSchedule blk -> PeerSchedule blk
bump ([(Time, SchedulePoint blk)] -> [(Time, SchedulePoint blk)])
-> [[(Time, SchedulePoint blk)]] -> [[(Time, SchedulePoint blk)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(Time, SchedulePoint blk)]]
advs)
 where
  bump :: [(Time, SchedulePoint blk)] -> [(Time, SchedulePoint blk)]
bump = [Time]
-> [(Time, SchedulePoint blk)] -> [(Time, SchedulePoint blk)]
forall blk.
[Time]
-> [(Time, SchedulePoint blk)] -> [(Time, SchedulePoint blk)]
bumpTips [Time]
earliestTips
  earliestTips :: [Time]
earliestTips = [Maybe Time] -> Time
forall {t :: * -> *}.
(Foldable t, Functor t) =>
t (Maybe Time) -> Time
chooseEarliest ([Maybe Time] -> Time) -> [[Maybe Time]] -> [Time]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Time]] -> [[Maybe Time]]
forall a. [[a]] -> [[Maybe a]]
zipPadN ([(Time, SchedulePoint blk)] -> [Time]
forall blk. [(Time, SchedulePoint blk)] -> [Time]
tipTimes ([(Time, SchedulePoint blk)] -> [Time])
-> [[(Time, SchedulePoint blk)]] -> [[Time]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(Time, SchedulePoint blk)]]
scheds)
  scheds :: [[(Time, SchedulePoint blk)]]
scheds = [[(Time, SchedulePoint blk)]]
honests [[(Time, SchedulePoint blk)]]
-> [[(Time, SchedulePoint blk)]] -> [[(Time, SchedulePoint blk)]]
forall a. Semigroup a => a -> a -> a
<> [[(Time, SchedulePoint blk)]]
advs
  chooseEarliest :: t (Maybe Time) -> Time
chooseEarliest t (Maybe Time)
times = t Time -> Time
forall a. Ord a => t a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (Time -> Maybe Time -> Time
forall a. a -> Maybe a -> a
fromMaybe (DiffTime -> Time
Time DiffTime
0) (Maybe Time -> Time) -> t (Maybe Time) -> t Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (Maybe Time)
times)

-- | This is a variant of 'uniformPointsWithExtraHonestPeers' that uses multiple tip points, used to simulate node downtimes.
-- Ultimately, this should be replaced by a redesign of the peer schedule generator that is aware of node liveness
-- intervals.
--
-- Chooses the first tip points somewhere in the middle of the honest chain:
-- The "pause slot" is half of the honest head slot, or the slot of the kth block, whichever is greater.
-- The last block smaller than the pause slot is then used as the first tip for each branch.
-- The second tip is the last block of each branch.
--
-- Includes rollbacks in some schedules.
uniformPointsWithExtraHonestPeersAndDowntime ::
  forall g m blk.
  (StatefulGen g m, AF.HasHeader blk) =>
  Int ->
  SecurityParam ->
  BlockTree blk ->
  g ->
  m (PointSchedule blk)
uniformPointsWithExtraHonestPeersAndDowntime :: forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
Int -> SecurityParam -> BlockTree blk -> g -> m (PointSchedule blk)
uniformPointsWithExtraHonestPeersAndDowntime
  Int
extraHonestPeers
  (SecurityParam NonZero Word64
k)
  BlockTree{AnchoredFragment blk
btTrunk :: forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk :: AnchoredFragment blk
btTrunk, [BlockTreeBranch blk]
btBranches :: forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches :: [BlockTreeBranch blk]
btBranches}
  g
g =
    do
      let
        kSlot :: Int
kSlot =
          Int -> (SlotNo -> Int) -> WithOrigin SlotNo -> Int
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin
            Int
0
            (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> (SlotNo -> Word64) -> SlotNo -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> Word64
unSlotNo)
            (AnchoredFragment blk -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot (Int -> AnchoredFragment blk -> AnchoredFragment blk
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.takeOldest (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
k) AnchoredFragment blk
btTrunk))
        midSlot :: Int
midSlot = (AnchoredFragment blk -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment blk
btTrunk) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
        lowerBound :: Int
lowerBound = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
kSlot Int
midSlot
      pauseSlot <- Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> (Int -> Word64) -> Int -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> SlotNo) -> m Int -> m SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> g -> m Int
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *). StatefulGen g m => (Int, Int) -> g -> m Int
Random.uniformRM (Int
lowerBound, AnchoredFragment blk -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment blk
btTrunk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) g
g
      honestTip0 <- firstTip pauseSlot btTrunk
      honests <-
        replicateM (extraHonestPeers + 1) $
          mkSchedule [(IsTrunk, [honestTip0, minusClamp (AF.length btTrunk) 1])] []
      advs <- takeBranches pauseSlot btBranches
      let (honests', advs') = syncTips honests advs
          psSchedule = [[(Time, SchedulePoint blk)]]
-> [[(Time, SchedulePoint blk)]]
-> Peers [(Time, SchedulePoint blk)]
forall a. [a] -> [a] -> Peers a
peers' [[(Time, SchedulePoint blk)]]
honests' [[(Time, SchedulePoint blk)]]
advs'
      psStartOrder <- shuffle $ getPeerIds psSchedule
      pure $ PointSchedule{psSchedule, psStartOrder, psMinEndTime = Time 0}
   where
    takeBranches :: SlotNo -> [BlockTreeBranch blk] -> m [[(Time, SchedulePoint blk)]]
takeBranches SlotNo
pause = \case
      [] -> [[(Time, SchedulePoint blk)]] -> m [[(Time, SchedulePoint blk)]]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      [BlockTreeBranch blk
b] -> [(Time, SchedulePoint blk)] -> [[(Time, SchedulePoint blk)]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Time, SchedulePoint blk)] -> [[(Time, SchedulePoint blk)]])
-> m [(Time, SchedulePoint blk)] -> m [[(Time, SchedulePoint blk)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotNo -> BlockTreeBranch blk -> m [(Time, SchedulePoint blk)]
withoutRollback SlotNo
pause BlockTreeBranch blk
b
      BlockTreeBranch blk
b1 : BlockTreeBranch blk
b2 : [BlockTreeBranch blk]
branches -> do
        a <- g -> m Double
forall g (m :: * -> *). StatefulGen g m => g -> m Double
Random.uniformDouble01M g
g
        if a < rollbackProb
          then do
            this <- withRollback pause b1 b2
            rest <- takeBranches pause branches
            pure (this : rest)
          else do
            this <- withoutRollback pause b1
            rest <- takeBranches pause (b2 : branches)
            pure (this : rest)

    withoutRollback :: SlotNo -> BlockTreeBranch blk -> m [(Time, SchedulePoint blk)]
withoutRollback SlotNo
pause BlockTreeBranch blk
branch = do
      tips <- SlotNo -> BlockTreeBranch blk -> m [(IsTrunk, [Int])]
forall {m :: * -> *} {b}.
(Monad m, HasHeader b) =>
SlotNo -> BlockTreeBranch b -> m [(IsTrunk, [Int])]
mkTips SlotNo
pause BlockTreeBranch blk
branch
      mkSchedule tips [btbSuffix branch]

    withRollback :: SlotNo
-> BlockTreeBranch blk
-> BlockTreeBranch blk
-> m [(Time, SchedulePoint blk)]
withRollback SlotNo
pause BlockTreeBranch blk
b1 BlockTreeBranch blk
b2 = do
      firstTips <- SlotNo -> BlockTreeBranch blk -> m [(IsTrunk, [Int])]
forall {m :: * -> *} {b}.
(Monad m, HasHeader b) =>
SlotNo -> BlockTreeBranch b -> m [(IsTrunk, [Int])]
mkTips SlotNo
pause BlockTreeBranch blk
b1
      let secondTips = [Int -> Int -> Int
forall a. (Ord a, Num a) => a -> a -> a
minusClamp (AnchoredFragment blk -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length (BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix BlockTreeBranch blk
b2)) Int
1]
      mkSchedule (firstTips ++ [(IsBranch, secondTips)]) [btbSuffix b1, btbSuffix b2]

    mkSchedule :: [(IsTrunk, [Int])]
-> [AnchoredFragment blk] -> m [(Time, SchedulePoint blk)]
mkSchedule [(IsTrunk, [Int])]
tips [AnchoredFragment blk]
branches = do
      params <- m PeerScheduleParams
mkParams
      peerScheduleFromTipPoints g params tips btTrunk branches

    mkTips :: SlotNo -> BlockTreeBranch b -> m [(IsTrunk, [Int])]
mkTips SlotNo
pause BlockTreeBranch b
branch
      | AnchoredSeq (WithOrigin SlotNo) (Anchor b) b -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredSeq (WithOrigin SlotNo) (Anchor b) b
full Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =
          String -> m [(IsTrunk, [Int])]
forall a. HasCallStack => String -> a
error String
"empty branch"
      | Bool
otherwise = do
          tip0 <- SlotNo -> AnchoredSeq (WithOrigin SlotNo) (Anchor b) b -> m Int
forall {f :: * -> *} {v} {a} {b}.
(Applicative f, Anchorable v a b, HasHeader b) =>
SlotNo -> AnchoredSeq v a b -> f Int
firstTip SlotNo
pause (BlockTreeBranch b -> AnchoredSeq (WithOrigin SlotNo) (Anchor b) b
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull BlockTreeBranch b
branch)
          let (pre, post) = partition (< firstSuffixBlock) [tip0, fullLen - 1]
          pure ((if null pre then [] else [(IsTrunk, pre)]) ++ [(IsBranch, shift <$> post)])
     where
      shift :: Int -> Int
shift Int
i = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstSuffixBlock
      firstSuffixBlock :: Int
firstSuffixBlock = Int
fullLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- AnchoredSeq (WithOrigin SlotNo) (Anchor b) b -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length (BlockTreeBranch b -> AnchoredSeq (WithOrigin SlotNo) (Anchor b) b
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix BlockTreeBranch b
branch)
      fullLen :: Int
fullLen = AnchoredSeq (WithOrigin SlotNo) (Anchor b) b -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredSeq (WithOrigin SlotNo) (Anchor b) b
full
      full :: AnchoredSeq (WithOrigin SlotNo) (Anchor b) b
full = BlockTreeBranch b -> AnchoredSeq (WithOrigin SlotNo) (Anchor b) b
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull BlockTreeBranch b
branch

    firstTip :: SlotNo -> AnchoredSeq v a b -> f Int
firstTip SlotNo
pause AnchoredSeq v a b
frag = Int -> f Int
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Int
forall a. (Ord a, Num a) => a -> a -> a
minusClamp (AnchoredSeq v a b -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length ((b -> Bool) -> AnchoredSeq v a b -> AnchoredSeq v a b
forall v a b.
Anchorable v a b =>
(b -> Bool) -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.dropWhileNewest (\b
b -> b -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot b
b SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
pause) AnchoredSeq v a b
frag)) Int
1)

    mkParams :: m PeerScheduleParams
mkParams = do
      -- These values appear to be large enough to create pauses of 100 seconds and more.
      tipL <- (DiffTime, DiffTime) -> g -> m DiffTime
forall g (m :: * -> *).
StatefulGen g m =>
(DiffTime, DiffTime) -> g -> m DiffTime
uniformRMDiffTime (DiffTime
0.5, DiffTime
1) g
g
      tipU <- uniformRMDiffTime (1, 2) g
      headerL <- uniformRMDiffTime (0.018, 0.03) g
      headerU <- uniformRMDiffTime (0.021, 0.04) g
      pure
        defaultPeerScheduleParams
          { pspTipDelayInterval = (tipL, tipU)
          , pspHeaderDelayInterval = (headerL, headerU)
          }

    rollbackProb :: Double
rollbackProb = Double
0.2

    -- Inefficient implementation, but sufficient for small lists.
    shuffle :: [a] -> m [a]
    shuffle :: forall a. [a] -> m [a]
shuffle [] = [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    shuffle [a]
xs = do
      i <- (Int, Int) -> g -> m Int
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *). StatefulGen g m => (Int, Int) -> g -> m Int
Random.uniformRM (Int
0, [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) g
g
      let x = [a]
xs [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
          xs' = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
i [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [a]
xs
      (x :) <$> shuffle xs'

newtype ForecastRange = ForecastRange {ForecastRange -> Word64
unForecastRange :: Word64}
  deriving Int -> ForecastRange -> String -> String
[ForecastRange] -> String -> String
ForecastRange -> String
(Int -> ForecastRange -> String -> String)
-> (ForecastRange -> String)
-> ([ForecastRange] -> String -> String)
-> Show ForecastRange
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ForecastRange -> String -> String
showsPrec :: Int -> ForecastRange -> String -> String
$cshow :: ForecastRange -> String
show :: ForecastRange -> String
$cshowList :: [ForecastRange] -> String -> String
showList :: [ForecastRange] -> String -> String
Show

data LoPBucketParams = LoPBucketParams
  { LoPBucketParams -> Integer
lbpCapacity :: Integer
  , LoPBucketParams -> Rational
lbpRate :: Rational
  }

data CSJParams = CSJParams
  { CSJParams -> SlotNo
csjpJumpSize :: SlotNo
  }
  deriving Int -> CSJParams -> String -> String
[CSJParams] -> String -> String
CSJParams -> String
(Int -> CSJParams -> String -> String)
-> (CSJParams -> String)
-> ([CSJParams] -> String -> String)
-> Show CSJParams
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> CSJParams -> String -> String
showsPrec :: Int -> CSJParams -> String -> String
$cshow :: CSJParams -> String
show :: CSJParams -> String
$cshowList :: [CSJParams] -> String -> String
showList :: [CSJParams] -> String -> String
Show

-- | Similar to 'ChainSyncTimeout' for BlockFetch. Only the states in which the
-- server has agency are specified. REVIEW: Should it be upstreamed to
-- ouroboros-network-protocols?
data BlockFetchTimeout = BlockFetchTimeout
  { BlockFetchTimeout -> Maybe DiffTime
busyTimeout :: Maybe DiffTime
  , BlockFetchTimeout -> Maybe DiffTime
streamingTimeout :: Maybe DiffTime
  }

-- | All the data used by point schedule tests.
data GenesisTest blk schedule = GenesisTest
  { forall blk schedule. GenesisTest blk schedule -> SecurityParam
gtSecurityParam :: SecurityParam
  , forall blk schedule. GenesisTest blk schedule -> GenesisWindow
gtGenesisWindow :: GenesisWindow
  , forall blk schedule. GenesisTest blk schedule -> ForecastRange
gtForecastRange :: ForecastRange -- REVIEW: Do we want to allow infinite forecast ranges?
  , forall blk schedule. GenesisTest blk schedule -> Delta
gtDelay :: Delta
  , forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree blk
  , forall blk schedule. GenesisTest blk schedule -> ChainSyncTimeout
gtChainSyncTimeouts :: ChainSyncTimeout
  , forall blk schedule. GenesisTest blk schedule -> BlockFetchTimeout
gtBlockFetchTimeouts :: BlockFetchTimeout
  , forall blk schedule. GenesisTest blk schedule -> LoPBucketParams
gtLoPBucketParams :: LoPBucketParams
  , forall blk schedule. GenesisTest blk schedule -> CSJParams
gtCSJParams :: CSJParams
  , forall blk schedule. GenesisTest blk schedule -> SlotLength
gtSlotLength :: SlotLength
  , forall blk schedule. GenesisTest blk schedule -> Word
gtExtraHonestPeers :: Word
  -- ^ The number of extra honest peers we want in the test.
  -- It is stored here for convenience, and because it may affect schedule and block tree generation.
  --
  -- There will be at most one adversarial peer per alternative branch in the block tree
  -- (exactly one per branch if no adversary does a rollback),
  -- and @1 + gtExtraHonestPeers@ honest peers.
  , forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule :: schedule
  }

type GenesisTestFull blk = GenesisTest blk (PointSchedule blk)

-- | All the data describing the result of a test
data RunGenesisTestResult = RunGenesisTestResult
  { RunGenesisTestResult -> String
rgtrTrace :: String
  , RunGenesisTestResult -> StateView TestBlock
rgtrStateView :: StateView TestBlock
  }

prettyGenesisTest :: (schedule -> [String]) -> GenesisTest TestBlock schedule -> [String]
prettyGenesisTest :: forall schedule.
(schedule -> [String])
-> GenesisTest TestBlock schedule -> [String]
prettyGenesisTest schedule -> [String]
prettySchedule GenesisTest TestBlock schedule
genesisTest =
  [ String
"GenesisTest:"
  , String
"  gtSecurityParam: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonZero Word64 -> String
forall a. Show a => a -> String
show (SecurityParam -> NonZero Word64
maxRollbacks SecurityParam
gtSecurityParam)
  , String
"  gtGenesisWindow: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (GenesisWindow -> Word64
unGenesisWindow GenesisWindow
gtGenesisWindow)
  , String
"  gtForecastRange: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (ForecastRange -> Word64
unForecastRange ForecastRange
gtForecastRange)
  , String
"  gtDelay: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
delta
  , String
"  gtSlotLength: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SlotLength -> String
forall a. Show a => a -> String
show SlotLength
gtSlotLength
  , String
"  gtCSJParams: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CSJParams -> String
forall a. Show a => a -> String
show CSJParams
gtCSJParams
  , String
"  gtChainSyncTimeouts: "
  , String
"    canAwait = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe DiffTime -> String
forall a. Show a => a -> String
show Maybe DiffTime
canAwaitTimeout
  , String
"    intersect = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe DiffTime -> String
forall a. Show a => a -> String
show Maybe DiffTime
intersectTimeout
  , String
"    mustReply = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe DiffTime -> String
forall a. Show a => a -> String
show Maybe DiffTime
mustReplyTimeout
  , String
"    idle = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe DiffTime -> String
forall a. Show a => a -> String
show Maybe DiffTime
idleTimeout
  , String
"  gtBlockFetchTimeouts: "
  , String
"    busy = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe DiffTime -> String
forall a. Show a => a -> String
show Maybe DiffTime
busyTimeout
  , String
"    streaming = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe DiffTime -> String
forall a. Show a => a -> String
show Maybe DiffTime
streamingTimeout
  , String
"  gtLoPBucketParams: "
  , String
"    lbpCapacity = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
lbpCapacity String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tokens"
  , String
"    lbpRate = "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rational -> String
forall a. Show a => a -> String
show Rational
lbpRate
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ≅ "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Float -> String
forall r. PrintfType r => String -> r
printf String
"%.2f" (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
lbpRate :: Float)
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tokens per second"
  , String
"  gtBlockTree:"
  ]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (AnchoredFragment TestBlock -> String)
-> [AnchoredFragment TestBlock] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (AnchoredFragment TestBlock -> String)
-> AnchoredFragment TestBlock
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment TestBlock -> String
terseFragment) (BlockTree TestBlock -> [AnchoredFragment TestBlock]
forall blk. BlockTree blk -> [AnchoredFragment blk]
allFragments BlockTree TestBlock
gtBlockTree)
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (BlockTree TestBlock -> [String]
forall blk. HasHeader blk => BlockTree blk -> [String]
prettyBlockTree BlockTree TestBlock
gtBlockTree)
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"  gtSchedule:"]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (schedule -> [String]
prettySchedule schedule
gtSchedule)
 where
  GenesisTest
    { SecurityParam
gtSecurityParam :: forall blk schedule. GenesisTest blk schedule -> SecurityParam
gtSecurityParam :: SecurityParam
gtSecurityParam
    , GenesisWindow
gtGenesisWindow :: forall blk schedule. GenesisTest blk schedule -> GenesisWindow
gtGenesisWindow :: GenesisWindow
gtGenesisWindow
    , ForecastRange
gtForecastRange :: forall blk schedule. GenesisTest blk schedule -> ForecastRange
gtForecastRange :: ForecastRange
gtForecastRange
    , gtDelay :: forall blk schedule. GenesisTest blk schedule -> Delta
gtDelay = Delta Int
delta
    , BlockTree TestBlock
gtBlockTree :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree TestBlock
gtBlockTree
    , gtChainSyncTimeouts :: forall blk schedule. GenesisTest blk schedule -> ChainSyncTimeout
gtChainSyncTimeouts =
      ChainSyncTimeout{Maybe DiffTime
canAwaitTimeout :: Maybe DiffTime
canAwaitTimeout :: ChainSyncTimeout -> Maybe DiffTime
canAwaitTimeout, Maybe DiffTime
intersectTimeout :: Maybe DiffTime
intersectTimeout :: ChainSyncTimeout -> Maybe DiffTime
intersectTimeout, Maybe DiffTime
mustReplyTimeout :: Maybe DiffTime
mustReplyTimeout :: ChainSyncTimeout -> Maybe DiffTime
mustReplyTimeout, Maybe DiffTime
idleTimeout :: Maybe DiffTime
idleTimeout :: ChainSyncTimeout -> Maybe DiffTime
idleTimeout}
    , gtBlockFetchTimeouts :: forall blk schedule. GenesisTest blk schedule -> BlockFetchTimeout
gtBlockFetchTimeouts = BlockFetchTimeout{Maybe DiffTime
busyTimeout :: BlockFetchTimeout -> Maybe DiffTime
busyTimeout :: Maybe DiffTime
busyTimeout, Maybe DiffTime
streamingTimeout :: BlockFetchTimeout -> Maybe DiffTime
streamingTimeout :: Maybe DiffTime
streamingTimeout}
    , gtLoPBucketParams :: forall blk schedule. GenesisTest blk schedule -> LoPBucketParams
gtLoPBucketParams = LoPBucketParams{Integer
lbpCapacity :: LoPBucketParams -> Integer
lbpCapacity :: Integer
lbpCapacity, Rational
lbpRate :: LoPBucketParams -> Rational
lbpRate :: Rational
lbpRate}
    , SlotLength
gtSlotLength :: forall blk schedule. GenesisTest blk schedule -> SlotLength
gtSlotLength :: SlotLength
gtSlotLength
    , CSJParams
gtCSJParams :: forall blk schedule. GenesisTest blk schedule -> CSJParams
gtCSJParams :: CSJParams
gtCSJParams
    , schedule
gtSchedule :: forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule :: schedule
gtSchedule
    } = GenesisTest TestBlock schedule
genesisTest

instance Functor (GenesisTest blk) where
  fmap :: forall a b. (a -> b) -> GenesisTest blk a -> GenesisTest blk b
fmap a -> b
f gt :: GenesisTest blk a
gt@GenesisTest{a
gtSchedule :: forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule :: a
gtSchedule} = GenesisTest blk a
gt{gtSchedule = f gtSchedule}

enrichedWith :: (Functor f, Monad m) => m (f a) -> (f a -> m b) -> m (f b)
enrichedWith :: forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
enrichedWith m (f a)
mfa f a -> m b
convert = m (f a)
mfa m (f a) -> (f a -> m (f b)) -> m (f b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \f a
fa -> (f a
fa f a -> b -> f b
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>) (b -> f b) -> m b -> m (f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> m b
convert f a
fa

-- | Wrap a 'ST' generator in 'Gen'.
stToGen ::
  (forall s. STGenM QCGen s -> ST s a) ->
  Gen a
stToGen :: forall a. (forall s. STGenM QCGen s -> ST s a) -> Gen a
stToGen forall s. STGenM QCGen s -> ST s a
gen = do
  seed :: QCGen <- Gen QCGen
forall a. Arbitrary a => Gen a
arbitrary
  pure (runSTGen_ seed gen)

ensureScheduleDuration :: GenesisTest blk a -> PointSchedule blk -> PointSchedule blk
ensureScheduleDuration :: forall blk a.
GenesisTest blk a -> PointSchedule blk -> PointSchedule blk
ensureScheduleDuration GenesisTest blk a
gt PointSchedule{Peers (PeerSchedule blk)
psSchedule :: forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule, [PeerId]
psStartOrder :: forall blk. PointSchedule blk -> [PeerId]
psStartOrder :: [PeerId]
psStartOrder, Time
psMinEndTime :: forall blk. PointSchedule blk -> Time
psMinEndTime :: Time
psMinEndTime} =
  PointSchedule
    { Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule
    , [PeerId]
psStartOrder :: [PeerId]
psStartOrder :: [PeerId]
psStartOrder
    , psMinEndTime :: Time
psMinEndTime = Time -> Time -> Time
forall a. Ord a => a -> a -> a
max Time
psMinEndTime (DiffTime -> Time
Time DiffTime
endingDelay)
    }
 where
  endingDelay :: DiffTime
endingDelay =
    let cst :: ChainSyncTimeout
cst = GenesisTest blk a -> ChainSyncTimeout
forall blk schedule. GenesisTest blk schedule -> ChainSyncTimeout
gtChainSyncTimeouts GenesisTest blk a
gt
        bft :: BlockFetchTimeout
bft = GenesisTest blk a -> BlockFetchTimeout
forall blk schedule. GenesisTest blk schedule -> BlockFetchTimeout
gtBlockFetchTimeouts GenesisTest blk a
gt
        bfGracePeriodDelay :: DiffTime
bfGracePeriodDelay = Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
adversaryCount DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
10
     in DiffTime
1
          DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
bfGracePeriodDelay
          DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
peerCount
            DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* [DiffTime] -> DiffTime
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum
              ( DiffTime
0
                  DiffTime -> [DiffTime] -> [DiffTime]
forall a. a -> [a] -> [a]
: [Maybe DiffTime] -> [DiffTime]
forall a. [Maybe a] -> [a]
catMaybes
                    [ ChainSyncTimeout -> Maybe DiffTime
canAwaitTimeout ChainSyncTimeout
cst
                    , ChainSyncTimeout -> Maybe DiffTime
intersectTimeout ChainSyncTimeout
cst
                    , BlockFetchTimeout -> Maybe DiffTime
busyTimeout BlockFetchTimeout
bft
                    , BlockFetchTimeout -> Maybe DiffTime
streamingTimeout BlockFetchTimeout
bft
                    ]
              )
  peerCount :: Int
peerCount = [Peer (PeerSchedule blk)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Peers (PeerSchedule blk) -> [Peer (PeerSchedule blk)]
forall a. Peers a -> [Peer a]
peersList Peers (PeerSchedule blk)
psSchedule)
  adversaryCount :: Int
adversaryCount = Map Int (PeerSchedule blk) -> Int
forall k a. Map k a -> Int
Map.size (Peers (PeerSchedule blk) -> Map Int (PeerSchedule blk)
forall a. Peers a -> Map Int a
adversarialPeers Peers (PeerSchedule blk)
psSchedule)