{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module Test.Consensus.Genesis.Tests.DensityDisconnect (tests) where

import           Cardano.Slotting.Slot (SlotNo (unSlotNo), WithOrigin (..))
import           Control.Exception (fromException)
import           Control.Monad.Class.MonadTime.SI (Time (..))
import           Data.Bifunctor
import           Data.Foldable (maximumBy, minimumBy, toList)
import           Data.Function (on)
import           Data.Functor (($>), (<&>))
import           Data.List (intercalate)
import           Data.List.NonEmpty (nonEmpty)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (fromMaybe)
import           Data.Maybe.Strict (StrictMaybe (..))
import           Data.Semigroup (Endo (..))
import           Data.Set (Set, (\\))
import qualified Data.Set as Set
import           Ouroboros.Consensus.Block (Point (GenesisPoint),
                     WithOrigin (NotOrigin), blockSlot, fromWithOrigin,
                     withOrigin)
import           Ouroboros.Consensus.Block.Abstract (Header, getHeader)
import           Ouroboros.Consensus.Config.SecurityParam
                     (SecurityParam (SecurityParam), maxRollbacks)
import           Ouroboros.Consensus.Genesis.Governor (DensityBounds,
                     densityDisconnect, sharedCandidatePrefix)
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                     (ChainSyncClientException (DensityTooLow),
                     ChainSyncState (..))
import           Ouroboros.Consensus.Util.Condense (condense)
import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (HasHeader, Tip (TipGenesis),
                     tipFromHeader)
import           Test.Consensus.BlockTree
import           Test.Consensus.Genesis.Setup
import           Test.Consensus.Genesis.Setup.Classifiers (classifiers,
                     genesisWindowAfterIntersection)
import           Test.Consensus.PeerSimulator.Run
                     (SchedulerConfig (scEnableLoE), defaultSchedulerConfig)
import           Test.Consensus.PeerSimulator.StateView
                     (PeerSimulatorComponent (..), StateView (..),
                     exceptionsByComponent)
import           Test.Consensus.PeerSimulator.Trace (prettyDensityBounds)
import           Test.Consensus.PointSchedule
import           Test.Consensus.PointSchedule.Peers
import           Test.Consensus.PointSchedule.Shrinking
                     (shrinkByRemovingAdversaries)
import           Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (..),
                     scheduleBlockPoint, scheduleHeaderPoint, scheduleTipPoint)
import qualified Test.QuickCheck as QC
import           Test.QuickCheck
import           Test.QuickCheck.Extras (unsafeMapSuchThatJust)
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Test.Util.Orphans.IOLike ()
import           Test.Util.PartialAccessors
import           Test.Util.TersePrinting (terseHFragment, terseHeader)
import           Test.Util.TestBlock (TestBlock)
import           Test.Util.TestEnv (adjustQuickCheckMaxSize,
                     adjustQuickCheckTests)

tests :: TestTree
tests :: TestTree
tests =
  (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
  (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckMaxSize (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
  String -> [TestTree] -> TestTree
testGroup String
"gdd" [
    String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"basic" Property
prop_densityDisconnectStatic,
    String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"monotonicity" Property
prop_densityDisconnectMonotonic,
    String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"re-triggers chain selection on disconnection" Property
prop_densityDisconnectTriggersChainSel
  ]

branchTip :: AnchoredFragment TestBlock -> Tip TestBlock
branchTip :: AnchoredFragment TestBlock -> Tip TestBlock
branchTip =
  (Anchor TestBlock -> Tip TestBlock)
-> (TestBlock -> Tip TestBlock)
-> Either (Anchor TestBlock) TestBlock
-> Tip TestBlock
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Tip TestBlock -> Anchor TestBlock -> Tip TestBlock
forall a b. a -> b -> a
const Tip TestBlock
forall {k} (b :: k). Tip b
TipGenesis) TestBlock -> Tip TestBlock
forall a. HasHeader a => a -> Tip a
tipFromHeader (Either (Anchor TestBlock) TestBlock -> Tip TestBlock)
-> (AnchoredFragment TestBlock
    -> Either (Anchor TestBlock) TestBlock)
-> AnchoredFragment TestBlock
-> Tip TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment TestBlock -> Either (Anchor TestBlock) TestBlock
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.head

toHeaders :: AnchoredFragment TestBlock -> AnchoredFragment (Header TestBlock)
toHeaders :: AnchoredFragment TestBlock -> AnchoredFragment (Header TestBlock)
toHeaders = (TestBlock -> Header TestBlock)
-> AnchoredFragment TestBlock
-> AnchoredFragment (Header TestBlock)
forall block2 block1.
(HasHeader block2, HeaderHash block1 ~ HeaderHash block2) =>
(block1 -> block2)
-> AnchoredFragment block1 -> AnchoredFragment block2
AF.mapAnchoredFragment TestBlock -> Header TestBlock
forall blk. GetHeader blk => blk -> Header blk
getHeader

data StaticCandidates =
  StaticCandidates {
    StaticCandidates -> SecurityParam
k        :: SecurityParam,
    StaticCandidates -> GenesisWindow
sgen     :: GenesisWindow,
    StaticCandidates -> [(PeerId, AnchoredFragment (Header TestBlock))]
suffixes :: [(PeerId, AnchoredFragment (Header TestBlock))],
    StaticCandidates -> Map PeerId (Tip TestBlock)
tips     :: Map PeerId (Tip TestBlock),
    StaticCandidates -> AnchoredFragment (Header TestBlock)
loeFrag  :: AnchoredFragment (Header TestBlock)
  }
  deriving Int -> StaticCandidates -> ShowS
[StaticCandidates] -> ShowS
StaticCandidates -> String
(Int -> StaticCandidates -> ShowS)
-> (StaticCandidates -> String)
-> ([StaticCandidates] -> ShowS)
-> Show StaticCandidates
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StaticCandidates -> ShowS
showsPrec :: Int -> StaticCandidates -> ShowS
$cshow :: StaticCandidates -> String
show :: StaticCandidates -> String
$cshowList :: [StaticCandidates] -> ShowS
showList :: [StaticCandidates] -> ShowS
Show

-- | Define one selection for each branch of the given block tree, consisting of the first @k@ blocks (or what's
-- available) of the branch's suffix.
--
-- Return a 'StaticCandidates' value for each of them, containing the candidate suffixes and LoE fragment computed by
-- 'sharedCandidatePrefix' from the selection.
staticCandidates :: GenesisTest TestBlock s -> [StaticCandidates]
staticCandidates :: forall s. GenesisTest TestBlock s -> [StaticCandidates]
staticCandidates GenesisTest {SecurityParam
gtSecurityParam :: SecurityParam
$sel:gtSecurityParam:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> SecurityParam
gtSecurityParam, GenesisWindow
gtGenesisWindow :: GenesisWindow
$sel:gtGenesisWindow:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> GenesisWindow
gtGenesisWindow, BlockTree TestBlock
gtBlockTree :: BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree} =
  AnchoredFragment (Header TestBlock) -> StaticCandidates
one (AnchoredFragment (Header TestBlock) -> StaticCandidates)
-> (AnchoredFragment TestBlock
    -> AnchoredFragment (Header TestBlock))
-> AnchoredFragment TestBlock
-> StaticCandidates
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment TestBlock -> AnchoredFragment (Header TestBlock)
toHeaders (AnchoredFragment TestBlock -> StaticCandidates)
-> [AnchoredFragment TestBlock] -> [StaticCandidates]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AnchoredFragment TestBlock]
selections
  where
    one :: AnchoredFragment (Header TestBlock) -> StaticCandidates
one AnchoredFragment (Header TestBlock)
curChain =
      StaticCandidates {
        $sel:k:StaticCandidates :: SecurityParam
k = SecurityParam
gtSecurityParam,
        $sel:sgen:StaticCandidates :: GenesisWindow
sgen = GenesisWindow
gtGenesisWindow,
        [(PeerId, AnchoredFragment (Header TestBlock))]
$sel:suffixes:StaticCandidates :: [(PeerId, AnchoredFragment (Header TestBlock))]
suffixes :: [(PeerId, AnchoredFragment (Header TestBlock))]
suffixes,
        Map PeerId (Tip TestBlock)
$sel:tips:StaticCandidates :: Map PeerId (Tip TestBlock)
tips :: Map PeerId (Tip TestBlock)
tips,
        AnchoredFragment (Header TestBlock)
$sel:loeFrag:StaticCandidates :: AnchoredFragment (Header TestBlock)
loeFrag :: AnchoredFragment (Header TestBlock)
loeFrag
      }
      where
        (AnchoredFragment (Header TestBlock)
loeFrag, [(PeerId, AnchoredFragment (Header TestBlock))]
suffixes) =
          AnchoredFragment (Header TestBlock)
-> [(PeerId, AnchoredFragment (Header TestBlock))]
-> (AnchoredFragment (Header TestBlock),
    [(PeerId, AnchoredFragment (Header TestBlock))])
forall blk peer.
GetHeader blk =>
AnchoredFragment (Header blk)
-> [(peer, AnchoredFragment (Header blk))]
-> (AnchoredFragment (Header blk),
    [(peer, AnchoredFragment (Header blk))])
sharedCandidatePrefix AnchoredFragment (Header TestBlock)
curChain ((AnchoredFragment TestBlock -> AnchoredFragment (Header TestBlock))
-> (PeerId, AnchoredFragment TestBlock)
-> (PeerId, AnchoredFragment (Header TestBlock))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second AnchoredFragment TestBlock -> AnchoredFragment (Header TestBlock)
toHeaders ((PeerId, AnchoredFragment TestBlock)
 -> (PeerId, AnchoredFragment (Header TestBlock)))
-> [(PeerId, AnchoredFragment TestBlock)]
-> [(PeerId, AnchoredFragment (Header TestBlock))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, AnchoredFragment TestBlock)]
candidates)

    selections :: [AnchoredFragment TestBlock]
