{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Test.Consensus.Genesis.Setup.Classifiers (
    Classifiers (..)
  , ResultClassifiers (..)
  , ScheduleClassifiers (..)
  , classifiers
  , resultClassifiers
  , scheduleClassifiers
  , simpleHash
  ) where

import           Cardano.Slotting.Slot (WithOrigin (..))
import           Data.List (sortOn, tails)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import           Data.Maybe (mapMaybe)
import           Data.Word (Word64)
import           Ouroboros.Consensus.Block (ChainHash (BlockHash), HeaderHash,
                     blockSlot, succWithOrigin)
import           Ouroboros.Consensus.Block.Abstract (SlotNo (SlotNo),
                     withOrigin)
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                     (ChainSyncClientException (DensityTooLow, EmptyBucket))
import           Ouroboros.Consensus.Util.IOLike (SomeException, fromException)
import           Ouroboros.Network.AnchoredFragment (anchor, anchorToSlotNo,
                     headSlot)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Driver.Limits
                     (ProtocolLimitFailure (ExceededTimeLimit))
import           Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..))
import           Test.Consensus.Network.AnchoredFragment.Extras (slotLength)
import           Test.Consensus.PeerSimulator.StateView
                     (PeerSimulatorResult (..), StateView (..), pscrToException)
import           Test.Consensus.PointSchedule
import           Test.Consensus.PointSchedule.Peers (PeerId (..), Peers (..))
import           Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (..))
import           Test.Util.Orphans.IOLike ()
import           Test.Util.TestBlock (TestBlock, TestHash (TestHash),
                     isAncestorOf)

-- | Interesting categories to classify test inputs
data Classifiers =
  Classifiers {
    -- | There are more than k blocks in at least one alternative chain after the intersection
    Classifiers -> Bool
existsSelectableAdversary      :: Bool,
    -- | There are more than k blocks in all alternative chains after the
    -- intersection. Note that this is always guaranteed for the honest chain.
    Classifiers -> Bool
allAdversariesSelectable       :: Bool,
    -- | There is always at least one block per sliding forecast window in all
    -- alternative chains. Note that this is always guaranteed for the honest
    -- chain.
    Classifiers -> Bool
allAdversariesForecastable     :: Bool,
    -- | All adversaries have at least @k+1@ block in the forecast window the
    -- follows their intersection with the trunk. Note that the generator always
    -- enforces that the trunk wins in all _Genesis_ windows after the
    -- intersection. In particular, if @sgen = sfor@, then the trunk will have
    -- at least @k+2@.
    Classifiers -> Bool
allAdversariesKPlus1InForecast :: Bool,
    -- | There are at least scg slots after the intersection on both the honest
    -- and the alternative chain
    --
    -- Knowing if there is a Genesis window after the intersection is important because
    -- otherwise the Genesis node has no chance to advance the immutable tip past
    -- the Limit on Eagerness.
    --
    Classifiers -> Bool
genesisWindowAfterIntersection :: Bool,
    -- | The honest chain's slot count is greater than or equal to the Genesis window size.
    Classifiers -> Bool
longerThanGenesisWindow        :: Bool
  }

classifiers :: AF.HasHeader blk => GenesisTest blk schedule -> Classifiers
classifiers :: forall blk schedule.
HasHeader blk =>
GenesisTest blk schedule -> Classifiers
classifiers GenesisTest {BlockTree blk
gtBlockTree :: BlockTree blk
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree, $sel:gtSecurityParam:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> SecurityParam
gtSecurityParam = SecurityParam Word64
k, $sel:gtGenesisWindow:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> GenesisWindow
gtGenesisWindow = GenesisWindow Word64
scg} =
  Classifiers {
    Bool
existsSelectableAdversary :: Bool
existsSelectableAdversary :: Bool
existsSelectableAdversary,
    Bool
allAdversariesSelectable :: Bool
allAdversariesSelectable :: Bool
allAdversariesSelectable,
    Bool
allAdversariesForecastable :: Bool
allAdversariesForecastable :: Bool
allAdversariesForecastable,
    Bool
allAdversariesKPlus1InForecast :: Bool
allAdversariesKPlus1InForecast :: Bool
allAdversariesKPlus1InForecast,
    Bool
genesisWindowAfterIntersection :: Bool
genesisWindowAfterIntersection :: Bool
genesisWindowAfterIntersection,
    Bool
longerThanGenesisWindow :: Bool
longerThanGenesisWindow :: Bool
longerThanGenesisWindow
  }
  where
    longerThanGenesisWindow :: Bool
