Tweak TestBlock to use getPerasCertInBlock in tests

Co-authored-by: Agustin Mista <agustin.mista@moduscreate.com>
Co-authored-by: Thomas BAGREL <thomas.bagrel@tweag.io>
Co-authored-by: Nicolas BACQUEY <nicolas.bacquey@tweag.io>

Author: 3 people

ouroboros-consensus/bench/PerasCertDB-bench/Main.hs

@@ -115,7 +115,7 @@ fragments = iterate' addSuccessorBlock genesisFragment
        in (xs AF.:> x) AF.:> TestBlock.mkNextBlock x nextBlockSlot dummyBody
 
   dummyBody :: TestBody
-  dummyBody = TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
+  dummyBody = TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
 
 -- | Given a chain fragment, construct a weight snapshot where there's a boosted block every 90 slots
 uniformWeightSnapshot :: AF.AnchoredFragment TestBlock -> PerasWeightSnapshot TestBlock

ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs

@@ -135,6 +135,7 @@ import Ouroboros.Consensus.Util.Condense
 import Ouroboros.Consensus.Util.IndexedMemPack
 import Ouroboros.Consensus.Util.Orphans ()
 import qualified Ouroboros.Network.Mock.Chain as Chain
+import Ouroboros.Network.Point (Block)
 import System.FS.API.Lazy
 import Test.Cardano.Slotting.Numeric ()
 import Test.Cardano.Slotting.TreeDiff ()
@@ -207,13 +208,13 @@ data TestBody = TestBody
   -- Note that this is a /local/ number, it is specific to this block,
   -- other blocks need not be aware of it.
   , tbIsValid :: !Bool
-  , tbPerasCertRound :: !(Maybe PerasRoundNo)
+  , tbPerasCert :: !(Maybe (PerasCert TestBlock))
   -- ^ Some real blocks will ocasionally carry a Peras certificate inside their
-  -- body to coordinate the end of a cooldown period. For the purposes of the
-  -- ChainDB, we don't really care about the details of the certificate other
-  -- than its round number, which needs to be stored (and carefully updated
-  -- whenever a newer one pops up) so it can be used to evaluate the Peras
-  -- voting rules and decide if a node should resume voting.
+  -- body to coordinate the end of a cooldown period.
+  -- NOTE: for the purposes of the ChainDB, we don't care about the details of
+  -- the certificate other than its round number, which needs to be stored (and
+  -- carefully updated whenever a newer one pops up) so it can be used to
+  -- evaluate the Peras voting rules and decide if a node should resume voting.
   }
   deriving stock (Eq, Show, Generic)
   deriving anyclass (NFData, NoThunks, Serialise, Hashable)
@@ -953,16 +954,22 @@ corruptionFiles = map snd . NE.toList
   Orphans
 -------------------------------------------------------------------------------}
 
+-- ** Hashable
+
 deriving newtype instance Hashable SlotNo
 deriving newtype instance Hashable BlockNo
 deriving newtype instance Hashable PerasRoundNo
-instance Hashable IsEBB
-
--- use generic instance
 
+instance Hashable IsEBB
+instance Hashable TestHeader
+instance Hashable TestBlock
+instance Hashable (Block SlotNo TestHeaderHash)
+instance Hashable (Point TestBlock)
+instance Hashable (MockPerasCert TestBlock)
+instance (Hashable a, Hashable (WithOrigin a)) => Hashable (WithOrigin a)
 instance (StandardHash b, Hashable (HeaderHash b)) => Hashable (ChainHash b)
 
--- use generic instance
+-- ** ToExpr
 
 instance ToExpr EBB
 instance ToExpr IsEBB

ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Iterator.hs

@@ -115,11 +115,11 @@ tests =
 
 -- All blocks on the same chain
 a, b, c, d, e :: TestBlock
-a = firstBlock 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
-b = mkNextBlock a 1 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
-c = mkNextBlock b 2 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
-d = mkNextBlock c 3 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
-e = mkNextBlock d 4 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
+a = firstBlock 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
+b = mkNextBlock a 1 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
+c = mkNextBlock b 2 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
+d = mkNextBlock c 3 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
+e = mkNextBlock d 4 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
 
 -- | Requested stream = A -> C
 --
