{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Consensus.Genesis.Setup
  ( module Test.Consensus.Genesis.Setup.GenChains
  , AdjustTestCount (..)
  , AdjustMaxSize (..)
  , ConformanceTest (..)
  , castHeaderHash
  , honestImmutableTip
  , mkConformanceTest
  , runConformanceTest
  , selectedHonestChain
  ) where

import Control.Exception (throw)
import Control.Monad.Class.MonadAsync
  ( AsyncCancelled (AsyncCancelled)
  )
import Control.Monad.IOSim (IOSim, runSimStrictShutdown)
import Control.Tracer (debugTracer, traceWith)
import Data.Maybe (mapMaybe)
import Ouroboros.Consensus.Block.Abstract
  ( ChainHash (..)
  , ConvertRawHash
  , GetHeader
  , Header
  )
import Ouroboros.Consensus.Block.SupportsDiffusionPipelining
  ( BlockSupportsDiffusionPipelining
  )
import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode)
import Ouroboros.Consensus.HardFork.Abstract
import Ouroboros.Consensus.Ledger.Basics (LedgerState)
import Ouroboros.Consensus.Ledger.Inspect (InspectLedger)
import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras)
import Ouroboros.Consensus.Ledger.SupportsProtocol
  ( LedgerSupportsProtocol
  )
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client
  ( ChainSyncClientException (..)
  )
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB
import Ouroboros.Consensus.Storage.LedgerDB.API
  ( CanUpgradeLedgerTables
  )
import Ouroboros.Consensus.Util.Condense
import Ouroboros.Consensus.Util.IOLike (Exception, fromException)
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Driver.Limits
  ( ProtocolLimitFailure (ExceededTimeLimit)
  )
import Ouroboros.Network.Util.ShowProxy
import Test.Consensus.BlockTree (onTrunk)
import Test.Consensus.Genesis.Setup.Classifiers
  ( Classifiers (..)
  , ResultClassifiers (..)
  , ScheduleClassifiers (..)
  , classifiers
  , resultClassifiers
  , scheduleClassifiers
  )
import Test.Consensus.Genesis.Setup.GenChains
import Test.Consensus.PeerSimulator.Config ()
import Test.Consensus.PeerSimulator.Run
import Test.Consensus.PeerSimulator.StateView
import Test.Consensus.PeerSimulator.Trace
  ( traceLinesWith
  , tracerTestBlock
  )
import Test.Consensus.PointSchedule
import Test.Consensus.PointSchedule.NodeState (NodeState)
import Test.QuickCheck
import Test.Tasty (TestTree)
import qualified Test.Tasty.QuickCheck as QC
import Test.Util.Orphans.IOLike ()
import Test.Util.QuickCheck (forAllGenRunShrinkCheck)
import Test.Util.TersePrinting (Terse)
import Test.Util.TestBlock (TestBlock)
import Test.Util.TestEnv
  ( adjustQuickCheckMaxSize
  , adjustQuickCheckTests
  )
import Test.Util.Tracer (recordingTracerM)
import Text.Printf (printf)

-- | Contains all necessary data to run a 'GenesisTest'.
-- It is defined to reify the testing infrastructure for
-- the conformance @testgen@ executable.
data ConformanceTest blk = ConformanceTest
  { forall blk. ConformanceTest blk -> Gen (GenesisTestFull blk)
ctGenerator :: Gen (GenesisTestFull blk)
  -- ^ The test generator.
  , forall blk. ConformanceTest blk -> SchedulerConfig
ctSchedulerConfig :: SchedulerConfig
  -- ^ Peer simulator scheduler configuration.
  , forall blk.
ConformanceTest blk
-> GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
ctShrinker :: (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
  -- ^ A shrinker allowed to inspect the output value of a test.
  , forall blk.
ConformanceTest blk
-> GenesisTestFull blk -> StateView blk -> Property
ctProperty :: GenesisTestFull blk -> StateView blk -> Property
  -- ^ The property to test.
  , forall blk. ConformanceTest blk -> AdjustTestCount
ctAdjustTestCount :: AdjustTestCount
  -- ^ Adjust the default number of test runs to check the property.
  , forall blk. ConformanceTest blk -> AdjustMaxSize
ctAdjustMaxSize :: AdjustMaxSize
  -- ^ Adjust the default test case maximum size.
  , forall blk. ConformanceTest blk -> String
ctDescription :: String
  -- ^ A description for the test.
  }

-- | A 'ConformanceTest' field type for the adjustment of required number of test runs.
newtype AdjustTestCount = AdjustTestCount (Int -> Int)

-- | A 'ConformanceTest' field type for maximum test case size adjustment.
newtype AdjustMaxSize = AdjustMaxSize (Int -> Int)

mkConformanceTest ::
  Testable prop =>
  -- | Test description.
  String ->
  -- | Adjustment of the default number of required test runs.
  AdjustTestCount ->
  -- | Adjustment of the default maximum test size.
  AdjustMaxSize ->
  -- | Test generator.
  Gen (GenesisTestFull blk) ->
  -- | Peer simulator scheduler configuration.
  SchedulerConfig ->
  -- | Result inspecting shrinker.
  (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]) ->
  -- | Property on test result.
  (GenesisTestFull blk -> StateView blk -> prop) ->
  ConformanceTest blk
