Add classifiers and sanity check to Genesis tests

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs

@@ -13,10 +13,19 @@ module Test.Consensus.Genesis.Setup (
   ) 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           Test.Consensus.Genesis.Setup.Classifiers (classifiers, Classifiers (..))
+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
@@ -27,12 +36,8 @@ import           Test.Util.Orphans.IOLike ()
 import           Test.Util.QuickCheck (forAllGenRunShrinkCheck)
 import           Test.Util.TestBlock (TestBlock)
 import           Test.Util.Tracer (recordingTracerTVar)
+import           Text.Printf (printf)
 
--- | See 'runGenesisTest'.
-data RunGenesisTestResult = RunGenesisTestResult {
-  rgtrTrace :: String,
-  rgtrStateView :: StateView TestBlock
-  }
 
 -- | Like 'runSimStrictShutdown' but fail when the main thread terminates if
 -- there are other threads still running or blocked. If one is trying to follow
@@ -90,12 +95,37 @@ forAllGenesisTest ::
 forAllGenesisTest generator schedulerConfig shrinker mkProperty =
   forAllGenRunShrinkCheck generator runner shrinker' $ \genesisTest result ->
     let cls = classifiers genesisTest
-     in classify (allAdversariesSelectable cls) "All adversaries selectable" $
-        classify (allAdversariesForecastable cls) "All adversaries forecastable" $
+        resCls = resultClassifiers genesisTest result
+        schCls = scheduleClassifiers genesisTest
+        stateView = rgtrStateView result
+     in classify (allAdversariesSelectable cls) "All adversaries have more than k blocks after intersection" $
+        classify (allAdversariesForecastable cls) "All adversaries have at least 1 forecastable block after intersection" $
         classify (allAdversariesKPlus1InForecast cls) "All adversaries have k+1 blocks in forecast window after intersection" $
         classify (genesisWindowAfterIntersection cls) "Full genesis window after intersection" $
+        classify (adversaryRollback schCls) "An adversary did a rollback" $
+        classify (honestRollback schCls) "The honest peer did a rollback" $
+        tabulate "Adversaries killed by LoP" [printf "%.1f%%" $ adversariesKilledByLoP resCls] $
+        tabulate "Adversaries killed by GDD" [printf "%.1f%%" $ adversariesKilledByGDD resCls] $
+        tabulate "Adversaries killed by Timeout" [printf "%.1f%%" $ adversariesKilledByTimeout resCls] $
+        tabulate "Surviving adversaries" [printf "%.1f%%" $ adversariesSurvived resCls] $
         counterexample (rgtrTrace result) $
-        mkProperty genesisTest (rgtrStateView result)
+        mkProperty genesisTest stateView .&&. hasOnlyExpectedExceptions stateView
   where
     runner = runGenesisTest schedulerConfig
     shrinker' gt = shrinker gt . rgtrStateView
+    hasOnlyExpectedExceptions StateView{svPeerSimulatorResults} =
+      conjoin $ isExpectedException <$> mapMaybe
+        (pscrToException . pseResult)
+        svPeerSimulatorResults
+    isExpectedException exn
+      | Just EmptyBucket           <- e = true
+      | Just DensityTooLow         <- e = true
+      | Just (ExceededTimeLimit _) <- e = true
+      | Just AsyncCancelled        <- e = true
+      | otherwise = counterexample
+        ("Encountered unexpected exception: " ++ show exn)
+        False
+      where
+        e :: (Exception e) => Maybe e
+        e = fromException exn
+        true = property True

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/Classifiers.hs