longerThanGenesisWindow = AnchoredFragment blk -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot AnchoredFragment blk
goodChain WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At (Word64 -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
scg)

    genesisWindowAfterIntersection :: Bool
genesisWindowAfterIntersection =
      (BlockTreeBranch blk -> Bool) -> [BlockTreeBranch blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any BlockTreeBranch blk -> Bool
fragmentHasGenesis [BlockTreeBranch blk]
branches

    fragmentHasGenesis :: BlockTreeBranch blk -> Bool
fragmentHasGenesis BlockTreeBranch blk
btb =
      let
        frag :: AnchoredFragment blk
frag = BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix BlockTreeBranch blk
btb
        SlotNo Word64
intersection = SlotNo -> (SlotNo -> SlotNo) -> WithOrigin SlotNo -> SlotNo
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin SlotNo
0 SlotNo -> SlotNo
forall a. a -> a
id (Anchor blk -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
anchorToSlotNo (AnchoredFragment blk -> Anchor blk
forall v a b. AnchoredSeq v a b -> a
anchor AnchoredFragment blk
frag))
      in BlockTreeBranch blk -> Bool
isSelectable BlockTreeBranch blk
btb Bool -> Bool -> Bool
&& AnchoredFragment blk -> Int
forall blk. HasHeader blk => AnchoredFragment blk -> Int
slotLength AnchoredFragment blk
frag Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
scg Bool -> Bool -> Bool
&& Word64
goodTipSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
intersection Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
scg

    existsSelectableAdversary :: Bool
existsSelectableAdversary =
      (BlockTreeBranch blk -> Bool) -> [BlockTreeBranch blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any BlockTreeBranch blk -> Bool
isSelectable [BlockTreeBranch blk]
branches

    allAdversariesSelectable :: Bool
allAdversariesSelectable =
      (BlockTreeBranch blk -> Bool) -> [BlockTreeBranch blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all BlockTreeBranch blk -> Bool
isSelectable [BlockTreeBranch blk]
branches

    isSelectable :: BlockTreeBranch blk -> Bool
isSelectable BlockTreeBranch blk
bt = 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
bt) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
k

    allAdversariesForecastable :: Bool
allAdversariesForecastable =
      (BlockTreeBranch blk -> Bool) -> [BlockTreeBranch blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all BlockTreeBranch blk -> Bool
isForecastable [BlockTreeBranch blk]
branches

    isForecastable :: BlockTreeBranch blk -> Bool
isForecastable BlockTreeBranch blk
bt =
      -- FIXME: We are using `scg` here but what we really mean is `sfor`.
      -- Distinguish `scg` vs. `sgen` vs. `sfor` and use the latter here.
      -- NOTE: We only care about the difference between slot numbers so it is
      -- not a problem to add @1@ to all of them. However, we do care VERY MUCH
      -- that this list includes the anchor.
      let slotNos :: [SlotNo]
slotNos = (WithOrigin SlotNo -> SlotNo
forall t. (Bounded t, Enum t) => WithOrigin t -> t
succWithOrigin (WithOrigin SlotNo -> SlotNo) -> WithOrigin SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$ Anchor blk -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
anchorToSlotNo (Anchor blk -> WithOrigin SlotNo)
-> Anchor blk -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk -> Anchor blk
forall v a b. AnchoredSeq v a b -> a
anchor (AnchoredFragment blk -> Anchor blk)
-> AnchoredFragment blk -> Anchor blk
forall a b. (a -> b) -> a -> b
$ BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull BlockTreeBranch blk
bt)
                    SlotNo -> [SlotNo] -> [SlotNo]
forall a. a -> [a] -> [a]
: ((blk -> SlotNo) -> [blk] -> [SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map ((SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+SlotNo
1) (SlotNo -> SlotNo) -> (blk -> SlotNo) -> blk -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot) ([blk] -> [SlotNo]) -> [blk] -> [SlotNo]
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst (AnchoredFragment blk -> [blk]) -> AnchoredFragment blk -> [blk]
forall a b. (a -> b) -> a -> b
$ BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull BlockTreeBranch blk
bt) in
      ((SlotNo, SlotNo) -> Bool) -> [(SlotNo, SlotNo)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(SlotNo Word64
prev, SlotNo Word64
next) -> Word64
next Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
prev Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
scg) ([SlotNo] -> [SlotNo] -> [(SlotNo, SlotNo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SlotNo]
slotNos (Int -> [SlotNo] -> [SlotNo]
forall a. Int -> [a] -> [a]
drop Int
1 [SlotNo]
slotNos))

    allAdversariesKPlus1InForecast :: Bool
allAdversariesKPlus1InForecast =
      (BlockTreeBranch blk -> Bool) -> [BlockTreeBranch blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all BlockTreeBranch blk -> Bool
hasKPlus1InForecast [BlockTreeBranch blk]
branches

    hasKPlus1InForecast :: BlockTreeBranch blk -> Bool
hasKPlus1InForecast BlockTreeBranch{AnchoredFragment blk
btbSuffix :: forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix :: AnchoredFragment blk
btbSuffix} =
      -- FIXME: We are using `scg` here but what we really mean is `sfor`.
      -- Distinguish `scg` vs. `sgen` vs. `sfor` and use the latter here.
      let forecastSlot :: SlotNo
forecastSlot = WithOrigin SlotNo -> SlotNo
forall t. (Bounded t, Enum t) => WithOrigin t -> t
succWithOrigin (Anchor blk -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
anchorToSlotNo (Anchor blk -> WithOrigin SlotNo)
-> Anchor blk -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk -> Anchor blk
forall v a b. AnchoredSeq v a b -> a
anchor AnchoredFragment blk
btbSuffix) SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ Word64 -> SlotNo
SlotNo Word64
scg
          forecastBlocks :: AnchoredFragment blk
forecastBlocks = (blk -> Bool) -> AnchoredFragment blk -> AnchoredFragment blk
forall v a b.
Anchorable v a b =>
(b -> Bool) -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.takeWhileOldest (\blk
b -> blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
b SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
forecastSlot) AnchoredFragment blk
btbSuffix
       in AnchoredFragment blk -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment blk
forecastBlocks Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

    SlotNo Word64
goodTipSlot = SlotNo -> (SlotNo -> SlotNo) -> WithOrigin SlotNo -> SlotNo
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin SlotNo
0 SlotNo -> SlotNo
forall a. a -> a
id (AnchoredFragment blk -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
headSlot AnchoredFragment blk
goodChain)

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

    goodChain :: AnchoredFragment blk
goodChain = BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
gtBlockTree

-- | Interesting categories to classify test results
data ResultClassifiers =
  ResultClassifiers{
    -- | Percentage of adversaries that were killed by receiving an EmptyBucket exception from the LoP
    ResultClassifiers -> Double
adversariesKilledByLoP     :: Double,
    -- | Percentage of adversaries that were disconnected because their fragment was not dense enough
    ResultClassifiers -> Double
adversariesKilledByGDD     :: Double,
    -- | Percentage of adversaries that were disconnected by network-level timeouts
    ResultClassifiers -> Double
adversariesKilledByTimeout :: Double,
    -- | Percentage of adversaries that weren't killed
    ResultClassifiers -> Double
adversariesSurvived        :: Double
  }

-- | Returned when there were no adversaries
nullResultClassifier :: ResultClassifiers
nullResultClassifier :: ResultClassifiers
nullResultClassifier = Double -> Double -> Double -> Double -> ResultClassifiers
ResultClassifiers Double
0 Double
0 Double
0 Double
0

resultClassifiers :: GenesisTestFull blk -> RunGenesisTestResult -> ResultClassifiers
resultClassifiers :: forall blk.
GenesisTestFull blk -> RunGenesisTestResult -> ResultClassifiers
resultClassifiers GenesisTest{PointSchedule blk
gtSchedule :: PointSchedule blk
$sel:gtSchedule:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule} RunGenesisTestResult{StateView TestBlock
rgtrStateView :: StateView TestBlock
$sel:rgtrStateView:RunGenesisTestResult :: RunGenesisTestResult -> StateView TestBlock
rgtrStateView} =
  if Double
adversariesCount Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
    then ResultClassifiers {
        adversariesKilledByLoP :: Double
adversariesKilledByLoP     = Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
adversariesKilledByLoPC     Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
adversariesCount,
        adversariesKilledByGDD :: Double
adversariesKilledByGDD     = Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
adversariesKilledByGDDC     Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
adversariesCount,
        adversariesKilledByTimeout :: Double
adversariesKilledByTimeout = Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
adversariesKilledByTimeoutC Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
adversariesCount,
        adversariesSurvived :: Double
adversariesSurvived        = Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
adversariesSurvivedC        Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
adversariesCount
      }
    else ResultClassifiers
nullResultClassifier
  where
    StateView{[PeerSimulatorResult TestBlock]
svPeerSimulatorResults :: [PeerSimulatorResult TestBlock]
svPeerSimulatorResults :: forall blk. StateView blk -> [PeerSimulatorResult blk]
svPeerSimulatorResults} = StateView TestBlock
rgtrStateView

    adversaries :: [PeerId]
    adversaries :: [PeerId]
adversaries = (Int -> PeerId) -> [Int] -> [PeerId]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> PeerId
AdversarialPeer ([Int] -> [PeerId]) -> [Int] -> [PeerId]
forall a b. (a -> b) -> a -> b
$ Map Int (PeerSchedule blk) -> [Int]
forall k a. Map k a -> [k]
Map.keys (Map Int (PeerSchedule blk) -> [Int])
-> Map Int (PeerSchedule blk) -> [Int]
forall a b. (a -> b) -> a -> b
$ 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
gtSchedule

    adversariesCount :: Double
adversariesCount = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ [PeerId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PeerId]
adversaries

    adversariesExceptions :: [(PeerId, SomeException)]
    adversariesExceptions :: [(PeerId, SomeException)]
adversariesExceptions = (PeerSimulatorResult TestBlock -> Maybe (PeerId, SomeException))
-> [PeerSimulatorResult TestBlock] -> [(PeerId, SomeException)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
      (\PeerSimulatorResult{PeerId
psePeerId :: PeerId
psePeerId :: forall blk. PeerSimulatorResult blk -> PeerId
psePeerId, PeerSimulatorComponentResult TestBlock
pseResult :: PeerSimulatorComponentResult TestBlock
pseResult :: forall blk.
PeerSimulatorResult blk -> PeerSimulatorComponentResult blk
pseResult} -> case PeerId
psePeerId of
        HonestPeer Int
_ -> Maybe (PeerId, SomeException)
forall a. Maybe a
Nothing
        PeerId
pid          -> (PeerId
pid,) (SomeException -> (PeerId, SomeException))
-> Maybe SomeException -> Maybe (PeerId, SomeException)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PeerSimulatorComponentResult TestBlock -> Maybe SomeException
forall blk. PeerSimulatorComponentResult blk -> Maybe SomeException
pscrToException PeerSimulatorComponentResult TestBlock
pseResult
      )
      [PeerSimulatorResult TestBlock]
svPeerSimulatorResults

    adversariesSurvivedC :: Double
adversariesSurvivedC = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ [PeerId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PeerId] -> Int) -> [PeerId] -> Int
forall a b. (a -> b) -> a -> b
$ (PeerId -> Bool) -> [PeerId] -> [PeerId]
forall a. (a -> Bool) -> [a] -> [a]
filter
      (\PeerId
pid -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PeerId
pid PeerId -> [PeerId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((PeerId, SomeException) -> PeerId)
-> [(PeerId, SomeException)] -> [PeerId]
forall a b. (a -> b) -> [a] -> [b]
map (PeerId, SomeException) -> PeerId
forall a b. (a, b) -> a
fst [(PeerId, SomeException)]
adversariesExceptions)
      [PeerId]
adversaries

    adversariesKilledByLoPC :: Double
adversariesKilledByLoPC = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ [(PeerId, SomeException)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(PeerId, SomeException)] -> Int)
-> [(PeerId, SomeException)] -> Int
forall a b. (a -> b) -> a -> b
$ ((PeerId, SomeException) -> Bool)
-> [(PeerId, SomeException)] -> [(PeerId, SomeException)]
forall a. (a -> Bool) -> [a] -> [a]
filter
      (\(PeerId
_, SomeException
exn) -> SomeException -> Maybe ChainSyncClientException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn Maybe ChainSyncClientException
-> Maybe ChainSyncClientException -> Bool
forall a. Eq a => a -> a -> Bool
== ChainSyncClientException -> Maybe ChainSyncClientException
forall a. a -> Maybe a
Just ChainSyncClientException
EmptyBucket)
      [(PeerId, SomeException)]
adversariesExceptions

    adversariesKilledByGDDC :: Double
adversariesKilledByGDDC = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ [(PeerId, SomeException)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(PeerId, SomeException)] -> Int)
-> [(PeerId, SomeException)] -> Int
forall a b. (a -> b) -> a -> b
$ ((PeerId, SomeException) -> Bool)
-> [(PeerId, SomeException)] -> [(PeerId, SomeException)]
forall a. (a -> Bool) -> [a] -> [a]
filter
      (\(PeerId
_, SomeException
exn) -> SomeException -> Maybe ChainSyncClientException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn Maybe ChainSyncClientException
-> Maybe ChainSyncClientException -> Bool
forall a. Eq a => a -> a -> Bool
== ChainSyncClientException -> Maybe ChainSyncClientException
forall a. a -> Maybe a
Just ChainSyncClientException
DensityTooLow)
      [(PeerId, SomeException)]
adversariesExceptions

    adversariesKilledByTimeoutC :: Double
adversariesKilledByTimeoutC = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ [(PeerId, SomeException)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(PeerId, SomeException)] -> Int)
-> [(PeerId, SomeException)] -> Int
forall a b. (a -> b) -> a -> b
$ ((PeerId, SomeException) -> Bool)
-> [(PeerId, SomeException)] -> [(PeerId, SomeException)]
forall a. (a -> Bool) -> [a] -> [a]
filter
      (\(PeerId
_, SomeException
exn) -> case SomeException -> Maybe ProtocolLimitFailure
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn of
        Just (ExceededTimeLimit StateToken st
_) -> Bool
True
        Maybe ProtocolLimitFailure
_                          -> Bool
False
      )
      [(PeerId, SomeException)]
adversariesExceptions

data ScheduleClassifiers =
  ScheduleClassifiers{
    -- | There is an adversary that did a rollback
    ScheduleClassifiers -> Bool
adversaryRollback     :: Bool,
    -- | The honest peer did a rollback
    ScheduleClassifiers -> Bool
honestRollback        :: Bool,
    -- | All adversaries have an empty schedule: the only way to disconnect them are
    -- network timeouts.
    ScheduleClassifiers -> Bool
allAdversariesEmpty   :: Bool,
    -- | All adversaries have trivial schedules: they only have an initial state, and
    -- do nothing afterwards.
    ScheduleClassifiers -> Bool
allAdversariesTrivial :: Bool
  }

scheduleClassifiers :: GenesisTestFull TestBlock -> ScheduleClassifiers
scheduleClassifiers :: GenesisTestFull TestBlock -> ScheduleClassifiers
scheduleClassifiers GenesisTest{$sel:gtSchedule:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule = PointSchedule TestBlock
schedule} =
  ScheduleClassifiers
    { Bool
adversaryRollback :: Bool
adversaryRollback :: Bool
adversaryRollback
    , Bool
honestRollback :: Bool
honestRollback :: Bool
honestRollback
    , Bool
allAdversariesEmpty :: Bool
allAdversariesEmpty :: Bool
allAdversariesEmpty
    , Bool
allAdversariesTrivial :: Bool
allAdversariesTrivial :: Bool
allAdversariesTrivial
    }
  where
    hasRollback :: PeerSchedule TestBlock -> Bool
    hasRollback :: PeerSchedule TestBlock -> Bool
hasRollback PeerSchedule TestBlock
peerSch' =
        ([WithOrigin TestBlock] -> Bool)
-> [[WithOrigin TestBlock]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool)
-> ([WithOrigin TestBlock] -> Bool)
-> [WithOrigin TestBlock]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [WithOrigin TestBlock] -> Bool
isSorted) [[WithOrigin TestBlock]
tips, [WithOrigin TestBlock]
headers, [WithOrigin TestBlock]
blocks]
      where
        peerSch :: PeerSchedule TestBlock
peerSch = ((Time, SchedulePoint TestBlock) -> Time)
-> PeerSchedule TestBlock -> PeerSchedule TestBlock
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Time, SchedulePoint TestBlock) -> Time
forall a b. (a, b) -> a
fst PeerSchedule TestBlock
peerSch'
        isSorted :: [WithOrigin TestBlock] -> Bool
isSorted [WithOrigin TestBlock]
l = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [WithOrigin TestBlock
x WithOrigin TestBlock -> WithOrigin TestBlock -> Bool
`ancestor` WithOrigin TestBlock
y | (WithOrigin TestBlock
x:WithOrigin TestBlock
y:[WithOrigin TestBlock]
_) <- [WithOrigin TestBlock] -> [[WithOrigin TestBlock]]
forall a. [a] -> [[a]]
tails [WithOrigin TestBlock]
l]
        ancestor :: WithOrigin TestBlock -> WithOrigin TestBlock -> Bool
ancestor WithOrigin TestBlock
Origin  WithOrigin TestBlock
Origin  = Bool
True
        ancestor WithOrigin TestBlock
Origin  (At TestBlock
_)  = Bool
True
        ancestor (At TestBlock
_)  WithOrigin TestBlock
Origin  = Bool
False
        ancestor (At TestBlock
p1) (At TestBlock
p2) = TestBlock
p1 TestBlock -> TestBlock -> Bool
`isAncestorOf` TestBlock
p2
        tips :: [WithOrigin TestBlock]
tips = ((Time, SchedulePoint TestBlock) -> Maybe (WithOrigin TestBlock))
-> PeerSchedule TestBlock -> [WithOrigin TestBlock]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
          (\(Time
_, SchedulePoint TestBlock
point) -> case SchedulePoint TestBlock
point of
            ScheduleTipPoint WithOrigin TestBlock
blk -> WithOrigin TestBlock -> Maybe (WithOrigin TestBlock)
forall a. a -> Maybe a
Just WithOrigin TestBlock
blk
            SchedulePoint TestBlock
_                    -> Maybe (WithOrigin TestBlock)
forall a. Maybe a
Nothing
          )
          PeerSchedule TestBlock
peerSch
        headers :: [WithOrigin TestBlock]
headers = ((Time, SchedulePoint TestBlock) -> Maybe (WithOrigin TestBlock))
-> PeerSchedule TestBlock -> [WithOrigin TestBlock]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
          (\(Time
_, SchedulePoint TestBlock
point) -> case SchedulePoint TestBlock
point of
            ScheduleHeaderPoint WithOrigin TestBlock
blk -> WithOrigin TestBlock -> Maybe (WithOrigin TestBlock)
forall a. a -> Maybe a
Just WithOrigin TestBlock
blk
            SchedulePoint TestBlock
_                       -> Maybe (WithOrigin TestBlock)
forall a. Maybe a
Nothing
          )
          PeerSchedule TestBlock
peerSch
        blocks :: [WithOrigin TestBlock]
blocks = ((Time, SchedulePoint TestBlock) -> Maybe (WithOrigin TestBlock))
-> PeerSchedule TestBlock -> [WithOrigin TestBlock]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
          (\(Time
_, SchedulePoint TestBlock
point) -> case SchedulePoint TestBlock
point of
            ScheduleBlockPoint WithOrigin TestBlock
blk -> WithOrigin TestBlock -> Maybe (WithOrigin TestBlock)
forall a. a -> Maybe a
Just WithOrigin TestBlock
blk
            SchedulePoint TestBlock
_                      -> Maybe (WithOrigin TestBlock)
forall a. Maybe a
Nothing
          )
          PeerSchedule TestBlock
peerSch

    rollbacks :: Peers Bool
    rollbacks :: Peers Bool
rollbacks = PeerSchedule TestBlock -> Bool
hasRollback (PeerSchedule TestBlock -> Bool)
-> Peers (PeerSchedule TestBlock) -> Peers Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PointSchedule TestBlock -> Peers (PeerSchedule TestBlock)
forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule PointSchedule TestBlock
schedule

    adversaryRollback :: Bool
adversaryRollback = (Bool -> Bool) -> Map Int Bool -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Bool -> Bool
forall a. a -> a
id (Map Int Bool -> Bool) -> Map Int Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Peers Bool -> Map Int Bool
forall a. Peers a -> Map Int a
adversarialPeers Peers Bool
rollbacks
    honestRollback :: Bool
honestRollback = (Bool -> Bool) -> Map Int Bool -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Bool -> Bool
forall a. a -> a
id (Map Int Bool -> Bool) -> Map Int Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Peers Bool -> Map Int Bool
forall a. Peers a -> Map Int a
honestPeers Peers Bool
rollbacks

    allAdversariesEmpty :: Bool
allAdversariesEmpty = (Bool -> Bool) -> Map Int Bool -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Bool -> Bool
forall a. a -> a
id (Map Int Bool -> Bool) -> Map Int Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Peers Bool -> Map Int Bool
forall a. Peers a -> Map Int a
adversarialPeers (Peers Bool -> Map Int Bool) -> Peers Bool -> Map Int Bool
forall a b. (a -> b) -> a -> b
$ PeerSchedule TestBlock -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PeerSchedule TestBlock -> Bool)
-> Peers (PeerSchedule TestBlock) -> Peers Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PointSchedule TestBlock -> Peers (PeerSchedule TestBlock)
forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule PointSchedule TestBlock
schedule

    isTrivial :: PeerSchedule TestBlock -> Bool
    isTrivial :: PeerSchedule TestBlock -> Bool
isTrivial = \case
      []             -> Bool
True
      (Time
t0, SchedulePoint TestBlock
_):PeerSchedule TestBlock
points -> ((Time, SchedulePoint TestBlock) -> Bool)
-> PeerSchedule TestBlock -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
t0) (Time -> Bool)
-> ((Time, SchedulePoint TestBlock) -> Time)
-> (Time, SchedulePoint TestBlock)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, SchedulePoint TestBlock) -> Time
forall a b. (a, b) -> a
fst) PeerSchedule TestBlock
points

    allAdversariesTrivial :: Bool