mkConformanceTest :: forall prop blk.
Testable prop =>
String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> prop)
-> ConformanceTest blk
mkConformanceTest String
ctDescription AdjustTestCount
ctAdjustTestCount AdjustMaxSize
ctAdjustMaxSize Gen (GenesisTestFull blk)
ctGenerator SchedulerConfig
ctSchedulerConfig GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
ctShrinker GenesisTestFull blk -> StateView blk -> prop
mkProperty =
  let ctProperty :: GenesisTestFull blk -> StateView blk -> Property
ctProperty = (prop -> Property)
-> (StateView blk -> prop) -> StateView blk -> Property
forall a b. (a -> b) -> (StateView blk -> a) -> StateView blk -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap prop -> Property
forall prop. Testable prop => prop -> Property
property ((StateView blk -> prop) -> StateView blk -> Property)
-> (GenesisTestFull blk -> StateView blk -> prop)
-> GenesisTestFull blk
-> StateView blk
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenesisTestFull blk -> StateView blk -> prop
mkProperty
   in ConformanceTest
        { String
ctDescription :: String
ctDescription :: String
ctDescription
        , AdjustTestCount
ctAdjustTestCount :: AdjustTestCount
ctAdjustTestCount :: AdjustTestCount
ctAdjustTestCount
        , AdjustMaxSize
ctAdjustMaxSize :: AdjustMaxSize
ctAdjustMaxSize :: AdjustMaxSize
ctAdjustMaxSize
        , Gen (GenesisTestFull blk)
ctGenerator :: Gen (GenesisTestFull blk)
ctGenerator :: Gen (GenesisTestFull blk)
ctGenerator
        , SchedulerConfig
ctSchedulerConfig :: SchedulerConfig
ctSchedulerConfig :: SchedulerConfig
ctSchedulerConfig
        , GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
ctShrinker :: GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
ctShrinker :: GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
ctShrinker
        , GenesisTestFull blk -> StateView blk -> Property
ctProperty :: GenesisTestFull blk -> StateView blk -> Property
ctProperty :: GenesisTestFull blk -> StateView blk -> Property
ctProperty
        }

-- | Like 'runSimStrictShutdown' but fail when the main thread terminates if
-- there are other threads still running or blocked. If one is trying to follow
-- a strict thread clean-up policy then this helps testing for that.
runSimStrictShutdownOrThrow :: forall a. (forall s. IOSim s a) -> a
runSimStrictShutdownOrThrow :: forall a. (forall s. IOSim s a) -> a
runSimStrictShutdownOrThrow forall s. IOSim s a
action =
  case (forall s. IOSim s a) -> Either Failure a
forall a. (forall s. IOSim s a) -> Either Failure a
runSimStrictShutdown IOSim s a
forall s. IOSim s a
action of
    Left Failure
e -> Failure -> a
forall a e. (HasCallStack, Exception e) => e -> a
throw Failure
e
    Right a
x -> a
x

-- | Runs the given 'GenesisTest' and 'PointSchedule' and evaluates the given
-- property on the final 'StateView'.
runGenesisTest ::
  ( Condense (StateView blk)
  , CondenseList (NodeState blk)
  , ShowProxy blk
  , ShowProxy (Header blk)
  , ConfigSupportsNode blk
  , LedgerSupportsProtocol blk
  , LedgerSupportsPeras blk
  , ChainDB.SerialiseDiskConstraints blk
  , BlockSupportsDiffusionPipelining blk
  , InspectLedger blk
  , HasHardForkHistory blk
  , ConvertRawHash blk
  , CanUpgradeLedgerTables (LedgerState blk)
  , HasPointScheduleTestParams blk
  , Eq (Header blk)
  , Eq blk
  , Terse blk
  , Condense (NodeState blk)
  ) =>
  ProtocolInfoArgs blk ->
  SchedulerConfig ->
  GenesisTestFull blk ->
  RunGenesisTestResult blk
