{-# 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
  , mkPointSchedule
  , peerSchedulesBlocks
  , peerStates
  , peersStates
  , peersStatesRelative
  , prettyGenesisTest
  , prettyPointSchedule
  , stToGen
  , uniformPoints
  ) where

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.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 qualified System.Random.Stateful as Random
import           System.Random.Stateful (STGenM, StatefulGen, runSTGen_)
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 (..), Peers (..),
                     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 PointSchedule blk
peers =
  [ String
"honest peers: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (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
honestPeers (Peers (PeerSchedule blk) -> Map Int (PeerSchedule blk))
-> Peers (PeerSchedule blk) -> Map Int (PeerSchedule blk)
forall a b. (a -> b) -> a -> b
$ PointSchedule blk -> Peers (PeerSchedule blk)
forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule PointSchedule blk
peers))
  , String
"adversaries: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (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) -> Map Int (PeerSchedule blk))
-> Peers (PeerSchedule blk) -> Map Int (PeerSchedule blk)
forall a b. (a -> b) -> a -> b
$ PointSchedule blk -> Peers (PeerSchedule blk)
forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule PointSchedule blk
peers))
  , String
"minimal duration: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Time -> String
forall a. Show a => a -> String
show (PointSchedule blk -> Time
forall blk. PointSchedule blk -> Time
psMinEndTime PointSchedule blk
peers)
  ] [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
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)
  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
peers)

    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.
--
-- Also 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 preliminary 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.
--
-- 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
$sel:name:Peer :: forall a. Peer a -> PeerId
name, $sel:value:Peer :: 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 -> Time) -> [Time] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map Time -> Time
shiftTime [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
    shiftTime :: Time -> Time
    shiftTime :: Time -> Time
shiftTime Time
t = DiffTime -> Time -> Time
addTime (- DiffTime
firstTipOffset) Time
t

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

    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)
$sel:psSchedule:PointSchedule :: forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule :: 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 {
    -- | The actual point schedule
    forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule   :: Peers (PeerSchedule blk),
    -- | 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.
    forall blk. PointSchedule blk -> Time
psMinEndTime :: Time
  }

mkPointSchedule :: Peers (PeerSchedule blk) -> PointSchedule blk
mkPointSchedule :: forall blk. Peers (PeerSchedule blk) -> PointSchedule blk
mkPointSchedule Peers (PeerSchedule blk)
sch = Peers (PeerSchedule blk) -> Time -> PointSchedule blk
forall blk. Peers (PeerSchedule blk) -> Time -> PointSchedule blk
PointSchedule Peers (PeerSchedule blk)
sch (Time -> PointSchedule blk) -> Time -> PointSchedule blk
forall a b. (a -> b) -> a -> b
$ DiffTime -> Time
Time DiffTime
0

-- | 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
  [(Time, SchedulePoint blk)]
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 []
  [(Time, SchedulePoint blk)]
adv <- 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
advParams [(IsTrunk
IsBranch, [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
btbFull BlockTreeBranch blk
branch) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1])] AnchoredFragment blk
btTrunk [BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull BlockTreeBranch blk
branch]
  PointSchedule blk -> m (PointSchedule blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PointSchedule blk -> m (PointSchedule blk))
-> PointSchedule blk -> m (PointSchedule blk)
forall a b. (a -> b) -> a -> b
$ Peers [(Time, SchedulePoint blk)] -> PointSchedule blk
forall blk. Peers (PeerSchedule blk) -> PointSchedule blk
mkPointSchedule (Peers [(Time, SchedulePoint blk)] -> PointSchedule blk)
-> Peers [(Time, SchedulePoint blk)] -> PointSchedule blk
forall a b. (a -> b) -> a -> b
$ [[(Time, SchedulePoint blk)]]
-> [[(Time, SchedulePoint blk)]]
-> Peers [(Time, SchedulePoint blk)]
forall a. [a] -> [a] -> Peers a
peers' [[(Time, SchedulePoint blk)]
honest] [[(Time, SchedulePoint blk)]
adv]
  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