allAdversariesTrivial = (Bool -> Bool) -> Map Int Bool -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Bool -> Bool
forall a. a -> a
id (Map Int Bool -> Bool) -> Map Int Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Peers Bool -> Map Int Bool
forall a. Peers a -> Map Int a
adversarialPeers (Peers Bool -> Map Int Bool) -> Peers Bool -> Map Int Bool
forall a b. (a -> b) -> a -> b
$ PeerSchedule TestBlock -> Bool
isTrivial (PeerSchedule TestBlock -> Bool)
-> Peers (PeerSchedule TestBlock) -> Peers Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PointSchedule TestBlock -> Peers (PeerSchedule TestBlock)
forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule PointSchedule TestBlock
schedule

simpleHash ::
  HeaderHash block ~ TestHash =>
  ChainHash block ->
  [Word64]
simpleHash :: forall block.
(HeaderHash block ~ TestHash) =>
ChainHash block -> [Word64]
simpleHash = \case
  BlockHash (TestHash NonEmpty Word64
h) -> [Word64] -> [Word64]
forall a. [a] -> [a]
reverse (NonEmpty Word64 -> [Word64]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Word64
h)
  -- not matching on @GenesisHash@ because 8.10 can't prove exhaustiveness of
  -- TestHash with the equality constraint
  ChainHash block
_ -> []