{-# 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 (..)
  )
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. (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 ::
  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
    (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 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.
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
rgtrTrace :: RunGenesisTestResult -> String
rgtrTrace :: String
rgtrTrace, StateView TestBlock
rgtrStateView :: 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
    | 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