runGenesisTest :: forall blk.
(Condense (StateView blk), CondenseList (NodeState blk),
 ShowProxy blk, ShowProxy (Header blk), ConfigSupportsNode blk,
 LedgerSupportsProtocol blk, LedgerSupportsPeras blk,
 SerialiseDiskConstraints blk, BlockSupportsDiffusionPipelining blk,
 InspectLedger blk, HasHardForkHistory blk, ConvertRawHash blk,
 CanUpgradeLedgerTables (LedgerState blk),
 HasPointScheduleTestParams blk, Eq (Header blk), Eq blk, Terse blk,
 Condense (NodeState blk)) =>
ProtocolInfoArgs blk
-> SchedulerConfig
-> GenesisTestFull blk
-> RunGenesisTestResult blk
runGenesisTest ProtocolInfoArgs blk
protocolInfoArgs SchedulerConfig
schedulerConfig GenesisTestFull blk
genesisTest =
  (forall s. IOSim s (RunGenesisTestResult blk))
-> RunGenesisTestResult blk
forall a. (forall s. IOSim s a) -> a
runSimStrictShutdownOrThrow ((forall s. IOSim s (RunGenesisTestResult blk))
 -> RunGenesisTestResult blk)
-> (forall s. IOSim s (RunGenesisTestResult blk))
-> RunGenesisTestResult blk
forall a b. (a -> b) -> a -> b
$ do
    (recordingTracer, getTrace) <- IOSim s (Tracer (IOSim s) String, IOSim s [String])
forall (m :: * -> *) ev. Monad m => m (Tracer m ev, m [ev])
recordingTracerM
    let tracer = if SchedulerConfig -> Bool
scDebug SchedulerConfig
schedulerConfig then Tracer (IOSim s) String
forall (m :: * -> *). Applicative m => Tracer m String
debugTracer else Tracer (IOSim s) String
recordingTracer

    traceLinesWith tracer $ prettyGenesisTest prettyPointSchedule genesisTest

    rgtrStateView <-
      runPointSchedule protocolInfoArgs schedulerConfig genesisTest =<< tracerTestBlock tracer
    traceWith tracer (condense rgtrStateView)
    rgtrTrace <- unlines <$> getTrace

    pure $ RunGenesisTestResult{rgtrTrace, rgtrStateView}

-- | Variant of 'runGenesisTest' that also takes a property on the final
-- 'StateView' and returns a QuickCheck property. The trace is printed in case
-- of counter-example.
-- TODO: This function was unused before the introduction of 'ConformanceTest';
-- we should decide if its worth keeping around. When testing other
-- implementations of the protocol (via the Conformance Testing of Consensus
-- harness) we won't have a 'StateView' to check properties on. However, it seems
-- plausible this functionality could be leveraged for internal testing purposes.
_runGenesisTest' ::
  Testable prop =>
  SchedulerConfig ->
  GenesisTestFull TestBlock ->
  (StateView TestBlock -> prop) ->
  Property
_runGenesisTest' :: forall prop.
Testable prop =>
SchedulerConfig
-> GenesisTestFull TestBlock
-> (StateView TestBlock -> prop)
-> Property
_runGenesisTest' SchedulerConfig
schedulerConfig GenesisTestFull TestBlock
genesisTest StateView TestBlock -> prop
makeProperty = IO Property -> Property
forall prop. Testable prop => IO prop -> Property
idempotentIOProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  protocolInfoArgs <- IO (ProtocolInfoArgs TestBlock)
forall blk.
HasPointScheduleTestParams blk =>
IO (ProtocolInfoArgs blk)
getProtocolInfoArgs
  let RunGenesisTestResult{rgtrTrace, rgtrStateView} =
        runGenesisTest protocolInfoArgs schedulerConfig genesisTest
  pure $ counterexample rgtrTrace $ makeProperty rgtrStateView