selections = BlockTreeBranch TestBlock -> AnchoredFragment TestBlock
selection (BlockTreeBranch TestBlock -> AnchoredFragment TestBlock)
-> [BlockTreeBranch TestBlock] -> [AnchoredFragment TestBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockTreeBranch TestBlock]
branches

    selection :: BlockTreeBranch TestBlock -> AnchoredFragment TestBlock
selection BlockTreeBranch TestBlock
branch =
      Int -> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.takeOldest (AnchoredFragment TestBlock -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length (BlockTreeBranch TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbPrefix BlockTreeBranch TestBlock
branch) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SecurityParam -> Word64
maxRollbacks SecurityParam
gtSecurityParam)) (BlockTreeBranch TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull BlockTreeBranch TestBlock
branch)

    tips :: Map PeerId (Tip TestBlock)
tips = AnchoredFragment TestBlock -> Tip TestBlock
branchTip (AnchoredFragment TestBlock -> Tip TestBlock)
-> Map PeerId (AnchoredFragment TestBlock)
-> Map PeerId (Tip TestBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, AnchoredFragment TestBlock)]
-> Map PeerId (AnchoredFragment TestBlock)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PeerId, AnchoredFragment TestBlock)]
candidates

    candidates :: [(PeerId, AnchoredFragment TestBlock)]
    candidates :: [(PeerId, AnchoredFragment TestBlock)]
candidates = [PeerId]
-> [AnchoredFragment TestBlock]
-> [(PeerId, AnchoredFragment TestBlock)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> PeerId
HonestPeer Int
1 PeerId -> [PeerId] -> [PeerId]
forall a. a -> [a] -> [a]
: [PeerId]
enumerateAdversaries) [AnchoredFragment TestBlock]
chains

    chains :: [AnchoredFragment TestBlock]
chains = BlockTree TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree TestBlock
gtBlockTree AnchoredFragment TestBlock
-> [AnchoredFragment TestBlock] -> [AnchoredFragment TestBlock]
forall a. a -> [a] -> [a]
: (BlockTreeBranch TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull (BlockTreeBranch TestBlock -> AnchoredFragment TestBlock)
-> [BlockTreeBranch TestBlock] -> [AnchoredFragment TestBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockTreeBranch TestBlock]
branches)

    branches :: [BlockTreeBranch TestBlock]
branches = BlockTree TestBlock -> [BlockTreeBranch TestBlock]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches BlockTree TestBlock
gtBlockTree

-- | Check that the GDD disconnects from some peers for each full Genesis window starting at any of a block tree's
-- intersections, and that it's not the honest peer.
prop_densityDisconnectStatic :: Property
prop_densityDisconnectStatic :: Property
prop_densityDisconnectStatic =
  Gen StaticCandidates -> (StaticCandidates -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen StaticCandidates
gen ((StaticCandidates -> Property) -> Property)
-> (StaticCandidates -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ StaticCandidates {SecurityParam
$sel:k:StaticCandidates :: StaticCandidates -> SecurityParam
k :: SecurityParam
k, GenesisWindow
$sel:sgen:StaticCandidates :: StaticCandidates -> GenesisWindow
sgen :: GenesisWindow
sgen, [(PeerId, AnchoredFragment (Header TestBlock))]
$sel:suffixes:StaticCandidates :: StaticCandidates -> [(PeerId, AnchoredFragment (Header TestBlock))]
suffixes :: [(PeerId, AnchoredFragment (Header TestBlock))]
suffixes, AnchoredFragment (Header TestBlock)
$sel:loeFrag:StaticCandidates :: StaticCandidates -> AnchoredFragment (Header TestBlock)
loeFrag :: AnchoredFragment (Header TestBlock)
loeFrag} -> do
    let ([PeerId]
disconnect, [(PeerId, DensityBounds TestBlock)]
_) = GenesisWindow
-> SecurityParam
-> Map PeerId (ChainSyncState TestBlock)
-> [(PeerId, AnchoredFragment (Header TestBlock))]
-> AnchoredFragment (Header TestBlock)
-> ([PeerId], [(PeerId, DensityBounds TestBlock)])
forall peer blk.
(Ord peer, LedgerSupportsProtocol blk) =>
GenesisWindow
-> SecurityParam
-> Map peer (ChainSyncState blk)
-> [(peer, AnchoredFragment (Header blk))]
-> AnchoredFragment (Header blk)
-> ([peer], [(peer, DensityBounds blk)])
densityDisconnect GenesisWindow
sgen SecurityParam
k (AnchoredFragment (Header TestBlock) -> ChainSyncState TestBlock
mkState (AnchoredFragment (Header TestBlock) -> ChainSyncState TestBlock)
-> Map PeerId (AnchoredFragment (Header TestBlock))
-> Map PeerId (ChainSyncState TestBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, AnchoredFragment (Header TestBlock))]
-> Map PeerId (AnchoredFragment (Header TestBlock))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PeerId, AnchoredFragment (Header TestBlock))]
suffixes) [(PeerId, AnchoredFragment (Header TestBlock))]
suffixes AnchoredFragment (Header TestBlock)
loeFrag
    String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"it should disconnect some node" (Bool -> Bool
not ([PeerId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PeerId]
disconnect))
      Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
     String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"it should not disconnect the honest peers"
       (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (PeerId -> Bool) -> [PeerId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PeerId -> Bool
isHonestPeerId [PeerId]
disconnect)
  where
    mkState :: AnchoredFragment (Header TestBlock) -> ChainSyncState TestBlock
    mkState :: AnchoredFragment (Header TestBlock) -> ChainSyncState TestBlock
mkState AnchoredFragment (Header TestBlock)
frag =
      ChainSyncState {
        csCandidate :: AnchoredFragment (Header TestBlock)
csCandidate = AnchoredFragment (Header TestBlock)
frag,
        csLatestSlot :: StrictMaybe (WithOrigin SlotNo)
csLatestSlot = WithOrigin SlotNo -> StrictMaybe (WithOrigin SlotNo)
forall a. a -> StrictMaybe a
SJust (AnchoredFragment (Header TestBlock) -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot AnchoredFragment (Header TestBlock)
frag),
        csIdling :: Bool
csIdling = Bool
False
      }
    gen :: Gen StaticCandidates
gen = do
      GenesisTest TestBlock ()
gt <- Gen Word -> Gen (GenesisTest TestBlock ())
genChains ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
QC.choose (Word
1, Word
4))
      [StaticCandidates] -> Gen StaticCandidates
forall a. HasCallStack => [a] -> Gen a
elements (GenesisTest TestBlock () -> [StaticCandidates]
forall s. GenesisTest TestBlock s -> [StaticCandidates]
staticCandidates GenesisTest TestBlock ()
gt)

data EvolvingPeer =
  EvolvingPeer {
    EvolvingPeer -> AnchoredFragment (Header TestBlock)
forkPrefix  :: AnchoredFragment (Header TestBlock),
    EvolvingPeer -> AnchoredFragment (Header TestBlock)
forkSuffix  :: AnchoredFragment (Header TestBlock),
    EvolvingPeer -> AnchoredFragment (Header TestBlock)
candidate   :: AnchoredFragment (Header TestBlock),
    EvolvingPeer -> [Header TestBlock]
suffix      :: [Header TestBlock],
    EvolvingPeer -> Tip TestBlock
tip         :: Tip TestBlock,
    EvolvingPeer -> Int
prefixSlots :: Int,
    EvolvingPeer -> WithOrigin SlotNo
forkSlot    :: WithOrigin SlotNo
  }
  deriving Int -> EvolvingPeer -> ShowS
[EvolvingPeer] -> ShowS
EvolvingPeer -> String
(Int -> EvolvingPeer -> ShowS)
-> (EvolvingPeer -> String)
-> ([EvolvingPeer] -> ShowS)
-> Show EvolvingPeer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EvolvingPeer -> ShowS
showsPrec :: Int -> EvolvingPeer -> ShowS
$cshow :: EvolvingPeer -> String
show :: EvolvingPeer -> String
$cshowList :: [EvolvingPeer] -> ShowS
showList :: [EvolvingPeer] -> ShowS
Show

data EvolvingPeers =
  EvolvingPeers {
    EvolvingPeers -> SecurityParam
k        :: SecurityParam,
    EvolvingPeers -> GenesisWindow
sgen     :: GenesisWindow,
    EvolvingPeers -> Peers EvolvingPeer
peers    :: Peers EvolvingPeer,
    EvolvingPeers -> AnchoredFragment (Header TestBlock)
loeFrag  :: AnchoredFragment (Header TestBlock),
    EvolvingPeers -> BlockTree TestBlock
fullTree :: BlockTree TestBlock
  }
  deriving Int -> EvolvingPeers -> ShowS
