Prototype lightweight checkpointing (non-combinator approach)

ouroboros-consensus-cardano/changelog.d/20240111_195320_facundo.dominguez_lightweight_checkpointing.md

@@ -0,0 +1,23 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+### Breaking
+
+- Implement lightweigth checkpointing [#449](https://github.com/IntersectMBO/ouroboros-consensus/issues/449).
+  A validation to help Genesis nodes follow the historical chain.
+

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Config.hs

@@ -26,6 +26,7 @@ import qualified Cardano.Chain.Genesis as CC.Genesis
 import qualified Cardano.Chain.Slotting as CC.Slot
 import qualified Cardano.Chain.Update as CC.Update
 import qualified Cardano.Crypto as Crypto
+import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           GHC.Generics (Generic)
 import           NoThunks.Class (NoThunks (..))
@@ -52,6 +53,8 @@ data instance BlockConfig ByronBlock = ByronConfig {
       --
       -- Like 'byronProtocolVersion', this is independent from the chain.
     , byronSoftwareVersion :: !CC.Update.SoftwareVersion
+
+    , byronCheckpoints     :: !(Map BlockNo ByronHash)
     }
   deriving (Generic, NoThunks)
 

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/HeaderValidation.hs

@@ -13,6 +13,7 @@ module Ouroboros.Consensus.Byron.Ledger.HeaderValidation (
 import qualified Cardano.Chain.Slotting as CC
 import           Control.Monad (when)
 import           Control.Monad.Except (throwError)
+import qualified Data.Map.Strict as Map
 import           Data.Word
 import           GHC.Generics (Generic)
 import           NoThunks.Class (NoThunks)
@@ -23,6 +24,7 @@ import           Ouroboros.Consensus.Byron.Ledger.Orphans ()
 import           Ouroboros.Consensus.Byron.Ledger.PBFT ()
 import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.HeaderValidation
+import           Ouroboros.Consensus.Util (whenJust)
 
 {-------------------------------------------------------------------------------
   Envelope
@@ -35,6 +37,7 @@ instance HasAnnTip ByronBlock where
 
 data ByronOtherHeaderEnvelopeError =
     UnexpectedEBBInSlot !SlotNo
+  | CheckpointMismatch -- TODO args
   deriving (Eq, Show, Generic, NoThunks)
 
 instance BasicEnvelopeValidation ByronBlock where
@@ -56,9 +59,13 @@ instance BasicEnvelopeValidation ByronBlock where
 instance ValidateEnvelope ByronBlock where
   type OtherHeaderEnvelopeError ByronBlock = ByronOtherHeaderEnvelopeError
 
-  additionalEnvelopeChecks cfg _ledgerView hdr =
+  additionalEnvelopeChecks cfg _ledgerView hdr = do
       when (fromIsEBB newIsEBB && not (canBeEBB actualSlotNo)) $
         throwError $ UnexpectedEBBInSlot actualSlotNo
+      when (not (fromIsEBB newIsEBB)) $ -- TODO fine to ignore EBBs?
+        whenJust (Map.lookup (blockNo hdr) checkpoints) $ \checkpoint ->
+          when (checkpoint /= blockHash hdr) $
+            throwError CheckpointMismatch
     where
       actualSlotNo :: SlotNo
       actualSlotNo = blockSlot hdr
@@ -75,3 +82,6 @@ instance ValidateEnvelope ByronBlock where
         . byronEpochSlots
         . configBlock
         $ cfg
+
+      checkpoints =
+        byronCheckpoints . configBlock $ cfg

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs

@@ -31,6 +31,7 @@ import qualified Cardano.Chain.Update as Update
 import qualified Cardano.Crypto as Crypto
 import           Control.Monad (guard)
 import           Data.Coerce (coerce)
+import           Data.Map.Strict (Map)
 import           Data.Maybe
 import           Data.Text (Text)
 import           Data.Void (Void)
@@ -180,13 +181,15 @@ data instance ProtocolParams ByronBlock = ProtocolParamsByron {
     }
 
 protocolInfoByron :: ProtocolParams ByronBlock
+                  -> Map BlockNo ByronHash -- ^ Checkpoints.
                   -> ProtocolInfo ByronBlock
 protocolInfoByron ProtocolParamsByron {
                       byronGenesis                = genesisConfig
                     , byronPbftSignatureThreshold = mSigThresh
                     , byronProtocolVersion        = pVer
                     , byronSoftwareVersion        = sVer
-                    } =
+                    }
+                  checkpoints =
     ProtocolInfo {
         pInfoConfig = TopLevelConfig {
             topLevelConfigProtocol = PBftConfig {
@@ -208,7 +211,7 @@ protocolInfoByron ProtocolParamsByron {
   where
     compactedGenesisConfig = compactGenesisConfig genesisConfig
 
-    blockConfig = mkByronConfig compactedGenesisConfig pVer sVer
+    blockConfig = mkByronConfig compactedGenesisConfig pVer sVer checkpoints
 
 protocolClientInfoByron :: EpochSlots -> ProtocolClientInfo ByronBlock
 protocolClientInfoByron epochSlots =
@@ -228,11 +231,13 @@ byronPBftParams cfg threshold = PBftParams {
 mkByronConfig :: Genesis.Config
               -> Update.ProtocolVersion
               -> Update.SoftwareVersion
+              -> Map BlockNo ByronHash
               -> BlockConfig ByronBlock
-mkByronConfig genesisConfig pVer sVer = ByronConfig {
+mkByronConfig genesisConfig pVer sVer checkpoints = ByronConfig {
       byronGenesisConfig   = genesisConfig
     , byronProtocolVersion = pVer
     , byronSoftwareVersion = sVer
+    , byronCheckpoints     = checkpoints
     }
 
 {-------------------------------------------------------------------------------

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs

@@ -72,6 +72,7 @@ import qualified Codec.CBOR.Encoding as CBOR
 import           Control.Exception (assert)
 import qualified Data.ByteString.Short as Short
 import           Data.Functor.These (These1 (..))
+import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.SOP.BasicFunctors
 import           Data.SOP.Counting
@@ -524,6 +525,7 @@ data instance ProtocolParams (CardanoBlock c) = ProtocolParamsCardano {
   , shelleyBasedProtocolParams    :: ProtocolParamsShelleyBased c
   , cardanoHardForkTriggers       :: CardanoHardForkTriggers
   , cardanoLedgerTransitionConfig :: L.TransitionConfig (L.LatestKnownEra c)
+  , cardanoCheckpoints            :: Map BlockNo (HeaderHash (CardanoBlock c))
   }
 
 type CardanoProtocolParams c = ProtocolParams (CardanoBlock c)
@@ -539,6 +541,7 @@ pattern CardanoProtocolParams ::
   -> ProtocolParams (ShelleyBlock (Praos  c) (ConwayEra  c))
   -> CardanoHardForkTriggers
   -> L.TransitionConfig (L.LatestKnownEra c)
+  -> Map BlockNo (HeaderHash (CardanoBlock c))
   -> CardanoProtocolParams c
 pattern CardanoProtocolParams {
         paramsByron
@@ -551,6 +554,7 @@ pattern CardanoProtocolParams {
       , paramsConway
       , hardForkTriggers
       , ledgerTransitionConfig
+      , checkpoints
       } =
     ProtocolParamsCardano {
         cardanoProtocolParamsPerEra = PerEraProtocolParams
@@ -566,6 +570,7 @@ pattern CardanoProtocolParams {
       , shelleyBasedProtocolParams = paramsShelleyBased
       , cardanoHardForkTriggers = hardForkTriggers
       , cardanoLedgerTransitionConfig = ledgerTransitionConfig
+      , cardanoCheckpoints = checkpoints
       }
 
 {-# COMPLETE CardanoProtocolParams #-}
@@ -618,6 +623,7 @@ protocolInfoCardano paramsCardano
         , triggerHardForkConway
         }
       , ledgerTransitionConfig
+      , checkpoints
       } = paramsCardano
 
     genesisShelley = ledgerTransitionConfig ^. L.tcShelleyGenesisL
@@ -686,6 +692,9 @@ protocolInfoCardano paramsCardano
           K protVerConway :*
           Nil
 
+    checkpointsForBlock :: ConvertRawHash blk => Proxy blk -> Map BlockNo (HeaderHash blk)
+    checkpointsForBlock p = Map.map (fromShortRawHash p . getOneEraHash) checkpoints
+
     -- Byron
 
     ProtocolInfo {
@@ -695,7 +704,7 @@ protocolInfoCardano paramsCardano
           , topLevelConfigBlock    = blockConfigByron
           }
       , pInfoInitLedger = initExtLedgerStateByron
-      } = protocolInfoByron paramsByron
+      } = protocolInfoByron paramsByron (checkpointsForBlock (Proxy @ByronBlock))
 
     partialConsensusConfigByron :: PartialConsensusConfig (BlockProtocol ByronBlock)
     partialConsensusConfigByron = consensusConfigByron
@@ -741,6 +750,7 @@ protocolInfoCardano paramsCardano
           protVerShelley
           genesisShelley
           (shelleyBlockIssuerVKey <$> credssShelleyBased)
+          (checkpointsForBlock (Proxy @(ShelleyBlock (TPraos c) (ShelleyEra c))))
 
     partialConsensusConfigShelley ::
          PartialConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) (ShelleyEra c)))
@@ -764,6 +774,7 @@ protocolInfoCardano paramsCardano
           protVerAllegra
           genesisShelley
           (shelleyBlockIssuerVKey <$> credssShelleyBased)
+          (checkpointsForBlock (Proxy @(ShelleyBlock (TPraos c) (AllegraEra c))))
 
     partialConsensusConfigAllegra ::
          PartialConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) (AllegraEra c)))
@@ -784,6 +795,7 @@ protocolInfoCardano paramsCardano
           protVerMary
           genesisShelley
           (shelleyBlockIssuerVKey <$> credssShelleyBased)
+          (checkpointsForBlock (Proxy @(ShelleyBlock (TPraos c) (MaryEra c))))
 
     partialConsensusConfigMary ::
          PartialConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) (MaryEra c)))