-- | All-in-one helper that generates a 'GenesisTest' and a 'Peers
-- PeerSchedule' from a 'ConformanceTest', runs them with 'runGenesisTest',
-- and checks whether the given property holds on the resulting 'StateView'.
runConformanceTest ::
  forall blk.
  ( Condense (StateView blk)
  , CondenseList (NodeState blk)
  , ShowProxy blk
  , ShowProxy (Header blk)
  , ConfigSupportsNode blk
  , LedgerSupportsProtocol blk
  , LedgerSupportsPeras blk
  , ChainDB.SerialiseDiskConstraints blk
  , BlockSupportsDiffusionPipelining blk
  , InspectLedger blk
  , HasHardForkHistory blk
  , ConvertRawHash blk
  , CanUpgradeLedgerTables (LedgerState blk)
  , HasPointScheduleTestParams blk
  , Eq (Header blk)
  , Eq blk
  , Terse blk
  , Condense (NodeState blk)
  ) =>
  ConformanceTest blk -> TestTree
runConformanceTest :: forall blk.
(Condense (StateView blk), CondenseList (NodeState blk),
 ShowProxy blk, ShowProxy (Header blk), ConfigSupportsNode blk,
 LedgerSupportsProtocol blk, LedgerSupportsPeras blk,
 SerialiseDiskConstraints blk, BlockSupportsDiffusionPipelining blk,
 InspectLedger blk, HasHardForkHistory blk, ConvertRawHash blk,
 CanUpgradeLedgerTables (LedgerState blk),
 HasPointScheduleTestParams blk, Eq (Header blk), Eq blk, Terse blk,
 Condense (NodeState blk)) =>