[EvolvingPeers] -> ShowS
EvolvingPeers -> String
(Int -> EvolvingPeers -> ShowS)
-> (EvolvingPeers -> String)
-> ([EvolvingPeers] -> ShowS)
-> Show EvolvingPeers
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EvolvingPeers -> ShowS
showsPrec :: Int -> EvolvingPeers -> ShowS
$cshow :: EvolvingPeers -> String
show :: EvolvingPeers -> String
$cshowList :: [EvolvingPeers] -> ShowS
showList :: [EvolvingPeers] -> ShowS
Show

data Evolution =
  Evolution {
    Evolution -> Peers EvolvingPeer
peers  :: Peers EvolvingPeer,
    Evolution -> Set PeerId
killed :: Set PeerId
  }

lastSlot ::
  AF.HasHeader b =>
  AnchoredFragment b ->
  Int
lastSlot :: forall b. HasHeader b => AnchoredFragment b -> Int
lastSlot =
  Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int)
-> (AnchoredFragment b -> Word64) -> AnchoredFragment b -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> (SlotNo -> Word64) -> WithOrigin SlotNo -> Word64
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin Word64
0 SlotNo -> Word64
unSlotNo (WithOrigin SlotNo -> Word64)
-> (AnchoredFragment b -> WithOrigin SlotNo)
-> AnchoredFragment b
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment b -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot

initCandidates :: GenesisTest TestBlock s -> EvolvingPeers
initCandidates :: forall s. GenesisTest TestBlock s -> EvolvingPeers
initCandidates 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, BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree TestBlock
gtBlockTree} =
  EvolvingPeers {
    $sel:k:EvolvingPeers :: SecurityParam
k = SecurityParam
gtSecurityParam,
    $sel:sgen:EvolvingPeers :: GenesisWindow
sgen = GenesisWindow
gtGenesisWindow,
    Peers EvolvingPeer
$sel:peers:EvolvingPeers :: Peers EvolvingPeer
peers :: Peers EvolvingPeer
peers,
    $sel:loeFrag:EvolvingPeers :: AnchoredFragment (Header TestBlock)
loeFrag = Anchor (Header TestBlock) -> AnchoredFragment (Header TestBlock)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (Header TestBlock)
forall block. Anchor block
AF.AnchorGenesis,
    $sel:fullTree:EvolvingPeers :: BlockTree TestBlock
fullTree = BlockTree TestBlock
gtBlockTree
  }
  where
    peers :: Peers EvolvingPeer
peers = [EvolvingPeer] -> [EvolvingPeer] -> Peers EvolvingPeer
forall a. [a] -> [a] -> Peers a
peers' [AnchoredFragment TestBlock
-> AnchoredFragment TestBlock
-> AnchoredFragment TestBlock
-> EvolvingPeer
peer AnchoredFragment TestBlock
trunk (Anchor TestBlock -> AnchoredFragment TestBlock
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty (AnchoredFragment TestBlock -> Anchor TestBlock
forall v a b. Anchorable v a b => AnchoredSeq v a b -> a
AF.headAnchor AnchoredFragment TestBlock
trunk)) (BlockTree TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree TestBlock
gtBlockTree)] (BlockTreeBranch TestBlock -> EvolvingPeer
branchPeer (BlockTreeBranch TestBlock -> EvolvingPeer)
-> [BlockTreeBranch TestBlock] -> [EvolvingPeer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockTreeBranch TestBlock]
branches)

    branchPeer :: BlockTreeBranch TestBlock -> EvolvingPeer
branchPeer BlockTreeBranch TestBlock
branch = AnchoredFragment TestBlock
-> AnchoredFragment TestBlock
-> AnchoredFragment TestBlock
-> EvolvingPeer
peer (BlockTreeBranch TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbPrefix BlockTreeBranch TestBlock
branch) (BlockTreeBranch TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix BlockTreeBranch TestBlock
branch) (BlockTreeBranch TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull BlockTreeBranch TestBlock
branch)

    peer :: AnchoredFragment TestBlock