@@ -804,6 +816,7 @@ protocolInfoCardano paramsCardano
           protVerAlonzo
           genesisShelley
           (shelleyBlockIssuerVKey <$> credssShelleyBased)
+          (checkpointsForBlock (Proxy @(ShelleyBlock (TPraos c) (AlonzoEra c))))
 
     partialConsensusConfigAlonzo ::
          PartialConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) (AlonzoEra c)))
@@ -824,6 +837,7 @@ protocolInfoCardano paramsCardano
           protVerBabbage
           genesisShelley
           (shelleyBlockIssuerVKey <$> credssShelleyBased)
+          (checkpointsForBlock (Proxy @(ShelleyBlock (Praos c) (BabbageEra c))))
 
     partialConsensusConfigBabbage ::
          PartialConsensusConfig (BlockProtocol (ShelleyBlock (Praos c) (BabbageEra c)))
@@ -844,6 +858,7 @@ protocolInfoCardano paramsCardano
           protVerConway
           genesisShelley
           (shelleyBlockIssuerVKey <$> credssShelleyBased)
+          (checkpointsForBlock (Proxy @(ShelleyBlock (Praos c) (ConwayEra c))))
 
     partialConsensusConfigConway ::
          PartialConsensusConfig (BlockProtocol (ShelleyBlock (Praos c) (ConwayEra c)))

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Config.hs