@@ -176,9 +176,9 @@ prop_1435_case1 =
     (Left (ForkTooOld (StreamFromInclusive (blockRealPoint b'))))
  where
   canContainEBB = const True
-  ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
-  b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
-  b' = mkNextBlock ebb 0 TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCertRound = Nothing}
+  ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
+  b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
+  b' = mkNextBlock ebb 0 TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCert = Nothing}
 
 -- | Requested stream = EBB' -> EBB' where EBB, B, and EBB' are all blocks in
 -- the same slot, and EBB' is not part of the current chain nor ChainDB.
@@ -197,9 +197,9 @@ prop_1435_case2 =
     (Left (ForkTooOld (StreamFromInclusive (blockRealPoint ebb'))))
  where
   canContainEBB = const True
-  ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
-  b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
-  ebb' = firstEBB canContainEBB TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCertRound = Nothing}
+  ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
+  b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
+  ebb' = firstEBB canContainEBB TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCert = Nothing}
 
 -- | Requested stream = EBB -> EBB where EBB and B are all blocks in the same
 -- slot.
@@ -218,8 +218,8 @@ prop_1435_case3 =
     (Right (map Right [ebb]))
  where
   canContainEBB = const True
-  ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
-  b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
+  ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
+  b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
 
 -- | Requested stream = EBB -> EBB where EBB and B are all blocks in the same
 -- slot.
@@ -238,8 +238,8 @@ prop_1435_case4 =
     (Right (map Right [ebb]))
  where
   canContainEBB = const True
-  ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
-  b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
+  ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
+  b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
 
 -- | Requested stream = EBB -> EBB where EBB and B' are all blocks in the same
 -- slot, and B' is not part of the current chain nor ChainDB.
@@ -258,8 +258,8 @@ prop_1435_case5 =
     (Left (ForkTooOld (StreamFromInclusive (blockRealPoint b'))))
  where
   canContainEBB = const True
-  ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
-  b' = mkNextBlock ebb 0 TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCertRound = Nothing}
+  ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
+  b' = mkNextBlock ebb 0 TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCert = Nothing}
 
 -- | Requested stream = EBB' -> EBB' where EBB and EBB' are all blocks in the
 -- same slot, and EBB' is not part of the current chain nor ChainDB.
@@ -278,8 +278,8 @@ prop_1435_case6 =
     (Left (ForkTooOld (StreamFromInclusive (blockRealPoint ebb'))))
  where
   canContainEBB = const True
-  ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing}
-  ebb' = firstEBB canContainEBB TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCertRound = Nothing}
+  ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing}
+  ebb' = firstEBB canContainEBB TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCert = Nothing}
 
 -- | The general property test
 prop_general_test ::

ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs

@@ -2120,24 +2120,37 @@ genBlkPair chunkInfo loe Model{..} =
         [ (4, return True)
         , (1, return False)
         ]
-    perasCertRound <- do
-      let maxRoundNo =
-            case Model.roundNoOfLatestCertSeen dbModel of
-              Nothing -> 0
-              Just (PerasRoundNo r) -> r + 1
+    perasCert <- do
       frequency
-        [ (9, return Nothing)
+        [ (4, return Nothing)
         , let freq = case loe of
                 LoEDisabled -> 1
                 -- The LoE does not yet support Peras.
                 LoEEnabled () -> 0
-           in (freq, Just . PerasRoundNo <$> choose (0, maxRoundNo))
+           in (freq, Just <$> genPerasCert)
         ]
     return
       TestBody
         { tbForkNo = forkNo
         , tbIsValid = isValid
-        , tbPerasCertRound = perasCertRound
+        , tbPerasCert = perasCert
+        }
+
+  genPerasCert :: Gen (PerasCert TestBlock)
+  genPerasCert = do
+    let maxRoundNo =
+          case Model.roundNoOfLatestCertSeen dbModel of
+            Nothing -> 0
+            Just (PerasRoundNo r) -> r + 1
+    roundNo <-
+      PerasRoundNo <$> choose (0, maxRoundNo)
+    boostedBlock <-
+      -- NOTE: we don't care about this boosted block, it could be @Genesis@
+      blockPoint <$> genSuccOfCurrentChainTip
+    pure
+      MockPerasCert
+        { mockCertRound = roundNo
+        , mockCertBlock = boostedBlock
         }
 
 -- | Generate a random security parameter (k)

ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs

@@ -49,6 +49,7 @@ import GHC.Generics
 import GHC.Stack
 import qualified Generics.SOP as SOP
 import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..))
 import Ouroboros.Consensus.Storage.Common
 import Ouroboros.Consensus.Storage.VolatileDB
 import Ouroboros.Consensus.Storage.VolatileDB.Impl.Types (FileId)
@@ -392,7 +393,7 @@ generatorCmdImpl Model{..} =
       TestBody
         <$> arbitrary
         <*> arbitrary
-        <*> liftArbitrary (PerasRoundNo <$> arbitrary)
+        <*> liftArbitrary genPerasCert
     prevHash <-
       frequency
         [ (1, return GenesisHash)
@@ -407,6 +408,16 @@ generatorCmdImpl Model{..} =
     let clen = ChainLength (fromIntegral (unBlockNo no))
     return $ mkBlock canContainEBB body prevHash slot no clen ebb
 
+  genPerasCert :: Gen (PerasCert Block)
+  genPerasCert = do
+    mockCertRound <- PerasRoundNo <$> arbitrary
+    mockCertBlock <- blockPoint <$> genRandomBlock
+    pure $
+      MockPerasCert
+        { mockCertRound
+        , mockCertBlock
+        }
+
   genHash :: Gen (HeaderHash Block)
   genHash =
     frequency