-> AnchoredFragment TestBlock
-> AnchoredFragment TestBlock
-> EvolvingPeer
peer AnchoredFragment TestBlock
forkPrefix AnchoredFragment TestBlock
forkSuffix AnchoredFragment TestBlock
chain =
      EvolvingPeer {
        $sel:forkPrefix:EvolvingPeer :: AnchoredFragment (Header TestBlock)
forkPrefix = AnchoredFragment TestBlock -> AnchoredFragment (Header TestBlock)
toHeaders AnchoredFragment TestBlock
forkPrefix,
        $sel:forkSuffix:EvolvingPeer :: AnchoredFragment (Header TestBlock)
forkSuffix = AnchoredFragment TestBlock -> AnchoredFragment (Header TestBlock)
toHeaders AnchoredFragment TestBlock
forkSuffix,
        $sel:candidate:EvolvingPeer :: AnchoredFragment (Header TestBlock)
candidate = Anchor (Header TestBlock) -> AnchoredFragment (Header TestBlock)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (Header TestBlock)
forall block. Anchor block
AF.AnchorGenesis,
        $sel:suffix:EvolvingPeer :: [Header TestBlock]
suffix = AnchoredFragment (Header TestBlock) -> [Header TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment (Header TestBlock)
headers,
        $sel:tip:EvolvingPeer :: Tip TestBlock
tip = AnchoredFragment TestBlock -> Tip TestBlock
branchTip AnchoredFragment TestBlock
chain,
        $sel:prefixSlots:EvolvingPeer :: Int
prefixSlots = AnchoredFragment TestBlock -> Int
forall b. HasHeader b => AnchoredFragment b -> Int
lastSlot AnchoredFragment TestBlock
forkPrefix,
        $sel:forkSlot:EvolvingPeer :: WithOrigin SlotNo
forkSlot = AnchoredFragment TestBlock -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.lastSlot AnchoredFragment TestBlock
forkSuffix
      }
      where
        headers :: AnchoredFragment (Header TestBlock)
headers = AnchoredFragment TestBlock -> AnchoredFragment (Header TestBlock)
toHeaders AnchoredFragment TestBlock
chain

    trunk :: AnchoredFragment TestBlock
trunk = BlockTree TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree TestBlock
gtBlockTree

    branches :: [BlockTreeBranch TestBlock]
branches = BlockTree TestBlock -> [BlockTreeBranch TestBlock]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches BlockTree TestBlock
gtBlockTree

data UpdateEvent = UpdateEvent {
     -- | The peer whose candidate was extended in this step
    UpdateEvent -> PeerId
target   :: PeerId
    -- | The header appended to the candidate of 'target'
  , UpdateEvent -> Header TestBlock
added    :: Header TestBlock
    -- | Peers that have been disconnected in the current step
  , UpdateEvent -> Set PeerId
killed   :: Set PeerId
    -- | The GDD data
  , UpdateEvent -> [(PeerId, DensityBounds TestBlock)]
bounds   :: [(PeerId, DensityBounds TestBlock)]
    -- | The current chains
  , UpdateEvent -> BlockTree (Header TestBlock)
tree     :: BlockTree (Header TestBlock)
  , UpdateEvent -> AnchoredFragment (Header TestBlock)
loeFrag  :: AnchoredFragment (Header TestBlock)
  , UpdateEvent -> AnchoredFragment (Header TestBlock)
curChain :: AnchoredFragment (Header TestBlock)
  }

snapshotTree :: Peers EvolvingPeer -> BlockTree (Header TestBlock)
snapshotTree :: Peers EvolvingPeer -> BlockTree (Header TestBlock)
snapshotTree Peers {Map Int EvolvingPeer
honestPeers :: Map Int EvolvingPeer
$sel:honestPeers:Peers :: forall a. Peers a -> Map Int a
honestPeers, Map Int EvolvingPeer
adversarialPeers :: Map Int EvolvingPeer
$sel:adversarialPeers:Peers :: forall a. Peers a -> Map Int a
adversarialPeers} =
  (AnchoredFragment (Header TestBlock)
 -> BlockTree (Header TestBlock) -> BlockTree (Header TestBlock))
-> BlockTree (Header TestBlock)
-> Map Int (AnchoredFragment (Header TestBlock))
-> BlockTree (Header TestBlock)
forall a b. (a -> b -> b) -> b -> Map Int a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AnchoredFragment (Header TestBlock)
-> BlockTree (Header TestBlock) -> BlockTree (Header TestBlock)
forall blk.
HasHeader blk =>
AnchoredFragment blk -> BlockTree blk -> BlockTree blk
addBranch' (AnchoredFragment (Header TestBlock) -> BlockTree (Header TestBlock)
forall blk. AnchoredFragment blk -> BlockTree blk
mkTrunk (EvolvingPeer -> AnchoredFragment (Header TestBlock)
candidate (Map Int EvolvingPeer -> EvolvingPeer
forall a. Map Int a -> a
getHonestPeer Map Int EvolvingPeer
honestPeers))) (EvolvingPeer -> AnchoredFragment (Header TestBlock)
candidate (EvolvingPeer -> AnchoredFragment (Header TestBlock))
-> Map Int EvolvingPeer
-> Map Int (AnchoredFragment (Header TestBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Int EvolvingPeer
adversarialPeers)

prettyUpdateEvent :: UpdateEvent -> [String]
prettyUpdateEvent :: UpdateEvent -> [String]
prettyUpdateEvent UpdateEvent {PeerId
$sel:target:UpdateEvent :: UpdateEvent -> PeerId
target :: PeerId
target, Header TestBlock
$sel:added:UpdateEvent :: UpdateEvent -> Header TestBlock
added :: Header TestBlock
added, Set PeerId
$sel:killed:UpdateEvent :: UpdateEvent -> Set PeerId
killed :: Set PeerId
killed, [(PeerId, DensityBounds TestBlock)]
$sel:bounds:UpdateEvent :: UpdateEvent -> [(PeerId, DensityBounds TestBlock)]
bounds :: [(PeerId, DensityBounds TestBlock)]
bounds, BlockTree (Header TestBlock)
$sel:tree:UpdateEvent :: UpdateEvent -> BlockTree (Header TestBlock)
tree :: BlockTree (Header TestBlock)
tree, AnchoredFragment (Header TestBlock)
$sel:loeFrag:UpdateEvent :: UpdateEvent -> AnchoredFragment (Header TestBlock)
loeFrag :: AnchoredFragment (Header TestBlock)
loeFrag, AnchoredFragment (Header TestBlock)
$sel:curChain:UpdateEvent :: UpdateEvent -> AnchoredFragment (Header TestBlock)
curChain :: AnchoredFragment (Header TestBlock)
curChain} =
  [
    String
"Extended " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PeerId -> String
forall a. Condense a => a -> String
condense PeerId
target String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Header TestBlock -> String
terseHeader Header TestBlock
added,
    String
"        disconnect: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Set PeerId -> String
forall a. Show a => a -> String
show Set PeerId
killed,
    String
"        LoE frag: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header TestBlock) -> String
terseHFragment AnchoredFragment (Header TestBlock)
loeFrag,
    String
"        selection: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header TestBlock) -> String
terseHFragment AnchoredFragment (Header TestBlock)
curChain
  ]
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [(PeerId, DensityBounds TestBlock)] -> [String]
prettyDensityBounds [(PeerId, DensityBounds TestBlock)]
bounds
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: BlockTree (Header TestBlock) -> [String]
forall blk. HasHeader blk => BlockTree blk -> [String]
prettyBlockTree BlockTree (Header TestBlock)
tree

data MonotonicityResult =
  HonestKilled
  |
  Nonmonotonic UpdateEvent
  |
  Finished

-- | Check whether the honest peer was killed or a peer's new losing state
-- violates monotonicity, i.e. if it was found to be losing before, it shouldn't
-- be found winning later.
--
-- If that is the case, return @Left (HonestKilled|Nonmonotonic, peers)@ to
-- indicate that the test is over and failed.
--
-- Otherwise, remove all adversaries that either have no more blocks or have
-- more than @sgen@ slots after their fork intersection. There is not other
-- motivation to shrink the adversary set other than ensuring termination.
--
-- If no adversaries remain, return @Left (Finished, peers)@ to indicate that
-- the test is over and succeeded.
--
-- Otherwise, return @Right remaining@ to continue with the next step.
updatePeers ::
  GenesisWindow ->
  Peers EvolvingPeer ->
  -- | Peers that were disconnected previously
  Set PeerId ->
  UpdateEvent ->
  Either (MonotonicityResult, Peers EvolvingPeer) Evolution
updatePeers :: GenesisWindow
-> Peers EvolvingPeer
-> Set PeerId
-> UpdateEvent
-> Either (MonotonicityResult, Peers EvolvingPeer) Evolution
updatePeers (GenesisWindow Word64
sgen) Peers EvolvingPeer
peers Set PeerId
killedBefore event :: UpdateEvent
event@UpdateEvent {PeerId
$sel:target:UpdateEvent :: UpdateEvent -> PeerId
target :: PeerId
target, $sel:killed:UpdateEvent :: UpdateEvent -> Set PeerId
killed = Set PeerId
killedNow}
  | Int -> PeerId
HonestPeer Int
1 PeerId -> Set PeerId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PeerId
killedNow
  = (MonotonicityResult, Peers EvolvingPeer)
-> Either (MonotonicityResult, Peers EvolvingPeer) Evolution
forall a b. a -> Either a b
Left (MonotonicityResult
HonestKilled, Peers EvolvingPeer
peers)
  | Bool -> Bool
not (Set PeerId -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set PeerId
violations)
  = (MonotonicityResult, Peers EvolvingPeer)
-> Either (MonotonicityResult, Peers EvolvingPeer) Evolution
forall a b. a -> Either a b
Left (UpdateEvent -> MonotonicityResult
Nonmonotonic UpdateEvent
event, Peers EvolvingPeer
peers)
  | Map Int EvolvingPeer -> Bool
forall a. Map Int a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Int EvolvingPeer
remaining
  = (MonotonicityResult, Peers EvolvingPeer)
-> Either (MonotonicityResult, Peers EvolvingPeer) Evolution
forall a b. a -> Either a b
Left (MonotonicityResult
Finished, Peers EvolvingPeer
peers)
  | Bool
otherwise
  = Evolution
-> Either (MonotonicityResult, Peers EvolvingPeer) Evolution
forall a b. b -> Either a b
Right Evolution
evo
  where
    -- The peers that were killed in an earlier step but not in the current one
    violations :: Set PeerId
violations = Set PeerId
killedBefore Set PeerId -> Set PeerId -> Set PeerId
forall a. Ord a => Set a -> Set a -> Set a
\\ Set PeerId
killedNow

    -- The new state if no violations were detected
    evo :: Evolution
evo@Evolution {$sel:peers:Evolution :: Evolution -> Peers EvolvingPeer
peers = Peers {$sel:adversarialPeers:Peers :: forall a. Peers a -> Map Int a
adversarialPeers = Map Int EvolvingPeer
remaining}}
      | Bool
targetExhausted
      -- If the target is done, reset the set of killed peers, since other peers
      -- may have lost only against the target.
      -- Remove the target from the active peers.
      = Evolution {$sel:peers:Evolution :: Peers EvolvingPeer
peers = PeerId -> Peers EvolvingPeer -> Peers EvolvingPeer
forall a. PeerId -> Peers a -> Peers a
deletePeer PeerId
target Peers EvolvingPeer
peers, $sel:killed:Evolution :: Set PeerId
killed = Set PeerId
forall a. Monoid a => a
mempty}
      | Bool
otherwise
      -- Otherwise replace the killed peers with the current set
      = Evolution {Peers EvolvingPeer
$sel:peers:Evolution :: Peers EvolvingPeer
peers :: Peers EvolvingPeer
peers, $sel:killed:Evolution :: Set PeerId
killed = Set PeerId
killedNow}

    -- Whether the extended peer is uninteresting for GDD from now on
    targetExhausted :: Bool
targetExhausted =
      -- Its fragment cannot be extended anymore, or
      [Header TestBlock] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Header TestBlock]
suffix Bool -> Bool -> Bool
||
      -- Its candidate is longer than a Genesis window
      AnchoredFragment (Header TestBlock) -> Int
forall b. HasHeader b => AnchoredFragment b -> Int
lastSlot AnchoredFragment (Header TestBlock)
candidate Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
prefixSlots Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sgen

    Peer {$sel:value:Peer :: forall a. Peer a -> a
value = EvolvingPeer {AnchoredFragment (Header TestBlock)
$sel:candidate:EvolvingPeer :: EvolvingPeer -> AnchoredFragment (Header TestBlock)
candidate :: AnchoredFragment (Header TestBlock)
candidate, [Header TestBlock]
$sel:suffix:EvolvingPeer :: EvolvingPeer -> [Header TestBlock]
suffix :: [Header TestBlock]
suffix, Int
$sel:prefixSlots:EvolvingPeer :: EvolvingPeer -> Int
prefixSlots :: Int
prefixSlots}} = PeerId -> Peers EvolvingPeer -> Peer EvolvingPeer
forall a. PeerId -> Peers a -> Peer a
getPeer PeerId
target Peers EvolvingPeer
peers

-- | Find the peer whose candidate has the earliest intersection.
-- If no peer has reached its fork suffix yet, return the one with the highest slot.
--
-- The selection will then be computed by taking up to k blocks after the immutable tip
-- on this peer's candidate fragment.
firstBranch :: Peers EvolvingPeer -> Peer EvolvingPeer
firstBranch :: Peers EvolvingPeer -> Peer EvolvingPeer
firstBranch Peers EvolvingPeer
peers =
  Peer EvolvingPeer -> Maybe (Peer EvolvingPeer) -> Peer EvolvingPeer
forall a. a -> Maybe a -> a
fromMaybe Peer EvolvingPeer
newest (Maybe (Peer EvolvingPeer) -> Peer EvolvingPeer)
-> Maybe (Peer EvolvingPeer) -> Peer EvolvingPeer
forall a b. (a -> b) -> a -> b
$
  (Peer EvolvingPeer -> Peer EvolvingPeer -> Ordering)
-> NonEmpty (Peer EvolvingPeer) -> Peer EvolvingPeer
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (SlotNo -> SlotNo -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SlotNo -> SlotNo -> Ordering)
-> (Peer EvolvingPeer -> SlotNo)
-> Peer EvolvingPeer
-> Peer EvolvingPeer
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Peer EvolvingPeer -> SlotNo
forkAnchor) (NonEmpty (Peer EvolvingPeer) -> Peer EvolvingPeer)
-> Maybe (NonEmpty (Peer EvolvingPeer))
-> Maybe (Peer EvolvingPeer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Peer EvolvingPeer] -> Maybe (NonEmpty (Peer EvolvingPeer))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ((Peer EvolvingPeer -> Bool)
-> [Peer EvolvingPeer] -> [Peer EvolvingPeer]
forall a. (a -> Bool) -> [a] -> [a]
filter Peer EvolvingPeer -> Bool
hasForked (Map PeerId (Peer EvolvingPeer) -> [Peer EvolvingPeer]
forall a. Map PeerId a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Peers EvolvingPeer -> Map PeerId (Peer EvolvingPeer)
forall a. Peers a -> Map PeerId (Peer a)
adversarialPeers'' Peers EvolvingPeer
peers)))
  where
    newest :: Peer EvolvingPeer
