Generalize test machinery's reliance on TestBlock

Here we generalize all uses of unnecessarily-specified `TestBlock`s to
instead be parametric `blk`s. For this we introduce two new type classes.

The `IssueTestBlock` class abstracts the operations needed to produce
blocks during chain generation.

The `HasPointScheduleTestParams` class abstracts the parameters needed to run
the point schedule tests. We invoke `getProtocolInfoArgs` at the beginning of
a test, and use it to construct a `ProtocolInfo`, which in turn provides both a
`TopLevelConfig` and an `ExtLedgerState`. The requirement of `IO` comes
from needing to eventually parse cardano config files.
A key point of entry for this change is found on
`PeerSimulator.Run.nodeLifecycle`, where the `ProtocolInfo` is delivered,
enabling the generalization of the simulation to arbitrary blocks.

We provide instances for `TestBlock`.

Co-authored-by: Nathan Bloomfield <nathan.bloomfield@tweag.io>
Co-authored-by: Xavier Góngora <xavier.gongora@tweag.io>

Author: 3 people

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -19,14 +20,30 @@ import Control.Monad.Class.MonadAsync
 import Control.Monad.IOSim (IOSim, runSimStrictShutdown)
 import Control.Tracer (debugTracer, traceWith)
 import Data.Maybe (mapMaybe)
+import Ouroboros.Consensus.Block.Abstract (ConvertRawHash, 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.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 Ouroboros.Network.Driver.Limits
   ( ProtocolLimitFailure (ExceededTimeLimit)
   )
+import Ouroboros.Network.Util.ShowProxy
 import Test.Consensus.Genesis.Setup.Classifiers
   ( Classifiers (..)
   , ResultClassifiers (..)
@@ -36,16 +53,19 @@ import Test.Consensus.Genesis.Setup.Classifiers
   , 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.Util.Orphans.IOLike ()
 import Test.Util.QuickCheck (forAllGenRunShrinkCheck)
+import Test.Util.TersePrinting (Terse)
 import Test.Util.TestBlock (TestBlock)
 import Test.Util.Tracer (recordingTracerM)
 import Text.Printf (printf)
@@ -62,17 +82,37 @@ runSimStrictShutdownOrThrow action =
 -- | 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
+  , 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 TestBlock ->
-  RunGenesisTestResult
-runGenesisTest schedulerConfig genesisTest =
+  GenesisTestFull blk ->
+  RunGenesisTestResult blk
+runGenesisTest protocolInfoArgs schedulerConfig genesisTest =
   runSimStrictShutdownOrThrow $ do
     (recordingTracer, getTrace) <- recordingTracerM
     let tracer = if scDebug schedulerConfig then debugTracer else recordingTracer
 
     traceLinesWith tracer $ prettyGenesisTest prettyPointSchedule genesisTest
 
-    rgtrStateView <- runPointSchedule schedulerConfig genesisTest =<< tracerTestBlock tracer
+    rgtrStateView <-
+      runPointSchedule protocolInfoArgs schedulerConfig genesisTest =<< tracerTestBlock tracer
     traceWith tracer (condense rgtrStateView)
     rgtrTrace <- unlines <$> getTrace
 
@@ -87,24 +127,44 @@ runGenesisTest' ::
   GenesisTestFull TestBlock ->
   (StateView TestBlock -> prop) ->
   Property
-runGenesisTest' schedulerConfig genesisTest makeProperty =
-  counterexample rgtrTrace $ makeProperty rgtrStateView
- where
-  RunGenesisTestResult{rgtrTrace, rgtrStateView} =
-    runGenesisTest schedulerConfig genesisTest
+runGenesisTest' schedulerConfig genesisTest makeProperty = idempotentIOProperty $ do
+  protocolInfoArgs <- 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', runs them with 'runGenesisTest', check whether the given
 -- property holds on the resulting 'StateView'.
 forAllGenesisTest ::
-  Testable prop =>
-  Gen (GenesisTestFull TestBlock) ->
+  forall blk prop.
+  ( Testable prop
+  , Condense (StateView blk)
+  , CondenseList (NodeState blk)
+  , ShowProxy blk
+  , ShowProxy (Header blk)
+  , ConfigSupportsNode blk
+  , LedgerSupportsProtocol 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)
+  ) =>
+  Gen (GenesisTestFull blk) ->
   SchedulerConfig ->
-  (GenesisTestFull TestBlock -> StateView TestBlock -> [GenesisTestFull TestBlock]) ->
-  (GenesisTestFull TestBlock -> StateView TestBlock -> prop) ->
+  (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]) ->
+  (GenesisTestFull blk -> StateView blk -> prop) ->
   Property
-forAllGenesisTest generator schedulerConfig shrinker mkProperty =
-  forAllGenRunShrinkCheck generator runner shrinker' $ \genesisTest result ->
+forAllGenesisTest generator schedulerConfig shrinker mkProperty = idempotentIOProperty $ do
+  protocolInfoArgs <- getProtocolInfoArgs
+  pure $ forAllGenRunShrinkCheck generator (runGenesisTest protocolInfoArgs schedulerConfig) shrinker' $ \genesisTest result ->
     let cls = classifiers genesisTest
         resCls = resultClassifiers genesisTest result
         schCls = scheduleClassifiers genesisTest
@@ -128,7 +188,6 @@ forAllGenesisTest generator schedulerConfig shrinker mkProperty =
           $ counterexample (rgtrTrace result)
           $ mkProperty genesisTest stateView .&&. hasOnlyExpectedExceptions stateView
  where
