[Peras #2] Introduce PerasCertDB and related tests

ouroboros-consensus/changelog.d/20250917_101832_thomas.bagrel_peras_cert_db.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
+
+- A bullet item for the Non-Breaking category.
+
+-->
+
+### Breaking
+
+- Added modules `Ouroboros.Consensus.Storage.PerasCertDB{,.API,.Impl}`, notably defining the types`PerasCertDB`, `PerasCertSnapshot` (read-only snapshot of certs contained in the DB), and `AddPerasCertResult`; alongside their respectives methods
+- Added modules `Test.Ouroboros.Storage.PerasCertDB{,.StateMachine,.Model}` for q-s-m testing of the `PerasCertDB` datatype. The corresponding tests have been included in the test suite defined by `Test.Ouroboros.Storage`

ouroboros-consensus/ouroboros-consensus.cabal

@@ -264,6 +264,9 @@ library
     Ouroboros.Consensus.Storage.LedgerDB.V2.Forker
     Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
     Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
+    Ouroboros.Consensus.Storage.PerasCertDB
+    Ouroboros.Consensus.Storage.PerasCertDB.API
+    Ouroboros.Consensus.Storage.PerasCertDB.Impl
     Ouroboros.Consensus.Storage.Serialisation
     Ouroboros.Consensus.Storage.VolatileDB
     Ouroboros.Consensus.Storage.VolatileDB.API
@@ -720,6 +723,9 @@ test-suite storage-test
     Test.Ouroboros.Storage.LedgerDB.V1.DbChangelog
     Test.Ouroboros.Storage.LedgerDB.V1.LMDB
     Test.Ouroboros.Storage.Orphans
+    Test.Ouroboros.Storage.PerasCertDB
+    Test.Ouroboros.Storage.PerasCertDB.Model
+    Test.Ouroboros.Storage.PerasCertDB.StateMachine
     Test.Ouroboros.Storage.VolatileDB
     Test.Ouroboros.Storage.VolatileDB.Mock
     Test.Ouroboros.Storage.VolatileDB.Model

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB.hs

@@ -0,0 +1,4 @@
+module Ouroboros.Consensus.Storage.PerasCertDB (module X) where
+
+import Ouroboros.Consensus.Storage.PerasCertDB.API as X
+import Ouroboros.Consensus.Storage.PerasCertDB.Impl as X

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Ouroboros.Consensus.Storage.PerasCertDB.API
+  ( PerasCertDB (..)
+  , AddPerasCertResult (..)
+
+    -- * 'PerasCertSnapshot'
+  , PerasCertSnapshot (..)
+  , PerasCertTicketNo
+  , zeroPerasCertTicketNo
+  ) where
+
+import Data.Word (Word64)
+import NoThunks.Class
+import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Peras.Weight
+import Ouroboros.Consensus.Util.IOLike
+import Ouroboros.Consensus.Util.STM (WithFingerprint (..))
+
+data PerasCertDB m blk = PerasCertDB
+  { addCert :: ValidatedPerasCert blk -> m AddPerasCertResult
+  -- ^ Add a Peras certificate to the database. The result indicates whether
+  -- the certificate was actually added, or if it was already present.
+  , getWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk))
+  -- ^ Return the Peras weights in order compare the current selection against
+  -- potential candidate chains, namely the weights for blocks not older than
+  -- the current immutable tip. It might contain weights for even older blocks
+  -- if they have not yet been garbage-collected.
+  --
+  -- The 'Fingerprint' is updated every time a new certificate is added, but it
+  -- stays the same when certificates are garbage-collected.
+  , getCertSnapshot :: STM m (PerasCertSnapshot blk)
+  , garbageCollect :: SlotNo -> m ()
+  -- ^ Garbage-collect state older than the given slot number.
+  , closeDB :: m ()
+  }
+  deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDB" (PerasCertDB m blk)
+
+data AddPerasCertResult = AddedPerasCertToDB | PerasCertAlreadyInDB
+  deriving stock (Show, Eq)
+
+data PerasCertSnapshot blk = PerasCertSnapshot
+  { containsCert :: PerasRoundNo -> Bool
+  -- ^ Do we have the certificate for this round?
+  , getCertsAfter :: PerasCertTicketNo -> [(ValidatedPerasCert blk, PerasCertTicketNo)]
+  }
+
+newtype PerasCertTicketNo = PerasCertTicketNo Word64
+  deriving stock Show
+  deriving newtype (Eq, Ord, Enum, NoThunks)
+
+zeroPerasCertTicketNo :: PerasCertTicketNo
+zeroPerasCertTicketNo = PerasCertTicketNo 0