newest = (Peer EvolvingPeer -> Peer EvolvingPeer -> Ordering)
-> [Peer EvolvingPeer] -> Peer EvolvingPeer
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (WithOrigin SlotNo -> WithOrigin SlotNo -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (WithOrigin SlotNo -> WithOrigin SlotNo -> Ordering)
-> (Peer EvolvingPeer -> WithOrigin SlotNo)
-> Peer EvolvingPeer
-> Peer EvolvingPeer
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (AnchoredFragment (Header TestBlock) -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot (AnchoredFragment (Header TestBlock) -> WithOrigin SlotNo)
-> (Peer EvolvingPeer -> AnchoredFragment (Header TestBlock))
-> Peer EvolvingPeer
-> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvolvingPeer -> AnchoredFragment (Header TestBlock)
candidate (EvolvingPeer -> AnchoredFragment (Header TestBlock))
-> (Peer EvolvingPeer -> EvolvingPeer)
-> Peer EvolvingPeer
-> AnchoredFragment (Header TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peer EvolvingPeer -> EvolvingPeer
forall a. Peer a -> a
value)) (Map PeerId (Peer EvolvingPeer) -> [Peer EvolvingPeer]
forall a. Map PeerId a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Peers EvolvingPeer -> Map PeerId (Peer EvolvingPeer)
forall a. Peers a -> Map PeerId (Peer a)
honestPeers'' Peers EvolvingPeer
peers) [Peer EvolvingPeer] -> [Peer EvolvingPeer] -> [Peer EvolvingPeer]
forall a. [a] -> [a] -> [a]
++ Map PeerId (Peer EvolvingPeer) -> [Peer EvolvingPeer]
forall a. Map PeerId a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Peers EvolvingPeer -> Map PeerId (Peer EvolvingPeer)
forall a. Peers a -> Map PeerId (Peer a)
adversarialPeers'' Peers EvolvingPeer
peers))
    forkAnchor :: Peer EvolvingPeer -> SlotNo
forkAnchor = SlotNo -> WithOrigin SlotNo -> SlotNo
forall t. t -> WithOrigin t -> t
fromWithOrigin SlotNo
0 (WithOrigin SlotNo -> SlotNo)
-> (Peer EvolvingPeer -> WithOrigin SlotNo)
-> Peer EvolvingPeer
-> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchor (Header TestBlock) -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
AF.anchorToSlotNo (Anchor (Header TestBlock) -> WithOrigin SlotNo)
-> (Peer EvolvingPeer -> Anchor (Header TestBlock))
-> Peer EvolvingPeer
-> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (Header TestBlock) -> Anchor (Header TestBlock)
forall v a b. AnchoredSeq v a b -> a
AF.anchor (AnchoredFragment (Header TestBlock) -> Anchor (Header TestBlock))
-> (Peer EvolvingPeer -> AnchoredFragment (Header TestBlock))
-> Peer EvolvingPeer
-> Anchor (Header TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvolvingPeer -> AnchoredFragment (Header TestBlock)
forkSuffix (EvolvingPeer -> AnchoredFragment (Header TestBlock))
-> (Peer EvolvingPeer -> EvolvingPeer)
-> Peer EvolvingPeer
-> AnchoredFragment (Header TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peer EvolvingPeer -> EvolvingPeer
forall a. Peer a -> a
value
    hasForked :: Peer EvolvingPeer -> Bool
hasForked Peer {$sel:value:Peer :: forall a. Peer a -> a
value = EvolvingPeer {AnchoredFragment (Header TestBlock)
$sel:candidate:EvolvingPeer :: EvolvingPeer -> AnchoredFragment (Header TestBlock)
candidate :: AnchoredFragment (Header TestBlock)
candidate, WithOrigin SlotNo
$sel:forkSlot:EvolvingPeer :: EvolvingPeer -> WithOrigin SlotNo
forkSlot :: WithOrigin SlotNo
forkSlot}} =
      AnchoredFragment (Header TestBlock) -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot AnchoredFragment (Header TestBlock)
candidate WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= WithOrigin SlotNo
forkSlot

-- | Determine the immutable tip by computing the latest point before the fork intesection
-- for all peers, and then taking the earliest among the results.
immutableTip :: Peers EvolvingPeer -> AF.Point (Header TestBlock)
immutableTip :: Peers EvolvingPeer -> Point (Header TestBlock)
immutableTip Peers EvolvingPeer
peers =
  [Point (Header TestBlock)] -> Point (Header TestBlock)
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (Peer EvolvingPeer -> Point (Header TestBlock)
lastHonest (Peer EvolvingPeer -> Point (Header TestBlock))
-> [Peer EvolvingPeer] -> [Point (Header TestBlock)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PeerId (Peer EvolvingPeer) -> [Peer EvolvingPeer]
forall a. Map PeerId a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Peers EvolvingPeer -> Map PeerId (Peer EvolvingPeer)
forall a. Peers a -> Map PeerId (Peer a)
adversarialPeers'' Peers EvolvingPeer
peers))
  where
    lastHonest :: Peer EvolvingPeer -> Point (Header TestBlock)
lastHonest Peer {$sel:value:Peer :: forall a. Peer a -> a
value = EvolvingPeer {AnchoredFragment (Header TestBlock)
$sel:candidate:EvolvingPeer :: EvolvingPeer -> AnchoredFragment (Header TestBlock)
candidate :: AnchoredFragment (Header TestBlock)
candidate, $sel:forkSlot:EvolvingPeer :: EvolvingPeer -> WithOrigin SlotNo
forkSlot = NotOrigin SlotNo
forkSlot}} =
      AnchoredFragment (Header TestBlock) -> Point (Header TestBlock)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment (Header TestBlock) -> Point (Header TestBlock))
-> AnchoredFragment (Header TestBlock) -> Point (Header TestBlock)
forall a b. (a -> b) -> a -> b
$
      (Header TestBlock -> Bool)
-> AnchoredFragment (Header TestBlock)
-> AnchoredFragment (Header TestBlock)
forall v a b.
Anchorable v a b =>
(b -> Bool) -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.dropWhileNewest (\ Header TestBlock
b -> Header TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header TestBlock
b SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
forkSlot) AnchoredFragment (Header TestBlock)
candidate
    lastHonest Peer EvolvingPeer
_ = Point (Header TestBlock)
forall {k} (block :: k). Point block
GenesisPoint

-- | Take one block off the peer's suffix and append it to the candidate fragment.
--
-- Since we don't remove the honest peer when it's exhausted, this may be called with an empty suffix.
movePeer :: EvolvingPeer -> (EvolvingPeer, Maybe (Header TestBlock))
movePeer :: EvolvingPeer -> (EvolvingPeer, Maybe (Header TestBlock))
movePeer = \case
  peer :: EvolvingPeer
peer@EvolvingPeer {AnchoredFragment (Header TestBlock)
$sel:candidate:EvolvingPeer :: EvolvingPeer -> AnchoredFragment (Header TestBlock)
candidate :: AnchoredFragment (Header TestBlock)
candidate, $sel:suffix:EvolvingPeer :: EvolvingPeer -> [Header TestBlock]
suffix = Header TestBlock
h : [Header TestBlock]
t} ->
    (EvolvingPeer
peer {candidate = candidate AF.:> h, suffix = t}, Header TestBlock -> Maybe (Header TestBlock)
forall a. a -> Maybe a
Just Header TestBlock
h)
  EvolvingPeer
peer -> (EvolvingPeer
peer, Maybe (Header TestBlock)
forall a. Maybe a
Nothing)

-- | Repeatedly run the GDD, each time updating the candidate fragment of a
-- random peer to advance by one header, until all peers have been discarded
-- (not the same as disconnected!) according to 'updatePeers'.
--
-- The selection is set to the first k blocks of the first fork, the
-- anchor being the intersection.
--
-- The latest slots are the youngest header of each candidate fragments.
--
-- The returned 'MonotonicityResult' indicates whether the honest peer won and
-- no monotonicity violations were detected (the peer stays being disconnected
-- if it starts being disconnected).
evolveBranches ::
  EvolvingPeers ->
  Gen (MonotonicityResult, EvolvingPeers, [UpdateEvent])
evolveBranches :: EvolvingPeers
-> Gen (MonotonicityResult, EvolvingPeers, [UpdateEvent])
evolveBranches EvolvingPeers {SecurityParam
$sel:k:EvolvingPeers :: EvolvingPeers -> SecurityParam
k :: SecurityParam
k, GenesisWindow
$sel:sgen:EvolvingPeers :: EvolvingPeers -> GenesisWindow
sgen :: GenesisWindow
sgen, $sel:peers:EvolvingPeers :: EvolvingPeers -> Peers EvolvingPeer
peers = Peers EvolvingPeer
initialPeers, BlockTree TestBlock
$sel:fullTree:EvolvingPeers :: EvolvingPeers -> BlockTree TestBlock
fullTree :: BlockTree TestBlock
fullTree} =
  [UpdateEvent]
-> Evolution
-> Gen (MonotonicityResult, EvolvingPeers, [UpdateEvent])
step [] Evolution {$sel:peers:Evolution :: Peers EvolvingPeer
peers = Peers EvolvingPeer
initialPeers, $sel:killed:Evolution :: Set PeerId
killed = Set PeerId
forall a. Monoid a => a
mempty}
  where
    step :: [UpdateEvent]
-> Evolution
-> Gen (MonotonicityResult, EvolvingPeers, [UpdateEvent])
step [UpdateEvent]
events Evolution {$sel:peers:Evolution :: Evolution -> Peers EvolvingPeer
peers = Peers EvolvingPeer
ps, $sel:killed:Evolution :: Evolution -> Set PeerId
killed = Set PeerId
killedBefore} = do
      (PeerId
target, Peers EvolvingPeer
nextPeers, Header TestBlock
added) <- Gen (Maybe (PeerId, Peers EvolvingPeer, Header TestBlock))
-> Gen (PeerId, Peers EvolvingPeer, Header TestBlock)
forall a. Gen (Maybe a) -> Gen a
unsafeMapSuchThatJust (Gen (Maybe (PeerId, Peers EvolvingPeer, Header TestBlock))
 -> Gen (PeerId, Peers EvolvingPeer, Header TestBlock))
-> Gen (Maybe (PeerId, Peers EvolvingPeer, Header TestBlock))
-> Gen (PeerId, Peers EvolvingPeer, Header TestBlock)
forall a b. (a -> b) -> a -> b
$ do
        -- Select a random peer
        PeerId
pid <- [PeerId] -> Gen PeerId
forall a. HasCallStack => [a] -> Gen a
elements [PeerId]
ids
        Maybe (PeerId, Peers EvolvingPeer, Header TestBlock)
-> Gen (Maybe (PeerId, Peers EvolvingPeer, Header TestBlock))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (PeerId, Peers EvolvingPeer, Header TestBlock)
 -> Gen (Maybe (PeerId, Peers EvolvingPeer, Header TestBlock)))