$sel:pgpExtraHonestPeers:PointsGeneratorParams :: PointsGeneratorParams -> Int
pgpExtraHonestPeers :: Int
pgpExtraHonestPeers, DowntimeParams
$sel:pgpDowntime:PointsGeneratorParams :: PointsGeneratorParams -> DowntimeParams
pgpDowntime :: DowntimeParams
pgpDowntime} = 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
  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

-- | 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 ::
  (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
  Int
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
  [[(Time, SchedulePoint blk)]]
honests <- Int
-> m [(Time, SchedulePoint blk)] -> m [[(Time, SchedulePoint blk)]]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
extraHonestPeers Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (m [(Time, SchedulePoint blk)] -> m [[(Time, SchedulePoint blk)]])
-> m [(Time, SchedulePoint blk)] -> m [[(Time, SchedulePoint blk)]]
forall a b. (a -> b) -> a -> b
$
    [(IsTrunk, [Int])]
-> [AnchoredFragment blk] -> m [(Time, SchedulePoint blk)]
mkSchedule [(IsTrunk
IsTrunk, [Int
honestTip0 .. 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])] []
  [[(Time, SchedulePoint blk)]]
advs <- [BlockTreeBranch blk] -> m [[(Time, SchedulePoint blk)]]
takeBranches [BlockTreeBranch blk]
btBranches
  PointSchedule blk -> m (PointSchedule blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PointSchedule blk -> m (PointSchedule blk))
-> PointSchedule blk -> m (PointSchedule blk)
forall a b. (a -> b) -> a -> b
$ Peers [(Time, SchedulePoint blk)] -> PointSchedule blk
forall blk. Peers (PeerSchedule blk) -> PointSchedule blk
mkPointSchedule (Peers [(Time, SchedulePoint blk)] -> PointSchedule blk)
-> Peers [(Time, SchedulePoint blk)] -> PointSchedule blk
forall a b. (a -> b) -> a -> b
$ [[(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
  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
          Double
a <- g -> m Double
forall g (m :: * -> *). StatefulGen g m => g -> m Double
Random.uniformDouble01M g
g
          if Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
rollbackProb
          then do
            [(Time, SchedulePoint blk)]
this <- BlockTreeBranch blk
-> BlockTreeBranch blk -> m [(Time, SchedulePoint blk)]
withRollback BlockTreeBranch blk
b1 BlockTreeBranch blk
b2
            [[(Time, SchedulePoint blk)]]
rest <- [BlockTreeBranch blk] -> m [[(Time, SchedulePoint blk)]]
takeBranches [BlockTreeBranch blk]
branches
            [[(Time, SchedulePoint blk)]] -> m [[(Time, SchedulePoint blk)]]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Time, SchedulePoint blk)]
this [(Time, SchedulePoint blk)]
-> [[(Time, SchedulePoint blk)]] -> [[(Time, SchedulePoint blk)]]
forall a. a -> [a] -> [a]
: [[(Time, SchedulePoint blk)]]
rest)
          else do
            [(Time, SchedulePoint blk)]
this <- BlockTreeBranch blk -> m [(Time, SchedulePoint blk)]
withoutRollback BlockTreeBranch blk
b1
            [[(Time, SchedulePoint blk)]]
rest <- [BlockTreeBranch blk] -> m [[(Time, SchedulePoint blk)]]
takeBranches (BlockTreeBranch blk
b2 BlockTreeBranch blk
-> [BlockTreeBranch blk] -> [BlockTreeBranch blk]
forall a. a -> [a] -> [a]
: [BlockTreeBranch blk]
branches)
            [[(Time, SchedulePoint blk)]] -> m [[(Time, SchedulePoint blk)]]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Time, SchedulePoint blk)]
