Super basic scaffolding

Author: amesgen

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

@@ -14,6 +14,8 @@ module Ouroboros.Consensus.Block.SupportsPeras
   , boostPerCert
   , BlockSupportsPeras (..)
   , PerasCert (..)
+  , ValidatedPerasCert (..)
+  , makePerasCfg
   ) where
 
 import Data.Monoid (Sum (..))
@@ -45,24 +47,78 @@ 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, Ord, Generic)
+  deriving anyclass NoThunks
+
 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
+    deriving stock (Show, Eq)
+
   perasCertRound = pcCertRound
   perasCertBoostedBlock = pcCertBoostedBlock
+
+  validatePerasCert cfg curRound cert
+    | pcCertRound cert > curRound =
+        Left $ PerasInFuture curRound (pcCertRound cert)
+    | otherwise =
+        Right
+          ValidatedPerasCert
+            { validatedPerasCert = cert
+            , validatedPerasCertBoost = perasCfgWeightBoost cfg
+            }
+
+-- | Derive a 'PerasCfg' from a 'BlockConfig'
+-- TODO this currently doesn't depend on 'BlockConfig' at all, but likely will
+makePerasCfg :: Maybe (BlockConfig blk) -> PerasCfg blk
+makePerasCfg _ =
+  PerasCfg
+    { perasCfgWeightBoost = boostPerCert
+    }

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

@@ -8,6 +8,7 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert
   , makePerasCertPoolWriterFromChainDB
   ) where
 
+import GHC.Exception (throw)
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
 import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
@@ -32,7 +33,10 @@ makePerasCertPoolReaderFromSnapshot getCertSnapshot =
         certSnapshot <- getCertSnapshot
         pure $
           take (fromIntegral limit) $
-            [ (ticketNo, perasCertRound cert, pure cert)
+            [ ( ticketNo
+              , perasCertRound (validatedPerasCert cert)
+              , pure (validatedPerasCert cert)
+              )
             | (cert, ticketNo) <- PerasCertDB.getCertsAfter certSnapshot lastKnown
             ]
     }
@@ -49,8 +53,9 @@ makePerasCertPoolWriterFromCertDB ::
 makePerasCertPoolWriterFromCertDB perasCertDB =
   ObjectPoolWriter
     { opwObjectId = perasCertRound
-    , opwAddObjects =
-        mapM_ $ PerasCertDB.addCert perasCertDB
+    , opwAddObjects = \certs -> do
+        validatePerasCerts certs >>=
+          mapM_ (PerasCertDB.addCert perasCertDB)
     , opwHasObject = do
         certSnapshot <- atomically $ PerasCertDB.getCertSnapshot perasCertDB
         pure $ PerasCertDB.containsCert certSnapshot
@@ -68,9 +73,24 @@ makePerasCertPoolWriterFromChainDB ::
 makePerasCertPoolWriterFromChainDB chainDB =
   ObjectPoolWriter
     { opwObjectId = perasCertRound
-    , opwAddObjects =
-        mapM_ $ ChainDB.addPerasCertAsync chainDB
+    , opwAddObjects = \certs -> do
+        validatePerasCerts certs >>=
+          mapM_ (ChainDB.addPerasCertAsync chainDB)
     , opwHasObject = do
         certSnapshot <- atomically $ ChainDB.getPerasCertSnapshot chainDB
         pure $ PerasCertDB.containsCert certSnapshot
     }
+
+validatePerasCerts ::
+  (StandardHash blk, Monad m) =>
+  [PerasCert blk] ->
+  m [ValidatedPerasCert blk]
+validatePerasCerts certs = do
+  let perasCfg = makePerasCfg Nothing
+      perasRoundNo = PerasRoundNo 999
+      -- ^ TODO replace these mocked-up values with real
+      -- ones when all the required plumbing is in place
+  case sequence (validatePerasCert perasCfg perasRoundNo <$> certs) of
+    Left validationError -> throw (userError (show validationError))
+    -- TODO   ^ refine this exception
+    Right validatedCerts -> return validatedCerts

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

@@ -392,8 +392,8 @@ data ChainDB m blk = ChainDB
   , getStatistics :: m (Maybe Statistics)
   -- ^ Get statistics from the LedgerDB, in particular the number of entries
   -- in the tables.
-  , addPerasCertAsync :: PerasCert blk -> m (AddPerasCertPromise m)
-  -- ^ TODO
+  , addPerasCertAsync :: ValidatedPerasCert blk -> m (AddPerasCertPromise m)
+  -- ^ TODO docs
   , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk))
   -- ^ TODO
   , getPerasCertSnapshot :: STM m (PerasCertSnapshot blk)