@@ -48,6 +48,7 @@ data instance BlockConfig (ShelleyBlock proto era) = ShelleyConfig {
       -- block producing nodes, this can be set to the empty map.
     , shelleyBlockIssuerVKeys :: !(Map (SL.KeyHash 'SL.BlockIssuer (EraCrypto era))
                                        (SL.VKey 'SL.BlockIssuer (EraCrypto era)))
+    , shelleyCheckpoints      :: !(Map BlockNo (HeaderHash (ShelleyBlock proto era)))
     }
   deriving stock (Generic)
 
@@ -59,15 +60,17 @@ mkShelleyBlockConfig ::
   => SL.ProtVer
   -> SL.ShelleyGenesis (EraCrypto era)
   -> [SL.VKey 'SL.BlockIssuer (EraCrypto era)]
+  -> Map BlockNo (HeaderHash (ShelleyBlock proto era))
   -> BlockConfig (ShelleyBlock proto era)
-mkShelleyBlockConfig protVer genesis blockIssuerVKeys = ShelleyConfig {
+mkShelleyBlockConfig protVer genesis blockIssuerVKeys checkpoints = ShelleyConfig {
       shelleyProtocolVersion  = protVer
     , shelleySystemStart      = SystemStart  $ SL.sgSystemStart  genesis
     , shelleyNetworkMagic     = NetworkMagic $ SL.sgNetworkMagic genesis
     , shelleyBlockIssuerVKeys = Map.fromList
         [ (SL.hashKey k, k)
         | k <- blockIssuerVKeys
         ]
+    , shelleyCheckpoints      = checkpoints
     }
 
 {-------------------------------------------------------------------------------

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs

@@ -474,7 +474,9 @@ instance ShelleyCompatible proto era => ValidateEnvelope (ShelleyBlock proto era
     EnvelopeCheckError proto
 
   additionalEnvelopeChecks cfg lv hdr =
-    envelopeChecks (configConsensus cfg) lv (shelleyHeaderRaw hdr)
+      envelopeChecks (configConsensus cfg) checkpoints lv (shelleyHeaderRaw hdr)
+    where
+      checkpoints = shelleyCheckpoints (configBlock cfg)
 
 {-------------------------------------------------------------------------------
   Auxiliary

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs

@@ -331,6 +331,7 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased {
           protVer
           genesis
           (shelleyBlockIssuerVKey <$> credentialss)
+          mempty -- TODO propagate?
 
     storageConfig :: StorageConfig (ShelleyBlock (TPraos c) era)
     storageConfig = ShelleyStorageConfig {

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs

@@ -42,6 +42,7 @@ import           Cardano.Slotting.Slot (SlotNo)
 import           Codec.Serialise (Serialise (..))
 import           Control.Monad.Except (Except)
 import           Data.Kind (Type)
+import           Data.Map.Strict (Map)
 import           Data.Typeable (Typeable)
 import           Data.Word (Word64)
 import           GHC.Generics (Generic)
@@ -117,6 +118,7 @@ class
   -- check things like maximum header size.
   envelopeChecks ::
     ConsensusConfig proto ->
+    Map BlockNo (ShelleyHash (ProtoCrypto proto)) ->
     LedgerView proto ->
     ShelleyProtocolHeader proto ->
     Except (EnvelopeCheckError proto) ()

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs

@@ -19,9 +19,10 @@ import           Cardano.Ledger.Slot (SlotNo (unSlotNo))
 import           Cardano.Protocol.TPraos.OCert
                      (OCert (ocertKESPeriod, ocertVkHot))
 import qualified Cardano.Protocol.TPraos.OCert as SL
-import           Control.Monad (unless)
+import           Control.Monad (unless, when)
 import           Control.Monad.Except (throwError)
 import           Data.Either (isRight)
+import qualified Data.Map.Strict as Map
 import           Data.Word (Word16, Word32)
 import           GHC.Generics (Generic)
 import           NoThunks.Class (NoThunks)
@@ -36,16 +37,16 @@ import           Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto,
                      ProtocolHeaderSupportsEnvelope (..),
                      ProtocolHeaderSupportsKES (..),
                      ProtocolHeaderSupportsLedger (..),
-                     ProtocolHeaderSupportsProtocol (..),
-                     ShelleyHash (ShelleyHash), ShelleyProtocol,
-                     ShelleyProtocolHeader)
+                     ProtocolHeaderSupportsProtocol (..), ShelleyHash (..),
+                     ShelleyProtocol, ShelleyProtocolHeader)
+import           Ouroboros.Consensus.Util (whenJust)
 
 
 type instance ProtoCrypto (Praos c) = c
 
 type instance ShelleyProtocolHeader (Praos c) = Header c
 
-data PraosEnvelopeError
+data PraosEnvelopeError c
   = ObsoleteNode Version Version
     -- ^ This is a subtle case.
     --
@@ -89,9 +90,10 @@ data PraosEnvelopeError
     -- <https://github.com/IntersectMBO/ouroboros-consensus/issues/325>.
   | HeaderSizeTooLarge Int Word16
   | BlockSizeTooLarge Word32 Word32
+  | CheckpointMismatch (ShelleyHash c) (ShelleyHash c)
   deriving (Eq, Generic, Show)
 
-instance NoThunks PraosEnvelopeError
+instance NoThunks (PraosEnvelopeError c)
 
 instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (Praos c) where
   pHeaderHash hdr = ShelleyHash $ headerHash hdr
@@ -102,16 +104,20 @@ instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (Praos c) where
   pHeaderSize hdr = fromIntegral $ headerSize hdr
   pHeaderBlockSize (Header body _) = fromIntegral $ hbBodySize body
 
-  type EnvelopeCheckError _ = PraosEnvelopeError
+  type EnvelopeCheckError (Praos c) = PraosEnvelopeError c
 
-  envelopeChecks cfg lv hdr = do
+  envelopeChecks cfg checkpoints lv hdr = do
     unless (m <= maxpv) $ throwError (ObsoleteNode m maxpv)
     unless (bhviewHSize bhv <= fromIntegral @Word16 @Int maxHeaderSize) $
       throwError $
         HeaderSizeTooLarge (bhviewHSize bhv) maxHeaderSize
     unless (bhviewBSize bhv <= maxBodySize) $
       throwError $
         BlockSizeTooLarge (bhviewBSize bhv) maxBodySize
+    whenJust (Map.lookup (pHeaderBlock hdr) checkpoints) $ \checkpoint ->
+      when (checkpoint /= pHeaderHash hdr) $
+        throwError $
+          CheckpointMismatch (pHeaderHash hdr) checkpoint
     where
       pp = praosParams cfg
       (MaxMajorProtVer maxpv) = praosMaxMajorPV pp