-> Maybe (PeerId, Peers EvolvingPeer, Header TestBlock)
-> Gen (Maybe (PeerId, Peers EvolvingPeer, Header TestBlock))
forall a b. (a -> b) -> a -> b
$ do
          -- Add a block to the candidate. If the peer has no more blocks,
          -- this returns 'Nothing' and the generator retries.
          (Peers EvolvingPeer
nextPeers, Header TestBlock
added) <- (Peers EvolvingPeer, Maybe (Header TestBlock))
-> Maybe (Peers EvolvingPeer, Header TestBlock)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a.
Monad m =>
(Peers EvolvingPeer, m a) -> m (Peers EvolvingPeer, a)
sequence ((EvolvingPeer -> (EvolvingPeer, Maybe (Header TestBlock)))
-> PeerId
-> Peers EvolvingPeer
-> (Peers EvolvingPeer, Maybe (Header TestBlock))
forall a b. (a -> (a, b)) -> PeerId -> Peers a -> (Peers a, b)
updatePeer EvolvingPeer -> (EvolvingPeer, Maybe (Header TestBlock))
movePeer PeerId
pid Peers EvolvingPeer
ps)
          (PeerId, Peers EvolvingPeer, Header TestBlock)
-> Maybe (PeerId, Peers EvolvingPeer, Header TestBlock)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PeerId
pid, Peers EvolvingPeer
nextPeers, Header TestBlock
added)
      let
        -- Compute the selection.
        curChain :: AnchoredFragment (Header TestBlock)
curChain = Point (Header TestBlock)
-> Peer EvolvingPeer -> AnchoredFragment (Header TestBlock)
selection (Peers EvolvingPeer -> Point (Header TestBlock)
immutableTip Peers EvolvingPeer
ps) (Peers EvolvingPeer -> Peer EvolvingPeer
firstBranch Peers EvolvingPeer
ps)
        candidates :: Map PeerId (AnchoredFragment (Header TestBlock))
