{-# 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.Ledger.BaseTypes (unNonZero)
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 (..)
  , 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
  { Classifiers -> Bool
existsSelectableAdversary :: Bool
  -- ^ There are more than k blocks in at least one alternative chain after the intersection
  , Classifiers -> Bool
allAdversariesSelectable :: 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
allAdversariesForecastable :: 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
allAdversariesKPlus1InForecast :: 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
genesisWindowAfterIntersection :: 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
longerThanGenesisWindow :: Bool
  -- ^ The honest chain's slot count is greater than or equal to the Genesis window size.
  }

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
gtBlockTree :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree, gtSecurityParam :: forall blk schedule. GenesisTest blk schedule -> SecurityParam
gtSecurityParam = SecurityParam NonZero Word64
k, gtGenesisWindow :: 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 (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero 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 (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero 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
  { ResultClassifiers -> Double
adversariesKilledByLoP :: Double
  -- ^ Percentage of adversaries that were killed by receiving an EmptyBucket exception from the LoP
  , ResultClassifiers -> Double
adversariesKilledByGDD :: Double
  -- ^ Percentage of adversaries that were disconnected because their fragment was not dense enough
  , ResultClassifiers -> Double
adversariesKilledByTimeout :: Double
  -- ^ Percentage of adversaries that were disconnected by network-level timeouts
  , ResultClassifiers -> Double
adversariesSurvived :: Double
  -- ^ Percentage of adversaries that weren't killed
  }

-- | 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
gtSchedule :: forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule} RunGenesisTestResult{StateView TestBlock
rgtrStateView :: StateView TestBlock
rgtrStateView :: 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
  { ScheduleClassifiers -> Bool
adversaryRollback :: Bool
  -- ^ There is an adversary that did a rollback
  , ScheduleClassifiers -> Bool
honestRollback :: Bool
  -- ^ The honest peer did a rollback
  , ScheduleClassifiers -> Bool
allAdversariesEmpty :: Bool
  -- ^ All adversaries have an empty schedule: the only way to disconnect them are
  -- network timeouts.
  , ScheduleClassifiers -> Bool
allAdversariesTrivial :: Bool
  -- ^ All adversaries have trivial schedules: they only have an initial state, and
  -- do nothing afterwards.
  }

scheduleClassifiers :: GenesisTestFull TestBlock -> ScheduleClassifiers
scheduleClassifiers :: GenesisTestFull TestBlock -> ScheduleClassifiers
scheduleClassifiers GenesisTest{gtSchedule :: 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)
  ChainHash block
GenesisHash -> []