ConformanceTest blk -> TestTree
runConformanceTest ConformanceTest blk
conformanceTest =
  (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests Int -> Int
atc (TestTree -> TestTree)
-> (TestTree -> TestTree) -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckMaxSize Int -> Int
ams (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
    String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
QC.testProperty String
ctDescription (Property -> TestTree)
-> (IO Property -> Property) -> IO Property -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Property -> Property
forall prop. Testable prop => IO prop -> Property
idempotentIOProperty (IO Property -> TestTree) -> IO Property -> TestTree
forall a b. (a -> b) -> a -> b
$ do
      protocolInfoArgs <- IO (ProtocolInfoArgs blk)
forall blk.
HasPointScheduleTestParams blk =>
IO (ProtocolInfoArgs blk)
getProtocolInfoArgs
      pure $
        forAllGenRunShrinkCheck ctGenerator (runGenesisTest protocolInfoArgs ctSchedulerConfig) shrinker' $
          \GenesisTestFull blk
genesisTest RunGenesisTestResult blk
result ->
            let cls :: Classifiers
cls = GenesisTestFull blk -> Classifiers
forall blk schedule.
HasHeader blk =>
GenesisTest blk schedule -> Classifiers
classifiers GenesisTestFull blk
genesisTest
                resCls :: ResultClassifiers
resCls = GenesisTestFull blk
-> RunGenesisTestResult blk -> ResultClassifiers
forall blk.
GenesisTestFull blk
-> RunGenesisTestResult blk -> ResultClassifiers
resultClassifiers GenesisTestFull blk
genesisTest RunGenesisTestResult blk
result
                schCls :: ScheduleClassifiers
schCls = GenesisTestFull blk -> ScheduleClassifiers
forall blk.
(HasHeader blk, Eq blk) =>
GenesisTestFull blk -> ScheduleClassifiers
scheduleClassifiers GenesisTestFull blk
genesisTest
                stateView :: StateView blk
stateView = RunGenesisTestResult blk -> StateView blk
forall blk. RunGenesisTestResult blk -> StateView blk
rgtrStateView RunGenesisTestResult blk
result
             in Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (Classifiers -> Bool
allAdversariesSelectable Classifiers
cls) String
"All adversaries have more than k blocks after intersection"
                  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify
                    (Classifiers -> Bool
allAdversariesForecastable Classifiers
cls)
                    String
"All adversaries have at least 1 forecastable block after intersection"
                  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify
                    (Classifiers -> Bool
allAdversariesKPlus1InForecast Classifiers
cls)
                    String
"All adversaries have k+1 blocks in forecast window after intersection"
                  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (Classifiers -> Bool
genesisWindowAfterIntersection Classifiers
cls) String
"Full genesis window after intersection"
                  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (ScheduleClassifiers -> Bool
adversaryRollback ScheduleClassifiers
schCls) String
"An adversary did a rollback"
                  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (ScheduleClassifiers -> Bool
honestRollback ScheduleClassifiers
schCls) String
"The honest peer did a rollback"
                  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (ScheduleClassifiers -> Bool
allAdversariesEmpty ScheduleClassifiers
schCls) String
"All adversaries have empty schedules"
                  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (ScheduleClassifiers -> Bool
allAdversariesTrivial ScheduleClassifiers
schCls) String
"All adversaries have trivial schedules"
                  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"Adversaries killed by LoP" [String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.1f%%" (Double -> String) -> Double -> String
forall a b. (a -> b) -> a -> b
$ ResultClassifiers -> Double
adversariesKilledByLoP ResultClassifiers
resCls]
                  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"Adversaries killed by GDD" [String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.1f%%" (Double -> String) -> Double -> String
forall a b. (a -> b) -> a -> b
$ ResultClassifiers -> Double
adversariesKilledByGDD ResultClassifiers
resCls]
                  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"Adversaries killed by Timeout" [String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.1f%%" (Double -> String) -> Double -> String
forall a b. (a -> b) -> a -> b
$ ResultClassifiers -> Double
adversariesKilledByTimeout ResultClassifiers
resCls]
                  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"Surviving adversaries" [String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.1f%%" (Double -> String) -> Double -> String
forall a b. (a -> b) -> a -> b
$ ResultClassifiers -> Double
adversariesSurvived ResultClassifiers
resCls]
                  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (RunGenesisTestResult blk -> String
forall blk. RunGenesisTestResult blk -> String
rgtrTrace RunGenesisTestResult blk
result)
                  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ GenesisTestFull blk -> StateView blk -> Property
ctProperty GenesisTestFull blk
genesisTest StateView blk
stateView Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. StateView blk -> Property
forall {blk}. StateView blk -> Property
hasOnlyExpectedExceptions StateView blk
stateView
 where
  ConformanceTest
    { ctAdjustTestCount :: forall blk. ConformanceTest blk -> AdjustTestCount
ctAdjustTestCount = AdjustTestCount Int -> Int
atc
    , ctAdjustMaxSize :: forall blk. ConformanceTest blk -> AdjustMaxSize
ctAdjustMaxSize = AdjustMaxSize Int -> Int
ams
    , String
ctDescription :: forall blk. ConformanceTest blk -> String
ctDescription :: String
ctDescription
    , Gen (GenesisTestFull blk)
ctGenerator :: forall blk. ConformanceTest blk -> Gen (GenesisTestFull blk)
ctGenerator :: Gen (GenesisTestFull blk)
ctGenerator
    , SchedulerConfig
ctSchedulerConfig :: forall blk. ConformanceTest blk -> SchedulerConfig
ctSchedulerConfig :: SchedulerConfig
ctSchedulerConfig
    , GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
ctShrinker :: forall blk.
ConformanceTest blk
-> GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
ctShrinker :: GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
ctShrinker
    , GenesisTestFull blk -> StateView blk -> Property
ctProperty :: forall blk.
ConformanceTest blk
-> GenesisTestFull blk -> StateView blk -> Property
ctProperty :: GenesisTestFull blk -> StateView blk -> Property
ctProperty
    } = ConformanceTest blk
conformanceTest
  shrinker' :: GenesisTestFull blk
-> RunGenesisTestResult blk -> [GenesisTestFull blk]
shrinker' GenesisTestFull blk
gt = GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
ctShrinker GenesisTestFull blk
gt (StateView blk -> [GenesisTestFull blk])
-> (RunGenesisTestResult blk -> StateView blk)
-> RunGenesisTestResult blk
-> [GenesisTestFull blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunGenesisTestResult blk -> StateView blk
forall blk. RunGenesisTestResult blk -> StateView blk
rgtrStateView
  hasOnlyExpectedExceptions :: StateView blk -> Property
hasOnlyExpectedExceptions StateView{[PeerSimulatorResult blk]
svPeerSimulatorResults :: [PeerSimulatorResult blk]
svPeerSimulatorResults :: forall blk. StateView blk -> [PeerSimulatorResult blk]
svPeerSimulatorResults} =
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$
      SomeException -> Property
isExpectedException
        (SomeException -> Property) -> [SomeException] -> [Property]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PeerSimulatorResult blk -> Maybe SomeException)
-> [PeerSimulatorResult blk] -> [SomeException]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
          (PeerSimulatorComponentResult blk -> Maybe SomeException
forall blk. PeerSimulatorComponentResult blk -> Maybe SomeException
pscrToException (PeerSimulatorComponentResult blk -> Maybe SomeException)
-> (PeerSimulatorResult blk -> PeerSimulatorComponentResult blk)
-> PeerSimulatorResult blk
-> Maybe SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerSimulatorResult blk -> PeerSimulatorComponentResult blk
forall blk.
PeerSimulatorResult blk -> PeerSimulatorComponentResult blk
pseResult)
          [PeerSimulatorResult blk]
svPeerSimulatorResults
  isExpectedException :: SomeException -> Property
isExpectedException SomeException
exn
    | Just ChainSyncClientException
EmptyBucket <- Maybe ChainSyncClientException
forall e. Exception e => Maybe e
e = Property
true
    | Just ChainSyncClientException
DensityTooLow <- Maybe ChainSyncClientException
forall e. Exception e => Maybe e
e = Property
true
    | Just (ExceededTimeLimit StateToken st
_) <- Maybe ProtocolLimitFailure
forall e. Exception e => Maybe e
e = Property
true
    | Just AsyncCancelled
AsyncCancelled <- Maybe AsyncCancelled
forall e. Exception e => Maybe e
e = Property
true
    | Just CandidateTooSparse{} <- Maybe ChainSyncClientException
forall e. Exception e => Maybe e
e = Property
true
    | Bool
otherwise =
        String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
          (String
"Encountered unexpected exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
exn)
          Bool
False
   where
    e :: Exception e => Maybe e
    e :: forall e. Exception e => Maybe e
e = SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn
    true :: Property
true = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True

-- | The 'StateView.svSelectedChain' produces an 'AnchoredFragment (Header blk)';
-- this function casts this type's hash to its instance, so that it can be used
-- for lookups on a 'BlockTree'.
castHeaderHash :: ChainHash (Header blk) -> ChainHash blk
castHeaderHash :: forall blk. ChainHash (Header blk) -> ChainHash blk
castHeaderHash = \case
  BlockHash HeaderHash (Header blk)
hash -> HeaderHash blk -> ChainHash blk
forall {k} (b :: k). HeaderHash b -> ChainHash b
BlockHash HeaderHash blk
HeaderHash (Header blk)
hash
  ChainHash (Header blk)
GenesisHash -> ChainHash blk
forall {k} (b :: k). ChainHash b
GenesisHash

-- | Check if the immutable tip of the selected chain of a 'GenesisTest' is honest.
-- In this setting, the immutable tip corresponds to the selected chain anchor
-- (see 'Ouroboros.Consensus.Storage.ChainDB.API.getCurrentChain') and
-- the honest chain is represented by the test 'BlockTree' trunk.
honestImmutableTip :: GetHeader blk => GenesisTestFull blk -> StateView blk -> Bool
honestImmutableTip :: forall blk.
GetHeader blk =>
GenesisTestFull blk -> StateView blk -> Bool
honestImmutableTip GenesisTest{BlockTree blk
gtBlockTree :: BlockTree blk
gtBlockTree :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree} StateView{AnchoredFragment (Header blk)
svSelectedChain :: AnchoredFragment (Header blk)
svSelectedChain :: forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain} =
  BlockTree blk -> Point (Header blk) -> Bool
forall blk.
GetHeader blk =>
BlockTree blk -> Point (Header blk) -> Bool
onTrunk BlockTree blk
gtBlockTree (Point (Header blk) -> Bool) -> Point (Header blk) -> Bool
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredFragment (Header blk)
svSelectedChain

-- | Check if the tip of the selected chain of a 'GenesisTest' is honest.
-- In this setting, the honest chain corresponds to the test 'BlockTree' trunk.
selectedHonestChain :: GetHeader blk => GenesisTestFull blk -> StateView blk -> Bool
selectedHonestChain :: forall blk.
GetHeader blk =>
GenesisTestFull blk -> StateView blk -> Bool
selectedHonestChain GenesisTest{BlockTree blk
gtBlockTree :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree blk
gtBlockTree} StateView{AnchoredFragment (Header blk)
svSelectedChain :: forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain :: AnchoredFragment (Header blk)
svSelectedChain} =
  BlockTree blk -> Point (Header blk) -> Bool
forall blk.
GetHeader blk =>
BlockTree blk -> Point (Header blk) -> Bool
onTrunk BlockTree blk
gtBlockTree (Point (Header blk) -> Bool) -> Point (Header blk) -> Bool
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment (Header blk) -> Point (Header blk))
-> AnchoredFragment (Header blk) -> Point (Header blk)
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk)
svSelectedChain