candidates = EvolvingPeer -> AnchoredFragment (Header TestBlock)
candidate (EvolvingPeer -> AnchoredFragment (Header TestBlock))
-> (Peer EvolvingPeer -> EvolvingPeer)
-> Peer EvolvingPeer
-> AnchoredFragment (Header TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peer EvolvingPeer -> EvolvingPeer
forall a. Peer a -> a
value (Peer EvolvingPeer -> AnchoredFragment (Header TestBlock))
-> Map PeerId (Peer EvolvingPeer)
-> Map PeerId (AnchoredFragment (Header TestBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Peers EvolvingPeer -> Map PeerId (Peer EvolvingPeer)
forall a. Peers a -> Map PeerId (Peer a)
toMap Peers EvolvingPeer
nextPeers
        states :: Map PeerId (ChainSyncState TestBlock)
states =
          Map PeerId (AnchoredFragment (Header TestBlock))
candidates Map PeerId (AnchoredFragment (Header TestBlock))
-> (AnchoredFragment (Header TestBlock)
    -> ChainSyncState TestBlock)
-> Map PeerId (ChainSyncState TestBlock)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ AnchoredFragment (Header TestBlock)
csCandidate ->
            ChainSyncState {
              AnchoredFragment (Header TestBlock)
csCandidate :: AnchoredFragment (Header TestBlock)
csCandidate :: AnchoredFragment (Header TestBlock)
csCandidate,
              csIdling :: Bool
csIdling = Bool
False,
              csLatestSlot :: StrictMaybe (WithOrigin SlotNo)
csLatestSlot = WithOrigin SlotNo -> StrictMaybe (WithOrigin SlotNo)
forall a. a -> StrictMaybe a
SJust (AnchoredFragment (Header TestBlock) -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot AnchoredFragment (Header TestBlock)
csCandidate)
            }
        -- Run GDD.
        (AnchoredFragment (Header TestBlock)
loeFrag, [(PeerId, AnchoredFragment (Header TestBlock))]
suffixes) = AnchoredFragment (Header TestBlock)
-> [(PeerId, AnchoredFragment (Header TestBlock))]
-> (AnchoredFragment (Header TestBlock),
    [(PeerId, AnchoredFragment (Header TestBlock))])
forall blk peer.
GetHeader blk =>
AnchoredFragment (Header blk)
-> [(peer, AnchoredFragment (Header blk))]
-> (AnchoredFragment (Header blk),
    [(peer, AnchoredFragment (Header blk))])
sharedCandidatePrefix AnchoredFragment (Header TestBlock)
curChain (Map PeerId (AnchoredFragment (Header TestBlock))
-> [(PeerId, AnchoredFragment (Header TestBlock))]
forall k a. Map k a -> [(k, a)]
Map.toList Map PeerId (AnchoredFragment (Header TestBlock))
candidates)
        (Set PeerId
killedNow, [(PeerId, DensityBounds TestBlock)]
bounds) = ([PeerId] -> Set PeerId)
-> ([PeerId], [(PeerId, DensityBounds TestBlock)])
-> (Set PeerId, [(PeerId, DensityBounds TestBlock)])
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 [PeerId] -> Set PeerId
forall a. Ord a => [a] -> Set a
Set.fromList (([PeerId], [(PeerId, DensityBounds TestBlock)])
 -> (Set PeerId, [(PeerId, DensityBounds TestBlock)]))
-> ([PeerId], [(PeerId, DensityBounds TestBlock)])
-> (Set PeerId, [(PeerId, DensityBounds TestBlock)])
forall a b. (a -> b) -> a -> b
$ GenesisWindow
-> SecurityParam
-> Map PeerId (ChainSyncState TestBlock)
-> [(PeerId, AnchoredFragment (Header TestBlock))]
-> AnchoredFragment (Header TestBlock)
-> ([PeerId], [(PeerId, DensityBounds TestBlock)])
forall peer blk.
(Ord peer, LedgerSupportsProtocol blk) =>
GenesisWindow
-> SecurityParam
-> Map peer (ChainSyncState blk)
-> [(peer, AnchoredFragment (Header blk))]
-> AnchoredFragment (Header blk)
-> ([peer], [(peer, DensityBounds blk)])
densityDisconnect GenesisWindow
sgen SecurityParam
k Map PeerId (ChainSyncState TestBlock)
states [(PeerId, AnchoredFragment (Header TestBlock))]
suffixes AnchoredFragment (Header TestBlock)
loeFrag
        event :: UpdateEvent
event = UpdateEvent {
          PeerId
$sel:target:UpdateEvent :: PeerId
target :: PeerId
target,
          Header TestBlock
$sel:added:UpdateEvent :: Header TestBlock
added :: Header TestBlock
added,
          $sel:killed:UpdateEvent :: Set PeerId
killed = Set PeerId
killedNow,
          [(PeerId, DensityBounds TestBlock)]
$sel:bounds:UpdateEvent :: [(PeerId, DensityBounds TestBlock)]
bounds :: [(PeerId, DensityBounds TestBlock)]
bounds,
          $sel:tree:UpdateEvent :: BlockTree (Header TestBlock)
tree = Peers EvolvingPeer -> BlockTree (Header TestBlock)
snapshotTree Peers EvolvingPeer
nextPeers,
          AnchoredFragment (Header TestBlock)
$sel:loeFrag:UpdateEvent :: AnchoredFragment (Header TestBlock)
loeFrag :: AnchoredFragment (Header TestBlock)
loeFrag,
          AnchoredFragment (Header TestBlock)
$sel:curChain:UpdateEvent :: AnchoredFragment (Header TestBlock)
curChain :: AnchoredFragment (Header TestBlock)
curChain
          }
        newEvents :: [UpdateEvent]
newEvents = UpdateEvent
event UpdateEvent -> [UpdateEvent] -> [UpdateEvent]
forall a. a -> [a] -> [a]
: [UpdateEvent]
events
        -- Check the termination condition and remove exhausted peers.
        updated :: Either (MonotonicityResult, Peers EvolvingPeer) Evolution
updated = GenesisWindow
-> Peers EvolvingPeer
-> Set PeerId
-> UpdateEvent
-> Either (MonotonicityResult, Peers EvolvingPeer) Evolution
updatePeers GenesisWindow
sgen Peers EvolvingPeer
nextPeers Set PeerId
killedBefore UpdateEvent
event
      ((MonotonicityResult, Peers EvolvingPeer)
 -> Gen (MonotonicityResult, EvolvingPeers, [UpdateEvent]))
-> (Evolution
    -> Gen (MonotonicityResult, EvolvingPeers, [UpdateEvent]))
-> Either (MonotonicityResult, Peers EvolvingPeer) Evolution
-> Gen (MonotonicityResult, EvolvingPeers, [UpdateEvent])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((MonotonicityResult, EvolvingPeers, [UpdateEvent])
-> Gen (MonotonicityResult, EvolvingPeers, [UpdateEvent])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((MonotonicityResult, EvolvingPeers, [UpdateEvent])
 -> Gen (MonotonicityResult, EvolvingPeers, [UpdateEvent]))
-> ((MonotonicityResult, Peers EvolvingPeer)
    -> (MonotonicityResult, EvolvingPeers, [UpdateEvent]))
-> (MonotonicityResult, Peers EvolvingPeer)
-> Gen (MonotonicityResult, EvolvingPeers, [UpdateEvent])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UpdateEvent]
-> AnchoredFragment (Header TestBlock)
-> (MonotonicityResult, Peers EvolvingPeer)
-> (MonotonicityResult, EvolvingPeers, [UpdateEvent])
result [UpdateEvent]
newEvents AnchoredFragment (Header TestBlock)
loeFrag) ([UpdateEvent]
-> Evolution
-> Gen (MonotonicityResult, EvolvingPeers, [UpdateEvent])
step [UpdateEvent]
newEvents) Either (MonotonicityResult, Peers EvolvingPeer) Evolution
updated
      where
        result :: [UpdateEvent]
-> AnchoredFragment (Header TestBlock)
-> (MonotonicityResult, Peers EvolvingPeer)
-> (MonotonicityResult, EvolvingPeers, [UpdateEvent])
result [UpdateEvent]
evs AnchoredFragment (Header TestBlock)
f (MonotonicityResult
res, Peers EvolvingPeer
final) = (MonotonicityResult
res, EvolvingPeers {SecurityParam
$sel:k:EvolvingPeers :: SecurityParam
k :: SecurityParam
k, GenesisWindow
$sel:sgen:EvolvingPeers :: GenesisWindow
sgen :: GenesisWindow
sgen, $sel:peers:EvolvingPeers :: Peers EvolvingPeer
peers = Peers EvolvingPeer
final, $sel:loeFrag:EvolvingPeers :: AnchoredFragment (Header TestBlock)
loeFrag = AnchoredFragment (Header TestBlock)
f, BlockTree TestBlock
$sel:fullTree:EvolvingPeers :: BlockTree TestBlock
fullTree :: BlockTree TestBlock
fullTree}, [UpdateEvent] -> [UpdateEvent]
forall a. [a] -> [a]
reverse [UpdateEvent]
evs)

        -- Take k blocks after the immutable tip on the first fork.
        selection :: Point (Header TestBlock)
-> Peer EvolvingPeer -> AnchoredFragment (Header TestBlock)
selection Point (Header TestBlock)
imm Peer {$sel:value:Peer :: forall a. Peer a -> a
value = EvolvingPeer {AnchoredFragment (Header TestBlock)
$sel:candidate:EvolvingPeer :: EvolvingPeer -> AnchoredFragment (Header TestBlock)
candidate :: AnchoredFragment (Header TestBlock)
candidate}} =
          case AnchoredFragment (Header TestBlock)
-> Point (Header TestBlock)
-> Maybe
     (AnchoredFragment (Header TestBlock),
      AnchoredFragment (Header TestBlock))
forall block1 block2.
(HasHeader block1, HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> Point block2
-> Maybe (AnchoredFragment block1, AnchoredFragment block1)
AF.splitAfterPoint AnchoredFragment (Header TestBlock)
candidate Point (Header TestBlock)
imm of
            Just (AnchoredFragment (Header TestBlock)
_, AnchoredFragment (Header TestBlock)
s) -> Int
-> AnchoredFragment (Header TestBlock)
-> AnchoredFragment (Header TestBlock)
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 (Header TestBlock)
s
            Maybe
  (AnchoredFragment (Header TestBlock),
   AnchoredFragment (Header TestBlock))
Nothing     -> String -> AnchoredFragment (Header TestBlock)
forall a. HasCallStack => String -> a
error String
"immutable tip not on candidate"

        ids :: [PeerId]
ids = [PeerId] -> [PeerId]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Peers EvolvingPeer -> [PeerId]
forall a. Peers a -> [PeerId]
getPeerIds Peers EvolvingPeer
ps)

    SecurityParam Word64
k' = SecurityParam
k

peerInfo :: EvolvingPeers -> [String]
peerInfo :: EvolvingPeers -> [String]
peerInfo EvolvingPeers {$sel:k:EvolvingPeers :: EvolvingPeers -> SecurityParam
k = SecurityParam Word64
k, $sel:sgen:EvolvingPeers :: EvolvingPeers -> GenesisWindow
sgen = GenesisWindow Word64
sgen, AnchoredFragment (Header TestBlock)
$sel:loeFrag:EvolvingPeers :: EvolvingPeers -> AnchoredFragment (Header TestBlock)
loeFrag :: AnchoredFragment (Header TestBlock)
loeFrag} =
  [
    String
"k: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
k,
    String
"sgen: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
sgen,
    String
"loeFrag: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> AnchoredFragment (Header TestBlock) -> String
terseHFragment AnchoredFragment (Header TestBlock)
loeFrag
  ]

-- | Tests that when GDD disconnects a peer, it continues to disconnect it when
-- its candidate fragment is extended.
prop_densityDisconnectMonotonic :: Property
prop_densityDisconnectMonotonic :: Property
prop_densityDisconnectMonotonic =
  Gen (MonotonicityResult, EvolvingPeers, [UpdateEvent])
-> ((MonotonicityResult, EvolvingPeers, [UpdateEvent]) -> Property)
-> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (MonotonicityResult, EvolvingPeers, [UpdateEvent])
gen (((MonotonicityResult, EvolvingPeers, [UpdateEvent]) -> Property)
 -> Property)
-> ((MonotonicityResult, EvolvingPeers, [UpdateEvent]) -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \ (MonotonicityResult
result, EvolvingPeers
final, [UpdateEvent]
events) ->
    Endo Property -> Property -> Property
forall a. Endo a -> a -> a
appEndo ((String -> Endo Property) -> [String] -> Endo Property
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Property -> Property) -> Endo Property
forall a. (a -> a) -> Endo a
Endo ((Property -> Property) -> Endo Property)
-> (String -> Property -> Property) -> String -> Endo Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample) (EvolvingPeers -> [String]
peerInfo EvolvingPeers
final)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    EvolvingPeers -> [UpdateEvent] -> MonotonicityResult -> Property
check EvolvingPeers
final [UpdateEvent]
events MonotonicityResult
result
  where
    check :: EvolvingPeers -> [UpdateEvent] -> MonotonicityResult -> Property
check EvolvingPeers
final [UpdateEvent]
events = \case
      MonotonicityResult
HonestKilled -> Property -> Property
withEvents (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Honest peer was killed" Bool
False
      Nonmonotonic UpdateEvent
event -> do
        let msg :: String
msg = String
"Peer went from losing to remaining"
        Property -> Property
withEvents (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([String] -> String
catLines (String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: UpdateEvent -> [String]
prettyUpdateEvent UpdateEvent
event)) Bool
False
      MonotonicityResult
Finished -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
      where
        withEvents :: Property -> Property
withEvents | Bool
debug = String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([String] -> String
catLines [String]
debugInfo)
                   | Bool
otherwise = Property -> Property
forall a. a -> a
id

        debugInfo :: [String]
debugInfo =
          String
"Event log:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (([String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
""]) ([String] -> [String])
-> (UpdateEvent -> [String]) -> UpdateEvent -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateEvent -> [String]
prettyUpdateEvent (UpdateEvent -> [String]) -> [UpdateEvent] -> [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [UpdateEvent]
events) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
          [String
"k: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
k'] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
          (String
"Full tree:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: BlockTree TestBlock -> [String]
forall blk. HasHeader blk => BlockTree blk -> [String]
prettyBlockTree (EvolvingPeers -> BlockTree TestBlock
fullTree EvolvingPeers
final) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
""])

        EvolvingPeers {$sel:k:EvolvingPeers :: EvolvingPeers -> SecurityParam
k = SecurityParam Word64
k'} = EvolvingPeers
final

    catLines :: [String] -> String
catLines = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"

    gen :: Gen (MonotonicityResult, EvolvingPeers, [UpdateEvent])
gen = do
      GenesisTest TestBlock ()
gt <- Gen Word -> Gen (GenesisTest TestBlock ())
genChains ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
QC.choose (Word
1, Word
4))
      EvolvingPeers
-> Gen (MonotonicityResult, EvolvingPeers, [UpdateEvent])
evolveBranches (GenesisTest TestBlock () -> EvolvingPeers
forall s. GenesisTest TestBlock s -> EvolvingPeers
initCandidates GenesisTest TestBlock ()
gt)

    debug :: Bool
debug = Bool
True

-- | Tests that a GDD disconnection re-triggers chain selection, i.e. when the current
-- selection is blocked by LoE, and the leashing adversary reveals it is not dense enough,
-- it gets disconnected and then the selection progresses.
prop_densityDisconnectTriggersChainSel :: Property
prop_densityDisconnectTriggersChainSel :: Property
prop_densityDisconnectTriggersChainSel =
  Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> Property)
-> Property
forall prop.
Testable prop =>
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> prop)
-> Property
forAllGenesisTest
    ( do
        gt :: GenesisTest TestBlock ()
gt@GenesisTest {BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree TestBlock
gtBlockTree} <- Gen Word -> Gen (GenesisTest TestBlock ())
genChains (Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
1)
        let ps :: PointSchedule TestBlock
ps = BlockTree TestBlock -> PointSchedule TestBlock
forall blk. HasHeader blk => BlockTree blk -> PointSchedule blk
lowDensitySchedule BlockTree TestBlock
gtBlockTree
            cls :: Classifiers
cls = GenesisTest TestBlock () -> Classifiers
forall blk schedule.
HasHeader blk =>
GenesisTest blk schedule -> Classifiers
classifiers GenesisTest TestBlock ()
gt
        if Classifiers -> Bool
genesisWindowAfterIntersection Classifiers
cls
          then GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock))
-> GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock)
forall a b. (a -> b) -> a -> b
$ GenesisTest TestBlock ()
gt GenesisTest TestBlock ()
-> PointSchedule TestBlock -> GenesisTestFull TestBlock
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PointSchedule TestBlock
ps
          else Gen (GenesisTestFull TestBlock)
forall a. a
discard
    )

    (SchedulerConfig
defaultSchedulerConfig {scEnableLoE = True})

    GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinkByRemovingAdversaries

    ( \GenesisTest {BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree TestBlock
gtBlockTree, PointSchedule TestBlock
gtSchedule :: PointSchedule TestBlock
$sel:gtSchedule:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule} stateView :: StateView TestBlock
stateView@StateView {Maybe TestBlock
svTipBlock :: Maybe TestBlock
svTipBlock :: forall blk. StateView blk -> Maybe blk
svTipBlock} ->
        let
          othersCount :: Int
othersCount = Map Int (PeerSchedule TestBlock) -> Int
forall k a. Map k a -> Int
Map.size (Peers (PeerSchedule TestBlock) -> Map Int (PeerSchedule TestBlock)
forall a. Peers a -> Map Int a
adversarialPeers (Peers (PeerSchedule TestBlock)
 -> Map Int (PeerSchedule TestBlock))
-> Peers (PeerSchedule TestBlock)
-> Map Int (PeerSchedule TestBlock)
forall a b. (a -> b) -> a -> b
$ PointSchedule TestBlock -> Peers (PeerSchedule TestBlock)
forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule PointSchedule TestBlock
gtSchedule)
          exnCorrect :: Bool
exnCorrect = case PeerSimulatorComponent -> StateView TestBlock -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncClient StateView TestBlock
stateView of
            [SomeException -> Maybe ChainSyncClientException
forall e. Exception e => SomeException -> Maybe e
fromException -> Just ChainSyncClientException
DensityTooLow] -> Bool
True
            []                 | Int
othersCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> Bool
True
            [SomeException]
_                                     -> Bool
False
          tipPointCorrect :: Bool
tipPointCorrect = TestBlock -> Maybe TestBlock
forall a. a -> Maybe a
Just (BlockTree TestBlock -> TestBlock
forall blk. HasHeader blk => BlockTree blk -> blk
getTrunkTip BlockTree TestBlock
gtBlockTree) Maybe TestBlock -> Maybe TestBlock -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe TestBlock
svTipBlock
        in String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Unexpected exceptions" Bool
exnCorrect
            Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
           String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"The tip of the final selection is not the expected one" Bool
tipPointCorrect
    )

  where
    -- 1. The adversary advertises blocks up to the intersection.
    -- 2. The honest node advertises all its chain, which is
    --    long enough to be blocked by the LoE.
    -- 3. The adversary gives a block after the genesis window,
    --    which should allow the GDD to realize that the chain
    --    is not dense enough, and that the whole of the honest
    --    chain should be selected.
    lowDensitySchedule :: HasHeader blk => BlockTree blk -> PointSchedule blk
    lowDensitySchedule :: forall blk. HasHeader blk => BlockTree blk -> PointSchedule blk
lowDensitySchedule BlockTree blk
tree =
      let trunkTip :: blk
trunkTip = BlockTree blk -> blk
forall blk. HasHeader blk => BlockTree blk -> blk
getTrunkTip BlockTree blk
tree
          branch :: BlockTreeBranch blk
branch = BlockTree blk -> BlockTreeBranch blk
forall blk. BlockTree blk -> BlockTreeBranch blk
getOnlyBranch BlockTree blk
tree
          intersect :: WithOrigin blk
intersect = case BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbPrefix BlockTreeBranch blk
branch of
            (AF.Empty Anchor blk
_)       -> WithOrigin blk
forall t. WithOrigin t
Origin
            (AnchoredFragment blk
_ AF.:> blk
tipBlock) -> blk -> WithOrigin blk
forall t. t -> WithOrigin t
At blk
tipBlock
          advTip :: blk
advTip = BlockTree blk -> blk
forall blk. HasHeader blk => BlockTree blk -> blk
getOnlyBranchTip BlockTree blk
tree
       in Peers (PeerSchedule blk) -> PointSchedule blk
forall blk. Peers (PeerSchedule blk) -> PointSchedule blk
mkPointSchedule (Peers (PeerSchedule blk) -> PointSchedule blk)
-> Peers (PeerSchedule blk) -> PointSchedule blk
forall a b. (a -> b) -> a -> b
$ [PeerSchedule blk]
-> [PeerSchedule blk] -> Peers (PeerSchedule blk)
forall a. [a] -> [a] -> Peers a
peers'
            -- Eagerly serve the honest tree, but after the adversary has
            -- advertised its chain up to the intersection.
            [[(DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleTipPoint blk
trunkTip),
              (DiffTime -> Time
Time DiffTime
0.5, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
trunkTip),
              (DiffTime -> Time
Time DiffTime
0.5, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint blk
trunkTip)
            ]]
            -- Advertise the alternate branch early, but wait for the honest
            -- node to have served its chain before disclosing the alternate
            -- branch is not dense enough.
            [[(DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleTipPoint blk
advTip),
              (DiffTime -> Time
Time DiffTime
0, WithOrigin blk -> SchedulePoint blk
forall blk. WithOrigin blk -> SchedulePoint blk
ScheduleHeaderPoint WithOrigin blk
intersect),
              (DiffTime -> Time
Time DiffTime
0, WithOrigin blk -> SchedulePoint blk
forall blk. WithOrigin blk -> SchedulePoint blk
ScheduleBlockPoint WithOrigin blk
intersect),
              (DiffTime -> Time
Time DiffTime
1, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
advTip),
              (DiffTime -> Time
Time DiffTime
1, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint blk
advTip)
            ]]