this [(Time, SchedulePoint blk)]
-> [[(Time, SchedulePoint blk)]] -> [[(Time, SchedulePoint blk)]]
forall a. a -> [a] -> [a]
: [[(Time, SchedulePoint blk)]]
rest)

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

    withRollback :: BlockTreeBranch blk
-> BlockTreeBranch blk -> m [(Time, SchedulePoint blk)]
withRollback BlockTreeBranch blk
b1 BlockTreeBranch blk
b2 = do
      [(IsTrunk, [Int])]
firstTips <- BlockTreeBranch blk -> m [(IsTrunk, [Int])]
forall {m :: * -> *} {b}.
(Monad m, HasHeader b) =>
BlockTreeBranch b -> m [(IsTrunk, [Int])]
mkTips BlockTreeBranch blk
b1
      let secondTips :: [Int]
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]
      [(IsTrunk, [Int])]
-> [AnchoredFragment blk] -> m [(Time, SchedulePoint blk)]
mkSchedule ([(IsTrunk, [Int])]
firstTips [(IsTrunk, [Int])] -> [(IsTrunk, [Int])] -> [(IsTrunk, [Int])]
forall a. [a] -> [a] -> [a]
++ [(IsTrunk
IsBranch, [Int]
secondTips)]) [BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix BlockTreeBranch blk
b1, BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix BlockTreeBranch blk
b2]

    mkSchedule :: [(IsTrunk, [Int])]
-> [AnchoredFragment blk] -> m [(Time, SchedulePoint blk)]
mkSchedule [(IsTrunk, [Int])]
tips [AnchoredFragment blk]
branches = do
      PeerScheduleParams
params <- m PeerScheduleParams
mkParams
      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
params [(IsTrunk, [Int])]
tips AnchoredFragment blk
btTrunk [AnchoredFragment blk]
branches

    mkTips :: BlockTreeBranch b -> m [(IsTrunk, [Int])]
