[Peras 6] Improve generation of Peras events in ChainDB state machine tests

ouroboros-consensus/changelog.d/20251124_140035_agustin.mista_improve_chaindb_qsm_tests.md

@@ -0,0 +1,24 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+For top level release notes, leave all the headers commented out.
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+### Non-Breaking
+
+- Allow generating k>2 in ChainDB state machine tests on the fly.
+- Improve chances of switching to a shorter chain in ChainDB state machine tests.
+
+<!--
+### Breaking
+
+- A bullet item for the Breaking category.
+
+-->

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs

@@ -14,9 +14,9 @@
 module Ouroboros.Consensus.Block.SupportsPeras
   ( PerasRoundNo (..)
   , PerasWeight (..)
-  , boostPerCert
   , BlockSupportsPeras (..)
   , PerasCert (..)
+  , PerasCfg (..)
   , ValidatedPerasCert (..)
   , makePerasCfg
   , HasPerasCert (..)

ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs

@@ -54,6 +54,9 @@ tests =
         prop_smoke
     ]
 
+perasTestCfg :: PerasCfg TestBlock
+perasTestCfg = makePerasCfg Nothing
+
 genPoint :: Gen (Point (TestBlock))
 genPoint =
   -- Sometimes pick the genesis point
@@ -77,15 +80,19 @@ genPerasCert = do
 instance WithId (PerasCert blk) PerasRoundNo where
   getId = pcCertRound
 
-newCertDB :: (IOLike m, StandardHash blk) => [PerasCert blk] -> m (PerasCertDB m blk)
-newCertDB certs = do
+newCertDB ::
+  (IOLike m, StandardHash blk) =>
+  PerasCfg blk ->
+  [PerasCert blk] ->
+  m (PerasCertDB m blk)
+newCertDB perasCfg certs = do
   db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer)
   mapM_
     ( \cert -> do
         let validatedCert =
               ValidatedPerasCert
                 { vpcCert = cert
-                , vpcCertBoost = boostPerCert
+                , vpcCertBoost = perasCfgWeightBoost perasCfg
                 }
         result <- PerasCertDB.addCert db validatedCert
         case result of
@@ -123,8 +130,8 @@ prop_smoke =
             , m [PerasCert TestBlock]
             )
         mkPoolInterfaces = do
-          outboundPool <- newCertDB certs
-          inboundPool <- newCertDB []
+          outboundPool <- newCertDB perasTestCfg certs
+          inboundPool <- newCertDB perasTestCfg []
 
           let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool
               inboundPoolWriter = makePerasCertPoolWriterFromCertDB inboundPool