-  runner = runGenesisTest schedulerConfig
   shrinker' gt = shrinker gt . rgtrStateView
   hasOnlyExpectedExceptions StateView{svPeerSimulatorResults} =
     conjoin $

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -21,14 +22,13 @@ 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
+import Ouroboros.Consensus.Block.Abstract
   ( ChainHash (..)
+  , HasHeader
   , HeaderHash
+  , SlotNo (SlotNo)
   , blockSlot
   , succWithOrigin
-  )
-import Ouroboros.Consensus.Block.Abstract
-  ( SlotNo (SlotNo)
   , withOrigin
   )
 import Ouroboros.Consensus.Config
@@ -45,7 +45,11 @@ import qualified Ouroboros.Network.AnchoredFragment as AF
 import Ouroboros.Network.Driver.Limits
   ( ProtocolLimitFailure (ExceededTimeLimit)
   )
-import Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..))
+import Test.Consensus.BlockTree
+  ( BlockTree (..)
+  , BlockTreeBranch (..)
+  , isAncestorOf
+  )
 import Test.Consensus.Network.AnchoredFragment.Extras (slotLength)
 import Test.Consensus.PeerSimulator.StateView
   ( PeerSimulatorResult (..)
@@ -56,11 +60,7 @@ import Test.Consensus.PointSchedule
 import Test.Consensus.PointSchedule.Peers (PeerId (..), Peers (..))
 import Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (..))
 import Test.Util.Orphans.IOLike ()
-import Test.Util.TestBlock
-  ( TestBlock
-  , TestHash (TestHash)
-  , isAncestorOf
-  )
+import Test.Util.TestBlock (TestHash (TestHash))
 
 -- | Interesting categories to classify test inputs
 data Classifiers
@@ -91,7 +91,7 @@ data Classifiers
   -- ^ The honest chain's slot count is greater than or equal to the Genesis window size.
   }
 
-classifiers :: AF.HasHeader blk => GenesisTest blk schedule -> Classifiers
+classifiers :: HasHeader blk => GenesisTest blk schedule -> Classifiers
 classifiers GenesisTest{gtBlockTree, gtSecurityParam = SecurityParam k, gtGenesisWindow = GenesisWindow scg} =
   Classifiers
     { existsSelectableAdversary
@@ -102,7 +102,7 @@ classifiers GenesisTest{gtBlockTree, gtSecurityParam = SecurityParam k, gtGenesi
     , longerThanGenesisWindow
     }
  where
-  longerThanGenesisWindow = AF.headSlot goodChain >= At (fromIntegral scg)
+  longerThanGenesisWindow = headSlot goodChain >= At (fromIntegral scg)
 
   genesisWindowAfterIntersection =
     any fragmentHasGenesis branches
@@ -169,7 +169,7 @@ data ResultClassifiers
 nullResultClassifier :: ResultClassifiers
 nullResultClassifier = ResultClassifiers 0 0 0 0
 
-resultClassifiers :: GenesisTestFull blk -> RunGenesisTestResult -> ResultClassifiers
+resultClassifiers :: GenesisTestFull blk -> RunGenesisTestResult blk -> ResultClassifiers
 resultClassifiers GenesisTest{gtSchedule} RunGenesisTestResult{rgtrStateView} =
   if adversariesCount > 0
     then
@@ -242,44 +242,31 @@ data ScheduleClassifiers
   -- do nothing afterwards.
   }
 
-scheduleClassifiers :: GenesisTestFull TestBlock -> ScheduleClassifiers
-scheduleClassifiers GenesisTest{gtSchedule = schedule} =
+scheduleClassifiers ::
+  forall blk. (HasHeader blk, Eq blk) => GenesisTestFull blk -> ScheduleClassifiers
+scheduleClassifiers GenesisTest{gtSchedule = schedule, gtBlockTree} =
   ScheduleClassifiers
     { adversaryRollback
     , honestRollback
     , allAdversariesEmpty
     , allAdversariesTrivial
     }
  where
-  hasRollback :: PeerSchedule TestBlock -> Bool
+  hasRollback :: PeerSchedule blk -> Bool
   hasRollback peerSch' =
     any (not . isSorted) [tips, headers, blocks]
    where
     peerSch = sortOn fst peerSch'
+    isSorted :: [WithOrigin blk] -> Bool
     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
+    ancestor = isAncestorOf gtBlockTree
+    tips, headers, blocks :: [WithOrigin blk]
+    (tips, headers, blocks) =
+      foldMap
         ( \(_, point) -> case point of
-            ScheduleBlockPoint blk -> Just blk
-            _ -> Nothing
+            ScheduleTipPoint blk -> (pure blk, mempty, mempty)
+            ScheduleHeaderPoint blk -> (mempty, pure blk, mempty)
+            ScheduleBlockPoint blk -> (mempty, mempty, pure blk)
         )
         peerSch
 
@@ -291,7 +278,7 @@ scheduleClassifiers GenesisTest{gtSchedule = schedule} =
 
   allAdversariesEmpty = all id $ adversarialPeers $ null <$> psSchedule schedule
 
-  isTrivial :: PeerSchedule TestBlock -> Bool
+  isTrivial :: PeerSchedule blk -> Bool
   isTrivial = \case
     [] -> True
     (t0, _) : points -> all ((== t0) . fst) points