[WIP] Add basic API for certificate validation

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -14,6 +15,10 @@ module Ouroboros.Consensus.Block.SupportsPeras
   , boostPerCert
   , BlockSupportsPeras (..)
   , PerasCert (..)
+  , ValidatedPerasCert (..)
+  , makePerasCfg
+  , HasPerasCert (..)
+  , HasPerasCertBoost (..)
   ) where
 
 import Data.Monoid (Sum (..))
@@ -45,24 +50,93 @@ instance Condense PerasWeight where
 boostPerCert :: PerasWeight
 boostPerCert = PerasWeight 15
 
+-- TODO using 'Validated' for extra safety? Or some @.Unsafe@ module?
+data ValidatedPerasCert blk = ValidatedPerasCert
+  { vpcCert :: !(PerasCert blk)
+  , vpcCertBoost :: !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
 
-  perasCertRound :: PerasCert blk -> PerasRoundNo
+  data PerasValidationErr blk
 
-  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
 
-  perasCertRound = pcCertRound
-  perasCertBoostedBlock = pcCertBoostedBlock
+  data PerasValidationErr blk
+    = PerasInFuture
+        -- current round
+        PerasRoundNo
+        -- round of cert
+        PerasRoundNo
+    deriving stock (Show, Eq)
+
+  validatePerasCert cfg curRound cert
+    | pcCertRound cert > curRound =
+        Left $ PerasInFuture curRound (pcCertRound cert)
+    | otherwise =
+        Right
+          ValidatedPerasCert
+            { vpcCert = cert
+            , vpcCertBoost = 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
+    }
+
+-- | Convenience classes to extract fields from both validated and unvalidated certificates
+class StandardHash blk => HasPerasCert cert blk where
+  getPerasCert :: cert blk -> PerasCert blk
+
+  getPerasCertRound :: cert blk -> PerasRoundNo
+  getPerasCertRound = pcCertRound . getPerasCert
+
+  getPerasCertBoostedBlock :: cert blk -> Point blk
+  getPerasCertBoostedBlock = pcCertBoostedBlock . getPerasCert
+
+instance StandardHash blk => HasPerasCert PerasCert blk where
+  getPerasCert = id
+
+instance StandardHash blk => HasPerasCert ValidatedPerasCert blk where
+  getPerasCert = vpcCert
+
+class HasPerasCertBoost cert blk where
+  getPerasCertBoost :: cert blk -> PerasWeight
+
+instance HasPerasCertBoost ValidatedPerasCert blk where
+  getPerasCertBoost = vpcCertBoost

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

@@ -1,3 +1,6 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
 -- | Instantiate 'ObjectPoolReader' and 'ObjectPoolWriter' using Peras
 -- certificates from the 'PerasCertDB' (or the 'ChainDB' which is wrapping the
 -- 'PerasCertDB').
@@ -8,6 +11,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)
@@ -26,13 +30,13 @@ makePerasCertPoolReaderFromSnapshot ::
   ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
 makePerasCertPoolReaderFromSnapshot getCertSnapshot =
   ObjectPoolReader
