Super basic scaffolding

Author: amesgen

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

@@ -45,24 +45,68 @@ instance Condense PerasWeight where
 boostPerCert :: PerasWeight
 boostPerCert = PerasWeight 15
 
+-- TODO using 'Validated' for extra safety? Or some @.Unsafe@ module?
+data ValidatedPerasCert blk = ValidatedPerasCert
+  { validatedPerasCert :: !(PerasCert blk)
+  , validatedPerasCertBoost :: !PerasWeight
+  }
+  deriving stock (Show, Eq)
+
 class
-  NoThunks (PerasCert blk) =>
+  ( Show (PerasCfg blk)
+  , NoThunks (PerasCert blk)
+  ) =>
   BlockSupportsPeras blk
   where
+  data PerasCfg blk
+
   data PerasCert blk
 
+  data PerasValidationErr blk
+
   perasCertRound :: PerasCert blk -> PerasRoundNo
 
   perasCertBoostedBlock :: PerasCert blk -> Point blk
 
+  validatePerasCert ::
+    PerasCfg blk ->
+    -- | Current round number
+    PerasRoundNo ->
+    PerasCert blk ->
+    Either (PerasValidationErr blk) (ValidatedPerasCert blk)
+
 -- TODO degenerate instance for all blks to get things to compile
 instance StandardHash blk => BlockSupportsPeras blk where
+  newtype PerasCfg blk = PerasCfg
+    { -- TODO eventually, this will come from the protocol parameters from the
+      -- ledger state
+      perasCfgWeightBoost :: PerasWeight
+    }
+    deriving stock (Show, Eq)
+
   data PerasCert blk = PerasCert
     { pcCertRound :: PerasRoundNo
     , pcCertBoostedBlock :: Point blk
     }
     deriving stock (Generic, Eq, Ord, Show)
     deriving anyclass NoThunks
 
+  data PerasValidationErr blk
+    = PerasInFuture
+        -- current round
+        PerasRoundNo
+        -- round of cert
+        PerasRoundNo
+
   perasCertRound = pcCertRound
   perasCertBoostedBlock = pcCertBoostedBlock
+
+  validatePerasCert cfg curRound cert
+    | perasCertRound cert > curRound =
+        Left $ PerasInFuture curRound (perasCertRound cert)
+    | otherwise =
+        Right
+          ValidatedPerasCert
+            { validatedPerasCert = cert
+            , validatedPerasCertBoost = perasCfgWeightBoost cfg
+            }

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs

@@ -68,8 +68,10 @@ makePerasCertPoolWriterFromChainDB ::
 makePerasCertPoolWriterFromChainDB chainDB =
   ObjectPoolWriter
     { opwObjectId = perasCertRound
-    , opwAddObjects =
-        mapM_ $ ChainDB.addPerasCertAsync chainDB
+    , opwAddObjects = \certs -> do
+        -- TODO validate certificates, throwing an exception if it fails,
+        -- disconnecting from the peer
+        mapM_ (ChainDB.addPerasCertAsync chainDB) certs
     , opwHasObject = do
         certSnapshot <- atomically $ ChainDB.getPerasCertSnapshot chainDB
         pure $ PerasCertDB.containsCert certSnapshot

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

@@ -393,7 +393,8 @@ data ChainDB m blk = ChainDB
   -- ^ Get statistics from the LedgerDB, in particular the number of entries
   -- in the tables.
   , addPerasCertAsync :: PerasCert blk -> m (AddPerasCertPromise m)
-  -- ^ TODO
+  -- ^ TODO docs
+  -- TODO take a 'ValidatedPerasCert'
   , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk))
   -- ^ TODO
   , getPerasCertSnapshot :: STM m (PerasCertSnapshot blk)

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

@@ -22,6 +22,8 @@ import Ouroboros.Consensus.Util.STM (WithFingerprint (..))
 
 data PerasCertDB m blk = PerasCertDB
   { addCert :: PerasCert blk -> m AddPerasCertResult
+  -- ^ TODO docs
+  -- TODO use 'ValidatedPerasCert'.
   , 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