@@ -530,7 +530,7 @@ newtype AddPerasCertPromise m = AddPerasCertPromise
   -- impossible).
   }
 
-addPerasCertSync :: IOLike m => ChainDB m blk -> PerasCert blk -> m ()
+addPerasCertSync :: IOLike m => ChainDB m blk -> ValidatedPerasCert blk -> m ()
 addPerasCertSync chainDB cert =
   waitPerasCertProcessed =<< addPerasCertAsync chainDB cert
 

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs

@@ -647,7 +647,9 @@ addBlockRunner fuse cdb@CDB{..} = forever $ do
             ChainSelAddPerasCert cert _varProcessed ->
               traceWith cdbTracer $
                 TraceAddPerasCertEvent $
-                  PoppedPerasCertFromQueue (perasCertRound cert) (perasCertBoostedBlock cert)
+                  PoppedPerasCertFromQueue
+                    (perasCertRound (validatedPerasCert cert))
+                    (perasCertBoostedBlock (validatedPerasCert cert))
           chainSelSync cdb message
           lift $ atomically $ processedChainSelMessage cdbChainSelQueue message
       )

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs

@@ -331,7 +331,7 @@ addPerasCertAsync ::
   forall m blk.
   (IOLike m, HasHeader blk) =>
   ChainDbEnv m blk ->
-  PerasCert blk ->
+  ValidatedPerasCert blk ->
   m (AddPerasCertPromise m)
 addPerasCertAsync CDB{cdbTracer, cdbChainSelQueue} =
   addPerasCertToQueue (TraceAddPerasCertEvent >$< cdbTracer) cdbChainSelQueue
@@ -529,10 +529,10 @@ chainSelSync cdb@CDB{..} (ChainSelAddPerasCert cert varProcessed) = do
   tracer = TraceAddPerasCertEvent >$< cdbTracer
 
   certRound :: PerasRoundNo
-  certRound = perasCertRound cert
+  certRound = perasCertRound (validatedPerasCert cert)
 
   boostedBlock :: Point blk
-  boostedBlock = perasCertBoostedBlock cert
+  boostedBlock = perasCertBoostedBlock (validatedPerasCert cert)
 
 -- | Return 'True' when the given header should be ignored when adding it
 -- because it is too old, i.e., we wouldn't be able to switch to a chain

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs

@@ -553,7 +553,7 @@ data ChainSelMessage m blk
     ChainSelAddBlock !(BlockToAdd m blk)
   | -- | Add a Peras certificate
     ChainSelAddPerasCert
-      !(PerasCert blk)
+      !(ValidatedPerasCert blk)
       -- | Used for 'AddPerasCertPromise'.
       !(StrictTMVar m ())
   | -- | Reprocess blocks that have been postponed by the LoE.
@@ -609,7 +609,7 @@ addPerasCertToQueue ::
   (IOLike m, StandardHash blk) =>
   Tracer m (TraceAddPerasCertEvent blk) ->
   ChainSelQueue m blk ->
-  PerasCert blk ->
+  ValidatedPerasCert blk ->
   m (AddPerasCertPromise m)
 addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do
   varProcessed <- newEmptyTMVarIO
@@ -624,7 +624,9 @@ addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do
       }
  where
   addedToQueue =
-    AddedPerasCertToQueue (perasCertRound cert) (perasCertBoostedBlock cert)
+    AddedPerasCertToQueue
+      (perasCertRound (validatedPerasCert cert))
+      (perasCertBoostedBlock (validatedPerasCert cert))
 
 -- | Try to add blocks again that were postponed due to the LoE.
 addReprocessLoEBlocks ::

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

@@ -21,7 +21,8 @@ import Ouroboros.Consensus.Util.IOLike
 import Ouroboros.Consensus.Util.STM (WithFingerprint (..))
 
 data PerasCertDB m blk = PerasCertDB
-  { addCert :: PerasCert blk -> m AddPerasCertResult
+  { addCert :: ValidatedPerasCert blk -> m AddPerasCertResult
+  -- ^ TODO docs
   , 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
@@ -44,7 +45,7 @@ data AddPerasCertResult = AddedPerasCertToDB | PerasCertAlreadyInDB
 data PerasCertSnapshot blk = PerasCertSnapshot
   { containsCert :: PerasRoundNo -> Bool
   -- ^ Do we have the certificate for this round?
-  , getCertsAfter :: PerasCertTicketNo -> [(PerasCert blk, PerasCertTicketNo)]
+  , getCertsAfter :: PerasCertTicketNo -> [(ValidatedPerasCert blk, PerasCertTicketNo)]
   }
 
 -- TODO: Once we store historical certificates on disk, this should (also) track

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

@@ -144,7 +144,7 @@ implAddCert ::
   , StandardHash blk
   ) =>
   PerasCertDbEnv m blk ->
-  PerasCert blk ->
+  ValidatedPerasCert blk ->
   m AddPerasCertResult
 implAddCert env cert = do
   traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt
@@ -186,8 +186,8 @@ implAddCert env cert = do
     , pcdbVolatileState
     } = env
 
-  roundNo = perasCertRound cert
-  boostedPt = perasCertBoostedBlock cert
+  boostedPt = perasCertBoostedBlock (validatedPerasCert cert)
+  roundNo = perasCertRound (validatedPerasCert cert)
 
 implGetWeightSnapshot ::
   IOLike m =>
@@ -237,7 +237,7 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot =
         }
      where
       keepCert cert =
-        pointSlot (perasCertBoostedBlock cert) >= NotOrigin slot
+        pointSlot (perasCertBoostedBlock (validatedPerasCert cert)) >= NotOrigin slot
 
 {-------------------------------------------------------------------------------
   Implementation-internal types
@@ -246,13 +246,13 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot =
 -- | Volatile Peras certificate state, i.e. certificates that could influence
 -- chain selection by boosting a volatile block.
 data PerasVolatileCertState blk = PerasVolatileCertState
-  { pvcsCerts :: !(Map PerasRoundNo (PerasCert blk))
+  { pvcsCerts :: !(Map PerasRoundNo (ValidatedPerasCert blk))
   -- ^ The boosted blocks by 'RoundNo' of all certificates currently in the db.
   , pvcsWeightByPoint :: !(PerasWeightSnapshot blk)
   -- ^ The weight of boosted blocks w.r.t. the certificates currently in the db.
   --
   -- INVARIANT: In sync with 'pvcsCerts'.
-  , pvcsCertsByTicket :: !(Map PerasCertTicketNo (PerasCert blk))
+  , pvcsCertsByTicket :: !(Map PerasCertTicketNo (ValidatedPerasCert blk))
   -- ^ The certificates by 'PerasCertTicketNo'.
   --
   -- INVARIANT: In sync with 'pvcsCerts'.

ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs

@@ -125,6 +125,8 @@ deriving anyclass instance ToExpr PerasWeight
 
 deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (PerasCert blk)
 
+deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (ValidatedPerasCert blk)
+
 {-------------------------------------------------------------------------------
   si-timers
 --------------------------------------------------------------------------------}

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

@@ -70,10 +70,16 @@ instance Arbitrary (Point blk) => Arbitrary (PerasCert blk) where
     pcCertBoostedBlock <- arbitrary
     pure $ PerasCert{pcCertRound, pcCertBoostedBlock}
 
-instance WithId (PerasCert blk) PerasRoundNo where
-  getId = pcCertRound
+instance Arbitrary (Point blk) => Arbitrary (ValidatedPerasCert blk) where
+  arbitrary = do
+    validatedPerasCert <- arbitrary
+    validatedPerasCertBoost <- pure boostPerCert
+    return $ ValidatedPerasCert{validatedPerasCert, validatedPerasCertBoost}
+
+instance WithId (ValidatedPerasCert blk) PerasRoundNo where
+  getId = pcCertRound . validatedPerasCert
 
-newCertDB :: (IOLike m, StandardHash blk) => [PerasCert blk] -> m (PerasCertDB m blk)
+newCertDB :: (IOLike m, StandardHash blk) => [ValidatedPerasCert blk] -> m (PerasCertDB m blk)
 newCertDB certs = do
   db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer)
   mapM_