-    { oprObjectId = perasCertRound
+    { oprObjectId = getPerasCertRound
     , oprZeroTicketNo = PerasCertDB.zeroPerasCertTicketNo
     , oprObjectsAfter = \lastKnown limit -> do
         certSnapshot <- getCertSnapshot
         pure $
           take (fromIntegral limit) $
-            [ (ticketNo, perasCertRound cert, pure cert)
+            [ (ticketNo, getPerasCertRound cert, pure (getPerasCert cert))
             | (cert, ticketNo) <- PerasCertDB.getCertsAfter certSnapshot lastKnown
             ]
     }
@@ -48,9 +52,10 @@ makePerasCertPoolWriterFromCertDB ::
   PerasCertDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m
 makePerasCertPoolWriterFromCertDB perasCertDB =
   ObjectPoolWriter
-    { opwObjectId = perasCertRound
-    , opwAddObjects =
-        mapM_ $ PerasCertDB.addCert perasCertDB
+    { opwObjectId = getPerasCertRound
+    , opwAddObjects = \certs -> do
+        let validatedCerts = validatePerasCerts certs
+        mapM_ (PerasCertDB.addCert perasCertDB) validatedCerts
     , opwHasObject = do
         certSnapshot <- atomically $ PerasCertDB.getCertSnapshot perasCertDB
         pure $ PerasCertDB.containsCert certSnapshot
@@ -67,10 +72,32 @@ makePerasCertPoolWriterFromChainDB ::
   ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m
 makePerasCertPoolWriterFromChainDB chainDB =
   ObjectPoolWriter
-    { opwObjectId = perasCertRound
-    , opwAddObjects =
-        mapM_ $ ChainDB.addPerasCertAsync chainDB
+    { opwObjectId = getPerasCertRound
+    , opwAddObjects = \certs -> do
+        let validatedCerts = validatePerasCerts certs
+        mapM_ (ChainDB.addPerasCertAsync chainDB) validatedCerts
     , opwHasObject = do
         certSnapshot <- atomically $ ChainDB.getPerasCertSnapshot chainDB
         pure $ PerasCertDB.containsCert certSnapshot
     }
+
+-- TODO following the same approach as 'ChainSyncClientException', but why not using GADT syntax?
+data PerasCertInboundException
+  = forall blk. PerasCertValidationError (PerasValidationErr blk)
+
+deriving instance Show PerasCertInboundException
+
+instance Exception PerasCertInboundException
+
+validatePerasCerts ::
+  StandardHash blk =>
+  [PerasCert blk] ->
+  [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 traverse (validatePerasCert perasCfg perasRoundNo) certs of
+    Left validationErr -> throw (PerasCertValidationError validationErr)
+    Right validatedCerts -> 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,7 @@ addBlockRunner fuse cdb@CDB{..} = forever $ do
             ChainSelAddPerasCert cert _varProcessed ->
               traceWith cdbTracer $
                 TraceAddPerasCertEvent $
-                  PoppedPerasCertFromQueue (perasCertRound cert) (perasCertBoostedBlock cert)
+                  PoppedPerasCertFromQueue (getPerasCertRound cert) (getPerasCertBoostedBlock 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 = getPerasCertRound cert
 
   boostedBlock :: Point blk
-  boostedBlock = perasCertBoostedBlock cert
+  boostedBlock = getPerasCertBoostedBlock 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
@@ -623,8 +623,7 @@ addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do
       { waitPerasCertProcessed = atomically $ takeTMVar varProcessed
       }
  where
-  addedToQueue =
-    AddedPerasCertToQueue (perasCertRound cert) (perasCertBoostedBlock cert)
+  addedToQueue = AddedPerasCertToQueue (getPerasCertRound cert) (getPerasCertBoostedBlock 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
@@ -169,7 +169,7 @@ implAddCert env cert = do
                   Map.insert roundNo cert pvcsCerts
               , -- Note that the same block might be boosted by multiple points.
                 pvcsWeightByPoint =
-                  addToPerasWeightSnapshot boostedPt boostPerCert pvcsWeightByPoint
+                  addToPerasWeightSnapshot boostedPt (getPerasCertBoost cert) pvcsWeightByPoint
               , pvcsCertsByTicket =
                   Map.insert pvcsLastTicketNo' cert pvcsCertsByTicket
               , pvcsLastTicketNo = pvcsLastTicketNo'
@@ -186,8 +186,8 @@ implAddCert env cert = do
     , pcdbVolatileState
     } = env
 
-  roundNo = perasCertRound cert
-  boostedPt = perasCertBoostedBlock cert
+  boostedPt = getPerasCertBoostedBlock cert
+  roundNo = getPerasCertRound cert
 
 implGetWeightSnapshot ::
   IOLike m =>
@@ -237,7 +237,7 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot =
         }
      where
       keepCert cert =
-        pointSlot (perasCertBoostedBlock cert) >= NotOrigin slot
+        pointSlot (getPerasCertBoostedBlock 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

@@ -78,7 +78,12 @@ newCertDB certs = do
   db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer)
   mapM_
     ( \cert -> do
-        result <- PerasCertDB.addCert db cert
+        let validatedCert =
+              ValidatedPerasCert
+                { vpcCert = cert
+                , vpcCertBoost = boostPerCert
+                }
+        result <- PerasCertDB.addCert db validatedCert
         case result of
           AddedPerasCertToDB -> pure ()
           PerasCertAlreadyInDB -> throwIO (userError "Expected AddedPerasCertToDB, but cert was already in DB")
@@ -121,6 +126,6 @@ prop_smoke protocolConstants (ListWithUniqueIds certs) =
         getAllInboundPoolContent = do
           snap <- atomically $ PerasCertDB.getCertSnapshot inboundPool
           let rawContent = PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo)
-          pure $ fst <$> rawContent
+          pure $ getPerasCert . fst <$> rawContent
 
     return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent)