{-# 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)


-- | 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. 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 ::
  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}

-- | 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.
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

-- | All-in-one helper that generates a 'GenesisTest' and a 'Peers
-- PeerSchedule', runs them with 'runGenesisTest', check whether the given
-- property holds on the resulting 'StateView'.
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 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
      | 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