@@ -1,31 +1,50 @@
 {-# LANGUAGE LambdaCase      #-}
 {-# LANGUAGE NamedFieldPuns  #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections   #-}
 {-# LANGUAGE TypeFamilies    #-}
 {-# LANGUAGE TypeOperators   #-}
 
 module Test.Consensus.Genesis.Setup.Classifiers (
     Classifiers (..)
+  , ResultClassifiers (..)
+  , ScheduleClassifiers (..)
   , classifiers
+  , resultClassifiers
+  , scheduleClassifiers
   , simpleHash
   ) where
 
-import           Cardano.Slotting.Slot (WithOrigin (At))
+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 (BlockHash), 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 (Peer (..), PeerId (..),
+                     Peers (..))
+import           Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (..))
 import           Test.Util.Orphans.IOLike ()
-import           Test.Util.TestBlock (TestHash (TestHash))
+import           Test.Util.TestBlock (TestBlock, TestHash (TestHash),
+                     isAncestorOf)
 
 -- | Interesting categories to classify test inputs
 data Classifiers =
@@ -116,6 +135,119 @@ classifiers GenesisTest {gtBlockTree, gtSecurityParam = SecurityParam k, gtGenes
 
     goodChain = btTrunk gtBlockTree
 
+-- | Interesting categories to classify test results
+data ResultClassifiers =
+  ResultClassifiers{
+    -- | Percentage of adversaries that were killed by receiving an EmptyBucket exception from the LoP
+    adversariesKilledByLoP     :: Double,
+    -- | Percentage of adversaries that were disconnected because their fragment was not dense enough
+    adversariesKilledByGDD     :: Double,
+    -- | Percentage of adversaries that were disconnected by network-level timeouts
+    adversariesKilledByTimeout :: Double,
+    -- | Percentage of adversaries that weren't killed
+    adversariesSurvived        :: Double
+  }
+
+-- | Returned when there were no adversaries
+nullResultClassifier :: ResultClassifiers
+nullResultClassifier = ResultClassifiers 0 0 0 0
+
+resultClassifiers :: GenesisTestFull blk -> RunGenesisTestResult -> ResultClassifiers
+resultClassifiers GenesisTest{gtSchedule} RunGenesisTestResult{rgtrStateView} =
+  if adversariesCount > 0
+    then ResultClassifiers {
+        adversariesKilledByLoP     = 100 * adversariesKilledByLoPC     / adversariesCount,
+        adversariesKilledByGDD     = 100 * adversariesKilledByGDDC     / adversariesCount,
+        adversariesKilledByTimeout = 100 * adversariesKilledByTimeoutC / adversariesCount,
+        adversariesSurvived        = 100 * adversariesSurvivedC        / adversariesCount
+      }
+    else nullResultClassifier
+  where
+    StateView{svPeerSimulatorResults} = rgtrStateView
+
+    adversaries :: [PeerId]
+    adversaries = Map.keys $ others gtSchedule
+
+    adversariesCount = fromIntegral $ length adversaries
+
+    adversariesExceptions :: [(PeerId, SomeException)]
+    adversariesExceptions = mapMaybe
+      (\PeerSimulatorResult{psePeerId, pseResult} -> case psePeerId of
+        HonestPeer -> Nothing
+        pid        -> (pid,) <$> pscrToException pseResult
+      )
+      svPeerSimulatorResults
+
+    adversariesSurvivedC = fromIntegral $ length $ filter
+      (\pid -> not $ pid `elem` map fst adversariesExceptions)
+      adversaries
+
+    adversariesKilledByLoPC = fromIntegral $ length $ filter
+      (\(_, exn) -> fromException exn == Just EmptyBucket)
+      adversariesExceptions
+
+    adversariesKilledByGDDC = fromIntegral $ length $ filter
+      (\(_, exn) -> fromException exn == Just DensityTooLow)
+      adversariesExceptions
+
+    adversariesKilledByTimeoutC = fromIntegral $ length $ filter
+      (\(_, exn) -> case fromException exn of
+        Just (ExceededTimeLimit _) -> True
+        _                          -> False
+      )
+      adversariesExceptions
+
+data ScheduleClassifiers =
+  ScheduleClassifiers{
+    -- | There is an adversary that did a rollback
+    adversaryRollback :: Bool,
+    -- | The honest peer did a rollback
+    honestRollback    :: Bool
+  }
+
+scheduleClassifiers :: GenesisTestFull TestBlock -> ScheduleClassifiers
+scheduleClassifiers GenesisTest{gtSchedule = schedule} =
+  ScheduleClassifiers
+    { adversaryRollback
+    , honestRollback
+    }
+  where
+    hasRollback :: PeerSchedule TestBlock -> Bool
+    hasRollback peerSch' =
+        any (not . isSorted) [tips, headers, blocks]
+      where
+        peerSch = sortOn fst peerSch'
+        isSorted l = and [x `ancestor` y | (x:y:_) <- tails l]
+        ancestor Origin  Origin  = True
+        ancestor Origin  (At _)  = True
+        ancestor (At _)  Origin  = False
+        ancestor (At p1) (At p2) = p1 `isAncestorOf` p2
+        tips = mapMaybe
+          (\(_, point) -> case point of
+            ScheduleTipPoint blk -> Just blk
+            _                    -> Nothing
+          )
+          peerSch
+        headers = mapMaybe
+          (\(_, point) -> case point of
+            ScheduleHeaderPoint blk -> Just blk
+            _                       -> Nothing
+          )
+          peerSch
+        blocks = mapMaybe
+          (\(_, point) -> case point of
+            ScheduleBlockPoint blk -> Just blk
+            _                      -> Nothing
+          )
+          peerSch
+
+    rollbacks :: Peers Bool
+    rollbacks = hasRollback <$> schedule
+
+    adversaryRollback = any value $ others rollbacks
+
+    honestRollback = value $ honest rollbacks
+
 simpleHash ::
   HeaderHash block ~ TestHash =>
   ChainHash block ->

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateView.hs

@@ -13,6 +13,7 @@ module Test.Consensus.PeerSimulator.StateView (
   , collectDisconnectedPeers
   , defaultStateViewTracers
   , exceptionsByComponent
+  , pscrToException
   , snapshotStateView
   ) where
 
@@ -85,6 +86,13 @@ toComponent (SomeChainSyncServerResult  _) = ChainSyncServer
 toComponent (SomeBlockFetchClientResult _) = BlockFetchClient
 toComponent (SomeBlockFetchServerResult _) = BlockFetchServer
 
+pscrToException :: PeerSimulatorComponentResult blk -> Maybe SomeException
+pscrToException (SomeChainSyncClientResult  (Left exn)) = Just exn
+pscrToException (SomeChainSyncServerResult  (Left exn)) = Just exn
+pscrToException (SomeBlockFetchClientResult (Left exn)) = Just exn
+pscrToException (SomeBlockFetchServerResult (Left exn)) = Just exn
+pscrToException _                                       = Nothing
+
 instance Eq (PeerSimulatorComponentResult blk) where
   (==) a b = toComponent a == toComponent b
 

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs

@@ -30,6 +30,7 @@ module Test.Consensus.PointSchedule (
   , NodeState (..)
   , PeerSchedule
   , PeersSchedule
+  , RunGenesisTestResult (..)
   , enrichedWith
   , genesisNodeState
   , longRangeAttack
@@ -71,6 +72,7 @@ import qualified System.Random.Stateful as Random
 import           System.Random.Stateful (STGenM, StatefulGen, runSTGen_)
 import           Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..),
                      allFragments, prettyBlockTree)
+import           Test.Consensus.PeerSimulator.StateView (StateView)
 import           Test.Consensus.PointSchedule.Peers (Peer (..), Peers (..),
                      mkPeers, peersList)
 import           Test.Consensus.PointSchedule.SinglePeer
@@ -335,6 +337,12 @@ data GenesisTest blk schedule = GenesisTest
 
 type GenesisTestFull blk = GenesisTest blk (PeersSchedule blk)
 
+-- | All the data describing the result of a test
+data RunGenesisTestResult = RunGenesisTestResult
+  { rgtrTrace     :: String,
+    rgtrStateView :: StateView TestBlock
+  }
+
 prettyGenesisTest :: (schedule -> [String]) -> GenesisTest TestBlock schedule -> [String]
 prettyGenesisTest prettySchedule genesisTest =
   [ "GenesisTest:"