mkTips BlockTreeBranch b
branch = do
      Int
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 ([Int]
pre, [Int]
post) = (Int -> Bool) -> [Int] -> ([Int], [Int])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
firstSuffixBlock) [Int
tip0 .. Int
lastBlock]
      [(IsTrunk, [Int])] -> m [(IsTrunk, [Int])]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((if [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
pre then [] else [(IsTrunk
IsTrunk, [Int]
pre)]) [(IsTrunk, [Int])] -> [(IsTrunk, [Int])] -> [(IsTrunk, [Int])]
forall a. [a] -> [a] -> [a]
++ [(IsTrunk
IsBranch, (Int -> Int
shift (Int -> Int) -> [Int] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
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
      DiffTime
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
      DiffTime
tipU <- (DiffTime, DiffTime) -> g -> m DiffTime
forall g (m :: * -> *).
StatefulGen g m =>
(DiffTime, DiffTime) -> g -> m DiffTime
uniformRMDiffTime (DiffTime
1, DiffTime
2) g
g
      DiffTime
headerL <- (DiffTime, DiffTime) -> g -> m DiffTime
forall g (m :: * -> *).
StatefulGen g m =>
(DiffTime, DiffTime) -> g -> m DiffTime
uniformRMDiffTime (DiffTime
0.018, DiffTime
0.03) g
g
      DiffTime
headerU <- (DiffTime, DiffTime) -> g -> m DiffTime
forall g (m :: * -> *).
StatefulGen g m =>
(DiffTime, DiffTime) -> g -> m DiffTime
uniformRMDiffTime (DiffTime
0.021, DiffTime
0.04) g
g
      PeerScheduleParams -> m PeerScheduleParams
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PeerScheduleParams
defaultPeerScheduleParams {pspTipDelayInterval = (tipL, tipU), pspHeaderDelayInterval = (headerL, headerU)}

    rollbackProb :: Double
rollbackProb = Double
0.2

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}.
[(Time, SchedulePoint blk)] -> [(Time, SchedulePoint 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}.
[(Time, SchedulePoint blk)] -> [(Time, SchedulePoint 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 ::
  (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 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
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
  SlotNo
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
  Int
honestTip0 <- SlotNo -> AnchoredFragment blk -> m Int
forall {f :: * -> *} {v} {a} {b}.
(Applicative f, Anchorable v a b, HasHeader b) =>
SlotNo -> AnchoredSeq v a b -> f Int
firstTip SlotNo
pauseSlot AnchoredFragment blk
btTrunk
  [[(Time, SchedulePoint blk)]]
honests <- Int
-> m [(Time, SchedulePoint blk)] -> m [[(Time, SchedulePoint blk)]]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
extraHonestPeers Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (m [(Time, SchedulePoint blk)] -> m [[(Time, SchedulePoint blk)]])
-> m [(Time, SchedulePoint blk)] -> m [[(Time, SchedulePoint blk)]]
forall a b. (a -> b) -> a -> b
$
    [(IsTrunk, [Int])]
-> [AnchoredFragment blk] -> m [(Time, SchedulePoint blk)]
mkSchedule [(IsTrunk
IsTrunk, [Int
honestTip0, 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 AnchoredFragment blk
btTrunk) Int
1])] []
  [[(Time, SchedulePoint blk)]]
advs <- SlotNo -> [BlockTreeBranch blk] -> m [[(Time, SchedulePoint blk)]]
takeBranches SlotNo
pauseSlot [BlockTreeBranch blk]
btBranches
  let ([[(Time, SchedulePoint blk)]]
honests', [[(Time, SchedulePoint blk)]]
advs') = [[(Time, SchedulePoint blk)]]
-> [[(Time, SchedulePoint blk)]]
-> ([[(Time, SchedulePoint blk)]], [[(Time, SchedulePoint blk)]])
forall blk.
[[(Time, SchedulePoint blk)]]
-> [[(Time, SchedulePoint blk)]]
-> ([[(Time, SchedulePoint blk)]], [[(Time, SchedulePoint blk)]])
syncTips [[(Time, SchedulePoint blk)]]
honests [[(Time, SchedulePoint blk)]]
advs
  PointSchedule blk -> m (PointSchedule blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PointSchedule blk -> m (PointSchedule blk))
-> PointSchedule blk -> m (PointSchedule blk)
forall a b. (a -> b) -> a -> b
$ Peers [(Time, SchedulePoint blk)] -> PointSchedule blk
forall blk. Peers (PeerSchedule blk) -> PointSchedule blk
mkPointSchedule (Peers [(Time, SchedulePoint blk)] -> PointSchedule blk)
-> Peers [(Time, SchedulePoint blk)] -> PointSchedule blk
forall a b. (a -> b) -> a -> b
$ [[(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'
  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
          Double
a <- g -> m Double
forall g (m :: * -> *). StatefulGen g m => g -> m Double
Random.uniformDouble01M g
g
          if Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
rollbackProb
          then do
            [(Time, SchedulePoint blk)]
this <- SlotNo
-> BlockTreeBranch blk
-> BlockTreeBranch blk
-> m [(Time, SchedulePoint blk)]
withRollback SlotNo
pause BlockTreeBranch blk
b1 BlockTreeBranch blk
b2
            [[(Time, SchedulePoint blk)]]
rest <- SlotNo -> [BlockTreeBranch blk] -> m [[(Time, SchedulePoint blk)]]
takeBranches SlotNo
pause [BlockTreeBranch blk]
branches
            [[(Time, SchedulePoint blk)]] -> m [[(Time, SchedulePoint blk)]]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Time, SchedulePoint blk)]
this [(Time, SchedulePoint blk)]
-> [[(Time, SchedulePoint blk)]] -> [[(Time, SchedulePoint blk)]]
forall a. a -> [a] -> [a]
: [[(Time, SchedulePoint blk)]]
rest)
          else do
            [(Time, SchedulePoint blk)]
this <- SlotNo -> BlockTreeBranch blk -> m [(Time, SchedulePoint blk)]
withoutRollback SlotNo
pause BlockTreeBranch blk
b1
            [[(Time, SchedulePoint blk)]]
rest <- SlotNo -> [BlockTreeBranch blk] -> m [[(Time, SchedulePoint blk)]]
takeBranches SlotNo
pause (BlockTreeBranch blk
b2 BlockTreeBranch blk
-> [BlockTreeBranch blk] -> [BlockTreeBranch blk]
forall a. a -> [a] -> [a]
: [BlockTreeBranch blk]
branches)
            [[(Time, SchedulePoint blk)]] -> m [[(Time, SchedulePoint blk)]]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Time, SchedulePoint blk)]
this [(Time, SchedulePoint blk)]
-> [[(Time, SchedulePoint blk)]] -> [[(Time, SchedulePoint blk)]]
forall a. a -> [a] -> [a]
: [[(Time, SchedulePoint blk)]]
rest)

    withoutRollback :: SlotNo -> BlockTreeBranch blk -> m [(Time, SchedulePoint blk)]
withoutRollback SlotNo
pause BlockTreeBranch blk
branch = do
      [(IsTrunk, [Int])]
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
      [(IsTrunk, [Int])]
-> [AnchoredFragment blk] -> m [(Time, SchedulePoint blk)]
mkSchedule [(IsTrunk, [Int])]
tips [BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix BlockTreeBranch blk
branch]

    withRollback :: SlotNo
-> BlockTreeBranch blk
-> BlockTreeBranch blk
-> m [(Time, SchedulePoint blk)]
withRollback SlotNo
pause BlockTreeBranch blk
b1 BlockTreeBranch blk
b2 = do
      [(IsTrunk, [Int])]
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]
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]
      [(IsTrunk, [Int])]
-> [AnchoredFragment blk] -> m [(Time, SchedulePoint blk)]
mkSchedule ([(IsTrunk, [Int])]
firstTips [(IsTrunk, [Int])] -> [(IsTrunk, [Int])] -> [(IsTrunk, [Int])]
forall a. [a] -> [a] -> [a]
++ [(IsTrunk
IsBranch, [Int]
secondTips)]) [BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix BlockTreeBranch blk
b1, BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix BlockTreeBranch blk
b2]

    mkSchedule :: [(IsTrunk, [Int])]
-> [AnchoredFragment blk] -> m [(Time, SchedulePoint blk)]
mkSchedule [(IsTrunk, [Int])]
tips [AnchoredFragment blk]
branches = do
      PeerScheduleParams
params <- m PeerScheduleParams
mkParams
      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
params [(IsTrunk, [Int])]
tips AnchoredFragment blk
btTrunk [AnchoredFragment blk]
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
      Int
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 ([Int]
pre, [Int]
post) = (Int -> Bool) -> [Int] -> ([Int], [Int])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
firstSuffixBlock) [Int
tip0, Int
fullLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
      [(IsTrunk, [Int])] -> m [(IsTrunk, [Int])]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((if [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
pre then [] else [(IsTrunk
IsTrunk, [Int]
pre)]) [(IsTrunk, [Int])] -> [(IsTrunk, [Int])] -> [(IsTrunk, [Int])]
forall a. [a] -> [a] -> [a]
++ [(IsTrunk
IsBranch, Int -> Int
shift (Int -> Int) -> [Int] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
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.
      DiffTime
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
      DiffTime
tipU <- (DiffTime, DiffTime) -> g -> m DiffTime
forall g (m :: * -> *).
StatefulGen g m =>
(DiffTime, DiffTime) -> g -> m DiffTime
uniformRMDiffTime (DiffTime
1, DiffTime
2) g
g
      DiffTime
headerL <- (DiffTime, DiffTime) -> g -> m DiffTime
forall g (m :: * -> *).
StatefulGen g m =>
(DiffTime, DiffTime) -> g -> m DiffTime
uniformRMDiffTime (DiffTime
0.018, DiffTime
0.03) g
g
      DiffTime
headerU <- (DiffTime, DiffTime) -> g -> m DiffTime
forall g (m :: * -> *).
StatefulGen g m =>
(DiffTime, DiffTime) -> g -> m DiffTime
uniformRMDiffTime (DiffTime
0.021, DiffTime
0.04) g
g
      PeerScheduleParams -> m PeerScheduleParams
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PeerScheduleParams
defaultPeerScheduleParams {pspTipDelayInterval = (tipL, tipU), pspHeaderDelayInterval = (headerL, headerU)}

    rollbackProb :: Double
rollbackProb = Double
0.2

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,
    -- | 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 -> Word
gtExtraHonestPeers   :: Word,
    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]
++ Word64 -> String
forall a. Show a => a -> String
show (SecurityParam -> 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
$sel:gtSecurityParam:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> SecurityParam
gtSecurityParam :: SecurityParam
gtSecurityParam
      , GenesisWindow
$sel:gtGenesisWindow:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> GenesisWindow
gtGenesisWindow :: GenesisWindow
gtGenesisWindow
      , ForecastRange
$sel:gtForecastRange:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> ForecastRange
gtForecastRange :: ForecastRange
gtForecastRange
      , $sel:gtDelay:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> Delta
gtDelay = Delta Int
delta
      , BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree TestBlock
gtBlockTree
      , $sel:gtChainSyncTimeouts:GenesisTest :: 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}
      , $sel:gtBlockFetchTimeouts:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockFetchTimeout
gtBlockFetchTimeouts = BlockFetchTimeout{Maybe DiffTime
$sel:busyTimeout:BlockFetchTimeout :: BlockFetchTimeout -> Maybe DiffTime
busyTimeout :: Maybe DiffTime
busyTimeout, Maybe DiffTime
$sel:streamingTimeout:BlockFetchTimeout :: BlockFetchTimeout -> Maybe DiffTime
streamingTimeout :: Maybe DiffTime
streamingTimeout}
      , $sel:gtLoPBucketParams:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> LoPBucketParams
gtLoPBucketParams = LoPBucketParams{Integer
$sel:lbpCapacity:LoPBucketParams :: LoPBucketParams -> Integer
lbpCapacity :: Integer
lbpCapacity, Rational
$sel:lbpRate:LoPBucketParams :: LoPBucketParams -> Rational
lbpRate :: Rational
lbpRate}
      , SlotLength
$sel:gtSlotLength:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> SlotLength
gtSlotLength :: SlotLength
gtSlotLength
      , CSJParams
$sel:gtCSJParams:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> CSJParams
gtCSJParams :: CSJParams
gtCSJParams
      , schedule
$sel:gtSchedule:GenesisTest :: 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
$sel:gtSchedule:GenesisTest :: 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
  QCGen
seed :: QCGen <- Gen QCGen
forall a. Arbitrary a => Gen a
arbitrary
  a -> Gen a
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QCGen -> (forall s. STGenM QCGen s -> ST s a) -> a
forall g a.
RandomGen g =>
g -> (forall s. STGenM g s -> ST s a) -> a
runSTGen_ QCGen
seed STGenM QCGen s -> ST s a
forall s. STGenM QCGen s -> ST s a
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)
$sel:psSchedule:PointSchedule :: forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule, Time
$sel:psMinEndTime:PointSchedule :: forall blk. PointSchedule blk -> Time
psMinEndTime :: Time
psMinEndTime} =
    PointSchedule
      { Peers (PeerSchedule blk)
$sel:psSchedule:PointSchedule :: Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule
      , $sel:psMinEndTime:PointSchedule :: 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
      in DiffTime
1 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)