{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Consensus.Genesis.Setup (
module Test.Consensus.Genesis.Setup.GenChains
, forAllGenesisTest
, runGenesisTest
, runGenesisTest'
) 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.MiniProtocol.ChainSync.Client
(ChainSyncClientException (DensityTooLow, EmptyBucket))
import Ouroboros.Consensus.Util.Condense
import Ouroboros.Consensus.Util.IOLike (Exception, fromException)
import Ouroboros.Network.Driver.Limits
(ProtocolLimitFailure (ExceededTimeLimit))
import Test.Consensus.Genesis.Setup.Classifiers (Classifiers (..),
ResultClassifiers (..), ScheduleClassifiers (..),
classifiers, resultClassifiers, scheduleClassifiers)
import Test.Consensus.Genesis.Setup.GenChains
import Test.Consensus.PeerSimulator.Run
import Test.Consensus.PeerSimulator.StateView
import Test.Consensus.PeerSimulator.Trace (traceLinesWith,
tracerTestBlock)
import Test.Consensus.PointSchedule
import Test.QuickCheck
import Test.Util.Orphans.IOLike ()
import Test.Util.QuickCheck (forAllGenRunShrinkCheck)
import Test.Util.TestBlock (TestBlock)
import Test.Util.Tracer (recordingTracerM)
import Text.Printf (printf)
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. Exception e => e -> a
throw Failure
e
Right a
x -> a
x
runGenesisTest ::
SchedulerConfig ->
GenesisTestFull TestBlock ->
RunGenesisTestResult
runGenesisTest :: SchedulerConfig
-> GenesisTestFull TestBlock -> RunGenesisTestResult
runGenesisTest SchedulerConfig
schedulerConfig GenesisTestFull TestBlock
genesisTest =
(forall s. IOSim s RunGenesisTestResult) -> RunGenesisTestResult
forall a. (forall s. IOSim s a) -> a
runSimStrictShutdownOrThrow ((forall s. IOSim s RunGenesisTestResult) -> RunGenesisTestResult)
-> (forall s. IOSim s RunGenesisTestResult) -> RunGenesisTestResult
forall a b. (a -> b) -> a -> b
$ do
(Tracer (IOSim s) String
recordingTracer, IOSim s [String]
getTrace) <- IOSim s (Tracer (IOSim s) String, IOSim s [String])
forall (m :: * -> *) ev. Monad m => m (Tracer m ev, m [ev])
recordingTracerM
let tracer :: Tracer (IOSim s) String
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
Tracer (IOSim s) String -> [String] -> IOSim s ()
forall (m :: * -> *). Tracer m String -> [String] -> m ()
traceLinesWith Tracer (IOSim s) String
tracer ([String] -> IOSim s ()) -> [String] -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ (PointSchedule TestBlock -> [String])
-> GenesisTestFull TestBlock -> [String]
forall schedule.
(schedule -> [String])
-> GenesisTest TestBlock schedule -> [String]
prettyGenesisTest PointSchedule TestBlock -> [String]
forall blk.
CondenseList (NodeState blk) =>
PointSchedule blk -> [String]
prettyPointSchedule GenesisTestFull TestBlock
genesisTest
StateView TestBlock
rgtrStateView <- SchedulerConfig
-> GenesisTestFull TestBlock
-> Tracer (IOSim s) (TraceEvent TestBlock)
-> IOSim s (StateView TestBlock)
forall (m :: * -> *).
(IOLike m, MonadTime m, MonadTimer m) =>
SchedulerConfig
-> GenesisTestFull TestBlock
-> Tracer m (TraceEvent TestBlock)
-> m (StateView TestBlock)
runPointSchedule SchedulerConfig
schedulerConfig GenesisTestFull TestBlock
genesisTest (Tracer (IOSim s) (TraceEvent TestBlock)
-> IOSim s (StateView TestBlock))
-> IOSim s (Tracer (IOSim s) (TraceEvent TestBlock))
-> IOSim s (StateView TestBlock)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Tracer (IOSim s) String
-> IOSim s (Tracer (IOSim s) (TraceEvent TestBlock))
forall (m :: * -> *).
IOLike m =>
Tracer m String -> m (Tracer m (TraceEvent TestBlock))
tracerTestBlock Tracer (IOSim s) String
tracer
Tracer (IOSim s) String -> String -> IOSim s ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer (IOSim s) String
tracer (StateView TestBlock -> String
forall a. Condense a => a -> String
condense StateView TestBlock
rgtrStateView)
String
rgtrTrace <- [String] -> String
unlines ([String] -> String) -> IOSim s [String] -> IOSim s String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOSim s [String]
getTrace
RunGenesisTestResult -> IOSim s RunGenesisTestResult
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunGenesisTestResult -> IOSim s RunGenesisTestResult)
-> RunGenesisTestResult -> IOSim s RunGenesisTestResult
forall a b. (a -> b) -> a -> b
$ RunGenesisTestResult {String
rgtrTrace :: String
$sel:rgtrTrace:RunGenesisTestResult :: String
rgtrTrace, StateView TestBlock
rgtrStateView :: StateView TestBlock
$sel:rgtrStateView:RunGenesisTestResult :: StateView TestBlock
rgtrStateView}
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 =
String -> prop -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
rgtrTrace (prop -> Property) -> prop -> Property
forall a b. (a -> b) -> a -> b
$ StateView TestBlock -> prop
makeProperty StateView TestBlock
rgtrStateView
where
RunGenesisTestResult{String
$sel:rgtrTrace:RunGenesisTestResult :: RunGenesisTestResult -> String
rgtrTrace :: String
rgtrTrace, StateView TestBlock
$sel:rgtrStateView:RunGenesisTestResult :: RunGenesisTestResult -> StateView TestBlock
rgtrStateView :: StateView TestBlock
rgtrStateView} =
SchedulerConfig
-> GenesisTestFull TestBlock -> RunGenesisTestResult
runGenesisTest SchedulerConfig
schedulerConfig GenesisTestFull TestBlock
genesisTest
forAllGenesisTest ::
Testable prop =>
Gen (GenesisTestFull TestBlock) ->
SchedulerConfig ->
(GenesisTestFull TestBlock -> StateView TestBlock -> [GenesisTestFull TestBlock]) ->
(GenesisTestFull TestBlock -> StateView TestBlock -> prop) ->
Property
forAllGenesisTest :: forall prop.
Testable prop =>
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> prop)
-> Property
forAllGenesisTest Gen (GenesisTestFull TestBlock)
generator SchedulerConfig
schedulerConfig GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinker GenesisTestFull TestBlock -> StateView TestBlock -> prop
mkProperty =
Gen (GenesisTestFull TestBlock)
-> (GenesisTestFull TestBlock -> RunGenesisTestResult)
-> (GenesisTestFull TestBlock
-> RunGenesisTestResult -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> RunGenesisTestResult -> Property)
-> Property
forall prop input output.
Testable prop =>
Gen input
-> (input -> output)
-> (input -> output -> [input])
-> (input -> output -> prop)
-> Property
forAllGenRunShrinkCheck Gen (GenesisTestFull TestBlock)
generator GenesisTestFull TestBlock -> RunGenesisTestResult
runner GenesisTestFull TestBlock
-> RunGenesisTestResult -> [GenesisTestFull TestBlock]
shrinker' ((GenesisTestFull TestBlock -> RunGenesisTestResult -> Property)
-> Property)
-> (GenesisTestFull TestBlock -> RunGenesisTestResult -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \GenesisTestFull TestBlock
genesisTest RunGenesisTestResult
result ->
let cls :: Classifiers
cls = GenesisTestFull TestBlock -> Classifiers
forall blk schedule.
HasHeader blk =>
GenesisTest blk schedule -> Classifiers
classifiers GenesisTestFull TestBlock
genesisTest
resCls :: ResultClassifiers
resCls = GenesisTestFull TestBlock
-> RunGenesisTestResult -> ResultClassifiers
forall blk.
GenesisTestFull blk -> RunGenesisTestResult -> ResultClassifiers
resultClassifiers GenesisTestFull TestBlock
genesisTest RunGenesisTestResult
result
schCls :: ScheduleClassifiers
schCls = GenesisTestFull TestBlock -> ScheduleClassifiers
scheduleClassifiers GenesisTestFull TestBlock
genesisTest
stateView :: StateView TestBlock
stateView = RunGenesisTestResult -> StateView TestBlock
rgtrStateView RunGenesisTestResult
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 -> String
rgtrTrace RunGenesisTestResult
result) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
GenesisTestFull TestBlock -> StateView TestBlock -> prop
mkProperty GenesisTestFull TestBlock
genesisTest StateView TestBlock
stateView prop -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. StateView TestBlock -> Property
forall {blk}. StateView blk -> Property
hasOnlyExpectedExceptions StateView TestBlock
stateView
where
runner :: GenesisTestFull TestBlock -> RunGenesisTestResult
runner = SchedulerConfig
-> GenesisTestFull TestBlock -> RunGenesisTestResult
runGenesisTest SchedulerConfig
schedulerConfig
shrinker' :: GenesisTestFull TestBlock
-> RunGenesisTestResult -> [GenesisTestFull TestBlock]
shrinker' GenesisTestFull TestBlock
gt = GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinker GenesisTestFull TestBlock
gt (StateView TestBlock -> [GenesisTestFull TestBlock])
-> (RunGenesisTestResult -> StateView TestBlock)
-> RunGenesisTestResult
-> [GenesisTestFull TestBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunGenesisTestResult -> StateView TestBlock
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 PeerHasAgency pr 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
| 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