From c98007bc8a8acce5feee84ca91d30e1fdfa615c3 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 8 Sep 2026 14:26:16 -0400 Subject: [PATCH 01/60] protocol: introduce BasePraos indirection --- .../shelley/Ouroboros/Consensus/Shelley/HFEras.hs | 1 + .../Ouroboros/Consensus/Shelley/Protocol/Praos.hs | 1 + .../Ouroboros/Consensus/Protocol/Praos.hs | 12 +++++++++++- 3 files changed, 13 insertions(+), 1 deletion(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs index d40b942821..3c5a3ffdf7 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -Wno-orphans #-} diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs index 480ee8424d..f5dbe13a87 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index d6740228ab..5592c201e1 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -16,7 +16,10 @@ module Ouroboros.Consensus.Protocol.Praos ( ConsensusConfig (..) + , BasePraos + , Leios , Praos + , PraosExtensions (..) , PraosCannotForge (..) , PraosCrypto , PraosFields (..) @@ -138,7 +141,14 @@ import Ouroboros.Consensus.Util.Versioned , encodeVersion ) -data Praos c +-- | Which optional extensions to the base Praos protocol are enabled. +data PraosExtensions = NoExtensions | ExtLeios + +data BasePraos (exts :: PraosExtensions) c + +type Praos = BasePraos NoExtensions + +type Leios = BasePraos ExtLeios class ( Crypto c From 486df2b261af3205a55d5ca5eb7a867fb5ffd8a3 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 8 Sep 2026 17:23:05 -0400 Subject: [PATCH 02/60] PraosWithLeios: introduce LeiosLedgerView --- .../golden/cardano/disk/ChainDepState_Babbage | Bin 375 -> 374 bytes .../golden/cardano/disk/ChainDepState_Conway | Bin 406 -> 405 bytes .../cardano/disk/ExtLedgerState_Babbage | Bin 1069 -> 1068 bytes .../golden/cardano/disk/ExtLedgerState_Conway | Bin 1706 -> 1705 bytes .../Ouroboros/Consensus/Cardano/Block.hs | 48 +-- .../Consensus/Cardano/CanHardFork.hs | 55 ++- .../Ouroboros/Consensus/Cardano/Ledger.hs | 4 +- .../Ouroboros/Consensus/Cardano/Node.hs | 19 +- .../Ouroboros/Consensus/Shelley/HFEras.hs | 10 +- .../Consensus/Shelley/Ledger/Forge.hs | 30 +- .../Consensus/Shelley/Ledger/Ledger.hs | 4 +- .../Consensus/Shelley/Ledger/Leios.hs | 43 +-- .../Shelley/Ledger/SupportsProtocol.hs | 40 +-- .../Ouroboros/Consensus/Shelley/Node/Praos.hs | 44 ++- .../Consensus/Shelley/Node/Serialisation.hs | 13 +- .../Consensus/Shelley/Node/TPraos.hs | 1 + .../Consensus/Shelley/Protocol/Abstract.hs | 33 +- .../Consensus/Shelley/Protocol/Praos.hs | 322 +++++++++++++---- .../Consensus/Shelley/Protocol/TPraos.hs | 6 + .../Ouroboros/Consensus/Shelley/ShelleyHFC.hs | 10 +- .../Test/Consensus/Shelley/Examples.hs | 107 +++--- .../Test/Consensus/Shelley/Generators.hs | 109 ++++-- .../Test/Consensus/Cardano/Translation.hs | 4 +- .../Test/Consensus/Shelley/Dijkstra.hs | 38 +- .../Ouroboros/Consensus/Protocol/Praos.hs | 284 ++++++++++----- .../Consensus/Protocol/Praos/Common.hs | 170 ++++++++- .../Consensus/Protocol/Praos/Header.hs | 338 ------------------ .../Ouroboros/Consensus/Protocol/Praos/VRF.hs | 139 ------- .../Consensus/Protocol/Praos/Views.hs | 207 ++++++++++- .../Protocol/Serialisation/Generators.hs | 51 ++- .../Consensus/Protocol/Praos/Header.hs | 11 +- ouroboros-consensus.cabal | 14 +- 32 files changed, 1243 insertions(+), 911 deletions(-) delete mode 100644 ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs delete mode 100644 ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/VRF.hs diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Babbage b/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Babbage index 694f15fce8dffd4bea76bd27a87e21533748e66b..2e06ac93cf4aa1346a99ec7b1c931741423f2e73 100644 GIT binary patch delta 12 Ucmey)^o?o4JSK*Yi3_d)03<5~u>b%7 delta 14 Wcmeyy^qpzKJSN7@i3_eVeggn7kOry% diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Conway b/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Conway index 3b78629521c3167124ce42b0cb1ba0aecafbe676..760307285a4749f2f4ed0f2c6283a5b02b163783 100644 GIT binary patch delta 12 UcmbQnJe7IEUM7Z)iTkes0384YF8}}l delta 14 WcmbQrJdJt6UM9xQiTkfHeggm~VFoAw diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage index 93fc4d50378fcb88e4389dbab8d62b51e51a4a07..99304ea08e5c9886a9df7a3c960e6cb106667173 100644 GIT binary patch delta 14 VcmZ3>v4&$q2s0By$K){PYXBo41ib(N delta 16 XcmZ3(v6f>)2s0C7=j1TvYmDCjEuRIp diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway index 82ebc490fbda1a9b498438e106c355e72f56d18e..cd0ae697a8d3201135895d2df17c09765f9a55ab 100644 GIT binary patch delta 22 ecmZ3*yOMXqMOHS3jwVLNMUy!h [Type] @@ -301,7 +301,7 @@ pattern TagMary :: f (ShelleyBlock (TPraos c) MaryEra) -> NS f (CardanoEras c) pattern TagAlonzo :: f (ShelleyBlock (TPraos c) AlonzoEra) -> NS f (CardanoEras c) pattern TagBabbage :: f (ShelleyBlock (Praos c) BabbageEra) -> NS f (CardanoEras c) pattern TagConway :: f (ShelleyBlock (Praos c) ConwayEra) -> NS f (CardanoEras c) -pattern TagDijkstra :: f (ShelleyBlock (Praos c) DijkstraEra) -> NS f (CardanoEras c) +pattern TagDijkstra :: f (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> NS f (CardanoEras c) pattern TagByron x = Z x pattern TagShelley x = S (Z x) @@ -323,7 +323,7 @@ pattern EraMary :: K () (ShelleyBlock (TPraos c) MaryEra) -> EraIndex (CardanoEr pattern EraAlonzo :: K () (ShelleyBlock (TPraos c) AlonzoEra) -> EraIndex (CardanoEras c) pattern EraBabbage :: K () (ShelleyBlock (Praos c) BabbageEra) -> EraIndex (CardanoEras c) pattern EraConway :: K () (ShelleyBlock (Praos c) ConwayEra) -> EraIndex (CardanoEras c) -pattern EraDijkstra :: K () (ShelleyBlock (Praos c) DijkstraEra) -> EraIndex (CardanoEras c) +pattern EraDijkstra :: K () (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> EraIndex (CardanoEras c) pattern EraByron x = EraIndex (TagByron x) pattern EraShelley x = EraIndex (TagShelley x) @@ -407,7 +407,7 @@ pattern TeleDijkstra :: g (ShelleyBlock (TPraos c) AlonzoEra) -> g (ShelleyBlock (Praos c) BabbageEra) -> g (ShelleyBlock (Praos c) ConwayEra) -> - f (ShelleyBlock (Praos c) DijkstraEra) -> + f (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> Telescope g f (CardanoEras c) -- Here we use layout and adjacency to make it obvious that we haven't @@ -468,7 +468,7 @@ pattern BlockBabbage b = HardForkBlock (OneEraBlock (TagBabbage (I b))) pattern BlockConway :: ShelleyBlock (Praos c) ConwayEra -> CardanoBlock c pattern BlockConway b = HardForkBlock (OneEraBlock (TagConway (I b))) -pattern BlockDijkstra :: ShelleyBlock (Praos c) DijkstraEra -> CardanoBlock c +pattern BlockDijkstra :: ShelleyBlock (PraosWithLeios c) DijkstraEra -> CardanoBlock c pattern BlockDijkstra b = HardForkBlock (OneEraBlock (TagDijkstra (I b))) {-# COMPLETE @@ -523,7 +523,7 @@ pattern HeaderConway :: pattern HeaderConway h = HardForkHeader (OneEraHeader (TagConway h)) pattern HeaderDijkstra :: - Header (ShelleyBlock (Praos c) DijkstraEra) -> + Header (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> CardanoHeader c pattern HeaderDijkstra h = HardForkHeader (OneEraHeader (TagDijkstra h)) @@ -566,7 +566,7 @@ pattern GenTxBabbage tx = HardForkGenTx (OneEraGenTx (TagBabbage tx)) pattern GenTxConway :: GenTx (ShelleyBlock (Praos c) ConwayEra) -> CardanoGenTx c pattern GenTxConway tx = HardForkGenTx (OneEraGenTx (TagConway tx)) -pattern GenTxDijkstra :: GenTx (ShelleyBlock (Praos c) DijkstraEra) -> CardanoGenTx c +pattern GenTxDijkstra :: GenTx (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> CardanoGenTx c pattern GenTxDijkstra tx = HardForkGenTx (OneEraGenTx (TagDijkstra tx)) {-# COMPLETE @@ -624,7 +624,7 @@ pattern GenTxIdConway txid = HardForkGenTxId (OneEraGenTxId (TagConway (WrapGenTxId txid))) pattern GenTxIdDijkstra :: - GenTxId (ShelleyBlock (Praos c) DijkstraEra) -> + GenTxId (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> CardanoGenTxId c pattern GenTxIdDijkstra txid = HardForkGenTxId (OneEraGenTxId (TagDijkstra (WrapGenTxId txid))) @@ -698,7 +698,7 @@ pattern ApplyTxErrConway err = HardForkApplyTxErrFromEra (OneEraApplyTxErr (TagConway (WrapApplyTxErr err))) pattern ApplyTxErrDijkstra :: - ApplyTxErr (ShelleyBlock (Praos c) DijkstraEra) -> + ApplyTxErr (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> CardanoApplyTxErr c pattern ApplyTxErrDijkstra err = HardForkApplyTxErrFromEra (OneEraApplyTxErr (TagDijkstra (WrapApplyTxErr err))) @@ -787,7 +787,7 @@ pattern LedgerErrorConway err = (OneEraLedgerError (TagConway (WrapLedgerErr err))) pattern LedgerErrorDijkstra :: - LedgerError (ShelleyBlock (Praos c) DijkstraEra) -> + LedgerError (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> CardanoLedgerError c pattern LedgerErrorDijkstra err = HardForkLedgerErrorFromEra @@ -860,7 +860,7 @@ pattern OtherHeaderEnvelopeErrorConway err = HardForkEnvelopeErrFromEra (OneEraEnvelopeErr (TagConway (WrapEnvelopeErr err))) pattern OtherHeaderEnvelopeErrorDijkstra :: - OtherHeaderEnvelopeError (ShelleyBlock (Praos c) DijkstraEra) -> + OtherHeaderEnvelopeError (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> CardanoOtherHeaderEnvelopeError c pattern OtherHeaderEnvelopeErrorDijkstra err = HardForkEnvelopeErrFromEra (OneEraEnvelopeErr (TagDijkstra (WrapEnvelopeErr err))) @@ -924,7 +924,7 @@ pattern TipInfoConway :: pattern TipInfoConway ti = OneEraTipInfo (TagConway (WrapTipInfo ti)) pattern TipInfoDijkstra :: - TipInfo (ShelleyBlock (Praos c) DijkstraEra) -> + TipInfo (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> CardanoTipInfo c pattern TipInfoDijkstra ti = OneEraTipInfo (TagDijkstra (WrapTipInfo ti)) @@ -1007,7 +1007,7 @@ pattern QueryIfCurrentConway :: pattern QueryIfCurrentDijkstra :: () => CardanoQueryResult c result ~ a => - BlockQuery (ShelleyBlock (Praos c) DijkstraEra) fp result -> + BlockQuery (ShelleyBlock (PraosWithLeios c) DijkstraEra) fp result -> CardanoQuery c fp a -- Here we use layout and adjacency to make it obvious that we haven't @@ -1171,7 +1171,7 @@ pattern CardanoCodecConfig :: CodecConfig (ShelleyBlock (TPraos c) AlonzoEra) -> CodecConfig (ShelleyBlock (Praos c) BabbageEra) -> CodecConfig (ShelleyBlock (Praos c) ConwayEra) -> - CodecConfig (ShelleyBlock (Praos c) DijkstraEra) -> + CodecConfig (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> CardanoCodecConfig c pattern CardanoCodecConfig cfgByron cfgShelley cfgAllegra cfgMary cfgAlonzo cfgBabbage cfgConway cfgDijkstra = HardForkCodecConfig @@ -1209,7 +1209,7 @@ pattern CardanoBlockConfig :: BlockConfig (ShelleyBlock (TPraos c) AlonzoEra) -> BlockConfig (ShelleyBlock (Praos c) BabbageEra) -> BlockConfig (ShelleyBlock (Praos c) ConwayEra) -> - BlockConfig (ShelleyBlock (Praos c) DijkstraEra) -> + BlockConfig (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> CardanoBlockConfig c pattern CardanoBlockConfig cfgByron cfgShelley cfgAllegra cfgMary cfgAlonzo cfgBabbage cfgConway cfgDijkstra = HardForkBlockConfig @@ -1247,7 +1247,7 @@ pattern CardanoStorageConfig :: StorageConfig (ShelleyBlock (TPraos c) AlonzoEra) -> StorageConfig (ShelleyBlock (Praos c) BabbageEra) -> StorageConfig (ShelleyBlock (Praos c) ConwayEra) -> - StorageConfig (ShelleyBlock (Praos c) DijkstraEra) -> + StorageConfig (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> CardanoStorageConfig c pattern CardanoStorageConfig cfgByron cfgShelley cfgAllegra cfgMary cfgAlonzo cfgBabbage cfgConway cfgDijkstra = HardForkStorageConfig @@ -1288,7 +1288,7 @@ pattern CardanoConsensusConfig :: PartialConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) AlonzoEra)) -> PartialConsensusConfig (BlockProtocol (ShelleyBlock (Praos c) BabbageEra)) -> PartialConsensusConfig (BlockProtocol (ShelleyBlock (Praos c) ConwayEra)) -> - PartialConsensusConfig (BlockProtocol (ShelleyBlock (Praos c) DijkstraEra)) -> + PartialConsensusConfig (BlockProtocol (ShelleyBlock (PraosWithLeios c) DijkstraEra)) -> CardanoConsensusConfig c pattern CardanoConsensusConfig cfgByron cfgShelley cfgAllegra cfgMary cfgAlonzo cfgBabbage cfgConway cfgDijkstra <- HardForkConsensusConfig @@ -1328,7 +1328,7 @@ pattern CardanoLedgerConfig :: PartialLedgerConfig (ShelleyBlock (TPraos c) AlonzoEra) -> PartialLedgerConfig (ShelleyBlock (Praos c) BabbageEra) -> PartialLedgerConfig (ShelleyBlock (Praos c) ConwayEra) -> - PartialLedgerConfig (ShelleyBlock (Praos c) DijkstraEra) -> + PartialLedgerConfig (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> CardanoLedgerConfig c pattern CardanoLedgerConfig cfgByron cfgShelley cfgAllegra cfgMary cfgAlonzo cfgBabbage cfgConway cfgDijkstra <- HardForkLedgerConfig @@ -1424,7 +1424,7 @@ pattern LedgerStateConway st <- ) pattern LedgerStateDijkstra :: - LedgerState (ShelleyBlock (Praos c) DijkstraEra) mk -> + LedgerState (ShelleyBlock (PraosWithLeios c) DijkstraEra) mk -> CardanoLedgerState c mk pattern LedgerStateDijkstra st <- HardForkLedgerState @@ -1505,7 +1505,7 @@ pattern ChainDepStateConway st <- (TeleConway _ _ _ _ _ _ (State.Current{currentState = WrapChainDepState st})) pattern ChainDepStateDijkstra :: - ChainDepState (BlockProtocol (ShelleyBlock (Praos c) DijkstraEra)) -> + ChainDepState (BlockProtocol (ShelleyBlock (PraosWithLeios c) DijkstraEra)) -> CardanoChainDepState c pattern ChainDepStateDijkstra st <- State.HardForkState @@ -1539,7 +1539,7 @@ pattern ChainDepStateDijkstra st <- instance forall c. ( PraosCrypto c - , ShelleyCompatible (Praos c) DijkstraEra + , ShelleyCompatible (PraosWithLeios c) DijkstraEra , HasCanonicalTxIn (CardanoEras c) , HasHardForkTxOut (CardanoEras c) , CanHardFork (CardanoEras c) @@ -1581,7 +1581,7 @@ instance -- epoch it was registered in, and 'mkStAnnTx' reads it too. dijkstraCfg = completeLedgerConfig - (Proxy @(ShelleyBlock (Praos c) DijkstraEra)) + (Proxy @(ShelleyBlock (PraosWithLeios c) DijkstraEra)) (State.epochInfoLedger cfg hfState) dijkstraPCfg in case applyLeiosClosure dijkstraCfg dijkstraTxs dijkstraLst of @@ -1625,7 +1625,7 @@ instance protocolStateLeiosAnnouncement cds = case cds of ChainDepStateDijkstra praosSt -> - protocolStateLeiosAnnouncement @(ShelleyBlock (Praos c) DijkstraEra) praosSt + protocolStateLeiosAnnouncement @(ShelleyBlock (PraosWithLeios c) DijkstraEra) praosSt _ -> Nothing assumeValidatedClosureTx tx = case tx of diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs index bca2782df5..0ad07c2f62 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -91,7 +91,7 @@ import Ouroboros.Consensus.Protocol.Abstract hiding ) import Ouroboros.Consensus.Protocol.PBFT.State (PBftState) import qualified Ouroboros.Consensus.Protocol.PBFT.State as PBftState -import Ouroboros.Consensus.Protocol.Praos (Praos) +import Ouroboros.Consensus.Protocol.Praos (Praos, PraosWithLeios) import qualified Ouroboros.Consensus.Protocol.Praos as Praos import Ouroboros.Consensus.Protocol.Praos.Common (PraosTiebreakerView) import Ouroboros.Consensus.Protocol.TPraos @@ -130,9 +130,9 @@ type CardanoHardForkConstraints c = , ShelleyCompatible (Praos c) ConwayEra , LedgerSupportsProtocol (ShelleyBlock (Praos c) ConwayEra) , LedgerSupportsPeras (ShelleyBlock (Praos c) ConwayEra) - , ShelleyCompatible (Praos c) DijkstraEra - , LedgerSupportsProtocol (ShelleyBlock (Praos c) DijkstraEra) - , LedgerSupportsPeras (ShelleyBlock (Praos c) DijkstraEra) + , ShelleyCompatible (PraosWithLeios c) DijkstraEra + , LedgerSupportsProtocol (ShelleyBlock (PraosWithLeios c) DijkstraEra) + , LedgerSupportsPeras (ShelleyBlock (PraosWithLeios c) DijkstraEra) ) -- | When performing era translations, two eras have special behaviours on the @@ -829,7 +829,7 @@ translateLedgerStateConwayToDijkstraWrapper :: WrapLedgerConfig TranslateLedgerState (ShelleyBlock (Praos c) ConwayEra) - (ShelleyBlock (Praos c) DijkstraEra) + (ShelleyBlock (PraosWithLeios c) DijkstraEra) translateLedgerStateConwayToDijkstraWrapper = RequireBoth $ \_cfgConway cfgDijkstra -> TranslateLedgerState @@ -840,12 +840,29 @@ translateLedgerStateConwayToDijkstraWrapper = . SL.translateEra' (getDijkstraTranslationContext cfgDijkstra) . Comp . Flip + . transLeiosLS + } + where + -- Only the protocol index changes, so nothing in here is converted; the + -- rebuild is what retypes it. Contrast 'transPraosLS', which crosses between + -- two genuinely different protocols. + transLeiosLS :: + LedgerState (ShelleyBlock (Praos c) ConwayEra) mk -> + LedgerState (ShelleyBlock (PraosWithLeios c) ConwayEra) mk + transLeiosLS (ShelleyLedgerState wo nes st tb lcr ctb) = + ShelleyLedgerState + { shelleyLedgerTip = fmap castShelleyTip wo + , shelleyLedgerState = nes + , shelleyLedgerTransition = st + , shelleyLedgerTables = coerce tb + , shelleyLedgerLatestPerasCertRound = lcr + , shelleyCumulativeTxBytes = ctb } translateLedgerTablesConwayToDijkstraWrapper :: TranslateLedgerTables (ShelleyBlock (Praos c) ConwayEra) - (ShelleyBlock (Praos c) DijkstraEra) + (ShelleyBlock (PraosWithLeios c) DijkstraEra) translateLedgerTablesConwayToDijkstraWrapper = TranslateLedgerTables { translateTxInWith = coerce @@ -853,7 +870,7 @@ translateLedgerTablesConwayToDijkstraWrapper = } getDijkstraTranslationContext :: - WrapLedgerConfig (ShelleyBlock (Praos c) DijkstraEra) -> + WrapLedgerConfig (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> SL.TranslationContext DijkstraEra getDijkstraTranslationContext = shelleyLedgerTranslationContext . unwrapLedgerConfig @@ -862,17 +879,33 @@ translateTxConwayToDijkstraWrapper :: SL.TranslationContext DijkstraEra -> InjectTx (ShelleyBlock (Praos c) ConwayEra) - (ShelleyBlock (Praos c) DijkstraEra) + (ShelleyBlock (PraosWithLeios c) DijkstraEra) translateTxConwayToDijkstraWrapper ctxt = InjectTx $ - fmap unComp . eitherToMaybe . runExcept . SL.translateEra ctxt . Comp + fmap unComp . eitherToMaybe . runExcept . SL.translateEra ctxt . Comp . transLeiosTx + where + transLeiosTx :: + GenTx (ShelleyBlock (Praos c) ConwayEra) -> + GenTx (ShelleyBlock (PraosWithLeios c) ConwayEra) + transLeiosTx (ShelleyTx ti tx) = ShelleyTx ti tx translateValidatedTxConwayToDijkstraWrapper :: forall c. SL.TranslationContext DijkstraEra -> InjectValidatedTx (ShelleyBlock (Praos c) ConwayEra) - (ShelleyBlock (Praos c) DijkstraEra) + (ShelleyBlock (PraosWithLeios c) DijkstraEra) translateValidatedTxConwayToDijkstraWrapper ctxt = InjectValidatedTx $ - fmap unComp . eitherToMaybe . runExcept . SL.translateEra ctxt . Comp + fmap unComp + . eitherToMaybe + . runExcept + . SL.translateEra ctxt + . Comp + . transLeiosValidatedTx + where + transLeiosValidatedTx :: + WrapValidatedGenTx (ShelleyBlock (Praos c) ConwayEra) -> + WrapValidatedGenTx (ShelleyBlock (PraosWithLeios c) ConwayEra) + transLeiosValidatedTx (WrapValidatedGenTx x) = case x of + ShelleyValidatedTx txid vtx -> WrapValidatedGenTx $ ShelleyValidatedTx txid vtx diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs index 7dffcff9f0..fe41f24a14 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs @@ -53,7 +53,7 @@ import Ouroboros.Consensus.Cardano.CanHardFork import Ouroboros.Consensus.HardFork.Combinator import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.Ledger.Tables -import Ouroboros.Consensus.Protocol.Praos (Praos) +import Ouroboros.Consensus.Protocol.Praos (Praos, PraosWithLeios) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Ledger ( BigEndianTxIn @@ -110,7 +110,7 @@ data CardanoTxOut c | AlonzoTxOut !(TxOut (LedgerState (ShelleyBlock (TPraos c) AlonzoEra))) | BabbageTxOut !(TxOut (LedgerState (ShelleyBlock (Praos c) BabbageEra))) | ConwayTxOut !(TxOut (LedgerState (ShelleyBlock (Praos c) ConwayEra))) - | DijkstraTxOut !(TxOut (LedgerState (ShelleyBlock (Praos c) DijkstraEra))) + | DijkstraTxOut !(TxOut (LedgerState (ShelleyBlock (PraosWithLeios c) DijkstraEra))) deriving stock (Show, Eq, Generic) deriving anyclass NoThunks diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index e695e3a04d..c324fae1d3 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs @@ -92,7 +92,7 @@ import Ouroboros.Consensus.Ledger.Tables import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run -import Ouroboros.Consensus.Protocol.Praos (Praos, PraosParams (..)) +import Ouroboros.Consensus.Protocol.Praos (Praos, PraosParams (..), PraosWithLeios) import Ouroboros.Consensus.Protocol.Praos.AgentClient import Ouroboros.Consensus.Protocol.Praos.Common ( PraosCanBeLeader (..) @@ -538,7 +538,7 @@ pattern CardanoHardForkTriggers' :: CardanoHardForkTrigger (ShelleyBlock (TPraos c) AlonzoEra) -> CardanoHardForkTrigger (ShelleyBlock (Praos c) BabbageEra) -> CardanoHardForkTrigger (ShelleyBlock (Praos c) ConwayEra) -> - CardanoHardForkTrigger (ShelleyBlock (Praos c) DijkstraEra) -> + CardanoHardForkTrigger (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> CardanoHardForkTriggers pattern CardanoHardForkTriggers' { triggerHardForkShelley @@ -869,7 +869,7 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano -- Dijkstra - blockConfigDijkstra :: BlockConfig (ShelleyBlock (Praos c) DijkstraEra) + blockConfigDijkstra :: BlockConfig (ShelleyBlock (PraosWithLeios c) DijkstraEra) blockConfigDijkstra = Shelley.mkShelleyBlockConfig cardanoProtocolVersion @@ -877,10 +877,10 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano (shelleyBlockIssuerVKey <$> credssShelleyBased) partialConsensusConfigDijkstra :: - PartialConsensusConfig (BlockProtocol (ShelleyBlock (Praos c) DijkstraEra)) + PartialConsensusConfig (BlockProtocol (ShelleyBlock (PraosWithLeios c) DijkstraEra)) partialConsensusConfigDijkstra = praosParams - partialLedgerConfigDijkstra :: PartialLedgerConfig (ShelleyBlock (Praos c) DijkstraEra) + partialLedgerConfigDijkstra :: PartialLedgerConfig (ShelleyBlock (PraosWithLeios c) DijkstraEra) partialLedgerConfigDijkstra = mkPartialLedgerConfigShelley transitionConfigDijkstra @@ -1137,6 +1137,13 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano praos = Praos.praosSharedBlockForging hotKey slotToPeriod credentials + let praosWithLeios :: + forall era. + Shelley.ShelleyCompatible (PraosWithLeios c) era => + BlockForging m (ShelleyBlock (PraosWithLeios c) era) + praosWithLeios = + Praos.praosWithLeiosSharedBlockForging hotKey slotToPeriod credentials + pure $ OptSkip $ -- Byron OptNP.fromNonEmptyNP $ @@ -1146,7 +1153,7 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano :* tpraos :* praos :* praos - :* praos + :* praosWithLeios :* Nil protocolClientInfoCardano :: diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs index 3c5a3ffdf7..9a0f42ce46 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs @@ -19,9 +19,9 @@ module Ouroboros.Consensus.Shelley.HFEras import Cardano.Ledger.Dijkstra.Era (DijkstraEraBlockHeader (..)) import Cardano.Protocol.Crypto -import Ouroboros.Consensus.Protocol.Praos (Praos) +import Ouroboros.Consensus.Protocol.Praos (Praos, PraosWithLeios) import qualified Ouroboros.Consensus.Protocol.Praos as Praos -import Ouroboros.Consensus.Protocol.Praos.Header (Header) +import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec import Ouroboros.Consensus.Protocol.TPraos (TPraos) import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos import Ouroboros.Consensus.Shelley.Eras @@ -60,7 +60,7 @@ type StandardBabbageBlock = ShelleyBlock (Praos StandardCrypto) BabbageEra type StandardConwayBlock = ShelleyBlock (Praos StandardCrypto) ConwayEra -type StandardDijkstraBlock = ShelleyBlock (Praos StandardCrypto) DijkstraEra +type StandardDijkstraBlock = ShelleyBlock (PraosWithLeios StandardCrypto) DijkstraEra {------------------------------------------------------------------------------- ShelleyCompatible @@ -86,8 +86,8 @@ instance Praos.PraosCrypto c => ShelleyCompatible (Praos c) BabbageEra instance Praos.PraosCrypto c => ShelleyCompatible (Praos c) ConwayEra -instance Praos.PraosCrypto c => ShelleyCompatible (Praos c) DijkstraEra where +instance Praos.PraosCrypto c => ShelleyCompatible (PraosWithLeios c) DijkstraEra where workaroundLedgerIssue5937 = encodeShelleyBlockWorkaroundLedgerIssue5937 -instance Crypto c => DijkstraEraBlockHeader (Header c) DijkstraEra where +instance Crypto c => DijkstraEraBlockHeader (LeiosCodec.Header c) DijkstraEra where prevNonceBlockHeaderL = error "Not implemented. Peras placeholder" diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs index 5353f58e7c..79a7d4e434 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs @@ -28,7 +28,7 @@ import Control.Monad (when) import Control.Tracer (traceWith) import Data.ByteString.Short (fromShort) import Data.Maybe (isJust) -import Data.Maybe.Strict (StrictMaybe (..), maybeToStrictMaybe) +import Data.Maybe.Strict (maybeToStrictMaybe) import qualified Data.Sequence.Strict as Seq import qualified Data.Typeable as Typeable import LeiosDemoTypes @@ -49,7 +49,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Protocol.Abstract (CanBeLeader) import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) -import Ouroboros.Consensus.Protocol.Praos.Header (HeaderLeiosExtension (..)) +import Ouroboros.Consensus.Protocol.Praos.Common (StrictMaybeLeios (..)) import Ouroboros.Consensus.Shelley.Eras (DijkstraEra) import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Config @@ -59,7 +59,7 @@ import Ouroboros.Consensus.Shelley.Ledger.Integrity import Ouroboros.Consensus.Shelley.Ledger.Mempool import Ouroboros.Consensus.Shelley.Protocol.Abstract ( ProtoCrypto - , ProtocolHeaderSupportsKES (configSlotsPerKESPeriod) + , ProtocolHeaderSupportsKES (ProtoHasLeios, configSlotsPerKESPeriod) , mkHeader ) @@ -72,9 +72,10 @@ forgeShelleyBlock :: (ShelleyCompatible proto era, Monad m) => HotKey (ProtoCrypto proto) m -> CanBeLeader proto -> + StrictMaybeLeios (ProtoHasLeios proto) () -> ForgeBlockArgs m (ShelleyBlock proto era) -> m (ShelleyBlock proto era, Maybe ForgedLeiosEb) -forgeShelleyBlock hotKey cbl ForgeBlockArgs{..} = do +forgeShelleyBlock hotKey cbl leiosToken ForgeBlockArgs{..} = do -- Forge an RB and attempt to announce an EB and/or certify a previously announced one: -- -- * Certify: if the forge loop decided to certify a previously-announced @@ -83,10 +84,17 @@ forgeShelleyBlock hotKey cbl ForgeBlockArgs{..} = do -- * Announce: forge and store a new EB from 'fbEbTxs' and announce it on this RB's header. -- When we are also certifying, 'fbEbTxs' contains transactions from the mempool that has already -- been rebased onto the post-certificate ledger state. - mayEbAnn <- - case Typeable.eqT @era @DijkstraEra of - Just Refl -> mkEb - Nothing -> pure Nothing + -- Matching the token refines 'ProtoHasLeios', which is what lets the Leios + -- branch build the header fields below. + (mayEbAnn :: Maybe (ForgedLeiosEb, EbAnnouncement), leiosFields) <- + case leiosToken of + SNothingLeios -> pure (Nothing, SNothingLeios) + SJustLeios () -> do + ann <- mkEb + pure + ( ann + , SJustLeios (isJust fbMayLeiosCert, maybeToStrictMaybe (snd <$> ann)) + ) let rbBody = mkBody fbMayLeiosCert actualRbBodySize = SL.blockBodySize protocolVersion rbBody hdr <- @@ -100,11 +108,7 @@ forgeShelleyBlock hotKey cbl ForgeBlockArgs{..} = do (SL.hashBlockBody @era rbBody) actualRbBodySize protocolVersion - $ SJust - HeaderLeiosExtension - { containsCert = isJust fbMayLeiosCert - , ebAnnouncement = maybeToStrictMaybe $ snd <$> mayEbAnn - } + leiosFields let blk = mkShelleyBlock $ SL.Block hdr rbBody case fst <$> mayEbAnn of diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index 39fc9e39ee..1678423d16 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -134,7 +134,7 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch) -import Ouroboros.Consensus.Protocol.Praos (Praos) +import Ouroboros.Consensus.Protocol.Praos (Praos, PraosWithLeios) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Eras ( AllegraEra @@ -1021,7 +1021,7 @@ instance HasLeiosVoting (ShelleyBlock (Praos c) ConwayEra) where getCurrentThreshold = const Nothing getMinCertificationGap _ _ = Nothing -instance HasLeiosVoting (ShelleyBlock (Praos c) DijkstraEra) where +instance HasLeiosVoting (ShelleyBlock (PraosWithLeios c) DijkstraEra) where -- The ledger already seats the committee, on the stake snapshot, at the era -- boundary; take it from there rather than selecting a second time here. -- diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs index 0d99f5184d..99fce47e83 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} @@ -59,18 +60,14 @@ import Ouroboros.Consensus.Protocol.Praos ( ConsensusConfig (..) , Praos , PraosCrypto + , PraosWithLeios , PraosParams (..) - , PraosState (..) + , BasePraosState (..) , Ticked (..) , WhetherToUpperBoundOCERT (..) ) +import Ouroboros.Consensus.Protocol.Praos.Common (StrictMaybeLeios (..)) import qualified Ouroboros.Consensus.Protocol.Praos as PP -import Ouroboros.Consensus.Protocol.Praos.Header - ( Header (..) - , HeaderBody (..) - , hbLeiosContainsCert - , hbLeiosEbAnnouncement - ) import Ouroboros.Consensus.Protocol.Praos.Views (plvPoolDistr) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Eras @@ -91,6 +88,12 @@ import Ouroboros.Consensus.Shelley.Ledger.Ledger ( LedgerState (..) , shelleyLedgerGlobals ) +import Ouroboros.Consensus.Shelley.Protocol.Abstract + ( pHeaderIssuer + , pHeaderLeiosContainsCert + , pHeaderLeiosEbAnnouncement + , pHeaderSlot + ) import Ouroboros.Consensus.Shelley.Ledger.Mempool ( GenTx (ShelleyTx) , mkShelleyTx @@ -117,8 +120,8 @@ instance ResolveLeiosBlock (ShelleyBlock (Praos c) ConwayEra) instance forall c. - (PraosCrypto c, ShelleyCompatible (Praos c) DijkstraEra) => - ResolveLeiosBlock (ShelleyBlock (Praos c) DijkstraEra) + (PraosCrypto c, ShelleyCompatible (PraosWithLeios c) DijkstraEra) => + ResolveLeiosBlock (ShelleyBlock (PraosWithLeios c) DijkstraEra) where -- The on-wire bytes and 'TxHash' a forged EB records for each tx (see -- 'forgeLeiosEb'): 'serialize'' the tx, and hash exactly those bytes. Matching @@ -213,28 +216,26 @@ instance blockLeiosCert blk = strictMaybeToMaybe $ blk.shelleyBlockRaw.blockBody ^. leiosCertBlockBodyL - headerContainsLeiosCert hdr = hbLeiosContainsCert headerBody - where - Header{headerBody} = shelleyHeaderRaw hdr + headerContainsLeiosCert = pHeaderLeiosContainsCert . shelleyHeaderRaw headerLeiosAnnouncement hdr = do - ann <- strictMaybeToMaybe $ hbLeiosEbAnnouncement headerBody + ann <- strictMaybeToMaybe $ pHeaderLeiosEbAnnouncement raw pure ( MkLeiosPoint - { pointSlotNo = headerBody.hbSlotNo + { pointSlotNo = pHeaderSlot raw , pointEbHash = ann.ebAnnouncementHash } , ann.ebAnnouncementSize ) where - Header{headerBody} = shelleyHeaderRaw hdr + raw = shelleyHeaderRaw hdr headerElId hdr = MkElId - headerBody.hbSlotNo - (Crypto.hashToBytesShort . unKeyHash . SL.hashKey $ headerBody.hbVk) + (pHeaderSlot raw) + (Crypto.hashToBytesShort . unKeyHash . SL.hashKey $ pHeaderIssuer raw) where - Header{headerBody} = shelleyHeaderRaw hdr + raw = shelleyHeaderRaw hdr -- The announcement is validated out-of-context against a (possibly lagging) -- immutable tip. We skip the OCERT counter's upper bound @@ -273,7 +274,9 @@ instance hv protocolStateLeiosAnnouncement st = do - ann <- strictMaybeToMaybe $ praosStateLeiosAnnouncement st + -- 'SNothingLeios' is unreachable at this extension, so this is total. + ann <- case praosStateLeiosAnnouncement st of + SJustLeios mbAnn -> strictMaybeToMaybe mbAnn pure ( MkLeiosPoint { pointSlotNo = fromWithOrigin (SlotNo 0) st.praosStateLastSlot @@ -287,4 +290,4 @@ instance case blockPrevHash blk of GenesisHash -> Nothing BlockHash h -> - Just $ MkRbHash $ toRawHash (Proxy @(ShelleyBlock (Praos c) DijkstraEra)) h + Just $ MkRbHash $ toRawHash (Proxy @(ShelleyBlock (PraosWithLeios c) DijkstraEra)) h diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs index 00f15b7209..900c74fed0 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -13,11 +14,9 @@ -- instance for 'ShelleyBlock'. module Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () where -import qualified Cardano.Ledger.Core as LedgerCore import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Protocol.TPraos.API as SL import Control.Monad.Except (MonadError (throwError)) -import qualified Lens.Micro import Ouroboros.Consensus.Block import Ouroboros.Consensus.Forecast import Ouroboros.Consensus.HardFork.History.Util @@ -25,15 +24,16 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol (..) ) -import Ouroboros.Consensus.Protocol.Praos (Praos) +import Ouroboros.Consensus.Protocol.Praos (BasePraos) import qualified Ouroboros.Consensus.Protocol.Praos as Praos (PraosCrypto) +import Ouroboros.Consensus.Protocol.Praos.Common (KnownPraosExtension) import qualified Ouroboros.Consensus.Protocol.Praos.Views as Praos import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Ledger import Ouroboros.Consensus.Shelley.Ledger.Protocol () import Ouroboros.Consensus.Shelley.Protocol.Abstract () -import Ouroboros.Consensus.Shelley.Protocol.Praos () +import Ouroboros.Consensus.Shelley.Protocol.Praos (HasPraosExtensionHeader) import Ouroboros.Consensus.Shelley.Protocol.TPraos () instance @@ -77,31 +77,27 @@ instance maxFor = addSlots swindow $ succWithOrigin at instance - ( ShelleyCompatible (Praos crypto) era + ( ShelleyCompatible (BasePraos pext crypto) era + , KnownPraosExtension pext + , HasPraosExtensionHeader pext + , Praos.ForecastsLeios pext era , SL.EraForecast era , Praos.PraosCrypto crypto ) => - LedgerSupportsProtocol (ShelleyBlock (Praos crypto) era) + LedgerSupportsProtocol (ShelleyBlock (BasePraos pext crypto) era) where - protocolLedgerView _cfg st = - let nes = tickedShelleyLedgerState st - - SL.NewEpochState{nesPd} = nes - - pparam :: forall a. Lens.Micro.Lens' (LedgerCore.PParams era) a -> a - pparam lens = getPParams nes Lens.Micro.^. lens - in Praos.PraosLedgerView - { Praos.plvPoolDistr = nesPd - , Praos.plvMaxBodySize = pparam LedgerCore.ppMaxBBSizeL - , Praos.plvMaxHeaderSize = pparam LedgerCore.ppMaxBHSizeL - , Praos.plvProtocolVersion = pparam LedgerCore.ppProtocolVersionL - } + -- 'SL.currentForecast' is 'SL.mkForecast': a projection of the state, with no + -- TICKF. 'SL.futureForecast' is TICKF and then that same projection. Reusing + -- it here is what makes this method and 'ledgerViewForecastAt' agree by + -- construction, instead of by two copies of the projection staying in step. + protocolLedgerView _cfg = + Praos.forecastToBasePraosLedgerView . SL.currentForecast . tickedShelleyLedgerState ledgerViewForecastAt cfg ledgerState = Forecast at $ \for -> if | NotOrigin for == at -> return $ - Praos.forecastToPraosLedgerView (SL.currentForecast shelleyLedgerState) + Praos.forecastToBasePraosLedgerView (SL.currentForecast shelleyLedgerState) | for < maxFor -> return $ futureLedgerView for | otherwise -> @@ -117,9 +113,9 @@ instance swindow = SL.stabilityWindow globals at = ledgerTipSlot ledgerState - futureLedgerView :: SlotNo -> Praos.PraosLedgerView + futureLedgerView :: SlotNo -> Praos.BasePraosLedgerView pext futureLedgerView for = - Praos.forecastToPraosLedgerView $ + Praos.forecastToBasePraosLedgerView $ SL.futureForecast globals for shelleyLedgerState -- Exclusive upper bound diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs index 29a27db6ab..c946e003bb 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs @@ -9,6 +9,7 @@ module Ouroboros.Consensus.Shelley.Node.Praos ( -- * BlockForging praosBlockForging , praosSharedBlockForging + , praosWithLeiosSharedBlockForging ) where import qualified Cardano.Ledger.Api.Era as L @@ -19,10 +20,13 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config (configConsensus) import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import Ouroboros.Consensus.Protocol.Praos - ( Praos + ( BasePraos + , Praos , PraosParams (..) + , PraosWithLeios , praosCheckCanForge ) +import Ouroboros.Consensus.Protocol.Praos.Common (StrictMaybeLeios (..)) import Ouroboros.Consensus.Shelley.Ledger ( ShelleyBlock , ShelleyCompatible @@ -32,6 +36,7 @@ import Ouroboros.Consensus.Shelley.Node.Common ( ShelleyLeaderCredentials (..) ) import Ouroboros.Consensus.Shelley.Protocol.Praos () +import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoHasLeios) import Ouroboros.Consensus.Util.IOLike (IOLike) {------------------------------------------------------------------------------- @@ -61,16 +66,20 @@ praosBlockForging praosParams hotKey credentials = -- -- The name of the era (separated by a @_@) will be appended to each -- 'forgeLabel'. -praosSharedBlockForging :: - forall m c era. - ( ShelleyCompatible (Praos c) era +-- | Shared by every Praos extension; the caller supplies the Leios token, +-- since it knows which extension it is. +basePraosSharedBlockForging :: + forall m pext c era. + ( ShelleyCompatible (BasePraos pext c) era , IOLike m ) => + StrictMaybeLeios (ProtoHasLeios (BasePraos pext c)) () -> HotKey.HotKey c m -> (SlotNo -> Absolute.KESPeriod) -> ShelleyLeaderCredentials c -> - BlockForging m (ShelleyBlock (Praos c) era) -praosSharedBlockForging + BlockForging m (ShelleyBlock (BasePraos pext c) era) +basePraosSharedBlockForging + leiosToken hotKey slotToPeriod ShelleyLeaderCredentials @@ -91,6 +100,29 @@ praosSharedBlockForging forgeShelleyBlock hotKey canBeLeader + leiosToken cfg , finalize = HotKey.finalize hotKey } + +praosSharedBlockForging :: + forall m c era. + ( ShelleyCompatible (Praos c) era + , IOLike m + ) => + HotKey.HotKey c m -> + (SlotNo -> Absolute.KESPeriod) -> + ShelleyLeaderCredentials c -> + BlockForging m (ShelleyBlock (Praos c) era) +praosSharedBlockForging = basePraosSharedBlockForging SNothingLeios + +praosWithLeiosSharedBlockForging :: + forall m c era. + ( ShelleyCompatible (PraosWithLeios c) era + , IOLike m + ) => + HotKey.HotKey c m -> + (SlotNo -> Absolute.KESPeriod) -> + ShelleyLeaderCredentials c -> + BlockForging m (ShelleyBlock (PraosWithLeios c) era) +praosWithLeiosSharedBlockForging = basePraosSharedBlockForging (SJustLeios ()) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs index 714ee97594..d6346afeb7 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs @@ -42,7 +42,8 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables (EmptyMK) import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Serialisation -import Ouroboros.Consensus.Protocol.Praos (PraosState) +import Ouroboros.Consensus.Protocol.Praos (BasePraosState) +import Ouroboros.Consensus.Protocol.Praos.Common (KnownPraosExtension) import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger @@ -106,11 +107,17 @@ instance ShelleyCompatible proto era => EncodeDisk (ShelleyBlock proto era) TPra instance ShelleyCompatible proto era => DecodeDisk (ShelleyBlock proto era) TPraosState where decodeDisk _ = decode -instance ShelleyCompatible proto era => EncodeDisk (ShelleyBlock proto era) PraosState where +instance + (ShelleyCompatible proto era, KnownPraosExtension pext) => + EncodeDisk (ShelleyBlock proto era) (BasePraosState pext) + where encodeDisk _ = encode -- | @'ChainDepState' ('BlockProtocol' ('ShelleyBlock' era))@ -instance ShelleyCompatible proto era => DecodeDisk (ShelleyBlock proto era) PraosState where +instance + (ShelleyCompatible proto era, KnownPraosExtension pext) => + DecodeDisk (ShelleyBlock proto era) (BasePraosState pext) + where decodeDisk _ = decode instance diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs index 716d2932fa..94ee664e7b 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs @@ -124,6 +124,7 @@ shelleySharedBlockForging hotKey slotToPeriod credentials = forgeShelleyBlock hotKey canBeLeader + SNothingLeios cfg , finalize = HotKey.finalize hotKey } diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs index e25195cf4a..94240b3ce1 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs @@ -20,6 +20,7 @@ module Ouroboros.Consensus.Shelley.Protocol.Abstract ( ProtoCrypto , ProtocolHeaderSupportsEnvelope (..) , default_pHeaderLeiosContainsCert + , default_pHeaderLeiosEbAnnouncement , ProtocolHeaderSupportsKES (..) , ProtocolHeaderSupportsProtocol (..) , ShelleyHash (..) @@ -30,7 +31,7 @@ module Ouroboros.Consensus.Shelley.Protocol.Abstract import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR)) import qualified Cardano.Crypto.Hash as Hash import Cardano.Crypto.VRF (OutputVRF) -import Cardano.Ledger.BaseTypes (ProtVer, StrictMaybe) +import Cardano.Ledger.BaseTypes (ProtVer, StrictMaybe (SNothing)) import Cardano.Ledger.Hashes ( EraIndependentBlockBody , EraIndependentBlockHeader @@ -62,8 +63,11 @@ import Ouroboros.Consensus.Protocol.Abstract , ValidateView ) import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) -import Ouroboros.Consensus.Protocol.Praos.Common (HasMaxMajorProtVer) -import Ouroboros.Consensus.Protocol.Praos.Header (HeaderLeiosExtension) +import Ouroboros.Consensus.Protocol.Praos.Common + ( HasMaxMajorProtVer + , StrictMaybeLeios + , WhetherHasLeios + ) import Ouroboros.Consensus.Protocol.Signed (SignedHeader) import Ouroboros.Consensus.Util.Condense (Condense (..)) @@ -127,6 +131,11 @@ class -- the header/body envelope. pHeaderLeiosContainsCert :: ShelleyProtocolHeader proto -> Bool + -- | The endorser block this header announces. 'SNothing' for + -- protocols/headers without Leios support, which use + -- 'default_pHeaderLeiosEbAnnouncement'. + pHeaderLeiosEbAnnouncement :: ShelleyProtocolHeader proto -> StrictMaybe EbAnnouncement + type EnvelopeCheckError proto :: Type -- | Carry out any protocol-specific envelope checks. For example, this might @@ -144,12 +153,25 @@ class default_pHeaderLeiosContainsCert :: ShelleyProtocolHeader proto -> Bool default_pHeaderLeiosContainsCert = const False +-- | The 'pHeaderLeiosEbAnnouncement' for protocols/headers without Leios +-- support: a header that cannot announce an endorser block never does. +default_pHeaderLeiosEbAnnouncement :: + ShelleyProtocolHeader proto -> StrictMaybe EbAnnouncement +default_pHeaderLeiosEbAnnouncement = const SNothing + -- | `ProtocolHeaderSupportsKES` describes functionality common to protocols -- using key evolving signature schemes. This includes verifying the header -- integrity (e.g. validating the KES signature), as well as constructing the -- header (made specific to KES-using protocols through the need to handle -- the hot key). class ProtocolHeaderSupportsKES proto where + -- | Whether this protocol's header carries the Leios fields. + -- + -- Unlike 'ShelleyProtocolHeader' this is not injective — several protocols + -- have no Leios — but it only ever indexes a 'StrictMaybeLeios', so nothing + -- needs to invert it. + type ProtoHasLeios proto :: WhetherHasLeios + -- | Extract the "slots per KES period" value from the protocol config. -- -- Note that we do not require `ConsensusConfig` in 'verifyHeaderIntegrity' @@ -181,8 +203,9 @@ class ProtocolHeaderSupportsKES proto where Int -> -- | Protocol version ProtVer -> - -- | Optional fields for Leios - StrictMaybe HeaderLeiosExtension -> + -- | Optional fields for Leios: whether the body carries a certificate, and + -- this header's announcement, if any + StrictMaybeLeios (ProtoHasLeios proto) (Bool, StrictMaybe EbAnnouncement) -> m (ShelleyProtocolHeader proto) -- | Extract the most recently announced (and not yet certified) Leios EB diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs index f5dbe13a87..41fd22f47c 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs @@ -1,31 +1,48 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Ouroboros.Consensus.Shelley.Protocol.Praos () where +module Ouroboros.Consensus.Shelley.Protocol.Praos + ( ShelleyHeaderView (..) + , HasPraosExtensionHeader (..) + ) where +import qualified Cardano.Crypto.Hash as Hash import qualified Cardano.Crypto.KES as KES import Cardano.Crypto.VRF (certifiedOutput) import Cardano.Ledger.BaseTypes (ProtVer (ProtVer)) import Cardano.Ledger.Chain (ChainChecksPParams (..)) +import Cardano.Ledger.Hashes (EraIndependentBlockBody, HASH) import Cardano.Ledger.Slot (SlotNo (unSlotNo)) +import Cardano.Protocol.Crypto (Crypto, KES) +import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec +import qualified Cardano.Protocol.Praos.BlockHeader as PraosCodec import Cardano.Protocol.TPraos.OCert ( OCert (ocertKESPeriod, ocertVkHot) ) import qualified Cardano.Protocol.TPraos.OCert as SL +import Cardano.Slotting.Block (BlockNo) import Data.Either (isRight) import Data.Maybe.Strict (StrictMaybe (..)) +import Data.Proxy (Proxy (Proxy)) +import Data.Word (Word32) +import LeiosDemoTypes (EbAnnouncement) import Ouroboros.Consensus.Protocol.Praos import Ouroboros.Consensus.Protocol.Praos.Common - ( MaxMajorProtVer (MaxMajorProtVer) - ) -import Ouroboros.Consensus.Protocol.Praos.Header - ( Header (..) - , HeaderBody (..) - , hbLeiosContainsCert - , headerHash - , headerSize + ( KnownPraosExtension (singPraosExtension) + , MaxMajorProtVer (MaxMajorProtVer) + , PraosExtensionHasLeios + , SingPraosExtension (..) + , StrictMaybeLeios (..) + , fromCodecEbAnnouncement + , toCodecEbAnnouncement ) import Ouroboros.Consensus.Protocol.Praos.Views import Ouroboros.Consensus.Protocol.Signed @@ -44,19 +61,137 @@ import Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks , envelopeCheck ) -type instance ProtoCrypto (Praos c) = c +{------------------------------------------------------------------------------- + The header as the Shelley block layer needs it +-------------------------------------------------------------------------------} + +-- | View of the block header required by the Shelley block layer. +-- +-- The counterpart to 'BaseHeaderView', which is what the 'ConsensusProtocol' +-- instance requires: this is what the @ProtocolHeaderSupports*@ classes require, +-- ie the header's identity and the body it claims. Keeping the two separate +-- keeps each narrow, and lets the extension-dependence of the upstream header +-- types be discharged in one place per view. +-- +-- Unindexed by @pext@, unlike 'BaseHeaderView': every field here is uniform +-- across the extensions, an extension without Leios simply reporting 'False' +-- and 'SNothing' for the last two. +data ShelleyHeaderView = ShelleyHeaderView + { shvHash :: !ShelleyHash + , shvSize :: !Int + -- ^ Over the bytes the header was decoded from; see 'headerSize'. + , shvBlockNo :: !BlockNo + , shvBodyHash :: !(Hash.Hash HASH EraIndependentBlockBody) + , shvBodySize :: !Word32 + , shvProtVer :: !ProtVer + , shvLeiosContainsCert :: !Bool + -- ^ Whether the block's body carries a Leios certificate, ie whether it is a + -- CertRB. + , shvLeiosEbAnnouncement :: !(StrictMaybe EbAnnouncement) + -- ^ The endorser block this header announces. + } + +-- | Project an extension's header into the two views that read it. +-- +-- Two projections rather than one because the views want different things: +-- 'BaseHeaderView' carries the signed body itself, and 'ShelleyHeaderView' the +-- block number, body hash and body size, which that one does not. +class HasPraosExtensionHeader pext where + headerToView :: + Crypto c => ShelleyProtocolHeader (BasePraos pext c) -> BaseHeaderView pext c + headerToShelleyView :: + Crypto c => ShelleyProtocolHeader (BasePraos pext c) -> ShelleyHeaderView + +instance HasPraosExtensionHeader PextNone where + headerToView hdr = + HeaderView + { hvPrevHash = PraosCodec.hbPrev body + , hvVK = PraosCodec.hbVk body + , hvVrfVK = PraosCodec.hbVrfVk body + , hvVrfRes = PraosCodec.hbVrfRes body + , hvOCert = PraosCodec.hbOCert body + , hvSlotNo = PraosCodec.hbSlotNo body + , hvLeios = SNothingLeios + , hvSigned = body + , hvSignature = PraosCodec.headerSig hdr + } + where + body = PraosCodec.headerBody hdr + + headerToShelleyView hdr = + ShelleyHeaderView + { shvHash = ShelleyHash $ PraosCodec.headerHash hdr + , shvSize = PraosCodec.headerSize hdr + , shvBlockNo = PraosCodec.hbBlockNo body + , shvBodyHash = PraosCodec.hbBodyHash body + , shvBodySize = PraosCodec.hbBodySize body + , shvProtVer = PraosCodec.hbProtVer body + , shvLeiosContainsCert = False + , shvLeiosEbAnnouncement = SNothing + } + where + body = PraosCodec.headerBody hdr + +instance HasPraosExtensionHeader PextLeios where + headerToView hdr = + HeaderView + { hvPrevHash = LeiosCodec.hbPrev body + , hvVK = LeiosCodec.hbVk body + , hvVrfVK = LeiosCodec.hbVrfVk body + , hvVrfRes = LeiosCodec.hbVrfRes body + , hvOCert = LeiosCodec.hbOCert body + , hvSlotNo = LeiosCodec.hbSlotNo body + , hvLeios = + SJustLeios + ( LeiosCodec.hbBlockBodyContainsLeiosCert body + , fromCodecEbAnnouncement <$> LeiosCodec.hbEbAnnouncement body + ) + , hvSigned = body + , hvSignature = LeiosCodec.headerSig hdr + } + where + body = LeiosCodec.headerBody hdr + + headerToShelleyView hdr = + ShelleyHeaderView + { shvHash = ShelleyHash $ LeiosCodec.headerHash hdr + , shvSize = LeiosCodec.headerSize hdr + , shvBlockNo = LeiosCodec.hbBlockNo body + , shvBodyHash = LeiosCodec.hbBodyHash body + , shvBodySize = LeiosCodec.hbBodySize body + , shvProtVer = LeiosCodec.hbProtVer body + , shvLeiosContainsCert = LeiosCodec.hbBlockBodyContainsLeiosCert body + , shvLeiosEbAnnouncement = + fromCodecEbAnnouncement <$> LeiosCodec.hbEbAnnouncement body + } + where + body = LeiosCodec.headerBody hdr + +{------------------------------------------------------------------------------- + Instances +-------------------------------------------------------------------------------} + +type instance ProtoCrypto (BasePraos pext c) = c + +type instance ShelleyProtocolHeader (BasePraos PextNone c) = PraosCodec.Header c -type instance ShelleyProtocolHeader (Praos c) = Header c +type instance ShelleyProtocolHeader (BasePraos PextLeios c) = LeiosCodec.Header c -instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (Praos c) where - pHeaderHash hdr = ShelleyHash $ headerHash hdr - pHeaderPrevHash (Header body _) = hbPrev body - pHeaderBodyHash (Header body _) = hbBodyHash body - pHeaderSlot (Header body _) = hbSlotNo body - pHeaderBlock (Header body _) = hbBlockNo body - pHeaderSize hdr = fromIntegral $ headerSize hdr - pHeaderBlockSize (Header body _) = fromIntegral $ hbBodySize body - pHeaderLeiosContainsCert (Header body _) = hbLeiosContainsCert body +instance + ( PraosCrypto c + , HasPraosExtensionHeader pext + ) => + ProtocolHeaderSupportsEnvelope (BasePraos pext c) + where + pHeaderHash = shvHash . headerToShelleyView @pext + pHeaderPrevHash = hvPrevHash . headerToView @pext + pHeaderBodyHash = shvBodyHash . headerToShelleyView @pext + pHeaderSlot = hvSlotNo . headerToView @pext + pHeaderBlock = shvBlockNo . headerToShelleyView @pext + pHeaderSize = fromIntegral . shvSize . headerToShelleyView @pext + pHeaderBlockSize = fromIntegral . shvBodySize . headerToShelleyView @pext + pHeaderLeiosContainsCert = shvLeiosContainsCert . headerToShelleyView @pext + pHeaderLeiosEbAnnouncement = shvLeiosEbAnnouncement . headerToShelleyView @pext type EnvelopeCheckError _ = EnvelopeError @@ -64,11 +199,11 @@ instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (Praos c) where envelopeCheck maxpv ccd $ EnvelopeHeaderView { ehvProtVer = m - , ehvHeaderSize = headerSize hdr - , ehvBodySize = hbBodySize body + , ehvHeaderSize = shvSize shv + , ehvBodySize = shvBodySize shv } where - Header body _ = hdr + shv = headerToShelleyView @pext hdr MaxMajorProtVer maxpv = praosMaxMajorPV (praosParams cfg) ProtVer m _ = plvProtocolVersion lv ccd = @@ -78,81 +213,134 @@ instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (Praos c) where , ccProtocolVersion = plvProtocolVersion lv } -instance PraosCrypto c => ProtocolHeaderSupportsKES (Praos c) where +instance + ( PraosCrypto c + , KnownPraosExtension pext + , HasPraosExtensionHeader pext + ) => + ProtocolHeaderSupportsKES (BasePraos pext c) + where + type ProtoHasLeios (BasePraos pext c) = PraosExtensionHasLeios pext + configSlotsPerKESPeriod cfg = praosSlotsPerKESPeriod $ praosParams cfg - verifyHeaderIntegrity slotsPerKESPeriod header = - isRight $ KES.verifySignedKES () ocertVkHot t headerBody headerSig + + verifyHeaderIntegrity slotsPerKESPeriod hdr = + withSignableDict $ + isRight $ + KES.verifySignedKES () ocertVkHot t (hvSigned hv) (hvSignature hv) where - Header{headerBody, headerSig} = header + hv = headerToView @pext hdr + + -- Each branch refines @pext@, so the body type reduces to one 'PraosCrypto' + -- covers; it cannot be discharged for an abstract @pext@. + withSignableDict :: (KES.Signable (KES c) (BaseHeaderBody pext c) => r) -> r + withSignableDict k = case singPraosExtension (Proxy @pext) of + SingPextNone -> k + SingPextLeios -> k + SL.OCert { ocertVkHot , ocertKESPeriod = SL.KESPeriod startOfKesPeriod - } = hbOCert headerBody + } = hvOCert hv currentKesPeriod = fromIntegral $ - unSlotNo (hbSlotNo headerBody) `div` slotsPerKESPeriod + unSlotNo (hvSlotNo hv) `div` slotsPerKESPeriod t | currentKesPeriod >= startOfKesPeriod = currentKesPeriod - startOfKesPeriod | otherwise = 0 - mkHeader hk cbl il slotNo blockNo prevHash bbHash sz protVer mLeiosExt = do - PraosFields{praosSignature, praosToSign} <- forgePraosFields hk cbl il mkBhBodyBytes - pure $ Header praosToSign praosSignature + + mkHeader hk cbl il slotNo blockNo prevHash bbHash sz protVer leios = + -- Each branch refines @pext@, so the body type is concrete: both the KES + -- 'Signable' dictionary and the header constructor are then available. + case singPraosExtension (Proxy @pext) of + SingPextNone -> do + PraosFields{praosSignature, praosToSign} <- forgePraosFields hk cbl il praosBody + -- The annotations here and below are load-bearing: 'PraosCodec.Header' + -- and 'LeiosCodec.Header' are pattern synonyms carrying a @Crypto + -- crypto@ constraint, so without one GHC has to solve that @crypto@ + -- inside two implications --- the synonym's and this branch's @pext@ + -- refinement --- where it is untouchable. 9.12 copes; 9.6 and 9.10 do + -- not. + pure (PraosCodec.Header praosToSign praosSignature :: PraosCodec.Header c) + SingPextLeios -> case leios of + SJustLeios (containsCert, mbAnn) -> do + PraosFields{praosSignature, praosToSign} <- + forgePraosFields hk cbl il $ \ts -> + extendHeaderBodyWithLeios + (praosBody ts) + containsCert + (toCodecEbAnnouncement <$> mbAnn) + pure (LeiosCodec.Header praosToSign praosSignature :: LeiosCodec.Header c) where - mkBhBodyBytes + -- The signature is load-bearing. Without it 'MonoLocalBinds' still gives + -- this a @crypto@ metavariable, but one born out here, which each branch + -- below then has to solve inside its @pext@ refinement, where it is + -- untouchable. 9.12 copes; 9.6 and 9.10 do not. The annotations on the two + -- header constructions are for the same reason: both 'Header's are pattern + -- synonyms carrying a @Crypto crypto@ constraint. + praosBody :: PraosToSign c -> PraosCodec.HeaderBody c + praosBody PraosToSign { praosToSignIssuerVK , praosToSignVrfVK , praosToSignVrfRes , praosToSignOCert } = - HeaderBody - { hbBlockNo = blockNo - , hbSlotNo = slotNo - , hbPrev = prevHash - , hbVk = praosToSignIssuerVK - , hbVrfVk = praosToSignVrfVK - , hbVrfRes = praosToSignVrfRes - , hbBodySize = fromIntegral sz - , hbBodyHash = bbHash - , hbOCert = praosToSignOCert - , hbProtVer = protVer - , hbLeiosExt = mLeiosExt + PraosCodec.HeaderBody + { PraosCodec.hbBlockNo = blockNo + , PraosCodec.hbSlotNo = slotNo + , PraosCodec.hbPrev = prevHash + , PraosCodec.hbVk = praosToSignIssuerVK + , PraosCodec.hbVrfVk = praosToSignVrfVK + , PraosCodec.hbVrfRes = praosToSignVrfRes + , PraosCodec.hbBodySize = fromIntegral sz + , PraosCodec.hbBodyHash = bbHash + , PraosCodec.hbOCert = praosToSignOCert + , PraosCodec.hbProtVer = protVer } protocolStateLeiosInfo _ cs = case praosStateLeiosAnnouncement cs of - SNothing -> Nothing - SJust ann -> Just (ann, praosStateLastSlot cs) + SNothingLeios -> Nothing + SJustLeios SNothing -> Nothing + SJustLeios (SJust ann) -> Just (ann, praosStateLastSlot cs) -instance PraosCrypto c => ProtocolHeaderSupportsProtocol (Praos c) where - type CannotForgeError (Praos c) = PraosCannotForge c - protocolHeaderView Header{headerBody, headerSig} = - HeaderView - { hvPrevHash = hbPrev headerBody - , hvVK = hbVk headerBody - , hvVrfVK = hbVrfVk headerBody - , hvVrfRes = hbVrfRes headerBody - , hvOCert = hbOCert headerBody - , hvSlotNo = hbSlotNo headerBody - , hvSigned = headerBody - , hvSignature = headerSig - } - pHeaderIssuer = hbVk . headerBody - pHeaderIssueNo = SL.ocertN . hbOCert . headerBody +instance + ( PraosCrypto c + , HasPraosExtensionHeader pext + ) => + ProtocolHeaderSupportsProtocol (BasePraos pext c) + where + type CannotForgeError (BasePraos pext c) = PraosCannotForge c + + protocolHeaderView = headerToView @pext + pHeaderIssuer = hvVK . headerToView @pext + pHeaderIssueNo = SL.ocertN . hvOCert . headerToView @pext -- This is the "unified" VRF value, prior to range extension which yields e.g. -- the leader VRF value used for slot election. -- -- In the future, we might want to use a dedicated range-extended VRF value -- here instead. - pTieBreakVRFValue = certifiedOutput . hbVrfRes . headerBody + pTieBreakVRFValue = certifiedOutput . hvVrfRes . headerToView @pext + +type instance Signed (PraosCodec.Header c) = PraosCodec.HeaderBody c + +instance PraosCrypto c => SignedHeader (PraosCodec.Header c) where + headerSigned = PraosCodec.headerBody + +type instance Signed (LeiosCodec.Header c) = LeiosCodec.HeaderBody c + +instance PraosCrypto c => SignedHeader (LeiosCodec.Header c) where + headerSigned = LeiosCodec.headerBody -type instance Signed (Header c) = HeaderBody c -instance PraosCrypto c => SignedHeader (Header c) where - headerSigned = headerBody +-- Concrete per extension, rather than one instance over @pext@: the +-- superclasses need 'Typeable' and 'SignedHeader' of the header type, which +-- only reduce once the extension is known. +instance PraosCrypto c => ShelleyProtocol (BasePraos PextNone c) -instance PraosCrypto c => ShelleyProtocol (Praos c) +instance PraosCrypto c => ShelleyProtocol (BasePraos PextLeios c) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs index 1e6a5342bf..009bd0b0a9 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -18,6 +19,7 @@ import Cardano.Slotting.Slot (unSlotNo) import Data.Either (isRight) import Data.Word (Word32) import Numeric.Natural (Natural) +import Ouroboros.Consensus.Protocol.Praos.Common (WhetherHasLeios (..)) import Ouroboros.Consensus.Protocol.Signed ( Signed , SignedHeader (headerSigned) @@ -42,6 +44,7 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract , ShelleyProtocol , ShelleyProtocolHeader , default_pHeaderLeiosContainsCert + , default_pHeaderLeiosEbAnnouncement ) import Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks ( EnvelopeError @@ -62,6 +65,7 @@ instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (TPraos c) where pHeaderSize = fromIntegral . originalBytesSize pHeaderBlockSize = fromIntegral @Word32 @Natural . SL.bsize . SL.bhbody pHeaderLeiosContainsCert = default_pHeaderLeiosContainsCert + pHeaderLeiosEbAnnouncement = default_pHeaderLeiosEbAnnouncement type EnvelopeCheckError _ = EnvelopeError @@ -79,6 +83,8 @@ instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (TPraos c) where MaxMajorProtVer maxPV = tpraosMaxMajorPV (tpraosParams cfg) instance PraosCrypto c => ProtocolHeaderSupportsKES (TPraos c) where + type ProtoHasLeios (TPraos c) = PextDoesNotHaveLeios + configSlotsPerKESPeriod cfg = tpraosSlotsPerKESPeriod $ tpraosParams cfg verifyHeaderIntegrity slotsPerKESPeriod hdr = isRight $ SL.verifySignedKES () ocertVkHot t hdrBody hdrSignature diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs index 958d0a0386..3778b00b55 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -88,6 +88,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Praos +import Ouroboros.Consensus.Protocol.Praos.Common (KnownPraosExtension) import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger @@ -271,8 +272,13 @@ instance { singleEraName = T.pack (L.eraName @era) } -instance Ouroboros.Consensus.Protocol.Praos.PraosCrypto c => HasPartialConsensusConfig (Praos c) where - type PartialConsensusConfig (Praos c) = PraosParams +instance + ( Ouroboros.Consensus.Protocol.Praos.PraosCrypto c + , KnownPraosExtension pext + ) => + HasPartialConsensusConfig (BasePraos pext c) + where + type PartialConsensusConfig (BasePraos pext c) = PraosParams completeConsensusConfig _ praosEpochInfo praosParams = PraosConfig{..} diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs index 54a6a3fb30..b2d4ad8b8d 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs @@ -28,6 +28,8 @@ import Cardano.Ledger.Core import qualified Cardano.Ledger.Core as LC import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Protocol.Crypto (StandardCrypto) +import qualified Cardano.Protocol.Leios.BlockHeader as Leios +import qualified Cardano.Protocol.Praos.BlockHeader as Praos import qualified Cardano.Protocol.TPraos.BlockHeader as SL import Cardano.Slotting.EpochInfo (fixedEpochInfo) import Cardano.Slotting.Time (mkSlotLength) @@ -35,10 +37,8 @@ import Data.Coerce (coerce) import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.Map as Map -import Data.Maybe (isJust) import Data.Maybe.Strict (StrictMaybe (..)) import qualified Data.Set as Set -import Data.Typeable (eqT) import LeiosDemoTypes (EbAnnouncement (..), LeiosEb (..), hashLeiosEb) import Lens.Micro import Ouroboros.Consensus.Block @@ -49,21 +49,17 @@ import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.Tables hiding (TxIn) import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Protocol.Abstract (translateChainDepState) -import Ouroboros.Consensus.Protocol.Praos (Praos) +import Ouroboros.Consensus.Protocol.Praos (BasePraos, Praos, PraosWithLeios) import Ouroboros.Consensus.Protocol.Praos.Common -import Ouroboros.Consensus.Protocol.Praos.Header - ( HeaderBody (HeaderBody) - , HeaderLeiosExtension (..) - ) -import qualified Ouroboros.Consensus.Protocol.Praos.Header as Praos +import Ouroboros.Consensus.Protocol.Praos.Views (extendHeaderBodyWithLeios) import Ouroboros.Consensus.Protocol.TPraos ( TPraos , TPraosState (TPraosState) ) -import Ouroboros.Consensus.Shelley.Eras (DijkstraEra) import Ouroboros.Consensus.Shelley.HFEras import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Ledger.Query.Types +import Ouroboros.Consensus.Shelley.Protocol.Abstract (ShelleyProtocolHeader) import Ouroboros.Consensus.Shelley.Protocol.TPraos () import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.Time (secondsToNominalDiffTime) @@ -82,6 +78,7 @@ import Test.Cardano.Protocol.TPraos.Examples , ledgerExamplesShelley , ledgerExamplesTPraos ) +import Test.Consensus.Shelley.Generators (praosHeaderBodyFromTPraos) import Test.Util.Orphans.Arbitrary () import Test.Util.Serialisation.Examples ( Examples (..) @@ -240,12 +237,17 @@ fromShelleyLedgerExamples ledgerConfig = exampleShelleyLedgerConfig leTranslationContext -- | TODO Factor this out into something nicer. -fromShelleyLedgerExamplesPraos :: - forall era. - ShelleyCompatible (Praos StandardCrypto) era => +fromShelleyLedgerExamplesBasePraos :: + forall pext era. + ( ShelleyCompatible (BasePraos pext StandardCrypto) era + , KnownPraosExtension pext + ) => + -- | Rebuild the example's TPraos header as this extension's header + (SL.BHeader StandardCrypto -> ShelleyProtocolHeader (BasePraos pext StandardCrypto)) -> ProtocolLedgerExamples (SL.BHeader StandardCrypto) era -> - Examples (ShelleyBlock (Praos StandardCrypto) era) -fromShelleyLedgerExamplesPraos + Examples (ShelleyBlock (BasePraos pext StandardCrypto) era) +fromShelleyLedgerExamplesBasePraos + translateHeader ProtocolLedgerExamples { pleLedgerExamples = Shelley.LedgerExamples{..} , .. @@ -275,39 +277,6 @@ fromShelleyLedgerExamplesPraos let SL.Block hdr1 bdy = pleBlock in SL.Block (translateHeader hdr1) bdy - translateHeader :: SL.BHeader StandardCrypto -> Praos.Header StandardCrypto - translateHeader (SL.BHeader bhBody bhSig) = - Praos.Header hBody hSig - where - hBody = - HeaderBody - { hbBlockNo = SL.bheaderBlockNo bhBody - , hbSlotNo = SL.bheaderSlotNo bhBody - , hbPrev = SL.bheaderPrev bhBody - , hbVk = SL.bheaderVk bhBody - , hbVrfVk = SL.bheaderVrfVk bhBody - , hbVrfRes = coerce $ SL.bheaderEta bhBody - , hbBodySize = SL.bsize bhBody - , hbBodyHash = SL.bhash bhBody - , hbOCert = SL.bheaderOCert bhBody - , hbProtVer = SL.bprotver bhBody - , hbLeiosExt = if isLeiosEra then SJust leiosExt else SNothing - } - hSig = coerce bhSig - - isLeiosEra = isJust $ eqT @era @DijkstraEra - - leiosExt = - HeaderLeiosExtension - { containsCert = True - , ebAnnouncement = - SJust - EbAnnouncement - { ebAnnouncementHash = hashLeiosEb $ MkLeiosEb mempty - , ebAnnouncementSize = 123 - } - } - hash = ShelleyHash $ SL.unHashHeader pleHashHeader serialisedBlock = Serialised "" tx = mkShelleyTx leTx @@ -385,8 +354,9 @@ fromShelleyLedgerExamplesPraos , shelleyCumulativeTxBytes = 0 } chainDepState = - translateChainDepState (Proxy @(TPraos StandardCrypto, Praos StandardCrypto)) $ - TPraosState (NotOrigin 1) pleChainDepState + translateChainDepState + (Proxy @(TPraos StandardCrypto, BasePraos pext StandardCrypto)) + $ TPraosState (NotOrigin 1) pleChainDepState extLedgerState = ExtLedgerState ledgerState @@ -394,6 +364,42 @@ fromShelleyLedgerExamplesPraos ledgerConfig = exampleShelleyLedgerConfig leTranslationContext +fromShelleyLedgerExamplesPraos :: + ShelleyCompatible (Praos StandardCrypto) era => + ProtocolLedgerExamples (SL.BHeader StandardCrypto) era -> + Examples (ShelleyBlock (Praos StandardCrypto) era) +fromShelleyLedgerExamplesPraos = fromShelleyLedgerExamplesBasePraos translatePraosHeader + +fromShelleyLedgerExamplesPraosWithLeios :: + ShelleyCompatible (PraosWithLeios StandardCrypto) era => + ProtocolLedgerExamples (SL.BHeader StandardCrypto) era -> + Examples (ShelleyBlock (PraosWithLeios StandardCrypto) era) +fromShelleyLedgerExamplesPraosWithLeios = + fromShelleyLedgerExamplesBasePraos translateLeiosHeader + +-- | Rebuild a TPraos example header as a Praos one. +translatePraosHeader :: SL.BHeader StandardCrypto -> Praos.Header StandardCrypto +translatePraosHeader (SL.BHeader bhBody bhSig) = + Praos.Header (praosHeaderBodyFromTPraos bhBody) (coerce bhSig) + +-- | As 'translatePraosHeader', with the Leios fields of an example CertRB that +-- announces an endorser block of its own. +translateLeiosHeader :: SL.BHeader StandardCrypto -> Leios.Header StandardCrypto +translateLeiosHeader (SL.BHeader bhBody bhSig) = + Leios.Header hBody (coerce bhSig) + where + hBody = + extendHeaderBodyWithLeios + (praosHeaderBodyFromTPraos bhBody) + True + ( SJust $ + toCodecEbAnnouncement + EbAnnouncement + { ebAnnouncementHash = hashLeiosEb $ MkLeiosEb mempty + , ebAnnouncementSize = 123 + } + ) + examplesShelley :: Examples StandardShelleyBlock examplesShelley = fromShelleyLedgerExamples ledgerExamplesShelley @@ -413,7 +419,8 @@ examplesConway :: Examples StandardConwayBlock examplesConway = fromShelleyLedgerExamplesPraos (ledgerExamplesTPraos Conway.ledgerExamples) examplesDijkstra :: Examples StandardDijkstraBlock -examplesDijkstra = fromShelleyLedgerExamplesPraos (ledgerExamplesTPraos Dijkstra.ledgerExamples) +examplesDijkstra = + fromShelleyLedgerExamplesPraosWithLeios (ledgerExamplesTPraos Dijkstra.ledgerExamples) exampleShelleyLedgerConfig :: TranslationContext era -> ShelleyLedgerConfig era exampleShelleyLedgerConfig translationContext = diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs index 928151f850..51a9363ee3 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs @@ -7,15 +7,22 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Test.Consensus.Shelley.Generators (SomeResult (..)) where +module Test.Consensus.Shelley.Generators + ( SomeResult (..) + , praosHeaderBodyFromTPraos + , translateTPraosHeader + ) where import Cardano.Ledger.Core (TranslationContext) import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Ledger.State (InstantStake) import Cardano.Protocol.Crypto (Crypto) +import qualified Cardano.Protocol.Leios.BlockHeader as Leios +import qualified Cardano.Protocol.Praos.BlockHeader as Praos import qualified Cardano.Protocol.TPraos.BlockHeader as SL import Cardano.Slotting.EpochInfo import Control.Monad (replicateM) @@ -26,13 +33,21 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool -import Ouroboros.Consensus.Protocol.Praos (Praos) +import Ouroboros.Consensus.Protocol.Praos (BasePraos) import qualified Ouroboros.Consensus.Protocol.Praos as Praos -import qualified Ouroboros.Consensus.Protocol.Praos.Header as Praos +import Ouroboros.Consensus.Protocol.Praos.Common + ( KnownPraosExtension (singPraosExtension) + , SingPraosExtension (SingPextLeios, SingPextNone) + ) +import Ouroboros.Consensus.Protocol.Praos.Views (extendHeaderBodyWithLeios) import Ouroboros.Consensus.Protocol.TPraos (TPraos, TPraosState (..)) import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Node.Common () +import Ouroboros.Consensus.Shelley.Protocol.Abstract + ( ShelleyProtocolHeader + , pHeaderHash + ) import Ouroboros.Consensus.Shelley.Protocol.Praos () import Ouroboros.Consensus.Shelley.Protocol.TPraos () import Ouroboros.Network.Block (mkSerialised) @@ -81,8 +96,11 @@ instance mkShelleyBlock <$> genBlock allPoolKeys instance - (Praos.PraosCrypto crypto, CanMock (Praos crypto) era) => - Arbitrary (ShelleyBlock (Praos crypto) era) + ( Praos.PraosCrypto crypto + , CanMock (BasePraos pext crypto) era + , Arbitrary (ShelleyProtocolHeader (BasePraos pext crypto)) + ) => + Arbitrary (ShelleyBlock (BasePraos pext crypto) era) where arbitrary = mkShelleyBlock <$> blk where @@ -100,47 +118,58 @@ instance genIssuerKeys defaultConstants Coherent . mkShelleyBlock <$> genCoherentBlock allPoolKeys +-- | The Praos header body of a TPraos one, which carries the same fields. +praosHeaderBodyFromTPraos :: SL.BHBody c -> Praos.HeaderBody c +praosHeaderBodyFromTPraos bhBody = + Praos.HeaderBody + { Praos.hbBlockNo = SL.bheaderBlockNo bhBody + , Praos.hbSlotNo = SL.bheaderSlotNo bhBody + , Praos.hbPrev = SL.bheaderPrev bhBody + , Praos.hbVk = SL.bheaderVk bhBody + , Praos.hbVrfVk = SL.bheaderVrfVk bhBody + , Praos.hbVrfRes = coerce $ SL.bheaderEta bhBody + , Praos.hbBodySize = SL.bsize bhBody + , Praos.hbBodyHash = SL.bhash bhBody + , Praos.hbOCert = SL.bheaderOCert bhBody + , Praos.hbProtVer = SL.bprotver bhBody + } + +-- | Rebuild a TPraos header as this extension's header. +-- +-- In 'Gen' because an extension may add fields the TPraos header has no +-- counterpart for. Only the generators that borrow upstream's coherent-block +-- generator need this; see the 'Coherent' instance below. +translateTPraosHeader :: + forall pext c. + (KnownPraosExtension pext, Crypto c) => + SL.BHeader c -> + Gen (ShelleyProtocolHeader (BasePraos pext c)) +translateTPraosHeader (SL.BHeader bhBody bhSig) = + case singPraosExtension (Proxy @pext) of + SingPextNone -> pure $ Praos.Header hBody (coerce bhSig) + SingPextLeios -> + flip Leios.Header (coerce bhSig) + <$> (extendHeaderBodyWithLeios hBody <$> arbitrary <*> arbitrary) + where + hBody = praosHeaderBodyFromTPraos bhBody + -- | Create a coherent Praos block -- -- TODO Establish a coherent block without doing this translation from a -- TPraos header. instance - CanMock (Praos crypto) era => - Arbitrary (Coherent (ShelleyBlock (Praos crypto) era)) + ( CanMock (BasePraos pext crypto) era + , KnownPraosExtension pext + ) => + Arbitrary (Coherent (ShelleyBlock (BasePraos pext crypto) era)) where arbitrary = do allPoolKeys <- replicateM (fromIntegral $ numCoreNodes defaultConstants) $ genIssuerKeys defaultConstants - blk <- genCoherentBlock allPoolKeys - Coherent . mkBlk <$> pure blk - where - mkBlk sleBlock = - mkShelleyBlock $ - let - SL.Block hdr1 bdy = sleBlock - in - SL.Block (translateHeader hdr1) bdy - - translateHeader :: Crypto c => SL.BHeader c -> Praos.Header c - translateHeader (SL.BHeader bhBody bhSig) = - Praos.Header hBody hSig - where - hBody = - Praos.HeaderBody - { Praos.hbBlockNo = SL.bheaderBlockNo bhBody - , Praos.hbSlotNo = SL.bheaderSlotNo bhBody - , Praos.hbPrev = SL.bheaderPrev bhBody - , Praos.hbVk = SL.bheaderVk bhBody - , Praos.hbVrfVk = SL.bheaderVrfVk bhBody - , Praos.hbVrfRes = coerce $ SL.bheaderEta bhBody - , Praos.hbBodySize = SL.bsize bhBody - , Praos.hbBodyHash = SL.bhash bhBody - , Praos.hbOCert = SL.bheaderOCert bhBody - , Praos.hbProtVer = SL.bprotver bhBody - , Praos.hbLeiosExt = SNothing - } - hSig = coerce bhSig + SL.Block hdr1 bdy <- genCoherentBlock allPoolKeys + hdr <- translateTPraosHeader hdr1 + pure $ Coherent $ mkShelleyBlock $ SL.Block hdr bdy instance CanMock (TPraos crypto) era => @@ -149,12 +178,14 @@ instance arbitrary = getHeader <$> arbitrary instance - CanMock (Praos crypto) era => - Arbitrary (Header (ShelleyBlock (Praos crypto) era)) + ( CanMock (BasePraos pext crypto) era + , Arbitrary (ShelleyProtocolHeader (BasePraos pext crypto)) + ) => + Arbitrary (Header (ShelleyBlock (BasePraos pext crypto) era)) where arbitrary = do hdr <- arbitrary - pure $ ShelleyHeader hdr (ShelleyHash $ Praos.headerHash hdr) + pure $ ShelleyHeader hdr (pHeaderHash hdr) instance Arbitrary ShelleyHash where arbitrary = ShelleyHash <$> arbitrary diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs index 9a4e6d1973..7b73ba2d32 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs @@ -196,7 +196,7 @@ conwayToDijkstraLedgerStateTranslation :: WrapLedgerConfig TranslateLedgerState (ShelleyBlock (Praos Crypto) ConwayEra) - (ShelleyBlock (Praos Crypto) DijkstraEra) + (ShelleyBlock (PraosWithLeios Crypto) DijkstraEra) PCons byronToShelleyLedgerStateTranslation ( PCons @@ -439,7 +439,7 @@ instance Arbitrary ( TestSetup (ShelleyBlock (Praos Crypto) ConwayEra) - (ShelleyBlock (Praos Crypto) DijkstraEra) + (ShelleyBlock (PraosWithLeios Crypto) DijkstraEra) ) where arbitrary = diff --git a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Dijkstra.hs b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Dijkstra.hs index 76779e4d49..c89877be01 100644 --- a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Dijkstra.hs +++ b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Dijkstra.hs @@ -12,14 +12,13 @@ import qualified Cardano.Ledger.Block as SL (pattern Block) import qualified Cardano.Ledger.Core as Core (hashBlockBody, sizeTxF, txSeqBlockBodyL) import Cardano.Ledger.Dijkstra.BlockBody (leiosCertBlockBodyL) import Cardano.Protocol.Crypto (StandardCrypto) -import qualified Data.ByteString as BS -import Lens.Micro ((&), (.~), (^.)) -import Ouroboros.Consensus.Protocol.Praos (Praos) -import Ouroboros.Consensus.Protocol.Praos.Header +import Cardano.Protocol.Leios.BlockHeader ( HeaderBody (..) - , HeaderLeiosExtension (..) , pattern Header ) +import qualified Data.ByteString as BS +import Lens.Micro ((&), (.~), (^.)) +import Ouroboros.Consensus.Protocol.Praos (PraosWithLeios) import Ouroboros.Consensus.Shelley.Eras (DijkstraEra) import Ouroboros.Consensus.Shelley.HFEras () import Ouroboros.Consensus.Shelley.Ledger @@ -61,7 +60,7 @@ tests = -- produce an endorser block no peer accepts. prop_leiosEbItemChargeCoversEncoder :: Property prop_leiosEbItemChargeCoversEncoder = - forAll (arbitrary :: Gen (GenTx (ShelleyBlock (Praos StandardCrypto) DijkstraEra))) $ + forAll (arbitrary :: Gen (GenTx (ShelleyBlock (PraosWithLeios StandardCrypto) DijkstraEra))) $ \(ShelleyTx _txid tx) -> let wireSize = toInteger $ BS.length (serialize' tx) chargedSize = toInteger $ tx ^. Core.sizeTxF @@ -76,9 +75,9 @@ prop_leiosBodyWithCertAndTxsRejected = "blockMatchesHeader should be False when body contains both Cert and Txs" (not (blockMatchesHeader (getHeader blk) blk)) where - genBlockWithTxsAndCert :: Gen (ShelleyBlock (Praos StandardCrypto) DijkstraEra) + genBlockWithTxsAndCert :: Gen (ShelleyBlock (PraosWithLeios StandardCrypto) DijkstraEra) genBlockWithTxsAndCert = do - shelleyHdr <- arbitrary :: Gen (Header (ShelleyBlock (Praos StandardCrypto) DijkstraEra)) + shelleyHdr <- arbitrary :: Gen (Header (ShelleyBlock (PraosWithLeios StandardCrypto) DijkstraEra)) txsBody <- genSmallDijkstraTxsBlockBody @DijkstraEra `suchThat` (\b -> not (null (b ^. Core.txSeqBlockBodyL))) cert <- arbitrary :: Gen LeiosCert @@ -91,7 +90,8 @@ prop_leiosBodyWithCertAndTxsRejected = ( Header hbody { hbBodyHash = Core.hashBlockBody body - , hbLeiosExt = SJust HeaderLeiosExtension{containsCert, ebAnnouncement = SNothing} + , hbBlockBodyContainsLeiosCert = containsCert + , hbEbAnnouncement = SNothing } sig -- invalid ) @@ -108,9 +108,9 @@ prop_leiosCertFlagMismatchRejected = not (blockMatchesHeader (getHeader blk) blk) ) where - genBlockCertHeaderAndTxsBody :: Gen (ShelleyBlock (Praos StandardCrypto) DijkstraEra) + genBlockCertHeaderAndTxsBody :: Gen (ShelleyBlock (PraosWithLeios StandardCrypto) DijkstraEra) genBlockCertHeaderAndTxsBody = do - shelleyHdr <- arbitrary :: Gen (Header (ShelleyBlock (Praos StandardCrypto) DijkstraEra)) + shelleyHdr <- arbitrary :: Gen (Header (ShelleyBlock (PraosWithLeios StandardCrypto) DijkstraEra)) txsBody <- genSmallDijkstraTxsBlockBody @DijkstraEra let Header hbody sig = shelleyHeaderRaw shelleyHdr return $ @@ -119,19 +119,27 @@ prop_leiosCertFlagMismatchRejected = ( Header hbody { hbBodyHash = Core.hashBlockBody txsBody - , hbLeiosExt = SJust HeaderLeiosExtension{containsCert = True, ebAnnouncement = SNothing} + , hbBlockBodyContainsLeiosCert = True + , hbEbAnnouncement = SNothing } sig -- invalid ) txsBody - genBlockTxsHeaderAndCertBody :: Gen (ShelleyBlock (Praos StandardCrypto) DijkstraEra) + genBlockTxsHeaderAndCertBody :: Gen (ShelleyBlock (PraosWithLeios StandardCrypto) DijkstraEra) genBlockTxsHeaderAndCertBody = do - shelleyHdr <- arbitrary :: Gen (Header (ShelleyBlock (Praos StandardCrypto) DijkstraEra)) + shelleyHdr <- arbitrary :: Gen (Header (ShelleyBlock (PraosWithLeios StandardCrypto) DijkstraEra)) certBody <- genSmallDijkstraCertBlockBody @DijkstraEra let Header hbody sig = shelleyHeaderRaw shelleyHdr return $ mkShelleyBlock $ SL.Block - (Header hbody{hbBodyHash = Core.hashBlockBody certBody, hbLeiosExt = SNothing} sig) + ( Header + hbody + { hbBodyHash = Core.hashBlockBody certBody + , hbBlockBodyContainsLeiosCert = False + , hbEbAnnouncement = SNothing + } + sig -- invalid + ) certBody diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index 5592c201e1..b1d08c9654 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -2,32 +2,37 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE ViewPatterns #-} module Ouroboros.Consensus.Protocol.Praos - ( ConsensusConfig (..) - , BasePraos - , Leios + ( BasePraos + , BasePraosState (..) + , BasePraosValidationErr (..) + , ConsensusConfig (..) , Praos - , PraosExtensions (..) + , PraosExtension (..) , PraosCannotForge (..) , PraosCrypto , PraosFields (..) , PraosIsLeader (..) , PraosParams (..) - , PraosState (..) + , PraosState , PraosToSign (..) - , PraosValidationErr (..) + , PraosValidationErr + , PraosWithLeios , Ticked (..) , forgePraosFields , praosCheckCanForge @@ -39,7 +44,7 @@ module Ouroboros.Consensus.Protocol.Praos , doValidateVRFSignature ) where -import Cardano.Binary (FromCBOR (..), ToCBOR (..), enforceSize) +import Cardano.Binary (Decoder, FromCBOR (..), ToCBOR (..), enforceSize) import qualified Cardano.Crypto.DSIGN as DSIGN import qualified Cardano.Crypto.Hash as Hash import qualified Cardano.Crypto.KES as KES @@ -53,6 +58,7 @@ import Cardano.Ledger.BaseTypes import qualified Cardano.Ledger.BaseTypes as SL import qualified Cardano.Ledger.Chain as SL import Cardano.Ledger.Core (fromEraCBOR, toEraCBOR) +import Cardano.Ledger.Dijkstra (DijkstraEra) import Cardano.Ledger.Hashes (HASH) import Cardano.Ledger.Keys ( DSIGN @@ -92,6 +98,14 @@ import Cardano.Slotting.Slot , WithOrigin , unSlotNo ) +import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec +import qualified Cardano.Protocol.Praos.BlockHeader as PraosCodec +import Cardano.Protocol.Praos.VRF + ( InputVRF + , mkInputVRF + , vrfLeaderValue + , vrfNonceValue + ) import qualified Codec.CBOR.Encoding as CBOR import Codec.Serialise (Serialise (decode, encode)) import Control.Exception (throw) @@ -99,9 +113,11 @@ import Control.Monad (unless) import Control.Monad.Except (Except, runExcept, throwError) import Data.Coerce (coerce) import Data.Functor.Identity (runIdentity) +import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (Proxy)) +import Data.Typeable (Typeable) import Data.Word (Word64) import GHC.Generics (Generic) import LeiosDemoTypes (EbAnnouncement, decodeEbAnnouncement, encodeEbAnnouncement) @@ -114,16 +130,6 @@ import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch) import Ouroboros.Consensus.Protocol.Praos.Common -import Ouroboros.Consensus.Protocol.Praos.Header - ( HeaderBody - , hbLeiosEbAnnouncement - ) -import Ouroboros.Consensus.Protocol.Praos.VRF - ( InputVRF - , mkInputVRF - , vrfLeaderValue - , vrfNonceValue - ) import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views import Ouroboros.Consensus.Protocol.TPraos ( ConsensusConfig (TPraosConfig, tpraosEpochInfo, tpraosParams) @@ -137,23 +143,23 @@ import Ouroboros.Consensus.Util.CBOR ) import Ouroboros.Consensus.Util.Versioned ( VersionDecoder (Decode) + , VersionNumber , decodeVersion , encodeVersion ) --- | Which optional extensions to the base Praos protocol are enabled. -data PraosExtensions = NoExtensions | ExtLeios - -data BasePraos (exts :: PraosExtensions) c +type BasePraos :: PraosExtension -> Type -> Type +data BasePraos pext c -type Praos = BasePraos NoExtensions +type Praos = BasePraos PextNone -type Leios = BasePraos ExtLeios +type PraosWithLeios = BasePraos PextLeios class ( Crypto c , DSIGN.Signable DSIGN (OCertSignable c) - , KES.Signable (KES c) (HeaderBody c) + , KES.Signable (KES c) (LeiosCodec.HeaderBody c) + , KES.Signable (KES c) (PraosCodec.HeaderBody c) , VRF.Signable (VRF c) InputVRF ) => PraosCrypto c @@ -270,7 +276,7 @@ newtype PraosIsLeader c = PraosIsLeader instance PraosCrypto c => NoThunks (PraosIsLeader c) -- | Static configuration -data instance ConsensusConfig (Praos c) = PraosConfig +data instance ConsensusConfig (BasePraos ext c) = PraosConfig { praosParams :: !PraosParams , praosEpochInfo :: !(EpochInfo (Except History.PastHorizonException)) -- it's useful for this record to be EpochInfo and one other thing, @@ -279,11 +285,9 @@ data instance ConsensusConfig (Praos c) = PraosConfig } deriving Generic -instance PraosCrypto c => NoThunks (ConsensusConfig (Praos c)) - -type PraosValidateView c = Views.HeaderView c +instance PraosCrypto c => NoThunks (ConsensusConfig (BasePraos ext c)) -instance HasMaxMajorProtVer (Praos c) where +instance HasMaxMajorProtVer (BasePraos c ext) where protoMaxMajorPV = praosMaxMajorPV . praosParams {------------------------------------------------------------------------------- @@ -295,7 +299,7 @@ instance HasMaxMajorProtVer (Praos c) where -- We track the last slot and the counters for operational certificates, as well -- as a series of nonces which get updated in different ways over the course of -- an epoch. -data PraosState = PraosState +data BasePraosState pext = PraosState { praosStateLastSlot :: !(WithOrigin SlotNo) , praosStateOCertCounters :: !(Map (KeyHash SL.BlockIssuer) Word64) -- ^ Operation Certificate counters @@ -312,7 +316,7 @@ data PraosState = PraosState , praosStateLastEpochBlockNonce :: !Nonce -- ^ Nonce corresponding to the LAB nonce of the last block of the previous -- epoch - , praosStateLeiosAnnouncement :: !(StrictMaybe EbAnnouncement) + , praosStateLeiosAnnouncement :: !(StrictMaybeLeios (PraosExtensionHasLeios pext) (StrictMaybe EbAnnouncement)) -- ^ The Leios 'EbAnnouncement' from the most recently applied header on -- this chain — overwritten on every header tick (so a header with no -- announcement clears the field). The 'ResolveLeiosBlock' instance for @@ -322,15 +326,40 @@ data PraosState = PraosState } deriving (Generic, Show, Eq) -instance NoThunks PraosState +type PraosState = BasePraosState PextNone -instance ToCBOR PraosState where +instance KnownPraosExtension pext => NoThunks (BasePraosState pext) + +instance KnownPraosExtension pext => ToCBOR (BasePraosState pext) where toCBOR = encode -instance FromCBOR PraosState where +instance KnownPraosExtension pext => FromCBOR (BasePraosState pext) where fromCBOR = decode -instance Serialise PraosState where +countOfFieldsInPraosState :: forall pext proxy a. (KnownPraosExtension pext, Num a) => proxy pext -> a +countOfFieldsInPraosState _ = + praos + leios + where + praos = 8 + leios = case praosExtensionHasLeios (Proxy @pext) of + PextDoesNotHaveLeiosDecided -> 0 + PextHasLeiosDecided -> 1 + +-- | @pext@ selects the codec, so each extension's version numbers are their own +-- namespace: these two are unrelated formats that merely both start counting. +-- +-- 'PextNone' is mainnet's, and so keeps the version mainnet writes. 'PextLeios' +-- starts at 1, which is what the code before 'BasePraos' wrote for Dijkstra -- +-- back when Dijkstra was paired with 'Praos' -- with the same fields in the +-- same order. A node already running the Leios prototype can therefore still +-- decode the chain-dep state in the snapshots it has on disk. +versionOfPraosState :: + forall pext proxy. KnownPraosExtension pext => proxy pext -> VersionNumber +versionOfPraosState _ = case praosExtensionHasLeios (Proxy @pext) of + PextDoesNotHaveLeiosDecided -> 0 + PextHasLeiosDecided -> 1 + +instance KnownPraosExtension pext => Serialise (BasePraosState pext) where encode PraosState { praosStateLastSlot @@ -343,9 +372,9 @@ instance Serialise PraosState where , praosStateLastEpochBlockNonce , praosStateLeiosAnnouncement } = - encodeVersion 1 $ + encodeVersion (versionOfPraosState (Proxy @pext)) $ mconcat - [ CBOR.encodeListLen 9 + [ CBOR.encodeListLen (countOfFieldsInPraosState (Proxy @pext)) , toCBOR praosStateLastSlot , toCBOR praosStateOCertCounters , toEraCBOR @ShelleyEra praosStateEvolvingNonce @@ -354,29 +383,17 @@ instance Serialise PraosState where , toEraCBOR @ShelleyEra praosStatePreviousEpochNonce , toEraCBOR @ShelleyEra praosStateLabNonce , toEraCBOR @ShelleyEra praosStateLastEpochBlockNonce - , encodeNullStrictMaybe encodeEbAnnouncement praosStateLeiosAnnouncement + , foldMap (encodeNullStrictMaybe encodeEbAnnouncement) praosStateLeiosAnnouncement ] decode = decodeVersion - [ (0, Decode decodePraosStateV0) - , (1, Decode decodePraosStateV1) + [ (versionOfPraosState (Proxy @pext), Decode decodePraosState) ] where - decodePraosStateV0 = do - enforceSize "PraosState" 8 - PraosState - <$> fromCBOR - <*> fromCBOR - <*> fromEraCBOR @ShelleyEra - <*> fromEraCBOR @ShelleyEra - <*> fromEraCBOR @ShelleyEra - <*> fromEraCBOR @ShelleyEra - <*> fromEraCBOR @ShelleyEra - <*> fromEraCBOR @ShelleyEra - <*> pure SNothing - decodePraosStateV1 = do - enforceSize "PraosState" 9 + decodePraosState :: forall s. Decoder s (BasePraosState pext) + decodePraosState = do + enforceSize "PraosState" (countOfFieldsInPraosState (Proxy @pext)) PraosState <$> fromCBOR <*> fromCBOR @@ -386,15 +403,22 @@ instance Serialise PraosState where <*> fromEraCBOR @ShelleyEra <*> fromEraCBOR @ShelleyEra <*> fromEraCBOR @ShelleyEra - <*> decodeNullStrictMaybe decodeEbAnnouncement - -data instance Ticked PraosState = TickedPraosState - { tickedPraosStateChainDepState :: PraosState - , tickedPraosStateLedgerView :: Views.PraosLedgerView + <*> traverse + (\() -> decodeNullStrictMaybe decodeEbAnnouncement) + (case praosExtensionHasLeios (Proxy @pext) of + PextDoesNotHaveLeiosDecided -> SNothingLeios + PextHasLeiosDecided -> SJustLeios () + ) + +data instance Ticked (BasePraosState pext) = TickedPraosState + { tickedPraosStateChainDepState :: BasePraosState pext + , tickedPraosStateLedgerView :: Views.BasePraosLedgerView pext } +----- + -- | Errors which we might encounter -data PraosValidationErr c +data BasePraosValidationErr pext c = VRFKeyUnknown !(KeyHash SL.StakePool) -- unknown VRF keyhash (not registered) | VRFKeyWrongVRFKey @@ -432,26 +456,29 @@ data PraosValidationErr c !String -- error message given by Consensus Layer | NoCounterForKeyHashOCERT !(KeyHash SL.BlockIssuer) -- stake pool key hash + | TodoLeios !(HasLeiosProof pext) String -- TODO Leios validation-error constructors belongs here, for the header -- checks described in 'updateChainDepState'. Deferred for now: -- 'PraosValidationErr' is used downstream (e.g. cardano-node tracers), so -- extending it would incur downstream integration work deriving Generic -deriving instance PraosCrypto c => Eq (PraosValidationErr c) +type PraosValidationErr c = BasePraosValidationErr PextNone c + +deriving instance (PraosCrypto c, Typeable pext) => Eq (BasePraosValidationErr pext c) -deriving instance PraosCrypto c => NoThunks (PraosValidationErr c) +deriving instance (PraosCrypto c, Typeable pext) => NoThunks (BasePraosValidationErr pext c) -deriving instance PraosCrypto c => Show (PraosValidationErr c) +deriving instance (PraosCrypto c, Typeable pext) => Show (BasePraosValidationErr pext c) -instance PraosCrypto c => ConsensusProtocol (Praos c) where - type ChainDepState (Praos c) = PraosState - type IsLeader (Praos c) = PraosIsLeader c - type CanBeLeader (Praos c) = PraosCanBeLeader c - type TiebreakerView (Praos c) = PraosTiebreakerView c - type LedgerView (Praos c) = Views.PraosLedgerView - type ValidationErr (Praos c) = PraosValidationErr c - type ValidateView (Praos c) = PraosValidateView c +instance (PraosCrypto c, KnownPraosExtension pext) => ConsensusProtocol (BasePraos pext c) where + type ChainDepState (BasePraos pext c) = BasePraosState pext + type IsLeader (BasePraos pext c) = PraosIsLeader c + type CanBeLeader (BasePraos pext c) = PraosCanBeLeader c + type TiebreakerView (BasePraos pext c) = PraosTiebreakerView c + type LedgerView (BasePraos pext c) = Views.BasePraosLedgerView pext + type ValidationErr (BasePraos pext c) = PraosValidationErr c + type ValidateView (BasePraos pext c) = Views.BaseHeaderView pext c protocolSecurityParam = praosSecurityParam . praosParams @@ -541,10 +568,14 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where -- chain-dep state has no announcement, so the first header can't set -- its cert bit) -- * LeiosCertTooYoung - check the slot gap against L - -- * LeiosEbTooBig - the maximum EB body size - -- * LeiosEbTxsTooBig - the maximum EB closure size - -- * LeiosEbCertExclusivity - the set cert bit requires the no txs + -- * LeiosEbTooBig - the maximum EB body size. NB the closure size + -- cannot be checked here: the announcement carries only the one + -- size, and it is the body size -- * etc + -- + -- NB cert/txs exclusivity is not among these: it is a property of the + -- body, and 'blockMatchesHeader' already enforces it where the body is + -- in hand. -- First, we check the KES signature, which validates that the issuer is -- in fact who they say they are. @@ -583,7 +614,10 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where else praosStateCandidateNonce cs , praosStateOCertCounters = Map.insert hk n $ praosStateOCertCounters cs - , praosStateLeiosAnnouncement = hbLeiosEbAnnouncement (Views.hvSigned b) + , praosStateLeiosAnnouncement = + case singPraosExtension (Proxy @pext) of + SingPextNone -> SNothingLeios + SingPextLeios -> SJustLeios $ fromCodecEbAnnouncement <$> LeiosCodec.hbEbAnnouncement (Views.hvSigned b) } where epochInfoWithErr = @@ -602,9 +636,9 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where -- | Check whether this node meets the leader threshold to issue a block. meetsLeaderThreshold :: - forall c. - ConsensusConfig (Praos c) -> - LedgerView (Praos c) -> + forall pext c. + ConsensusConfig (BasePraos pext c) -> + LedgerView (BasePraos pext c) -> SL.KeyHash SL.StakePool -> VRF.CertifiedVRF (VRF c) InputVRF -> Bool @@ -624,12 +658,12 @@ meetsLeaderThreshold Map.lookup keyHash poolDistr validateVRFSignature :: - forall c. + forall pext c. PraosCrypto c => Nonce -> - Views.PraosLedgerView -> + Views.BasePraosLedgerView pext -> ActiveSlotCoeff -> - Views.HeaderView c -> + Views.BaseHeaderView pext c -> Except (PraosValidationErr c) () validateVRFSignature eta0 (Views.plvPoolDistr -> SL.PoolDistr pd _) = doValidateVRFSignature eta0 pd @@ -637,12 +671,12 @@ validateVRFSignature eta0 (Views.plvPoolDistr -> SL.PoolDistr pd _) = -- NOTE: this function is much easier to test than 'validateVRFSignature' because we don't need -- to construct a 'PraosConfig' nor 'LedgerView' to test it. doValidateVRFSignature :: - forall c. + forall pext c. PraosCrypto c => Nonce -> Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> ActiveSlotCoeff -> - Views.HeaderView c -> + Views.BaseHeaderView pext c -> Except (PraosValidationErr c) () doValidateVRFSignature eta0 pd f b = do case Map.lookup hk pd of @@ -669,11 +703,11 @@ doValidateVRFSignature eta0 pd f b = do slot = Views.hvSlotNo b validateKESSignature :: - PraosCrypto c => - ConsensusConfig (Praos c) -> - LedgerView (Praos c) -> + (KnownPraosExtension pext, PraosCrypto c) => + ConsensusConfig (BasePraos pext c) -> + LedgerView (BasePraos pext c) -> Map (KeyHash SL.BlockIssuer) Word64 -> - Views.HeaderView c -> + Views.BaseHeaderView pext c -> Except (PraosValidationErr c) () validateKESSignature _cfg@( PraosConfig @@ -701,25 +735,25 @@ data WhetherToUpperBoundOCERT -- NOTE: This function is much easier to test than 'validateKESSignature' because we don't need to -- construct a 'PraosConfig' nor 'LedgerView' to test it. doValidateKESSignature :: - PraosCrypto c => + (PraosCrypto c, KnownPraosExtension pext) => Word64 -> Word64 -> Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> Map (KeyHash SL.BlockIssuer) Word64 -> - Views.HeaderView c -> + Views.BaseHeaderView pext c -> Except (PraosValidationErr c) () doValidateKESSignature = doValidateKESSignatureWorker UpperBoundOCERT -- | The worker underlying 'doValidateKESSignature', parameterized by whether to -- enforce the OCERT counter's upper bound (see 'WhetherToUpperBoundOCERT'). -doValidateKESSignatureWorker :: - PraosCrypto c => +doValidateKESSignatureWorker :: forall pext c. + (KnownPraosExtension pext, PraosCrypto c) => WhetherToUpperBoundOCERT -> Word64 -> Word64 -> Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> Map (KeyHash SL.BlockIssuer) Word64 -> - Views.HeaderView c -> + Views.BaseHeaderView pext c -> Except (PraosValidationErr c) () doValidateKESSignatureWorker whetherToUpperBound praosMaxKESEvo praosSlotsPerKESPeriod stakeDistribution ocertCounters b = do @@ -732,8 +766,9 @@ doValidateKESSignatureWorker whetherToUpperBound praosMaxKESEvo praosSlotsPerKES DSIGN.verifySignedDSIGN () vkcold (OCert.ocertToSignable oc) tau ?!: InvalidSignatureOCERT n c0 - KES.verifySignedKES () vk_hot t (Views.hvSigned b) (Views.hvSignature b) - ?!: InvalidKesSignatureOCERT kp_ c0_ t praosMaxKESEvo + withSignableDict $ + KES.verifySignedKES () vk_hot t (Views.hvSigned b) (Views.hvSignature b) + ?!: InvalidKesSignatureOCERT kp_ c0_ t praosMaxKESEvo case currentIssueNo of Nothing -> do @@ -762,6 +797,19 @@ doValidateKESSignatureWorker whetherToUpperBound praosMaxKESEvo praosSlotsPerKES | otherwise = Nothing + -- The result type is fixed rather than polymorphic in @r@: inside the + -- implication this constraint introduces, an @r@ would be untouchable, so + -- GHC could not solve it against the caller's type (it manages on 9.12 but + -- not on 9.6 or 9.10). + withSignableDict :: + ( KES.Signable (KES c) (Views.BaseHeaderBody pext c) => + Except (BasePraosValidationErr pext c) () + ) -> + Except (BasePraosValidationErr pext c) () + withSignableDict k = case singPraosExtension (Proxy @pext) of + SingPextNone -> k + SingPextLeios -> k + {------------------------------------------------------------------------------- CannotForge -------------------------------------------------------------------------------} @@ -787,7 +835,7 @@ data PraosCannotForge c deriving instance PraosCrypto c => Show (PraosCannotForge c) praosCheckCanForge :: - ConsensusConfig (Praos c) -> + ConsensusConfig (BasePraos pext c) -> SlotNo -> HotKey.KESInfo -> Either (PraosCannotForge c) () @@ -812,8 +860,11 @@ praosCheckCanForge PraosProtocolSupportsNode -------------------------------------------------------------------------------} -instance PraosCrypto c => PraosProtocolSupportsNode (Praos c) where - type PraosProtocolSupportsNodeCrypto (Praos c) = c +instance + (PraosCrypto c, KnownPraosExtension pext) => + PraosProtocolSupportsNode (BasePraos pext c) + where + type PraosProtocolSupportsNodeCrypto (BasePraos pext c) = c getPraosNonces _prx cdst = PraosNonces @@ -849,13 +900,16 @@ instance PraosCrypto c => PraosProtocolSupportsNode (Praos c) where -- - They share the same ADDRHASH algorithm -- - They share the same DSIGN verification keys -- - They share the same VRF verification keys -instance TranslateProto (TPraos c) (Praos c) where +instance KnownPraosExtension pext => TranslateProto (TPraos c) (BasePraos pext c) where translateLedgerView _ SL.TPraosLedgerView{SL.tplvPoolDistr, SL.tplvChainChecks} = Views.PraosLedgerView { Views.plvPoolDistr = tplvPoolDistr , Views.plvMaxHeaderSize = SL.ccMaxBHSize tplvChainChecks , Views.plvMaxBodySize = SL.ccMaxBBSize tplvChainChecks , Views.plvProtocolVersion = SL.ccProtocolVersion tplvChainChecks + , Views.plvLeios = case praosExtensionHasLeios (Proxy @pext) of + PextDoesNotHaveLeiosDecided -> SNothingLeios + PextHasLeiosDecided -> SJustLeios Views.initialLeiosLedgerView } translateChainDepState _ tpState = @@ -868,7 +922,9 @@ instance TranslateProto (TPraos c) (Praos c) where , praosStatePreviousEpochNonce = epochNonce -- same as current epoch nonce , praosStateLabNonce = csLabNonce , praosStateLastEpochBlockNonce = SL.ticknStatePrevHashNonce csTickn - , praosStateLeiosAnnouncement = SNothing + , praosStateLeiosAnnouncement = case praosExtensionHasLeios (Proxy @pext) of + PextDoesNotHaveLeiosDecided -> SNothingLeios + PextHasLeiosDecided -> SJustLeios SNothing } where SL.ChainDepState{SL.csProtocol, SL.csTickn, SL.csLabNonce} = @@ -892,3 +948,33 @@ infix 1 ?! (Left e1) ?!: f = throwError $ f e1 infix 1 ?!: + +-- | Crossing from the base protocol into the Leios extension. +-- +-- Everything carries over unchanged; only the Leios announcement has to be +-- introduced, and it starts empty, since no header of the extension we are +-- leaving could have carried one. +instance TranslateProto (BasePraos PextNone c) (BasePraos PextLeios c) where + -- The Leios data has to be conjured from a state that has none; see + -- 'Views.initialLeiosLedgerView'. + translateLedgerView _ lv = + Views.PraosLedgerView + { Views.plvPoolDistr = Views.plvPoolDistr lv + , Views.plvMaxHeaderSize = Views.plvMaxHeaderSize lv + , Views.plvMaxBodySize = Views.plvMaxBodySize lv + , Views.plvProtocolVersion = Views.plvProtocolVersion lv + , Views.plvLeios = SJustLeios Views.initialLeiosLedgerView + } + + translateChainDepState _ st = + PraosState + { praosStateLastSlot = praosStateLastSlot st + , praosStateOCertCounters = praosStateOCertCounters st + , praosStateEvolvingNonce = praosStateEvolvingNonce st + , praosStateCandidateNonce = praosStateCandidateNonce st + , praosStateEpochNonce = praosStateEpochNonce st + , praosStatePreviousEpochNonce = praosStatePreviousEpochNonce st + , praosStateLabNonce = praosStateLabNonce st + , praosStateLastEpochBlockNonce = praosStateLastEpochBlockNonce st + , praosStateLeiosAnnouncement = SJustLeios SNothing + } diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs index 6d3de0ef8f..7fdd34c015 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs @@ -6,7 +6,11 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -25,28 +29,53 @@ module Ouroboros.Consensus.Protocol.Praos.Common , PraosNonces (..) , PraosProtocolSupportsNode (..) , instantiatePraosCredentials + + -- * Leios + , PraosExtension (..) + , HasLeiosProof + , WhetherHasLeios (..) + , WhetherHasLeiosDecided (..) + , KnownPraosExtension (..) + , SingPraosExtension (..) + , StrictMaybeLeios (..) + , toHasLeiosProof + , fromCodecEbAnnouncement + , toCodecEbAnnouncement ) where import Cardano.Crypto.DSIGN.BLS12381 (BLS12381MinSigDSIGN) import Cardano.Crypto.DSIGN.Class (SignKeyDSIGN) +import qualified Cardano.Crypto.Hash as Hash import qualified Cardano.Crypto.KES.Class as KES import Cardano.Crypto.VRF import qualified Cardano.Crypto.VRF as VRF import qualified Cardano.KESAgent.KES.Crypto as Agent import Cardano.Ledger.BaseTypes (Nonce) import qualified Cardano.Ledger.BaseTypes as SL -import Cardano.Ledger.Binary (FromCBOR, ToCBOR) +import Cardano.Ledger.Binary (FromCBOR (..), ToCBOR (..)) +import Cardano.Ledger.Hashes + ( extractHash + , unsafeMakeSafeHash + ) import Cardano.Ledger.Keys (DSIGN, KeyHash, KeyRole (BlockIssuer)) import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Protocol.Crypto (Crypto, KES, VRF) +import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec import qualified Cardano.Protocol.TPraos.OCert as OCert import Cardano.Slotting.Slot (SlotNo) +import Control.DeepSeq (NFData (..)) import qualified Control.Tracer as Tracer import Data.Function (on) +import Data.Kind (Constraint, Type) import Data.Map.Strict (Map) import Data.Ord (Down (..)) +import Data.Proxy (Proxy (Proxy)) +import Data.Type.Equality ((:~:) (Refl)) +import Data.Typeable (Typeable, typeRep) import Data.Word (Word64) import GHC.Generics (Generic) +import GHC.Show (showSpace) +import LeiosDemoTypes (EbAnnouncement (..), EbHash (MkEbHash)) import NoThunks.Class import Ouroboros.Consensus.Protocol.Abstract import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey @@ -361,3 +390,142 @@ class ConsensusProtocol p => PraosProtocolSupportsNode p where getPraosNonces :: proxy p -> ChainDepState p -> PraosNonces getOpCertCounters :: proxy p -> ChainDepState p -> Map (KeyHash BlockIssuer) Word64 + +----- + +-- | Which optional extensions to the base Praos protocol are enabled. +-- +-- We define them here, as part of Praos, because we want exactly one single +-- source of truth (this subtree of the module hierarchy) to explicitly +-- determine how the base protocol and whichever of its extensions are enabled +-- simultaneously to interact /as a @ConsensusProtocol@/. +-- +-- We define one constructor per each subset extensions that are known to be +-- simultaneously compatible and worthwhile. (For now it's just Leios, but more +-- extensions are planned, such as Phalanx.) +data PraosExtension = PextNone | PextLeios + +-- | When possible, use 'WhetherHasLeiosDecided' instead +type SingPraosExtension :: PraosExtension -> Type +data SingPraosExtension pext where + SingPextNone :: SingPraosExtension PextNone + SingPextLeios :: SingPraosExtension PextLeios + +-- | A 'Bool' isomorph for better type errors +data WhetherHasLeios = PextHasLeios | PextDoesNotHaveLeios + +data WhetherHasLeiosDecided pext = + (PraosExtensionHasLeios pext ~ PextHasLeios) => PextHasLeiosDecided + | + (PraosExtensionHasLeios pext ~ PextDoesNotHaveLeios) => PextDoesNotHaveLeiosDecided + +type KnownPraosExtension :: PraosExtension -> Constraint +class (Typeable pext, Typeable (PraosExtensionHasLeios pext)) => KnownPraosExtension pext where + type PraosExtensionHasLeios pext :: WhetherHasLeios + praosExtensionHasLeios :: proxy pext -> WhetherHasLeiosDecided pext + -- | When possible, use 'praosExtensionHasLeios' instead, since it's less + -- informative + singPraosExtension :: proxy pext -> SingPraosExtension pext + +instance KnownPraosExtension PextNone where + type PraosExtensionHasLeios _ = PextDoesNotHaveLeios + praosExtensionHasLeios = const PextDoesNotHaveLeiosDecided + singPraosExtension = const SingPextNone + +instance KnownPraosExtension PextLeios where + type PraosExtensionHasLeios _ = PextHasLeios + praosExtensionHasLeios = const PextHasLeiosDecided + singPraosExtension = const SingPextLeios + +----- + +-- | Newtype wrapper to avoid 'NoThunks' orphan +type HasLeiosProof :: PraosExtension -> Type +newtype HasLeiosProof pext = + MkHasLeiosProof (PraosExtensionHasLeios pext :~: PextHasLeios) + deriving (Eq, Show) + +deriving via OnlyCheckWhnf (HasLeiosProof pext) instance Typeable pext => NoThunks (HasLeiosProof pext) + +toHasLeiosProof :: WhetherHasLeiosDecided pext -> Maybe (HasLeiosProof pext) +toHasLeiosProof = \case + PextHasLeiosDecided -> Just $ MkHasLeiosProof Refl + PextDoesNotHaveLeiosDecided -> Nothing + +----- + +type StrictMaybeLeios :: WhetherHasLeios -> Type -> Type +-- | Like 'StrictMaybe', but it's @SJust@ if and only if 'PraosExtensionHasLeios' +data StrictMaybeLeios whether a where + -- | Encoding and decoding this is a complete noop. + SNothingLeios :: StrictMaybeLeios PextDoesNotHaveLeios a + -- | Encoding and decoding this has no extra wrapper. + SJustLeios :: !a -> StrictMaybeLeios PextHasLeios a + +instance Functor (StrictMaybeLeios whether) where + fmap f = \case + SNothingLeios -> SNothingLeios + SJustLeios a -> SJustLeios $ f a + +instance Foldable (StrictMaybeLeios whether) where + foldMap f = \case + SNothingLeios -> mempty + SJustLeios a -> f a + +instance Traversable (StrictMaybeLeios whether) where + traverse f = \case + SNothingLeios -> pure SNothingLeios + SJustLeios a -> SJustLeios <$> f a + +instance Eq a => Eq (StrictMaybeLeios whether a) where + SNothingLeios == SNothingLeios = True + SJustLeios a == SJustLeios b = a == b + +instance Ord a => Ord (StrictMaybeLeios whether a) where + compare SNothingLeios SNothingLeios = EQ + compare (SJustLeios a) (SJustLeios b) = compare a b + +instance Show a => Show (StrictMaybeLeios whether a) where + showsPrec p = \case + SNothingLeios -> showString "SNothingLeios" + SJustLeios a -> showParen (p >= 11) $ showString "SJustLeios" <> showSpace <> shows a + +instance NFData a => NFData (StrictMaybeLeios whether a) where + rnf = \case + SNothingLeios -> () + SJustLeios a -> rnf a + +instance (Typeable whether, NoThunks a) => NoThunks (StrictMaybeLeios whether a) where + showTypeOf _ = unwords + [ "StrictMaybeLeios" + , "(" ++ show (typeRep (Proxy @whether)) ++ ")" + , "(" ++ showTypeOf (Proxy @a) ++ ")" + ] + wNoThunks ctxt = \case + SNothingLeios -> wNoThunks ctxt () + SJustLeios a -> wNoThunks ctxt a + +----- + +-- | The announcement as 'LeiosDemoTypes' spells it. +-- +-- The two records differ only in how they wrap the endorser block's hash: +-- upstream as a 'SafeHash', 'LeiosDemoTypes' as an 'EbHash'. Both hold the same +-- packed bytes. +fromCodecEbAnnouncement :: LeiosCodec.EbAnnouncement -> EbAnnouncement +fromCodecEbAnnouncement ann = + EbAnnouncement + { ebAnnouncementHash = + MkEbHash $ Hash.hashToPackedBytes $ extractHash $ LeiosCodec.ebAnnouncementHash ann + , ebAnnouncementSize = LeiosCodec.ebAnnouncementSize ann + } + +-- | The inverse of 'fromCodecEbAnnouncement'. +toCodecEbAnnouncement :: EbAnnouncement -> LeiosCodec.EbAnnouncement +toCodecEbAnnouncement ann = + LeiosCodec.EbAnnouncement + { LeiosCodec.ebAnnouncementHash = unsafeMakeSafeHash (Hash.hashFromPackedBytes bytes) + , LeiosCodec.ebAnnouncementSize = ebAnnouncementSize ann + } + where + MkEbHash bytes = ebAnnouncementHash ann diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs deleted file mode 100644 index 6edf3181d8..0000000000 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ /dev/null @@ -1,338 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - --- | Block header associated with Praos. --- --- The choice of whether to associate the header with the ledger era or the --- protocol is a little artitrary. Functionally the header contains things which --- are associated with both ledger and protocol, and which are used by both. --- --- We choose to associate the header with the protocol, since it more strongly --- binds in that direction, and to assist with the mental picture that the --- protocol is concerned with the block header, while the ledger is concerned --- with the block body. However, in order to more cleanly illustrate which parts --- of the header are _strictly_ protocol concerns, we also provide a view of the --- header (in 'Ouroboros.Consensus.Protocol.Praos.Views') which extracts just --- the fields needed for the Praos protocol. This also allows us to hide the --- more detailed construction of the header. -module Ouroboros.Consensus.Protocol.Praos.Header - ( Header (Header, headerBody, headerSig) - , HeaderBody (..) - , HeaderLeiosExtension (..) - , hbLeiosContainsCert - , hbLeiosEbAnnouncement - , headerHash - , headerSize - ) where - -import qualified Cardano.Crypto.Hash as Hash -import qualified Cardano.Crypto.KES as KES -import Cardano.Crypto.Util - ( SignableRepresentation (getSignableRepresentation) - ) -import qualified Cardano.Crypto.VRF as VRF -import Cardano.Ledger.BaseTypes (ProtVer (pvMajor), StrictMaybe (..), strictMaybe) -import Cardano.Ledger.Binary - ( Annotator (..) - , DecCBOR (decCBOR) - , EncCBOR (..) - , decodeBool - , decodeFixedSized - , decodeListLen - , decodeNullStrictMaybe - , encodeBool - , encodeFixedSized - , encodeListLen - , encodeNullStrictMaybe - , fromPlainDecoder - , fromPlainEncoding - , serialize' - , unCBORGroup - ) -import Cardano.Ledger.Binary.Coders -import qualified Cardano.Ledger.Binary.Plain as Plain -import Cardano.Ledger.Block (Block (..), EraBlockHeader (..)) -import Cardano.Ledger.Core (Era) -import Cardano.Ledger.Hashes - ( EraIndependentBlockBody - , EraIndependentBlockHeader - , HASH - , HashAnnotated (..) - , SafeToHash - , extractHash - , originalBytesSize - ) -import Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey, hashKey) -import Cardano.Ledger.MemoBytes - ( Mem - , MemoBytes - , MemoHashIndex - , Memoized (..) - , getMemoRawType - , getMemoSafeHash - , mkMemoized - ) -import Cardano.Protocol.Crypto (Crypto, KES, VRF) -import Cardano.Protocol.TPraos.BlockHeader (PrevHash) -import Cardano.Protocol.TPraos.OCert (OCert) -import Cardano.Slotting.Block (BlockNo) -import Cardano.Slotting.Slot (SlotNo) -import Control.Monad ((>=>)) -import Data.Word (Word32) -import GHC.Generics (Generic) -import LeiosDemoTypes (EbAnnouncement, decodeEbAnnouncement, encodeEbAnnouncement) -import Lens.Micro (lens, to) -import NoThunks.Class (NoThunks (..)) -import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF) - --- | The body of the header is the part which gets hashed to form the hash --- chain. -data HeaderBody crypto = HeaderBody - { hbBlockNo :: !BlockNo - -- ^ block number - , hbSlotNo :: !SlotNo - -- ^ block slot - , hbPrev :: !PrevHash - -- ^ Hash of the previous block header - , hbVk :: !(VKey BlockIssuer) - -- ^ verification key of block issuer - , hbVrfVk :: !(VRF.VerKeyVRF (VRF crypto)) - -- ^ VRF verification key for block issuer - , hbVrfRes :: !(VRF.CertifiedVRF (VRF crypto) InputVRF) - -- ^ Certified VRF value - , hbBodySize :: !Word32 - -- ^ Size of the block body - , hbBodyHash :: !(Hash.Hash HASH EraIndependentBlockBody) - -- ^ Hash of block body - , hbOCert :: !(OCert crypto) - -- ^ operational certificate - , hbProtVer :: !ProtVer - -- ^ protocol version - , hbLeiosExt :: !(StrictMaybe HeaderLeiosExtension) - -- ^ Whether the header / protocol is extended with Leios features. - -- TODO: This Maybe can be avoided by doing version-aware encoding/decoding - -- and this would then become an always extended Leios header - } - deriving Generic - -deriving instance Crypto crypto => Show (HeaderBody crypto) - -deriving instance Crypto crypto => Eq (HeaderBody crypto) - -instance - Crypto crypto => - SignableRepresentation (HeaderBody crypto) - where - getSignableRepresentation hb = serialize' (pvMajor (hbProtVer hb)) hb - -instance - Crypto crypto => - NoThunks (HeaderBody crypto) - --- | New header fields for Leios. -data HeaderLeiosExtension = HeaderLeiosExtension - { containsCert :: !Bool - -- ^ Whether this block's body carries a Leios certificate (i.e. it is a - -- "CertRB", certifying the endorser block its predecessor announced). - -- Dijkstra-only ('False' on earlier eras). - , ebAnnouncement :: !(StrictMaybe EbAnnouncement) - -- ^ Leios endorser-block announcement Dijkstra-only ('SNothing' on earlier - -- eras). - } - deriving (Eq, Show, Generic) - -instance NoThunks HeaderLeiosExtension - -hbLeiosContainsCert :: HeaderBody crypto -> Bool -hbLeiosContainsCert = strictMaybe False containsCert . hbLeiosExt - -hbLeiosEbAnnouncement :: HeaderBody crypto -> StrictMaybe EbAnnouncement -hbLeiosEbAnnouncement = hbLeiosExt >=> ebAnnouncement - -data HeaderRaw crypto = HeaderRaw - { headerRawBody :: !(HeaderBody crypto) - , headerRawSig :: !(KES.SignedKES (KES crypto) (HeaderBody crypto)) - } - deriving (Show, Generic) - -instance Crypto c => Eq (HeaderRaw c) where - h1 == h2 = - headerRawSig h1 == headerRawSig h2 - && headerRawBody h1 == headerRawBody h2 - -instance - Crypto crypto => - NoThunks (HeaderRaw crypto) - --- | Full header type, carrying its own memoised bytes. -newtype Header crypto = HeaderConstr (MemoBytes (HeaderRaw crypto)) - deriving Generic - deriving newtype (Eq, Show, NoThunks, Plain.ToCBOR, SafeToHash) - -instance Memoized (Header crypto) where - type RawType (Header crypto) = HeaderRaw crypto - -type instance MemoHashIndex (HeaderRaw crypto) = EraIndependentBlockHeader - -instance HashAnnotated (Header crypto) EraIndependentBlockHeader where - hashAnnotated = getMemoSafeHash - -pattern Header :: - Crypto crypto => - HeaderBody crypto -> - KES.SignedKES (KES crypto) (HeaderBody crypto) -> - Header crypto -pattern Header{headerBody, headerSig} <- (getMemoRawType -> HeaderRaw headerBody headerSig) - where - Header body sig = mkMemoized (pvMajor (hbProtVer body)) $ HeaderRaw body sig -{-# COMPLETE Header #-} - --- | Compute the size of the header -headerSize :: Header crypto -> Int -headerSize = originalBytesSize - --- | Hash a header -headerHash :: - Header crypto -> - Hash.Hash HASH EraIndependentBlockHeader -headerHash = extractHash . hashAnnotated - --------------------------------------------------------------------------------- --- Serialisation --------------------------------------------------------------------------------- - -instance Crypto crypto => EncCBOR (HeaderBody crypto) where - encCBOR - HeaderBody - { hbBlockNo - , hbSlotNo - , hbPrev - , hbVk - , hbVrfVk - , hbVrfRes - , hbBodySize - , hbBodyHash - , hbOCert - , hbProtVer - , hbLeiosExt - } = - encodeListLen len - <> encCBOR hbBlockNo - <> encCBOR hbSlotNo - <> encCBOR hbPrev - <> encCBOR hbVk - <> encodeFixedSized hbVrfVk - <> encCBOR hbVrfRes - <> encCBOR hbBodySize - <> encCBOR hbBodyHash - <> encCBOR hbOCert - <> encCBOR hbProtVer - <> encodeLeiosExt - where - (len, encodeLeiosExt) = case hbLeiosExt of - SNothing -> (10, mempty) - SJust ext -> (12, encodeLeios ext) - - encodeLeios HeaderLeiosExtension{containsCert, ebAnnouncement} = - encodeBool containsCert - <> encodeNullStrictMaybe (fromPlainEncoding . encodeEbAnnouncement) ebAnnouncement - -instance Crypto crypto => DecCBOR (HeaderBody crypto) where - decCBOR = do - -- TODO: support indef length lists - len <- decodeListLen - hbBlockNo <- decCBOR - hbSlotNo <- decCBOR - hbPrev <- decCBOR - hbVk <- decCBOR - hbVrfVk <- decodeFixedSized - hbVrfRes <- decCBOR - hbBodySize <- decCBOR - hbBodyHash <- decCBOR - hbOCert <- unCBORGroup <$> decCBOR - hbProtVer <- decCBOR - hbLeiosExt <- case len of - 10 -> pure SNothing - 12 -> SJust <$> decodeLeiosExtension - _ -> fail $ "Praos HeaderBody CBOR has wrong length: " <> show len - pure - HeaderBody - { hbBlockNo - , hbSlotNo - , hbPrev - , hbVk - , hbVrfVk - , hbVrfRes - , hbBodySize - , hbBodyHash - , hbOCert - , hbProtVer - , hbLeiosExt - } - where - decodeLeiosExtension = - HeaderLeiosExtension - <$> decodeBool - <*> decodeNullStrictMaybe (fromPlainDecoder $ decodeEbAnnouncement) - -encodeHeaderRaw :: - Crypto crypto => - HeaderRaw crypto -> - Encode (Closed Dense) (HeaderRaw crypto) -encodeHeaderRaw (HeaderRaw body sig) = - Rec HeaderRaw !> To body !> E encodeFixedSized sig - -instance Crypto crypto => EncCBOR (HeaderRaw crypto) where - encCBOR = encode . encodeHeaderRaw - -instance Crypto crypto => DecCBOR (HeaderRaw crypto) where - decCBOR = decode $ RecD HeaderRaw DecCBOR (Annotator (HeaderRaw crypto)) where - decCBOR = pure <$> decCBOR - -instance Crypto c => EncCBOR (Header c) - -deriving via - Mem (HeaderRaw crypto) - instance - Crypto crypto => DecCBOR (Annotator (Header crypto)) - -instance (Crypto c, Era era) => EraBlockHeader (Header c) era where - blockIssuerBlockHeaderG = - to (\(Block (Header hb _) _) -> hashKey (hbVk hb)) - blockHeaderSizeBlockHeaderG = - to (\(Block hdr _) -> originalBytesSize hdr) - blockBodySizeBlockHeaderL = - lens - (\(Block (Header hb _) _) -> hbBodySize hb) - ( \(Block (Header hb sig) body) sz -> - Block (Header hb{hbBodySize = sz} sig) body - ) - blockBodyHashBlockHeaderL = - lens - (\(Block (Header hb _) _) -> hbBodyHash hb) - ( \(Block (Header hb sig) body) h -> - Block (Header hb{hbBodyHash = h} sig) body - ) - slotNoBlockHeaderL = - lens - (\(Block (Header hb _) _) -> hbSlotNo hb) - ( \(Block (Header hb sig) body) s -> - Block (Header hb{hbSlotNo = s} sig) body - ) - protVerBlockHeaderL = - lens - (\(Block (Header hb _) _) -> hbProtVer hb) - ( \(Block (Header hb sig) body) pv -> - Block (Header hb{hbProtVer = pv} sig) body - ) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/VRF.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/VRF.hs deleted file mode 100644 index bb485e4d44..0000000000 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/VRF.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- | This module implements VRF range extension as described in --- https://iohk.io/en/research/library/papers/on-uc-secure-range-extension-and-batch-verification-for-ecvrf/ -module Ouroboros.Consensus.Protocol.Praos.VRF - ( InputVRF - , VRFUsage (..) - , mkInputVRF - , vrfLeaderValue - , vrfNonceValue - ) where - -import Cardano.Binary (ToCBOR) -import Cardano.Crypto.Hash - ( Blake2b_256 - , Hash - , castHash - , hashSize - , hashToBytes - , hashWith - ) -import qualified Cardano.Crypto.Hash as Hash -import Cardano.Crypto.Util - ( SignableRepresentation (getSignableRepresentation) - , bytesToNatural - ) -import Cardano.Crypto.VRF - ( CertifiedVRF (certifiedOutput) - , getOutputVRFBytes - ) -import Cardano.Ledger.BaseTypes (Nonce (NeutralNonce, Nonce)) -import Cardano.Ledger.Binary (runByteBuilder) -import Cardano.Ledger.Hashes (HASH) -import Cardano.Ledger.Slot (SlotNo (SlotNo)) -import Cardano.Protocol.Crypto (Crypto (VRF)) -import Cardano.Protocol.TPraos.BlockHeader - ( BoundedNatural - , assertBoundedNatural - ) -import qualified Data.ByteString.Builder as BS -import qualified Data.ByteString.Builder.Extra as BS -import Data.Proxy (Proxy (Proxy)) -import GHC.Generics (Generic) -import NoThunks.Class (NoThunks) -import Numeric.Natural (Natural) - --- | Input to the verifiable random function. Consists of the hash of the slot --- and the epoch nonce. -newtype InputVRF = InputVRF {unInputVRF :: Hash Blake2b_256 InputVRF} - deriving (Eq, Ord, Show, Generic) - deriving newtype (NoThunks, ToCBOR) - -instance SignableRepresentation InputVRF where - getSignableRepresentation (InputVRF x) = hashToBytes x - --- | Construct a unified VRF value -mkInputVRF :: - SlotNo -> - -- | Epoch nonce - Nonce -> - InputVRF -mkInputVRF (SlotNo slot) eNonce = - InputVRF - . Hash.castHash - . Hash.hashWith id - . runByteBuilder (8 + 32) - $ BS.word64BE slot - <> ( case eNonce of - NeutralNonce -> mempty - Nonce h -> BS.byteStringCopy (Hash.hashToBytes h) - ) - --- | Indicate the usage of the VRF result. -data VRFUsage - = -- | The VRF value will be used to establish whether the issuing node is - -- indeed a leader for this slot. - VRFLeader - | -- | The VRF value will be used to contribute to the evolving nonce. - VRFNonce - --- | Singleton VRF usage -data SVRFUsage a where - SVRFLeader :: SVRFUsage VRFLeader - SVRFNonce :: SVRFUsage VRFNonce - --- | Indicate the result of the VRF evaluation. -data VRFResult (v :: VRFUsage) - --- | Compute a hash of the unified VRF output appropriate to its usage. -hashVRF :: - forall (v :: VRFUsage) c proxy. - proxy c -> - SVRFUsage v -> - CertifiedVRF (VRF c) InputVRF -> - Hash HASH (VRFResult v) -hashVRF _ use certVRF = - let vrfOutputAsBytes = getOutputVRFBytes $ certifiedOutput certVRF - in case use of - SVRFLeader -> castHash $ hashWith id $ "L" <> vrfOutputAsBytes - SVRFNonce -> castHash $ hashWith id $ "N" <> vrfOutputAsBytes - --- | Range-extend a VRF output to be used for leader checks from the relevant --- hash. See section 4.1 of the linked paper for details. -vrfLeaderValue :: - forall c proxy. - proxy c -> - CertifiedVRF (VRF c) InputVRF -> - BoundedNatural -vrfLeaderValue p cvrf = - assertBoundedNatural - ((2 :: Natural) ^ (8 * hashSize (Proxy @HASH))) - (bytesToNatural . hashToBytes $ hashVRF p SVRFLeader cvrf) - --- | Range-extend a VRF output to be used for the evolving nonce. See section --- 4.1 of the linked paper for details. -vrfNonceValue :: - forall c proxy. - proxy c -> - CertifiedVRF (VRF c) InputVRF -> - Nonce -vrfNonceValue p = - -- The double hashing below is perhaps a little confusing. The first hash is - -- how we do range extension as per the VRF paper. The second hash is how we - -- generate a nonce value from a VRF output. However, that "VRF output" is now - -- itself a hash. - -- - -- However, while the VRF hash is crypto-dependent, for the nonce we use a - -- fixed `Blake2b_256` hashing function. So this double hashing is still - -- needed. - Nonce . castHash . hashWith id . hashToBytes . hashVRF p SVRFNonce diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs index 9597d1987a..e18e72362e 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs @@ -1,30 +1,98 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Ouroboros.Consensus.Protocol.Praos.Views - ( HeaderView (..) - , PraosLedgerView (..) - , forecastToPraosLedgerView + ( BaseHeaderBody + , BaseHeaderView (..) + , BasePraosLedgerView (..) + , ForecastsLeios (..) + , LeiosLedgerView (..) + , PraosLedgerView + , initialLeiosLedgerView + , forecastToBasePraosLedgerView + , extendHeaderBodyWithLeios ) where import Cardano.Crypto.KES (SignedKES) import Cardano.Crypto.VRF (CertifiedVRF, VRFAlgorithm (VerKeyVRF)) -import Cardano.Ledger.BaseTypes (ProtVer) +import Cardano.Ledger.BaseTypes + ( Milliseconds32 (..) + , ProtVer + , StrictMaybe + , UnitInterval + ) import Cardano.Ledger.Chain (ChainChecksPParams (..)) import Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey) import qualified Cardano.Ledger.Shelley.API as SL +import Cardano.Ledger.State (LeiosCommittee, emptyLeiosCommittee) import Cardano.Protocol.Crypto (KES, VRF) +import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec +import qualified Cardano.Protocol.Praos.BlockHeader as PraosCodec +import Cardano.Protocol.Praos.VRF (InputVRF) import Cardano.Protocol.TPraos.BlockHeader (PrevHash) import Cardano.Protocol.TPraos.OCert (OCert) import Cardano.Slotting.Slot (SlotNo) +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy (Proxy)) import Data.Word (Word16, Word32) +import LeiosDemoTypes (EbAnnouncement) import Lens.Micro ((^.)) -import Ouroboros.Consensus.Protocol.Praos.Header (HeaderBody) -import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF) +import Ouroboros.Consensus.Protocol.Praos.Common + +{------------------------------------------------------------------------------- + The upstream header types, per extension +-------------------------------------------------------------------------------} + +-- | The upstream @cardano-protocol@ header body this extension uses. +-- +-- Its owners define one per protocol, wholly separately, and future extensions +-- of Praos (eg Ouroboros Phalanx) will presumably each bring another. This is +-- the KES-signed object, which is why it appears in 'BaseHeaderView' as-is +-- rather than being projected field by field. +type BaseHeaderBody :: PraosExtension -> Type -> Type +type family BaseHeaderBody pext :: Type -> Type where + BaseHeaderBody PextNone = PraosCodec.HeaderBody + BaseHeaderBody PextLeios = LeiosCodec.HeaderBody + +-- | The Leios header body is the Praos one plus the two Leios fields, so +-- whoever builds one builds the Praos body first and hands it here. +extendHeaderBodyWithLeios :: + PraosCodec.HeaderBody c -> + -- | Whether the block body carries a Leios certificate + Bool -> + StrictMaybe LeiosCodec.EbAnnouncement -> + LeiosCodec.HeaderBody c +extendHeaderBodyWithLeios pb containsCert ann = + LeiosCodec.HeaderBody + { LeiosCodec.hbBlockNo = PraosCodec.hbBlockNo pb + , LeiosCodec.hbSlotNo = PraosCodec.hbSlotNo pb + , LeiosCodec.hbPrev = PraosCodec.hbPrev pb + , LeiosCodec.hbVk = PraosCodec.hbVk pb + , LeiosCodec.hbVrfVk = PraosCodec.hbVrfVk pb + , LeiosCodec.hbVrfRes = PraosCodec.hbVrfRes pb + , LeiosCodec.hbBodySize = PraosCodec.hbBodySize pb + , LeiosCodec.hbBodyHash = PraosCodec.hbBodyHash pb + , LeiosCodec.hbOCert = PraosCodec.hbOCert pb + , LeiosCodec.hbProtVer = PraosCodec.hbProtVer pb + , LeiosCodec.hbBlockBodyContainsLeiosCert = containsCert + , LeiosCodec.hbEbAnnouncement = ann + } + +{------------------------------------------------------------------------------- + Header view +-------------------------------------------------------------------------------} + +type BaseHeaderView :: PraosExtension -> Type -> Type -- | View of the block header required by the Praos protocol. -data HeaderView crypto = HeaderView +data BaseHeaderView pext crypto = HeaderView { hvPrevHash :: !PrevHash -- ^ Hash of the previous block , hvVK :: !(VKey BlockIssuer) @@ -37,13 +105,31 @@ data HeaderView crypto = HeaderView -- ^ operational certificate , hvSlotNo :: !SlotNo -- ^ Slot - , hvSigned :: !(HeaderBody crypto) + , hvLeios :: + !( StrictMaybeLeios + (PraosExtensionHasLeios pext) + (Bool, StrictMaybe EbAnnouncement) + ) + -- ^ The Leios payload: whether this block's body carries a certificate (ie + -- whether it is a CertRB), and the endorser block this header announces. + -- + -- Statically absent unless the extension has Leios, since the header checks + -- that read it only exist there. + , hvSigned :: !(BaseHeaderBody pext crypto) -- ^ Header which must be signed - , hvSignature :: !(SignedKES (KES crypto) (HeaderBody crypto)) + , hvSignature :: !(SignedKES (KES crypto) (BaseHeaderBody pext crypto)) -- ^ KES Signature of the header } -data PraosLedgerView = PraosLedgerView + +{------------------------------------------------------------------------------- + Ledger view +-------------------------------------------------------------------------------} + +type BasePraosLedgerView :: PraosExtension -> Type + +-- | View of the ledger required by the Praos protocol. +data BasePraosLedgerView pext = PraosLedgerView { plvPoolDistr :: SL.PoolDistr -- ^ Stake distribution , plvMaxHeaderSize :: !Word16 @@ -52,21 +138,108 @@ data PraosLedgerView = PraosLedgerView -- ^ Maximum block body size , plvProtocolVersion :: !ProtVer -- ^ Current protocol version + , plvLeios :: !(StrictMaybeLeios (PraosExtensionHasLeios pext) LeiosLedgerView) + -- ^ The Leios data, statically absent unless the extension has Leios. + -- + -- One field rather than one per datum, so the committee and the parameters + -- cannot disagree about whether Leios is enabled. } - deriving Show --- | Build a 'PraosLedgerView' from a ledger 'EraForecast' -forecastToPraosLedgerView :: - forall t era. - SL.EraForecast era => +deriving instance Show (BasePraosLedgerView pext) + +type PraosLedgerView = BasePraosLedgerView PextNone + +-- | The Leios part of 'BasePraosLedgerView'. +-- +-- Only what the protocol itself checks. The other Leios parameters bound an +-- endorser block's contents, which is validated with a real ledger state in +-- hand, so doesn't need to be forecasted. +data LeiosLedgerView = LeiosLedgerView + { llvCommittee :: !LeiosCommittee + -- ^ Who may vote this epoch, and with what weight + , llvQuorumStakeThreshold :: !UnitInterval + -- ^ Weight a certificate must accumulate + , llvAnnouncementPeriodLength :: !Milliseconds32 + , llvVotePeriodLength :: !Milliseconds32 + , llvDiffusionPeriodLength :: !Milliseconds32 + -- ^ The three periods that determine how long after its announcement an + -- endorser block may be certified. Kept as durations, since converting to a + -- count of slots needs the slot length, which only the consensus config has. + , llvMaxEbBodySize :: !Word32 + -- ^ Maximum total size of an endorser block itself (/not/ the closure) + } + deriving (Eq, Show) + +-- | The Leios view of a ledger state that seats no committee. +-- +-- Nothing can be certified against it: the committee is empty and the quorum is +-- the entire weight. This is the truth rather than a placeholder, both before +-- the Leios era and during its first epochs, until a snapshot seated by the new +-- era's rules rotates in. +-- +-- The remaining parameters have no counterpart in such a state, so they admit +-- anything. They only bound an endorser block, whose contents are checked again +-- against the era's parameters proper, whereas an over-permissive committee +-- would be unsound. +initialLeiosLedgerView :: LeiosLedgerView +initialLeiosLedgerView = + LeiosLedgerView + { llvCommittee = emptyLeiosCommittee + , llvQuorumStakeThreshold = maxBound + , llvAnnouncementPeriodLength = Milliseconds32 0 + , llvVotePeriodLength = Milliseconds32 0 + , llvDiffusionPeriodLength = Milliseconds32 1000000000 + , llvMaxEbBodySize = 0 + } + +type ForecastsLeios :: PraosExtension -> Type -> Constraint + +-- | The Leios part of an era's forecast, as this extension sees it. +-- +-- Reading that part needs 'SL.DijkstraEraForecast', which the extensions +-- without Leios must not demand of their eras. 'KnownPraosExtension' cannot +-- serve here: refining @pext@ says nothing about @era@, and it is an @era@ +-- dictionary that is missing. +class ForecastsLeios pext era where + forecastToLeiosPart :: + proxy pext -> + SL.Forecast t era -> + StrictMaybeLeios (PraosExtensionHasLeios pext) LeiosLedgerView + +instance ForecastsLeios PextNone era where + forecastToLeiosPart _ _ = SNothingLeios + +instance SL.DijkstraEraForecast era => ForecastsLeios PextLeios era where + forecastToLeiosPart _ = SJustLeios . forecastToLeiosLedgerView + +-- | Build a 'BasePraosLedgerView' from a ledger 'SL.Forecast' +forecastToBasePraosLedgerView :: + forall pext t era. + (ForecastsLeios pext era, SL.EraForecast era) => SL.Forecast t era -> - PraosLedgerView -forecastToPraosLedgerView f = + BasePraosLedgerView pext +forecastToBasePraosLedgerView f = PraosLedgerView { plvPoolDistr = f ^. SL.poolDistrForecastL @era @t , plvMaxHeaderSize = ccMaxBHSize cc , plvMaxBodySize = ccMaxBBSize cc , plvProtocolVersion = ccProtocolVersion cc + , plvLeios = forecastToLeiosPart (Proxy @pext) f } where cc = SL.forecastChainChecks @t @era f + +forecastToLeiosLedgerView :: + forall t era. + SL.DijkstraEraForecast era => + SL.Forecast t era -> + LeiosLedgerView +forecastToLeiosLedgerView f = + LeiosLedgerView + { llvCommittee = f ^. SL.leiosCommitteeForecastL @era @t + , llvQuorumStakeThreshold = f ^. SL.leiosQuorumStakeThresholdForecastL @era @t + , llvAnnouncementPeriodLength = f ^. SL.leiosAnnouncementPeriodLengthForecastL @era @t + , llvVotePeriodLength = f ^. SL.leiosVotePeriodLengthForecastL @era @t + , llvDiffusionPeriodLength = f ^. SL.leiosDiffusionPeriodLengthForecastL @era @t + , llvMaxEbBodySize = f ^. SL.maxEndorserBlockReferencesSizeForecastL @era @t + } diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs index 52929a57dd..716ef9b1b1 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Generators suitable for serialisation. Note that these are not guaranteed @@ -8,6 +10,12 @@ module Test.Consensus.Protocol.Serialisation.Generators () where import Cardano.Crypto.KES (unsoundPureSignedKES) import Cardano.Crypto.VRF (evalCertified) import Cardano.Ledger.BaseTypes (StrictMaybe (..)) +import qualified Cardano.Protocol.Leios.BlockHeader as Leios +import Cardano.Protocol.Praos.BlockHeader + ( Header (Header) + , HeaderBody (..) + ) +import Cardano.Protocol.Praos.VRF (InputVRF, mkInputVRF) import Cardano.Protocol.TPraos.BlockHeader (HashHeader, PrevHash (..)) import Cardano.Protocol.TPraos.OCert ( KESPeriod (KESPeriod) @@ -19,17 +27,23 @@ import Cardano.Slotting.Slot , WithOrigin (At, Origin) ) import qualified Data.ByteString as BS +import Data.Proxy (Proxy (Proxy)) import LeiosDemoTypes ( EbAnnouncement (EbAnnouncement) , EbHash ) -import Ouroboros.Consensus.Protocol.Praos (PraosState (PraosState)) +import Ouroboros.Consensus.Protocol.Praos (BasePraosState (PraosState)) import qualified Ouroboros.Consensus.Protocol.Praos as Praos -import Ouroboros.Consensus.Protocol.Praos.Header - ( Header (..) - , HeaderBody (..) +import Ouroboros.Consensus.Protocol.Praos.Common + ( KnownPraosExtension (praosExtensionHasLeios) + , StrictMaybeLeios (SJustLeios, SNothingLeios) + , toCodecEbAnnouncement + , WhetherHasLeiosDecided + ( PextDoesNotHaveLeiosDecided + , PextHasLeiosDecided + ) ) -import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF, mkInputVRF) +import Ouroboros.Consensus.Protocol.Praos.Views (extendHeaderBodyWithLeios) import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators () import Test.Cardano.StrictContainers.Instances () import Test.Crypto.KES () @@ -74,10 +88,6 @@ instance Praos.PraosCrypto c => Arbitrary (HeaderBody c) where <*> arbitrary <*> ocert <*> arbitrary - -- FIXME: Cannot generate HeaderLeiosExtension because we don't know - -- for which era/protocol version this header is. However, Dijkstra is - -- currently disabled anyways in Test.Consensus.Cardano.Generators - <*> pure SNothing instance Praos.PraosCrypto c => Arbitrary (Header c) where arbitrary = do @@ -87,7 +97,21 @@ instance Praos.PraosCrypto c => Arbitrary (Header c) where let hSig = unsoundPureSignedKES () period hBody sKey pure $ Header hBody hSig -instance Arbitrary PraosState where +instance Arbitrary Leios.EbAnnouncement where + arbitrary = toCodecEbAnnouncement <$> arbitrary + +instance Praos.PraosCrypto c => Arbitrary (Leios.HeaderBody c) where + arbitrary = extendHeaderBodyWithLeios <$> arbitrary <*> arbitrary <*> arbitrary + +instance Praos.PraosCrypto c => Arbitrary (Leios.Header c) where + arbitrary = do + hBody <- arbitrary + period <- arbitrary + sKey <- arbitrary + let hSig = unsoundPureSignedKES () period hBody sKey + pure $ Leios.Header hBody hSig + +instance KnownPraosExtension pext => Arbitrary (BasePraosState pext) where arbitrary = PraosState <$> oneof @@ -101,4 +125,9 @@ instance Arbitrary PraosState where <*> arbitrary <*> arbitrary <*> arbitrary - <*> pure SNothing + <*> traverse + (\() -> arbitrary) + ( case praosExtensionHasLeios (Proxy @pext) of + PextDoesNotHaveLeiosDecided -> SNothingLeios + PextHasLeiosDecided -> SJustLeios () + ) diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs index 4fe022860f..b07647c569 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs @@ -89,19 +89,21 @@ import Data.Coerce (coerce) import Data.Foldable (toList) import qualified Data.Map as Map import Data.Maybe (fromJust, fromMaybe) -import Data.Maybe.Strict (StrictMaybe (..)) import Data.Proxy (Proxy (..)) import Data.Ratio ((%)) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Word (Word64) import GHC.Generics (Generic) -import Ouroboros.Consensus.Protocol.Praos (PraosValidationErr (..)) -import Ouroboros.Consensus.Protocol.Praos.Header +import Ouroboros.Consensus.Protocol.Praos + ( BasePraosValidationErr (..) + , PraosValidationErr + ) +import Cardano.Protocol.Praos.BlockHeader ( Header , HeaderBody (..) , pattern Header ) -import Ouroboros.Consensus.Protocol.Praos.VRF +import Cardano.Protocol.Praos.VRF ( InputVRF , mkInputVRF , vrfLeaderValue @@ -445,7 +447,6 @@ genHeaderBody context = do hbBodyHash <- genHash (hbOCert, kesPeriod) <- genCert hbSlotNo context let hbProtVer = protocolVersionZero - hbLeiosExt = SNothing -- XXX: Never contains leios fields headerBody = HeaderBody{..} pure $ (headerBody, kesPeriod) where diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index e5a425adbe..10067e12d0 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -1152,26 +1152,25 @@ library protocol Ouroboros.Consensus.Protocol.Praos Ouroboros.Consensus.Protocol.Praos.AgentClient Ouroboros.Consensus.Protocol.Praos.Common - Ouroboros.Consensus.Protocol.Praos.Header - Ouroboros.Consensus.Protocol.Praos.VRF Ouroboros.Consensus.Protocol.Praos.Views Ouroboros.Consensus.Protocol.TPraos build-depends: Win32-network ^>=0.2, base >=4.14 && <4.23, - bytestring, cardano-binary, cardano-crypto-class:cardano-crypto-class, cardano-ledger-binary, cardano-ledger-core, + cardano-ledger-dijkstra ^>=0.4, cardano-ledger-shelley ^>=1.20, - cardano-protocol ^>=0.1.1.0, + cardano-protocol >= 0.1.1 && <0.2, cardano-protocol-tpraos ^>=1.6, cardano-slotting, cborg, containers, contra-tracer, + deepseq, io-classes, io-sim, kes-agent ^>=1.3, @@ -1205,7 +1204,7 @@ library unstable-protocol-testlib cardano-ledger-binary, cardano-ledger-core, cardano-ledger-shelley-test, - cardano-protocol ^>=0.1.1.0, + cardano-protocol, cardano-slotting, cardano-strict-containers:{cardano-strict-containers, testlib}, containers, @@ -1595,7 +1594,7 @@ library cardano cardano-ledger-mary ^>=1.11, cardano-ledger-shelley, cardano-prelude, - cardano-protocol ^>=0.1.1.0, + cardano-protocol, cardano-protocol-tpraos, cardano-slotting, cardano-strict-containers, @@ -1762,7 +1761,7 @@ library unstable-shelley-testlib cardano-ledger-shelley:{cardano-ledger-shelley, testlib}, cardano-ledger-shelley-ma-test, cardano-ledger-shelley-test, - cardano-protocol ^>=0.1.1.0, + cardano-protocol, cardano-protocol-tpraos:{cardano-protocol-tpraos, testlib}, cardano-slotting, cardano-strict-containers, @@ -1805,6 +1804,7 @@ test-suite shelley-test cardano-ledger-core, cardano-ledger-dijkstra:{cardano-ledger-dijkstra, testlib}, cardano-ledger-shelley, + cardano-protocol, cardano-protocol-tpraos, cardano-slotting, cborg, From 4b57e659ab56e992ae6e551054fe7e5599c124ed Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Wed, 9 Sep 2026 11:24:15 -0400 Subject: [PATCH 03/60] cabal&protocol: eliminate (9.12) warnings --- .../Ouroboros/Consensus/Protocol/Praos.hs | 1 - .../Test/Consensus/Protocol/Serialisation/Generators.hs | 1 - ouroboros-consensus.cabal | 4 +--- 3 files changed, 1 insertion(+), 5 deletions(-) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index b1d08c9654..2abdc51bcd 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -58,7 +58,6 @@ import Cardano.Ledger.BaseTypes import qualified Cardano.Ledger.BaseTypes as SL import qualified Cardano.Ledger.Chain as SL import Cardano.Ledger.Core (fromEraCBOR, toEraCBOR) -import Cardano.Ledger.Dijkstra (DijkstraEra) import Cardano.Ledger.Hashes (HASH) import Cardano.Ledger.Keys ( DSIGN diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs index 716ef9b1b1..51dbfaecd4 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs @@ -9,7 +9,6 @@ module Test.Consensus.Protocol.Serialisation.Generators () where import Cardano.Crypto.KES (unsoundPureSignedKES) import Cardano.Crypto.VRF (evalCertified) -import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import qualified Cardano.Protocol.Leios.BlockHeader as Leios import Cardano.Protocol.Praos.BlockHeader ( Header (Header) diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 10067e12d0..cdf4417b29 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -1162,7 +1162,6 @@ library protocol cardano-crypto-class:cardano-crypto-class, cardano-ledger-binary, cardano-ledger-core, - cardano-ledger-dijkstra ^>=0.4, cardano-ledger-shelley ^>=1.20, cardano-protocol >= 0.1.1 && <0.2, cardano-protocol-tpraos ^>=1.6, @@ -1206,7 +1205,7 @@ library unstable-protocol-testlib cardano-ledger-shelley-test, cardano-protocol, cardano-slotting, - cardano-strict-containers:{cardano-strict-containers, testlib}, + cardano-strict-containers:testlib, containers, ouroboros-consensus, ouroboros-consensus:{protocol, unstable-consensus-testlib}, @@ -1805,7 +1804,6 @@ test-suite shelley-test cardano-ledger-dijkstra:{cardano-ledger-dijkstra, testlib}, cardano-ledger-shelley, cardano-protocol, - cardano-protocol-tpraos, cardano-slotting, cborg, constraints, From 6273947cd656421ba87970f9f0c7925d3b4e639b Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Wed, 9 Sep 2026 14:58:07 -0400 Subject: [PATCH 04/60] BlockToAdd: add blockPredecessorSlot field --- .../byron/Ouroboros/Consensus/Byron/Node.hs | 2 +- .../Ouroboros/Consensus/ByronDual/Node.hs | 2 +- .../Cardano/Tools/DBSynthesizer/Forging.hs | 2 +- .../Ouroboros/Consensus/Network/NodeToNode.hs | 3 +- .../Ouroboros/Consensus/NodeKernel.hs | 8 +- .../Ouroboros/Consensus/NodeKernel/Forge.hs | 8 +- .../Test/ThreadNet/Network.hs | 2 +- .../Consensus/Genesis/Tests/LoE/CaughtUp.hs | 10 ++- .../Consensus/PeerSimulator/BlockFetch.hs | 4 +- .../Test/Consensus/PeerSimulator/Run.hs | 5 +- .../HardFork/Combinator/Node/InitStorage.hs | 4 +- .../Ouroboros/Consensus/HeaderValidation.hs | 50 +++++++++-- .../BlockFetch/ClientInterface.hs | 37 +++++++-- .../MiniProtocol/ChainSync/Client.hs | 17 +++- .../Consensus/Storage/ChainDB/API.hs | 36 +++++--- .../Consensus/Storage/ChainDB/Impl.hs | 12 ++- .../Storage/ChainDB/Impl/ChainSel.hs | 14 ++-- .../Consensus/Storage/ChainDB/Impl/Types.hs | 21 ++++- .../Consensus/Storage/ChainDB/Init.hs | 7 +- .../Test/Util/Header.hs | 21 ++++- .../MiniProtocol/BlockFetch/Client.hs | 13 ++- .../Storage/ChainDB/FollowerPromptness.hs | 20 +++-- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 72 +++++++++++++--- .../Test/Ouroboros/Storage/ChainDB/Unit.hs | 82 ++++++++++--------- 24 files changed, 325 insertions(+), 127 deletions(-) diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs index 02e2e01a7b..79c47d0809 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs @@ -302,7 +302,7 @@ instance NodeInitStorage ByronBlock where tip <- ledgerTipPoint <$> getCurrentLedger case tip of BlockPoint{} -> return () - GenesisPoint -> addBlock genesisEBB + GenesisPoint -> addBlock Origin genesisEBB where genesisEBB = forgeEBB (getByronBlockConfig cfg) (SlotNo 0) (BlockNo 0) GenesisHash diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs index 152a0d7f55..846b2bcfb4 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs @@ -247,7 +247,7 @@ instance NodeInitStorage DualByronBlock where tip <- ledgerTipPoint <$> getCurrentLedger case tip of BlockPoint{} -> return () - GenesisPoint -> addBlock genesisEBB + GenesisPoint -> addBlock Origin genesisEBB where genesisEBB :: DualByronBlock genesisEBB = diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs index a68f383d83..64ea48f5f9 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs @@ -421,7 +421,7 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg votingKey genTxs leio -- Add the block to the chain DB (synchronously) and verify adoption let noPunish = InvalidBlockPunishment.noPunishment - result <- lift $ ChainDB.addBlockAsync chainDB noPunish newBlock + result <- lift $ ChainDB.addBlockAsync chainDB noPunish (pointSlot bcPrevPoint) newBlock mbCurTip <- lift $ atomically $ ChainDB.blockProcessed result when (mbCurTip /= SuccesfullyAddedBlock (blockPoint newBlock)) $ diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index af70538401..ee358daab5 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -150,6 +150,7 @@ import Ouroboros.Consensus.HeaderValidation (HeaderWithTime) import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Mempool.API (getLeiosTxIndex) +import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server import Ouroboros.Consensus.MiniProtocol.ChainSync.Client ( ChainSyncStateView (..) @@ -287,7 +288,7 @@ data Handlers m addr blk = Handlers NodeToNodeVersion -> ControlMessageSTM m -> FetchedMetricsTracer m -> - BlockFetchClient (HeaderWithTime blk) blk m () + BlockFetchClient (HeaderWithTime blk) blk (BlockFetchClientInterface.MatchedBlock blk) m () , hBlockFetchServer :: ConnectionId addr -> NodeToNodeVersion -> diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index c613d70310..776ae48709 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -188,7 +188,7 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel -- ^ The node's mempool , getTopLevelConfig :: TopLevelConfig blk -- ^ The node's top-level static configuration - , getFetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk m + , getFetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk (BlockFetchClientInterface.MatchedBlock blk) m -- ^ The fetch client registry, used for the block fetch clients. , getKeepAliveRegistry :: KeepAliveRegistry (ConnectionId addrNTN) m -- ^ The keep-alive registry, used by block-fetch decision logic to read @@ -682,8 +682,8 @@ data InternalState m addrNTN addrNTC blk = IS , systemTime :: SystemTime m , chainDB :: ChainDB m blk , blockFetchInterface :: - BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk m - , fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk m + BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk (BlockFetchClientInterface.MatchedBlock blk) m + , fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk (BlockFetchClientInterface.MatchedBlock blk) m , varChainSyncHandles :: ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk , varGsmState :: StrictTVar m GSM.GsmState , mempool :: Mempool m blk @@ -781,7 +781,7 @@ initInternalState chainDbView = BlockFetchClientInterface.defaultChainDbView chainDB blockFetchInterface :: - BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk m + BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk (BlockFetchClientInterface.MatchedBlock blk) m blockFetchInterface = BlockFetchClientInterface.mkBlockFetchConsensusInterface (dbfTracer tracers) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs index caad650e79..18d2c6ebd2 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs @@ -281,6 +281,7 @@ forge forgeEventTracer forgeStateInfoTracer leiosTracer forgeCCtx cfg chainDB me chainDB mempool currentSlot + (pointSlot bcPrevPoint) (Block.fbRbTxs forgeBlockArgs) (Block.fbEbTxs forgeBlockArgs) newBlock @@ -494,11 +495,14 @@ addBlockToChainDB :: ChainDB m blk -> Mempool m blk -> SlotNo -> + -- | The slot of the block we are extending, from the 'BlockContext' this + -- block was forged against. + WithOrigin SlotNo -> [Validated (GenTx blk)] -> [Validated (GenTx blk)] -> blk -> WithEarlyExit m () -addBlockToChainDB trace chainDB mempool currentSlot rbTxs ebTxs newBlock = do +addBlockToChainDB trace chainDB mempool currentSlot predSlot rbTxs ebTxs newBlock = do let noPunish = InvalidBlockPunishment.noPunishment -- no way to punish yourself -- Make sure that if an async exception is thrown while a block is -- added to the chain db, we will remove txs from the mempool. @@ -508,7 +512,7 @@ addBlockToChainDB trace chainDB mempool currentSlot rbTxs ebTxs newBlock = do -- 'uninterruptibleMask_' to make sure that async exceptions do not -- interrupt it. uninterruptibleMask_ $ do - result <- lift $ ChainDB.addBlockAsync chainDB noPunish newBlock + result <- lift $ ChainDB.addBlockAsync chainDB noPunish predSlot newBlock -- Block until we have processed the block mbCurTip <- lift $ atomically $ ChainDB.blockProcessed result diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index 441d5bd165..680238038e 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -990,7 +990,7 @@ runThreadNetwork -- ChainDB will reject it as invalid, and -- 'Test.ThreadNet.General.prop_general' will eventually fail -- because of a block rejection. - void $ ChainDB.addBlock chainDB InvalidBlockPunishment.noPunishment ebb + void $ ChainDB.addBlock chainDB InvalidBlockPunishment.noPunishment (pointSlot p) ebb pure blk -- This variable holds the number of the earliest slot in which the diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs index 9bfffa67a6..8672336df9 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs @@ -141,16 +141,18 @@ run = withRegistry \registry -> do AF.Empty AF.AnchorGenesis AF.:> getHeader blkA hdl <- atomically $ mkTestChainSyncClientHandle initialFrag atomically $ cschcAddHandle chainSyncHandles peer1 hdl - addBlk blkA + addBlk Origin blkA -- Then, send C. atomically $ modifyTVar (cschState hdl) $ \s -> ChainSyncState - { csCandidate = csCandidate s AF.:> attachSlotTime cfg (getHeader blkC) + { csCandidate = + csCandidate s + AF.:> attachSlotTime cfg (AF.headSlot (csCandidate s)) (getHeader blkC) , csLatestSlot = pure $ NotOrigin $ blockSlot blkC , csIdling = csIdling s } - addBlk blkC + addBlk (NotOrigin (blockSlot blkA)) blkC -- Finally, roll back to the initial fragment and idle. atomically $ modifyTVar (cschState hdl) $ \_s -> @@ -168,7 +170,7 @@ run = withRegistry \registry -> do attachSlotTimeToFragment cfg $ AF.Empty AF.AnchorGenesis AF.:> getHeader blkB atomically $ cschcAddHandle chainSyncHandles peer2 hdl - addBlk blkB + addBlk Origin blkB -- Finally, idle. atomically $ modifyTVar (cschState hdl) $ \s -> diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs index a80284fa4c..bb8542e425 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs @@ -115,7 +115,7 @@ startBlockFetchLogic :: Tracer m (TraceEvent blk) -> ProtocolInfo blk -> ChainDB m blk -> - FetchClientRegistry PeerId (HeaderWithTime blk) blk m -> + FetchClientRegistry PeerId (HeaderWithTime blk) blk (BlockFetchClientInterface.MatchedBlock blk) m -> KeepAliveRegistry PeerId m -> ChainSyncClientHandleCollection PeerId m blk -> m () @@ -190,7 +190,7 @@ runBlockFetchClient :: PeerId -> BlockFetchTimeout -> StateViewTracers blk m -> - FetchClientRegistry PeerId (HeaderWithTime blk) blk m -> + FetchClientRegistry PeerId (HeaderWithTime blk) blk (BlockFetchClientInterface.MatchedBlock blk) m -> KeepAliveRegistry PeerId m -> ControlMessageSTM m -> -- | Send and receive message via the given 'Channel'. diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs index f6fb1f6474..0ac8e04077 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs @@ -46,6 +46,7 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client , ChainSyncLoPBucketEnabledConfig (..) , viewChainSyncState ) +import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.Node.GsmState as GSM import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..)) @@ -177,7 +178,7 @@ startChainSyncConnectionThread :: Tracer m (TraceEvent blk) -> TopLevelConfig blk -> ChainDbView m blk -> - FetchClientRegistry PeerId (HeaderWithTime blk) blk m -> + FetchClientRegistry PeerId (HeaderWithTime blk) blk (BlockFetchClientInterface.MatchedBlock blk) m -> SharedResources m blk -> ChainSyncResources m blk -> ChainSyncTimeout -> @@ -227,7 +228,7 @@ startBlockFetchConnectionThread :: ResourceRegistry m -> Tracer m (TraceEvent blk) -> StateViewTracers blk m -> - FetchClientRegistry PeerId (HeaderWithTime blk) blk m -> + FetchClientRegistry PeerId (HeaderWithTime blk) blk (BlockFetchClientInterface.MatchedBlock blk) m -> KeepAliveRegistry PeerId m -> ControlMessageSTM m -> SharedResources m blk -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node/InitStorage.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node/InitStorage.hs index 82242e192e..87f35ce4cc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node/InitStorage.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node/InitStorage.hs @@ -68,8 +68,8 @@ instance CanHardFork xs => NodeInitStorage (HardForkBlock xs) where nodeInitChainDB cfg' InitChainDB - { addBlock = - addBlock initChainDB + { addBlock = \predSlot -> + addBlock initChainDB predSlot . injectNS' (Proxy @I) index , getCurrentLedger = return currentLedger } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs index 0fd7f8a1a1..0590ed7bd8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs @@ -68,6 +68,7 @@ module Ouroboros.Consensus.HeaderValidation -- * Header with time , HeaderWithTime (..) , mkHeaderWithTime + , mkHeadersWithTime ) where import Cardano.Binary (enforceSize) @@ -104,6 +105,7 @@ import Ouroboros.Consensus.Ticked import Ouroboros.Consensus.Util (whenJust) import Ouroboros.Consensus.Util.Assert import qualified Ouroboros.Consensus.Util.CBOR as Util.CBOR +import qualified Ouroboros.Network.AnchoredFragment as AF {------------------------------------------------------------------------------- Preliminary: annotated tip @@ -597,15 +599,24 @@ deriving instance StandardHash blk => NoThunks (TipInfoIsEBB blk) Header with time -------------------------------------------------------------------------------} --- | A header paired with the time of the slot that it inhabits. +-- | A header paired with what the chain it arrived on says about it. -- --- Note that the header's slot was translated to this time (in the ChainSync --- client) according to the header's chain. This clarification may be helpful, --- since it's possible that some other chain would translate that same slot to --- a different time. +-- Note that the header's slot was translated to 'hwtSlotRelativeTime' (in the +-- ChainSync client) according to the header's chain. This clarification may be +-- helpful, since it's possible that some other chain would translate that same +-- slot to a different time. +-- +-- TODO rename this type, eg to @EnrichedHeader@: it no longer merely adds a +-- time, and the @hwt@ prefix on its fields is similarly outdated. data HeaderWithTime blk = HeaderWithTime { hwtHeader :: !(Header blk) , hwtSlotRelativeTime :: !RelativeTime + , hwtPredecessorSlot :: !(WithOrigin SlotNo) + -- ^ The slot of the header's predecessor on the chain it arrived on. + -- + -- The header commits only to its predecessor's hash, so this is knowledge + -- of that chain rather than of the header. It is nonetheless unambiguous, + -- since every chain carrying this header carries the same predecessor. } deriving Generic @@ -658,10 +669,12 @@ mkHeaderWithTime :: ) => LedgerConfig blk -> LedgerState blk mk -> + -- | The slot of the header's predecessor + WithOrigin SlotNo -> Header blk -> HeaderWithTime blk {-# INLINE mkHeaderWithTime #-} -mkHeaderWithTime cfg lst = \hdr -> +mkHeaderWithTime cfg lst = \predSlot hdr -> let summary = hardForkSummary cfg lst slot = realPointSlot $ headerRealPoint hdr qry = Qry.slotToWallclock slot @@ -669,8 +682,33 @@ mkHeaderWithTime cfg lst = \hdr -> in HeaderWithTime { hwtHeader = hdr , hwtSlotRelativeTime = slotTime + , hwtPredecessorSlot = predSlot } +-- | Convert a fragment of 'Header's to 'HeaderWithTime's +-- +-- Each header's predecessor is the header before it on the fragment, except +-- for the oldest, whose predecessor is the fragment's anchor. +-- +-- PREREQ: as 'mkHeaderWithTime', for every header on the fragment. +mkHeadersWithTime :: + ( HasHardForkHistory blk + , HasHeader (Header blk) + , Typeable blk + ) => + LedgerConfig blk -> + LedgerState blk mk -> + AF.AnchoredFragment (Header blk) -> + AF.AnchoredFragment (HeaderWithTime blk) +mkHeadersWithTime cfg lst frag = + AF.fromOldestFirst (AF.castAnchor (AF.anchor frag)) $ + zipWith + (mkHeaderWithTime cfg lst) + (AF.anchorToSlotNo (AF.anchor frag) : map (NotOrigin . blockSlot) hdrs) + hdrs + where + hdrs = AF.toOldestFirst frag + {------------------------------------------------------------------------------- Serialisation -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs index fc17ab16eb..0fedec98ea 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs @@ -6,6 +6,7 @@ -- | Initialization of the 'BlockFetchConsensusInterface' module Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface ( ChainDbView (..) + , MatchedBlock (..) , defaultChainDbView , mkBlockFetchConsensusInterface , readFetchModeDefault @@ -67,7 +68,8 @@ data ChainDbView m blk = ChainDbView , getCurrentChainWithTime :: STM m (AnchoredFragment (HeaderWithTime blk)) , getIsFetched :: STM m (Point blk -> Bool) , getMaxSlotNo :: STM m MaxSlotNo - , addBlockAsync :: InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk) + , addBlockAsync :: + InvalidBlockPunishment m -> WithOrigin SlotNo -> blk -> m (AddBlockPromise m blk) , getChainSelStarvation :: STM m ChainSelStarvation , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) } @@ -129,6 +131,18 @@ readFetchModeDefault then FetchModeDeadline else FetchModeBulkSync +-- | A block that matched the header the BlockFetch client requested it for, +-- paired with what that header knows and the block itself does not +-- +-- The BlockFetch client derives this from the header and the block together, +-- which is what ties the annotation to the very header this block was matched +-- against. +data MatchedBlock blk = MatchedBlock + { matchedBlock :: !blk + , matchedBlockPredecessorSlot :: !(WithOrigin SlotNo) + -- ^ 'hwtPredecessorSlot' of that header + } + mkBlockFetchConsensusInterface :: forall m peer blk. ( IOLike m @@ -145,7 +159,7 @@ mkBlockFetchConsensusInterface :: -- | See 'readFetchMode'. STM m FetchMode -> DiffusionPipeliningSupport -> - BlockFetchConsensusInterface peer (HeaderWithTime blk) blk m + BlockFetchConsensusInterface peer (HeaderWithTime blk) blk (MatchedBlock blk) m mkBlockFetchConsensusInterface csjTracer bcfg @@ -159,8 +173,15 @@ mkBlockFetchConsensusInterface getCandidates :: STM m (Map peer (AnchoredFragment (HeaderWithTime blk))) getCandidates = CSClient.viewChainSyncState (CSClient.cschcMap csHandlesCol) CSClient.csCandidate - blockMatchesHeader :: HeaderWithTime blk -> blk -> Bool - blockMatchesHeader hwt b = Block.blockMatchesHeader (hwtHeader hwt) b + blockMatchesHeader :: HeaderWithTime blk -> blk -> Maybe (MatchedBlock blk) + blockMatchesHeader hwt b + | Block.blockMatchesHeader (hwtHeader hwt) b = + Just + MatchedBlock + { matchedBlock = b + , matchedBlockPredecessorSlot = hwtPredecessorSlot hwt + } + | otherwise = Nothing readCandidateChains :: STM m (Map peer (AnchoredFragment (HeaderWithTime blk))) readCandidateChains = getCandidates @@ -173,7 +194,7 @@ mkBlockFetchConsensusInterface -- See 'mkAddFetchedBlock_' mkAddFetchedBlock :: - STM m (Point blk -> blk -> m ()) + STM m (Point blk -> MatchedBlock blk -> m ()) mkAddFetchedBlock = do pipeliningPunishment <- InvalidBlockPunishment.mkForDiffusionPipelining pure $ mkAddFetchedBlock_ pipeliningPunishment pipelining @@ -188,9 +209,10 @@ mkBlockFetchConsensusInterface ) -> DiffusionPipeliningSupport -> Point blk -> - blk -> + MatchedBlock blk -> m () - mkAddFetchedBlock_ pipeliningPunishment enabledPipelining _pt blk = void $ do + mkAddFetchedBlock_ pipeliningPunishment enabledPipelining _pt matched = void $ do + let MatchedBlock blk predSlot = matched disconnect <- InvalidBlockPunishment.mkPunishThisThread -- A BlockFetch peer can either send an entire range or none of the -- range; anything else will incur a disconnect. And in 'FetchDeadline' @@ -226,6 +248,7 @@ mkBlockFetchConsensusInterface addBlockAsync chainDB punishment + predSlot blk readFetchedMaxSlotNo :: STM m MaxSlotNo diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs index f014e6123b..7e19540ec5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs @@ -1188,14 +1188,22 @@ withTime fragment (HeaderStateHistory history) = ) $ AF.fromOldestFirst (AF.castAnchor $ AF.anchor fragment) - $ fmap addTimeToHeader - $ zip (AF.toOldestFirst fragment) (AF.toOldestFirst history) + $ fmap enrichHeader + $ zip3 + ( AF.anchorToSlotNo (AF.anchor fragment) + : map (NotOrigin . blockSlot) (AF.toOldestFirst fragment) + ) + (AF.toOldestFirst fragment) + (AF.toOldestFirst history) where - addTimeToHeader :: (Header blk, HeaderStateWithTime blk) -> HeaderWithTime blk - addTimeToHeader (hdr, hsWt) = + enrichHeader :: + (WithOrigin SlotNo, Header blk, HeaderStateWithTime blk) -> + HeaderWithTime blk + enrichHeader (predSlot, hdr, hsWt) = HeaderWithTime { hwtHeader = hdr , hwtSlotRelativeTime = hswtSlotTime hsWt + , hwtPredecessorSlot = predSlot } {------------------------------------------------------------------------------- @@ -1949,6 +1957,7 @@ checkValid cfgEnv intEnv hdr hdrSlotTime theirTip kis ledgerView = do HeaderWithTime { hwtHeader = hdr , hwtSlotRelativeTime = hdrSlotTime + , hwtPredecessorSlot = AF.headSlot theirFrag } theirFrag' = theirFrag :> validatedHdr -- Advance the most recent intersection if we have the same diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 158387eeda..7e90528397 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -143,7 +143,8 @@ import System.FS.API.Types (FsError) -- The ChainDB instantiates all the various type parameters of these databases -- to conform to the unified interface we provide here. data ChainDB m blk = ChainDB - { addBlockAsync :: InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk) + { addBlockAsync :: + InvalidBlockPunishment m -> WithOrigin SlotNo -> blk -> m (AddBlockPromise m blk) -- ^ Add a block to the heap of blocks -- -- We do /not/ assume that the block is valid (under the legder rules); @@ -519,9 +520,10 @@ data AddBlockResult blk -- | Add a block synchronously: wait until the block has been written to disk -- (see 'blockWrittenToDisk'). -addBlockWaitWrittenToDisk :: IOLike m => ChainDB m blk -> InvalidBlockPunishment m -> blk -> m Bool -addBlockWaitWrittenToDisk chainDB punish blk = do - promise <- addBlockAsync chainDB punish blk +addBlockWaitWrittenToDisk :: + IOLike m => ChainDB m blk -> InvalidBlockPunishment m -> WithOrigin SlotNo -> blk -> m Bool +addBlockWaitWrittenToDisk chainDB punish predSlot blk = do + promise <- addBlockAsync chainDB punish predSlot blk atomically $ blockWrittenToDisk promise -- | Add a block synchronously: wait until the block has been processed (see @@ -531,17 +533,24 @@ addBlockWaitWrittenToDisk chainDB punish blk = do -- Note: this is a partial function, only to support tests. -- -- PRECONDITION: the block to be added must not be from the future. See 'addBlockAsync'. -addBlock :: IOLike m => ChainDB m blk -> InvalidBlockPunishment m -> blk -> m (AddBlockResult blk) -addBlock chainDB punish blk = do - promise <- addBlockAsync chainDB punish blk +addBlock :: + IOLike m => + ChainDB m blk -> + InvalidBlockPunishment m -> + WithOrigin SlotNo -> + blk -> + m (AddBlockResult blk) +addBlock chainDB punish predSlot blk = do + promise <- addBlockAsync chainDB punish predSlot blk atomically $ blockProcessed promise -- | Add a block synchronously. Variant of 'addBlock' that doesn't return the -- new tip of the ChainDB. -- -- Note: this is a partial function, only to support tests. -addBlock_ :: IOLike m => ChainDB m blk -> InvalidBlockPunishment m -> blk -> m () -addBlock_ = void ..: addBlock +addBlock_ :: + IOLike m => ChainDB m blk -> InvalidBlockPunishment m -> WithOrigin SlotNo -> blk -> m () +addBlock_ cdb punish predSlot = void . addBlock cdb punish predSlot -- | Alias for naming consistency. -- The short name was chosen to avoid a larger diff from alignment changes. @@ -639,14 +648,19 @@ toChain chainDB = withRegistry $ \registry -> fromChain :: forall m blk. - IOLike m => + (IOLike m, HasHeader blk) => m (ChainDB m blk) -> Chain blk -> m (ChainDB m blk) fromChain openDB chain = do chainDB <- openDB - mapM_ (addBlock_ chainDB noPunishment) $ Chain.toOldestFirst chain + -- Adding a whole chain oldest-first, so each block's predecessor is the one + -- added just before it. + mapM_ (uncurry (addBlock_ chainDB noPunishment)) $ + zip (Origin : map (NotOrigin . blockSlot) blks) blks return chainDB + where + blks = Chain.toOldestFirst chain {------------------------------------------------------------------------------- Iterator API diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index 4dbd452311..bde104a643 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -61,7 +61,7 @@ import NoThunks.Class import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract -import Ouroboros.Consensus.HeaderValidation (mkHeaderWithTime) +import Ouroboros.Consensus.HeaderValidation (mkHeadersWithTime) import Ouroboros.Consensus.Ledger.Extended (ledgerState) import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) @@ -249,11 +249,9 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do -- the volatile tip ledger state can translate the slots of the volatile -- headers chainWithTime = - AF.mapAnchoredFragment - ( mkHeaderWithTime - lcfg - (ledgerState curLedger) - ) + mkHeadersWithTime + lcfg + (ledgerState curLedger) chain varChain <- newTVarWithInvariantIO checkInternalChain $ InternalChain chain chainWithTime @@ -304,7 +302,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do h <- fmap CDBHandle $ newTVarIO $ ChainDbOpen env let chainDB = API.ChainDB - { addBlockAsync = getEnv2 h ChainSel.addBlockAsync + { addBlockAsync = getEnv3 h ChainSel.addBlockAsync , chainSelAsync = getEnv h ChainSel.triggerChainSelectionAsync , getCurrentChain = getEnvSTM h Query.getCurrentChain , getCurrentChainWithTime = getEnvSTM h Query.getCurrentChainWithTime diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index 6765c89814..7619e8aeff 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -68,7 +68,7 @@ import Ouroboros.Consensus.HardFork.Abstract import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.HeaderValidation ( HeaderWithTime (..) - , mkHeaderWithTime + , mkHeadersWithTime ) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended @@ -313,6 +313,7 @@ addBlockAsync :: (IOLike m, HasHeader blk) => ChainDbEnv m blk -> InvalidBlockPunishment m -> + WithOrigin SlotNo -> blk -> m (AddBlockPromise m blk) addBlockAsync CDB{cdbTracer, cdbChainSelQueue} = @@ -1053,12 +1054,11 @@ switchTo CDB{..} weights triggerPt chainDiff reason = MkSuccessForkerAction $ \f diffWithTime = -- the new ledger state can translate the slots of the new -- headers - Diff.map - ( mkHeaderWithTime - lcfg - (ledgerState newLedger) - ) - chainDiff + ChainDiff (Diff.getRollback chainDiff) $ + mkHeadersWithTime + lcfg + (ledgerState newLedger) + (Diff.getSuffix chainDiff) newChainWithTime = case Diff.apply curChainWithTime diffWithTime of Nothing -> error "chainDiff failed for HeaderWithTime" diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index 1c3e25b103..4d12b5d3cb 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -28,6 +28,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Types , getEnv , getEnv1 , getEnv2 + , getEnv3 , getEnvTrans2 , getEnvSTM , getEnvSTM1 @@ -214,6 +215,17 @@ getEnv2 :: m r getEnv2 h f a b = getEnv h (\env -> f env a b) +-- | Variant of getEnv for functions taking three arguments. +getEnv3 :: + (IOLike m, HasCallStack, HasHeader blk) => + ChainDbHandle m blk -> + (ChainDbEnv m blk -> a -> b -> c -> m r) -> + a -> + b -> + c -> + m r +getEnv3 h f a b c = getEnv h (\env -> f env a b c) + -- | Variant 'of 'getEnv' for functions taking two arguments. getEnvTrans2 :: (IOLike m, HasCallStack, HasHeader blk) => @@ -595,6 +607,11 @@ data BlockToAdd m blk = BlockToAdd { blockPunish :: !(InvalidBlockPunishment m) -- ^ Executed immediately upon determining this block or one from its prefix -- is invalid. + , blockPredecessorSlot :: !(WithOrigin SlotNo) + -- ^ The slot of this block's predecessor. + -- + -- Leios uses this to validate the certificate in a CertRB /before/ chain + -- selection, which is necessary for The Recovery Path. , blockToAdd :: !blk , varBlockWrittenToDisk :: !(StrictTMVar m Bool) -- ^ Used for the 'blockWrittenToDisk' field of 'AddBlockPromise'. @@ -639,14 +656,16 @@ addBlockToAdd :: Tracer m (TraceAddBlockEvent blk) -> ChainSelQueue m blk -> InvalidBlockPunishment m -> + WithOrigin SlotNo -> blk -> m (AddBlockPromise m blk) -addBlockToAdd tracer (ChainSelQueue{varChainSelQueue, varChainSelPoints}) punish blk = do +addBlockToAdd tracer (ChainSelQueue{varChainSelQueue, varChainSelPoints}) punish predSlot blk = do varBlockWrittenToDisk <- newEmptyTMVarIO varBlockProcessed <- newEmptyTMVarIO let !toAdd = BlockToAdd { blockPunish = punish + , blockPredecessorSlot = predSlot , blockToAdd = blk , varBlockWrittenToDisk , varBlockProcessed diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Init.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Init.hs index 65525d0de5..ac3b5dee20 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Init.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Init.hs @@ -10,6 +10,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Init , map ) where +import Ouroboros.Consensus.Block (SlotNo, WithOrigin) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) @@ -20,8 +21,8 @@ import Prelude hiding (map) -- | Restricted interface to the 'ChainDB' used on node initialization data InitChainDB m blk = InitChainDB - { addBlock :: blk -> m () - -- ^ Add a block to the DB + { addBlock :: WithOrigin SlotNo -> blk -> m () + -- ^ Add a block to the DB, given the slot of its predecessor , getCurrentLedger :: m (LedgerState blk EmptyMK) -- ^ Return the current ledger state } @@ -45,6 +46,6 @@ map :: InitChainDB m blk' map f g db = InitChainDB - { addBlock = addBlock db . f + { addBlock = \predSlot -> addBlock db predSlot . f , getCurrentLedger = g <$> getCurrentLedger db } diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Header.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Header.hs index f8b019d23a..cb5e5f252a 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Header.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Header.hs @@ -10,7 +10,12 @@ module Test.Util.Header import Cardano.Slotting.EpochInfo.API (epochInfoSlotToRelativeTime) import Data.Functor.Identity (runIdentity) import Data.Typeable (Typeable) -import Ouroboros.Consensus.Block (Header, blockSlot) +import Ouroboros.Consensus.Block + ( Header + , SlotNo + , WithOrigin (NotOrigin) + , blockSlot + ) import Ouroboros.Consensus.Config (TopLevelConfig) import Ouroboros.Consensus.HardFork.Combinator.Abstract ( ImmutableEraParams @@ -38,18 +43,28 @@ attachSlotTimeToFragment :: TopLevelConfig blk -> AnchoredFragment (Header blk) -> AnchoredFragment (HeaderWithTime blk) -attachSlotTimeToFragment cfg = AF.mapAnchoredFragment (attachSlotTime cfg) +attachSlotTimeToFragment cfg frag = + AF.fromOldestFirst (AF.castAnchor (AF.anchor frag)) $ + zipWith + (attachSlotTime cfg) + (AF.anchorToSlotNo (AF.anchor frag) : map (NotOrigin . blockSlot) hdrs) + hdrs + where + hdrs = AF.toOldestFirst frag attachSlotTime :: (AF.HasHeader (Header blk), ImmutableEraParams blk) => TopLevelConfig blk -> + -- | The slot of the header's predecessor + WithOrigin SlotNo -> Header blk -> HeaderWithTime blk -attachSlotTime cfg hdr = +attachSlotTime cfg predSlot hdr = HeaderWithTime { hwtHeader = hdr , hwtSlotRelativeTime = runIdentity $ epochInfoSlotToRelativeTime ei (blockSlot hdr) + , hwtPredecessorSlot = predSlot } where ei = immutableEpochInfo cfg diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs index 9bbf4f156e..11cbe042b0 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs @@ -94,7 +94,7 @@ import Test.Tasty import Test.Tasty.QuickCheck import Test.Util.ChainDB import Test.Util.ChainUpdates -import Test.Util.Header (attachSlotTime) +import Test.Util.Header (attachSlotTimeToFragment) import Test.Util.LogicalClock (Tick (..)) import qualified Test.Util.LogicalClock as LogicalClock import Test.Util.Orphans.IOLike () @@ -169,7 +169,9 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do blockFetchConsensusInterface = mkTestBlockFetchConsensusInterface ( Map.map - (AF.mapAnchoredFragment (attachSlotTime topLevelConfig . getHeader)) + ( attachSlotTimeToFragment topLevelConfig + . AF.mapAnchoredFragment getHeader + ) <$> getCandidates ) chainDbView @@ -323,7 +325,12 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do mkTestBlockFetchConsensusInterface :: STM m (Map PeerId (AnchoredFragment (HeaderWithTime TestBlock))) -> BlockFetchClientInterface.ChainDbView m TestBlock -> - BlockFetchConsensusInterface PeerId (HeaderWithTime TestBlock) TestBlock m + BlockFetchConsensusInterface + PeerId + (HeaderWithTime TestBlock) + TestBlock + (BlockFetchClientInterface.MatchedBlock TestBlock) + m mkTestBlockFetchConsensusInterface getCandidates chainDbView = ( BlockFetchClientInterface.mkBlockFetchConsensusInterface @m @PeerId nullTracer diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs index 7d98a325b0..2bb7f6baf4 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs @@ -24,7 +24,6 @@ import Control.Monad (forever) import Control.Monad.IOSim (runSimOrThrow) import Control.ResourceRegistry import Control.Tracer (Tracer (..), contramapM, mkTracer, traceWith) -import Data.Foldable (for_) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) @@ -159,11 +158,20 @@ runFollowerPromptnessTest FollowerPromptnessTestSetup{..} = withRegistry \regist Chain.AddBlock hdrHash -> addTiming varFollowerInstrTimings hdrHash Chain.RollBack _ -> pure () - -- Add all blocks to the ChainDB. - let addBlock = ChainDB.addBlock_ chainDB Punishment.noPunishment - for_ chainUpdates \case - AddBlock blk -> addBlock blk - SwitchFork _ blks -> for_ blks addBlock + -- Add all blocks to the ChainDB, each with its predecessor's slot: the + -- previous block of the same update, or else the tip the update extends. + let addBlocks tipSlot = \case + [] -> pure tipSlot + blk : blks -> do + ChainDB.addBlock_ chainDB Punishment.noPunishment tipSlot blk + addBlocks (NotOrigin (blockSlot blk)) blks + addUpdates tipSlot = \case + [] -> pure () + AddBlock blk : upds -> + addBlocks tipSlot [blk] >>= \tipSlot' -> addUpdates tipSlot' upds + SwitchFork p blks : upds -> + addBlocks (pointSlot p) blks >>= \tipSlot' -> addUpdates tipSlot' upds + addUpdates Origin chainUpdates tentativeHeaderSetTimings <- readTVarIO varTentativeSetTimings tentativeHeaderUnsetTimings <- readTVarIO varTentativeUnsetTimings diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index ed219b333d..39c45cbaab 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs @@ -107,7 +107,7 @@ import Data.Word (Word16, Word64) import GHC.Generics (Generic) import qualified Generics.SOP as SOP import qualified LeiosDemoDb as LeiosDb -import LeiosDemoTypes (HasLeiosVoting) +import LeiosDemoTypes (HasLeiosVoting, TraceLeiosChainSel) import NoThunks.Class (AllowThunk (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime.WallClock.Types @@ -198,9 +198,15 @@ newtype Persistent a = Persistent {unPersistent :: a} -- | Commands data Cmd blk it flr - = -- | Add a block, with (possibly) some gap blocks leading to it. + = -- | Add a block, with the slot of its predecessor and (possibly) some gap + -- blocks leading to it. + -- + -- The generator supplies the predecessor's slot because it knows it even + -- when the predecessor is a gap block that was never added, just as the + -- real node knows it from the header that incurred the fetch request. + -- -- For more information about gap blocks, refer to 'GenState' below. - AddBlock blk (Persistent [blk]) + AddBlock blk (WithOrigin SlotNo) (Persistent [blk]) | -- | Add a Peras cert for a block, with (possibly) some gap blocks leading to it. -- For more information about gap blocks, refer to 'GenState' below. AddPerasCert (WithArrivalTime (ValidatedPerasCert blk)) (Persistent [blk]) @@ -444,7 +450,7 @@ run :: m (Success blk (TestIterator m blk) (TestFollower m blk)) run cfg env@ChainDBEnv{varDB, ..} cmd = readTVarIO varDB >>= \st@ChainDBState{chainDB = chainDB@ChainDB{..}, internal} -> case cmd of - AddBlock blk _ -> Point <$> advanceAndAdd st blk + AddBlock blk predSlot _ -> Point <$> advanceAndAdd st predSlot blk AddPerasCert cert _ -> Unit <$> addPerasCertSync chainDB cert GetCurrentChain -> Chain <$> atomically getCurrentChain GetTipBlock -> MbBlock <$> getTipBlock @@ -478,10 +484,11 @@ run cfg env@ChainDBEnv{varDB, ..} cmd = follower = fmap Flr . giveWithEq ignore _ = Unit () - advanceAndAdd :: ChainDBState m blk -> blk -> m (Point blk) - advanceAndAdd ChainDBState{chainDB} blk = do + advanceAndAdd :: + ChainDBState m blk -> WithOrigin SlotNo -> blk -> m (Point blk) + advanceAndAdd ChainDBState{chainDB} predSlot blk = do -- `blockProcessed` always returns 'Just' - res <- addBlock chainDB InvalidBlockPunishment.noPunishment blk + res <- addBlock chainDB InvalidBlockPunishment.noPunishment predSlot blk return $ case res of FailedToAddBlock f -> error $ "advanceAndAdd: block not added - " ++ f SuccesfullyAddedBlock pt -> pt @@ -701,7 +708,7 @@ runPure :: DBModel blk -> (Resp blk IteratorId FollowerId, DBModel blk) runPure cfg = \case - AddBlock blk _ -> ok Point $ update (add blk) + AddBlock blk _ _ -> ok Point $ update (add blk) AddPerasCert cert _ -> ok Unit $ ((),) . update (Model.addPerasCert cfg cert) GetCurrentChain -> ok Chain $ query (Model.volatileChain k getHeader) GetTipBlock -> ok MbBlock $ query Model.tipBlock @@ -874,6 +881,14 @@ data GenState blk -- 'genAddPerasCert'. We don't want to discard these because they can be used -- to fill gaps between existing blocks added via 'AddBlock', simulating -- blocks and certificates arriving out of order. + , generatedSlots :: Map (HeaderHash blk) SlotNo + -- ^ The slot of every block ever generated, so that 'genAddBlock' can supply + -- a block's predecessor slot. + -- + -- Never pruned, unlike the model's own stores: garbage collection drops a + -- block from the VolatileDB, and only a block that was copied reaches the + -- ImmutableDB, so 'Model.blocks' can lose a predecessor that a later + -- generated block still names. } deriving Generic @@ -889,6 +904,7 @@ emptyGenState :: GenState blk emptyGenState = GenState { seenBlocks = Map.empty + , generatedSlots = Map.empty } -- | Use the extra state stored in a generated command to update a model's @@ -900,8 +916,8 @@ updateGenState :: GenState blk updateGenState cmd gs = case unAt cmd of - AddBlock _ (Persistent blks) -> saveSeenBlocks blks gs - AddPerasCert _ (Persistent blks) -> saveSeenBlocks blks gs + AddBlock blk _ (Persistent blks) -> saveSeenBlocks blks $ saveSlots (blk : blks) gs + AddPerasCert _ (Persistent blks) -> saveSeenBlocks blks $ saveSlots blks gs _ -> gs where saveSeenBlocks blks gs' = @@ -912,6 +928,14 @@ updateGenState cmd gs = (seenBlocks gs') } + saveSlots blks gs' = + gs' + { generatedSlots = + Map.union + (Map.fromList [(blockHash blk, blockSlot blk) | blk <- blks]) + (generatedSlots gs') + } + -- | Execution model data Model blk m r = Model { dbModel :: DBModel blk @@ -1224,7 +1248,25 @@ generator loe genBlock m@Model{..} = genAddBlock :: Gen (Cmd blk it flr) genAddBlock = do (blk, gapBlks) <- genBlock m - pure $ AddBlock blk gapBlks + pure $ AddBlock blk (predecessorSlot gapBlks blk) gapBlks + + -- Every block the generators build sits on top of a block they have already + -- built, so its predecessor is either genesis or one of the blocks below, + -- even when it is a gap block that will never be added to the ChainDB or one + -- whose predecessor the model has since garbage-collected. + predecessorSlot :: Persistent [blk] -> blk -> WithOrigin SlotNo + predecessorSlot (Persistent gapBlks) blk = case blockPrevHash blk of + GenesisHash -> Origin + BlockHash h -> case Map.lookup h generated of + Nothing -> error "genAddBlock: predecessor was never generated" + Just predSlot -> NotOrigin predSlot + where + generated = + Map.union + -- The blocks this very call generated are not in 'generatedSlots' yet; + -- 'updateGenState' only sees the command once it is built. + (Map.fromList [(blockHash b, blockSlot b) | b <- gapBlks]) + (generatedSlots genState) genAddPerasCert :: Gen (Cmd blk it flr) genAddPerasCert = do @@ -1348,6 +1390,11 @@ shrinker :: shrinker _ = const [] -- TODO: implement the shrinker. Command -- 'PersistBlksThenGC' should be shrunk to -- ['PersistBlks'] +-- +-- TODO If the shrinker removes generated /blocks/ from the generated chains, +-- then the predecessor slots recorded in the 'AddBlock' commands might become +-- stale... but so would their hashes, so maybe the invariant on those two +-- fields isn't an additional problem. {------------------------------------------------------------------------------- The final state machine @@ -1552,6 +1599,8 @@ deriving instance SOP.Generic (TraceCopyToImmutableDBEvent blk) deriving instance SOP.HasDatatypeInfo (TraceCopyToImmutableDBEvent blk) deriving instance SOP.Generic (TraceValidationEvent blk) deriving instance SOP.HasDatatypeInfo (TraceValidationEvent blk) +deriving instance SOP.Generic (TraceLeiosChainSel blk) +deriving instance SOP.HasDatatypeInfo (TraceLeiosChainSel blk) deriving instance SOP.Generic (TraceInitChainSelEvent blk) deriving instance SOP.HasDatatypeInfo (TraceInitChainSelEvent blk) deriving instance SOP.Generic (TraceOpenEvent blk) @@ -2125,6 +2174,7 @@ traceEventName = \case PipeliningEvent{} -> "PipeliningEvent" ChangingSelection{} -> "ChangingSelection" TraceAddBlockCall{} -> "TraceAddBlockCall" + AddBlockLeiosEvent ev' -> "Leios." <> constrName ev' TraceFollowerEvent ev -> "Follower." <> constrName ev TraceCopyToImmutableDBEvent ev -> "CopyToImmutableDB." <> constrName ev TraceInitChainSelEvent ev -> diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs index bdad6c69c6..8b151a1468 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs @@ -33,6 +33,7 @@ import Control.Monad.Trans.Class (lift) import Control.ResourceRegistry (closeRegistry, unsafeNewRegistry) import Data.Maybe (isJust) import qualified LeiosDemoDb as LeiosDb +import Ouroboros.Consensus.Block (WithOrigin (NotOrigin, Origin)) import Ouroboros.Consensus.Block.RealPoint ( RealPoint (..) , blockRealPoint @@ -53,7 +54,13 @@ import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Storage.ImmutableDB.Chunks as ImmutableDB import Ouroboros.Consensus.Util.IOLike import qualified Ouroboros.Network.AnchoredFragment as AF -import Ouroboros.Network.Block (ChainUpdate (..), Point, blockPoint) +import Ouroboros.Network.Block + ( ChainUpdate (..) + , Point + , SlotNo + , blockPoint + , blockSlot + ) import qualified Ouroboros.Network.Mock.Chain as Mock import Test.Ouroboros.Storage.ChainDB.Model (Model) import qualified Test.Ouroboros.Storage.ChainDB.Model as Model @@ -137,14 +144,14 @@ followerSwitchesToNewChain :: followerSwitchesToNewChain = let fork i = TestBody i True Nothing in do - b1 <- addBlock $ firstBlock 0 $ fork 0 -- b1 on top of G - b2 <- addBlock $ mkNextBlock b1 1 $ fork 0 -- b2 on top of b1 + b1 <- addBlock Origin $ firstBlock 0 $ fork 0 -- b1 on top of G + b2 <- addBlock (NotOrigin (blockSlot b1)) $ mkNextBlock b1 1 $ fork 0 -- b2 on top of b1 f <- newFollower followerForward f [blockPoint b2] >>= \case Right (Just pt) -> assertEqual (blockPoint b2) pt "Expected to be at b2" _ -> failWith "Expecting a success" - b3 <- addBlock $ mkNextBlock b1 2 $ fork 1 -- b3 on top of b1 - b4 <- addBlock $ mkNextBlock b3 3 $ fork 1 -- b4 on top of b3 + b3 <- addBlock (NotOrigin (blockSlot b1)) $ mkNextBlock b1 2 $ fork 1 -- b3 on top of b1 + b4 <- addBlock (NotOrigin (blockSlot b3)) $ mkNextBlock b3 3 $ fork 1 -- b4 on top of b3 followerInstruction f >>= \case Right (Just (RollBack actual)) -> -- Expect to rollback to the intersection point between [b1, b2] and @@ -174,15 +181,15 @@ ouroboros_network_4183 :: ouroboros_network_4183 = let fork i = TestBody i True Nothing in do - b1 <- addBlock $ firstEBB (const True) $ fork 0 - b2 <- addBlock $ mkNextBlock b1 0 $ fork 0 - b3 <- addBlock $ mkNextBlock b2 1 $ fork 1 - b4 <- addBlock $ mkNextBlock b2 1 $ fork 0 + b1 <- addBlock Origin $ firstEBB (const True) $ fork 0 + b2 <- addBlock (NotOrigin (blockSlot b1)) $ mkNextBlock b1 0 $ fork 0 + b3 <- addBlock (NotOrigin (blockSlot b2)) $ mkNextBlock b2 1 $ fork 1 + b4 <- addBlock (NotOrigin (blockSlot b2)) $ mkNextBlock b2 1 $ fork 0 f <- newFollower void $ followerForward f [blockPoint b1] - void $ addBlock $ mkNextBlock b4 4 $ fork 0 + void $ addBlock (NotOrigin (blockSlot b4)) $ mkNextBlock b4 4 $ fork 0 persistBlks - void $ addBlock $ mkNextBlock b3 3 $ fork 1 + void $ addBlock (NotOrigin (blockSlot b3)) $ mkNextBlock b3 3 $ fork 1 followerInstruction f >>= \case Right (Just (RollBack actual)) -> assertEqual (blockPoint b1) actual "Rollback to wrong point" @@ -203,14 +210,14 @@ ouroboros_network_3999 :: ) => m () ouroboros_network_3999 = do - b1 <- addBlock $ firstBlock 0 $ fork 1 - b2 <- addBlock $ mkNextBlock b1 1 $ fork 1 - b3 <- addBlock $ mkNextBlock b2 2 $ fork 1 + b1 <- addBlock Origin $ firstBlock 0 $ fork 1 + b2 <- addBlock (NotOrigin (blockSlot b1)) $ mkNextBlock b1 1 $ fork 1 + b3 <- addBlock (NotOrigin (blockSlot b2)) $ mkNextBlock b2 2 $ fork 1 i <- streamAssertSuccess (inclusiveFrom b1) (inclusiveTo b3) - b4 <- addBlock $ mkNextBlock b1 3 $ fork 2 - b5 <- addBlock $ mkNextBlock b4 4 $ fork 2 - b6 <- addBlock $ mkNextBlock b5 5 $ fork 2 - void $ addBlock $ mkNextBlock b6 6 $ fork 2 + b4 <- addBlock (NotOrigin (blockSlot b1)) $ mkNextBlock b1 3 $ fork 2 + b5 <- addBlock (NotOrigin (blockSlot b4)) $ mkNextBlock b4 4 $ fork 2 + b6 <- addBlock (NotOrigin (blockSlot b5)) $ mkNextBlock b5 5 $ fork 2 + void $ addBlock (NotOrigin (blockSlot b6)) $ mkNextBlock b6 6 $ fork 2 persistBlksThenGC -- The block b1 is part of the current chain, so should always be returned. @@ -248,9 +255,9 @@ waitForImmutableBlock_existingBlock :: forall m. (Block m ~ TestBlock, SupportsUnitTest m, MonadError TestFailure m) => m () waitForImmutableBlock_existingBlock = do -- add three blocks, as @k@ is set to 2 in these test - b1 <- addBlock $ firstBlock 0 $ fork0 - b2 <- addBlock $ mkNextBlock b1 1 $ fork0 - _b3 <- addBlock $ mkNextBlock b2 2 $ fork0 + b1 <- addBlock Origin $ firstBlock 0 $ fork0 + b2 <- addBlock (NotOrigin (blockSlot b1)) $ mkNextBlock b1 1 $ fork0 + _b3 <- addBlock (NotOrigin (blockSlot b2)) $ mkNextBlock b2 2 $ fork0 -- copy the blocks older than @k@ into ImmutableDB, -- should copy only b1 persistBlks @@ -274,9 +281,9 @@ waitForImmutableBlock_existingBlockConcurrent = do addBlocksConcurrently :: m () addBlocksConcurrently = do -- add three blocks, as @k@ is set to 2 in these test - b1 <- addBlock $ firstBlock 0 $ fork0 - b2 <- addBlock $ mkNextBlock b1 1 $ fork0 - _b3 <- addBlock $ mkNextBlock b2 2 $ fork0 + b1 <- addBlock Origin $ firstBlock 0 $ fork0 + b2 <- addBlock (NotOrigin (blockSlot b1)) $ mkNextBlock b1 1 $ fork0 + _b3 <- addBlock (NotOrigin (blockSlot b2)) $ mkNextBlock b2 2 $ fork0 -- copy the blocks older than @k@ into ImmutableDB, -- should copy only b1 persistBlks @@ -290,10 +297,10 @@ waitForImmutableBlock_wrongHash :: forall m. (Block m ~ TestBlock, SupportsUnitTest m, MonadError TestFailure m) => m () waitForImmutableBlock_wrongHash = do -- add four blocks, as @k@ is set to 2 in these test - b1 <- addBlock $ firstBlock 0 $ fork0 - b2 <- addBlock $ mkNextBlock b1 1 $ fork0 - b3 <- addBlock $ mkNextBlock b2 2 $ fork0 - _b4 <- addBlock $ mkNextBlock b3 3 $ fork0 + b1 <- addBlock Origin $ firstBlock 0 $ fork0 + b2 <- addBlock (NotOrigin (blockSlot b1)) $ mkNextBlock b1 1 $ fork0 + b3 <- addBlock (NotOrigin (blockSlot b2)) $ mkNextBlock b2 2 $ fork0 + _b4 <- addBlock (NotOrigin (blockSlot b3)) $ mkNextBlock b3 3 $ fork0 -- copy the blocks older than @k@ into ImmutableDB, -- should copy only b1 and b2 persistBlks @@ -313,10 +320,10 @@ waitForImmutableBlock_emptySlot :: forall m. (Block m ~ TestBlock, SupportsUnitTest m, MonadError TestFailure m) => m () waitForImmutableBlock_emptySlot = do -- add four blocks, as @k@ is set to 2 in these test - b1 <- addBlock $ firstBlock 1 $ fork0 - b2 <- addBlock $ mkNextBlock b1 2 $ fork0 - b3 <- addBlock $ mkNextBlock b2 3 $ fork0 - _b4 <- addBlock $ mkNextBlock b3 4 $ fork0 + b1 <- addBlock Origin $ firstBlock 1 $ fork0 + b2 <- addBlock (NotOrigin (blockSlot b1)) $ mkNextBlock b1 2 $ fork0 + b3 <- addBlock (NotOrigin (blockSlot b2)) $ mkNextBlock b2 3 $ fork0 + _b4 <- addBlock (NotOrigin (blockSlot b3)) $ mkNextBlock b3 4 $ fork0 -- copy the blocks older than @k@ into ImmutableDB, -- should copy only b1 persistBlks @@ -406,7 +413,8 @@ class SupportsUnitTest m where type Block m addBlock :: - Block m -> m (Block m) + -- | The slot of the block's predecessor + WithOrigin SlotNo -> Block m -> m (Block m) newFollower :: m (FollowerId m) @@ -507,8 +515,8 @@ instance SM.MbChainUpdate mcu -> pure (Right mcu) _ -> failWith $ "followerInstruction: unexpected result" <> show result - addBlock blk = do - void $ runModelCmd (SM.AddBlock blk (SM.Persistent [])) + addBlock predSlot blk = do + void $ runModelCmd (SM.AddBlock blk predSlot (SM.Persistent [])) pure blk followerForward followerId points = do @@ -649,8 +657,8 @@ instance (IOLike m, TestConstraints blk) => SupportsUnitTest (SystemM blk m) whe type FollowerId (SystemM blk m) = SM.TestFollower m blk type Block (SystemM blk m) = blk - addBlock blk = do - void $ runCmd (SM.AddBlock blk (SM.Persistent [])) + addBlock predSlot blk = do + void $ runCmd (SM.AddBlock blk predSlot (SM.Persistent [])) pure blk persistBlks = From 0217d4f2ba7093564113f2413cbec984caa2c9be Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Wed, 9 Sep 2026 16:58:45 -0400 Subject: [PATCH 05/60] ChainSel: add precheckLeiosCert Fixes https://github.com/input-output-hk/ouroboros-leios/issues/1071 Thus, the node will never pipeline the header of a CertRB when its cert's claim is false. It's still possible for the header to be pipelined even if the cert is invalid, but only if it's an invalid cert making a claim we have already evidenced by a (different) (valid) cert. --- .../Consensus/Shelley/Ledger/Ledger.hs | 15 ++ ouroboros-consensus.cabal | 1 + .../src/ouroboros-consensus/LeiosDemoTypes.hs | 40 ++++ .../ouroboros-consensus/LeiosValidClaims.hs | 88 ++++++++ .../Consensus/HardFork/Combinator/Leios.hs | 22 +- .../Consensus/Storage/ChainDB/Impl.hs | 3 + .../Storage/ChainDB/Impl/Background.hs | 22 ++ .../Storage/ChainDB/Impl/ChainSel.hs | 201 ++++++++++++++++-- .../Consensus/Storage/ChainDB/Impl/Types.hs | 17 ++ 9 files changed, 388 insertions(+), 21 deletions(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/LeiosValidClaims.hs diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index 1678423d16..e02e5dbf6a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -135,6 +135,8 @@ import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch) import Ouroboros.Consensus.Protocol.Praos (Praos, PraosWithLeios) +import Ouroboros.Consensus.Protocol.Praos.Common (StrictMaybeLeios (SJustLeios)) +import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Eras ( AllegraEra @@ -1055,3 +1057,16 @@ instance HasLeiosVoting (ShelleyBlock (PraosWithLeios c) DijkstraEra) where ^. ppLeiosQuorumStakeThresholdL -- TODO: Use UnitInterval further upstream & unboundRational + + -- The forecast counterpart of the two accessors above. Reading them from the + -- view rather than the state is what lets ChainSel validate a CertRB's + -- certificate before it has applied the block's predecessor. + -- + -- 'SNothingLeios' is unreachable at this extension, so this is total. + getLeiosCommitteeFromView _ lv = + case Views.plvLeios lv of + SJustLeios llv -> + Just + ( Views.llvCommittee llv + , unboundRational (Views.llvQuorumStakeThreshold llv) + ) diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index cdf4417b29..cca0d1522f 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -119,6 +119,7 @@ library LeiosTxCache.Reference LeiosUtils.CallTrace LeiosUtils.TimeBoundedLoop + LeiosValidClaims LeiosVoteState LeiosVoting Ouroboros.Consensus.Block diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs index 698cdc9597..5221cbb415 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs @@ -128,12 +128,14 @@ import LeiosUtils.CallTrace (SomeJsonCallTrace (..), callTraceToObject) import Lens.Micro ((^.)) import NoThunks.Class (OnlyCheckWhnfNamed (..)) import qualified Numeric +import Ouroboros.Consensus.Block.Abstract (BlockProtocol) import Ouroboros.Consensus.Ledger.Basics (EmptyMK, LedgerConfig, LedgerState) import Ouroboros.Consensus.Ledger.SupportsMempool ( ByteSize32 (..) , TxMeasureMetrics , txMeasureMetricTxSizeBytes ) +import Ouroboros.Consensus.Protocol.Abstract (LedgerView) import Ouroboros.Consensus.Util (ShowProxy (..)) import Ouroboros.Consensus.Util.IOLike (IOLike, NoThunks) import Ouroboros.Network.PeerSelection.LedgerPeers.Type @@ -1321,6 +1323,28 @@ data LeiosExtValidationError LeiosCertificateAfterGenesis !LeiosCert !LeiosPoint | -- | The certificate failed committee / threshold / signature verification. LeiosInvalidCertificate !LeiosCert !LeiosPoint !RbHash !VerificationError + | -- | ChainSel's forecast-based check rejected the CertRB before chain + -- selection reached it. + -- + -- That check runs before the announcing block's ledger state exists, so + -- unlike the constructors above it cannot report which EB was announced. + LeiosCertificateForecastRejected + !LeiosCert + -- | The slot of the CertRB's predecessor, ie of the announcing block + -- The CertRB's own point is already on the enclosing tracer event. + !(WithOrigin SlotNo) + !LeiosForecastRejection + deriving stock (Eq, Show, Generic) + +-- | Why ChainSel's forecast-based check rejected a CertRB. +data LeiosForecastRejection + = -- | The CertRB's predecessor is genesis, so it would certify at genesis. + LeiosForecastAfterGenesis + | -- | The forecast view has no Leios committee or no quorum threshold. A + -- CertRB in such an era is itself a protocol violation. + LeiosForecastMissingCommittee !RbHash + | -- | The certificate failed committee / threshold / signature verification. + LeiosForecastInvalidCertificate !RbHash !VerificationError deriving stock (Eq, Show, Generic) deriving via @@ -1345,6 +1369,22 @@ class HasLeiosVoting blk where -- 'Nothing' if the protocol parameter does not yet exist on the current era. getCurrentThreshold :: LedgerState blk EmptyMK -> Maybe Weight + -- | The committee and quorum threshold according to a /forecast/ ledger view + -- rather than an applied ledger state. + -- + -- ChainSel validates the certificate in a CertRB before it has applied that + -- block's predecessor, so it has no ledger state to read the committee off; + -- it forecasts the view instead. The two must agree wherever both are + -- available: this is the same committee 'getLeiosCommittee' would return for + -- a state at the forecast slot. + -- The proxy fixes the block type: 'LedgerView' is a non-injective family, so + -- the view alone does not determine it. + getLeiosCommitteeFromView :: + proxy blk -> + LedgerView (BlockProtocol blk) -> + Maybe (LeiosCommittee, Weight) + getLeiosCommitteeFromView _ _ = Nothing + -- | Slots that must elapse between an EB's announcement and the block that -- may certify it, per 'minCertificationGap'. Reading it needs the era's -- protocol parameters and its slot length, both of which only the era's diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosValidClaims.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosValidClaims.hs new file mode 100644 index 0000000000..50cf5ca820 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosValidClaims.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | The set of 'RbHash'es we have seen a valid Leios certificate for. +-- +-- A CertRB claims that the endorser block announced by its predecessor is +-- certified; the claim is identified by the announcing block's 'RbHash', which +-- is the CertRB's prev-hash. Verifying a certificate is somewhat expensive, and +-- several CertRBs can make the same claim, so a claim is verified at most once. +-- +-- Only /positive/ verdicts are recorded. A negative verdict is not cached: +-- there are unboundedly many invalid certificates that could make a given +-- claim, and another certificate making the same claim may well be valid. +module LeiosValidClaims + ( ValidClaims + , emptyValidClaims + , insertValidClaim + , memberValidClaim + , pruneValidClaims + , sizeValidClaims + ) where + +import Cardano.Slotting.Slot (SlotNo) +import qualified Data.Foldable +import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Strict (Map) +import Data.Set.NonEmpty (NESet) +import qualified Data.Set.NonEmpty as NESet +import GHC.Generics (Generic) +import LeiosDemoTypes (RbHash) +import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) + +-- | Claims known to be certified, indexed both by claim and by the slot of the +-- announcing block, the latter so that pruning is a range operation. +-- +-- INVARIANT: the halves agree --- @slotOfClaim ! r == s@ iff @r@ occurs in +-- @claimsBySlot ! s@. +data ValidClaims + = MkValidClaims + { slotOfClaim :: !(Strict.Map RbHash SlotNo) + , claimsBySlot :: !(Strict.Map SlotNo (NESet RbHash)) + } + deriving stock (Show, Generic) + +deriving via + OnlyCheckWhnfNamed "ValidClaims" ValidClaims + instance + NoThunks ValidClaims + +emptyValidClaims :: ValidClaims +emptyValidClaims = MkValidClaims Map.empty Map.empty + +-- | Record that this claim is certified, as of the slot of the block that +-- announced the EB. +insertValidClaim :: SlotNo -> RbHash -> ValidClaims -> ValidClaims +insertValidClaim slot rbHash vc + | Map.member rbHash (slotOfClaim vc) = vc + | otherwise = + MkValidClaims + { slotOfClaim = Map.insert rbHash slot (slotOfClaim vc) + , claimsBySlot = + Map.insertWith (<>) slot (NESet.singleton rbHash) (claimsBySlot vc) + } + +memberValidClaim :: RbHash -> ValidClaims -> Bool +memberValidClaim rbHash = Map.member rbHash . slotOfClaim + +-- | Forget every claim announced strictly before the given slot. +-- +-- Called whenever the ChainDB's immutable tip advances: a claim announced below +-- the immutable tip can no longer be the subject of a block we might select. +-- The comparison is strict so that the immutable tip's own announcement +-- survives. +pruneValidClaims :: SlotNo -> ValidClaims -> ValidClaims +pruneValidClaims immTipSlot vc = + MkValidClaims + { slotOfClaim = Data.Foldable.foldl' dropSlot (slotOfClaim vc) pruned + , claimsBySlot = claimsBySlot' + } + where + (pruned, claimsBySlot') = Map.spanAntitone (< immTipSlot) (claimsBySlot vc) + + dropSlot fwd rs = Data.Foldable.foldl' (flip Map.delete) fwd rs + +sizeValidClaims :: ValidClaims -> Int +sizeValidClaims = Map.size . slotOfClaim diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Leios.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Leios.hs index 7149192dd8..b680e8084b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Leios.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Leios.hs @@ -28,12 +28,18 @@ import Ouroboros.Consensus.HardFork.Combinator.Basics , distribLedgerConfig ) import Ouroboros.Consensus.HardFork.Combinator.Protocol () +import Ouroboros.Consensus.HardFork.Combinator.Protocol.LedgerView + ( HardForkLedgerView_ (HardForkLedgerView) + ) import qualified Ouroboros.Consensus.HardFork.Combinator.State as State import Ouroboros.Consensus.HardFork.Combinator.State.Types ( Current (..) , HardForkState (..) ) -import Ouroboros.Consensus.TypeFamilyWrappers (WrapLedgerConfig (..)) +import Ouroboros.Consensus.TypeFamilyWrappers + ( WrapLedgerConfig (..) + , WrapLedgerView (..) + ) -- | Dispatch to the active era of a hard-fork chain. Requires every era in -- the @xs@ list to have a 'HasLeiosVoting' instance. @@ -57,6 +63,20 @@ instance (\(Current _ (Flip ls)) -> K (getCurrentThreshold ls)) (Telescope.tip tele) + -- As above, but dispatching on the per-era ledger /view/ the protocol layer + -- carries instead of the ledger state. + getLeiosCommitteeFromView _ (HardForkLedgerView _transition (HardForkState tele)) = + hcollapse $ + hcmap + (Proxy @HasLeiosVoting) + (\(Current _ wlv) -> K (getLeiosCommitteeFromView (eraProxy wlv) (unwrapLedgerView wlv))) + (Telescope.tip tele) + where + -- The wrapper is a newtype, hence injective, so matching on it is what + -- recovers the era that the non-injective 'LedgerView' loses. + eraProxy :: WrapLedgerView blk -> Proxy blk + eraProxy _ = Proxy + -- Unlike the other two, this one needs the era's config as well as its -- state, and the combinator only stores partial configs -- hence completing -- them against an 'EpochInfo' reconstructed from the very state we are diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index bde104a643..784938ac6e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -57,6 +57,7 @@ import LeiosDemoTypes , acquiredLeiosEbHashes , acquiredLeiosEbsFromList ) +import LeiosValidClaims (emptyValidClaims) import NoThunks.Class import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config @@ -229,6 +230,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do (fromWithOrigin (SlotNo 0) (pointSlot immutableDbTipPoint)) varAcquiredLeiosEbs <- newTVarIO (acquiredLeiosEbsFromList initialAcquiredLeiosEbs) + varLeiosValidClaims <- newTVarIO emptyValidClaims chain <- ChainSel.initialChainSelection immutableDB @@ -291,6 +293,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do , cdbChainSelQueue = chainSelQueue , cdbLoE = Args.cdbsLoE cdbSpecificArgs , cdbAcquiredLeiosEbs = varAcquiredLeiosEbs + , cdbLeiosValidClaims = varLeiosValidClaims , cdbLeiosDb = Args.cdbsLeiosDb cdbSpecificArgs , cdbLeiosEvictTxCache = Args.cdbsLeiosEvictTxCache cdbSpecificArgs , cdbChainSelStarvation = varChainSelStarvation diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs index 40d0d9fab5..619e572202 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs @@ -74,6 +74,7 @@ import LeiosUtils.CallTrace , rootCallCtx ) import qualified LeiosUtils.CallTrace as CallTrace +import qualified LeiosValidClaims import Ouroboros.Consensus.Block import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.Ledger.Inspect @@ -110,6 +111,8 @@ launchBgTasks :: , BlockSupportsDiffusionPipelining blk , InspectLedger blk , HasHardForkHistory blk + , LedgerDB.ResolveLeiosBlock blk + , LeiosDemoTypes.HasLeiosVoting blk ) => ChainDbEnv m blk -> -- | Number of immutable blocks replayed on ledger DB startup @@ -372,6 +375,7 @@ copyToImmutableDBRunner cdb@CDB{..} ledgerDbTasksTrigger gcSchedule = do -- so the set stops advertising a closure well before that closure can be -- evicted. pruneAcquiredLeiosEbs cdb gcSlotNo + pruneLeiosValidClaims cdb gcSlotNo scheduleGC' gcSlotNo scheduleGC' :: WithOrigin SlotNo -> m () @@ -521,6 +525,22 @@ pruneAcquiredLeiosEbs CDB{..} immTip = atomically $ do (writeTVar cdbAcquiredLeiosEbs) (LeiosDemoTypes.pruneAcquiredLeiosEbs immTip acquired) +-- | Prune the verified-claim set by age as a VolatileDB GC is scheduled, +-- dropping every claim announced strictly before the immutable tip. +-- +-- New CertRBs younger than than the immutable tip /could/ arrive that make a +-- claim equal to one we've already pruned. But the ChainSel logic already skips +-- those, since the CertRB is not actionable: switching to it would require +-- rolling back (at least) our immutable tip. +pruneLeiosValidClaims :: + IOLike m => ChainDbEnv m blk -> WithOrigin SlotNo -> m () +pruneLeiosValidClaims CDB{..} immTip = case immTip of + Origin -> pure () + NotOrigin immTipSlot -> + atomically $ + modifyTVar cdbLeiosValidClaims $ + LeiosValidClaims.pruneValidClaims immTipSlot + {------------------------------------------------------------------------------- Scheduling garbage collections -------------------------------------------------------------------------------} @@ -726,6 +746,8 @@ addBlockRunner :: , BlockSupportsDiffusionPipelining blk , InspectLedger blk , HasHardForkHistory blk + , LedgerDB.ResolveLeiosBlock blk + , LeiosDemoTypes.HasLeiosVoting blk , HasCallStack ) => Fuse m -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index 7619e8aeff..cf7bb9dfa6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -17,7 +17,8 @@ -- and @newTipSlotInEpoch@ and for that we need a @Summary@ which needs the -- header state that only the ExtLedgerState contains. module Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel - ( addBlockAsync + ( TentativeHeaderPermission (..) + , addBlockAsync , addPerasCertAsync , chainSelSync , chainSelectionForBlock @@ -31,7 +32,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel import Cardano.Ledger.BaseTypes (unNonZero) import Control.Exception (assert) import Control.Monad (forM_, join, void, when) -import Control.Monad.Except () +import Control.Monad.Except (runExcept) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict import Control.Tracer (Tracer, nullTracer, traceWith, (>$<)) @@ -51,14 +52,23 @@ import GHC.Stack (HasCallStack) import LeiosDemoTypes ( AcquiredLeiosEbsSet , EbHash + , HasLeiosVoting (getLeiosCommitteeFromView) + , LeiosExtValidationError (LeiosCertificateForecastRejected) + , LeiosForecastRejection + ( LeiosForecastAfterGenesis + , LeiosForecastInvalidCertificate + , LeiosForecastMissingCommittee + ) , acquiredLeiosEbHashes , acquiredLeiosEbsSetMember , pointEbHash + , verifyLeiosCert ) import LeiosUtils.CallTrace ( CallCtx , SomeJsonCallTrace (SomeJsonCallTrace) ) +import qualified LeiosValidClaims import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Config @@ -70,6 +80,7 @@ import Ouroboros.Consensus.HeaderValidation ( HeaderWithTime (..) , mkHeadersWithTime ) +import Ouroboros.Consensus.Forecast (Forecast (forecastAt, forecastFor)) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect @@ -280,6 +291,7 @@ initialChainSelection , varTentativeState , varTentativeHeader , punish = Nothing + , tentativeHeaderPermission = MayNotSetTentativeHeader , getTentativeFollowers = pure [] } @@ -347,6 +359,8 @@ chainSelSync :: , BlockSupportsDiffusionPipelining blk , InspectLedger blk , HasHardForkHistory blk + , ResolveLeiosBlock blk + , HasLeiosVoting blk , HasCallStack ) => ChainDbEnv m blk -> @@ -400,6 +414,8 @@ chainSelAddBlock :: , BlockSupportsDiffusionPipelining blk , InspectLedger blk , HasHardForkHistory blk + , ResolveLeiosBlock blk + , HasLeiosVoting blk , HasCallStack ) => ChainDbEnv m blk -> @@ -444,7 +460,24 @@ chainSelAddBlock cdb@CDB{..} _cctx BlockToAdd{blockToAdd = b, ..} = do encloseWith (traceEv >$< addBlockTracer) $ VolatileDB.putBlock cdbVolatileDB b lift $ deliverWrittenToDisk True - chainSelectionForBlock cdb (BlockCache.singleton b) hdr blockPunish + lift (precheckLeiosCert cdb blockPredecessorSlot b) >>= \case + Right tentativeHeaderPermission -> + chainSelectionForBlock + cdb + (BlockCache.singleton b) + hdr + tentativeHeaderPermission + blockPunish + Left leiosErr -> lift $ do + let e = ExtValidationErrorLeios leiosErr + traceWith (AddBlockValidation >$< addBlockTracer) $ + InvalidBlock e (blockRealPoint b) + addInvalidBlock cdbInvalid e (blockRealPoint b) + -- The rejected certificate is the block's own, so this punishes the + -- block itself rather than its prefix. + InvalidBlockPunishment.enact + blockPunish + InvalidBlockPunishment.BlockItself newTip <- lift $ atomically $ Query.getTipPoint cdb @@ -532,7 +565,12 @@ chainSelAddPerasCert cdb@CDB{..} cert varProcessed = do -- Trigger chain selection for the boosted block. lift $ lift $ traceWith tracer $ ChainSelectionForBoostedBlock certRound boostedBlock - lift $ chainSelectionForBlock cdb BlockCache.empty boostedHdr noPunishment + lift $ chainSelectionForBlock + cdb + BlockCache.empty + boostedHdr + MayNotSetTentativeHeader + noPunishment -- Deliver promise indicating that we processed the cert. lift $ atomically $ putTMVar varProcessed () @@ -590,7 +628,7 @@ chainSelReprocessLeiosEb cdb@CDB{..} ebHash = lift $ do , VolatileDB.biHasLeiosCert bi ] - chainSelEnv = mkChainSelEnv cdb BlockCache.empty weights curChain Nothing + chainSelEnv = mkChainSelEnv cdb BlockCache.empty weights curChain MayNotSetTentativeHeader Nothing chainDiffs :: [[(ChainDiff (Header blk), ReasonForSwitch' blk)]] <- for @@ -657,7 +695,7 @@ chainSelReprocessLoEBlocks cdb@CDB{..} varProcessed = lift $ do , not $ AF.pointOnFragment (realPointToPoint loePt) curChain ] - chainSelEnv = mkChainSelEnv cdb BlockCache.empty weights curChain Nothing + chainSelEnv = mkChainSelEnv cdb BlockCache.empty weights curChain MayNotSetTentativeHeader Nothing chainDiffs :: [[(ChainDiff (Header blk), ReasonForSwitch' blk)]] <- for @@ -676,6 +714,111 @@ chainSelReprocessLoEBlocks cdb@CDB{..} varProcessed = lift $ do atomically $ putTMVar varProcessed () + +-- | Verify the certificate in a CertRB before chain selection considers it +-- +-- ChainSel would otherwise only discover an invalid certificate once it applied +-- the block. That only reason that's too late is because downstream peers' +-- LeiosFetch interprets the header of a CertRB to be an offer of the certified +-- EB. And the downstream LeiosFetch would disconnect from us if we claimed more +-- than one EB were certified for the same election (which Leios goes to great +-- lengths to ensure is only possible if the adversary has already defeated the +-- network). +-- +-- Only positive verdicts are cached; see 'LeiosValidClaims'. +-- +-- 'Left' means the CertRB is invalid. 'Right' says whether its header may be +-- pipelined, which it may only if this function verified the certificate (or +-- had already verified one making the same claim): every way of declining to +-- reach a verdict yields 'MayNotSetTentativeHeader' rather than a crash or an +-- unchecked pipelining. +precheckLeiosCert :: + forall m blk. + ( IOLike m + , LedgerSupportsProtocol blk + , ResolveLeiosBlock blk + , HasLeiosVoting blk + ) => + ChainDbEnv m blk -> + -- | The slot of the block's predecessor, ie of the announcing block + WithOrigin SlotNo -> + blk -> + m (Either LeiosExtValidationError TentativeHeaderPermission) +precheckLeiosCert CDB{..} predSlot b = case blockLeiosCert b of + Nothing -> pure $ Right MaySetTentativeHeader + Just cert -> case (announcingRbHash b, predSlot) of + (Nothing, _) -> reject cert LeiosForecastAfterGenesis + (_, Origin) -> reject cert LeiosForecastAfterGenesis + (Just rbHash, NotOrigin announcingSlot) -> do + (known, immTip) <- + atomically $ + (,) + <$> (LeiosValidClaims.memberValidClaim rbHash <$> readTVar cdbLeiosValidClaims) + <*> (ledgerState <$> LedgerDB.getImmutableTip cdbLedgerDB) + let immForecast = ledgerViewForecastAt (configLedger cdbTopLevelConfig) immTip + if + -- We've already validated cert that makes the same claim as this one, + -- so we already know it's safe to pipeline this header, even if /this/ + -- cert is invalid. + | known -> pure $ Right MaySetTentativeHeader + -- The announcing block precedes the immutable tip, so it is on a fork + -- below it and no candidate through this CertRB can ever be selected. + -- There is nothing to protect, and the forecast's precondition forbids + -- looking that far back anyway. + -- + -- There's only a small window in which BlockFetch would have requested + -- this block and that it would arrive too late to be effective; the + -- imminent 'chainSelectionForBlock' will similarly ignore it, because + -- it's unreachable from our current selection. + | NotOrigin announcingSlot < forecastAt immForecast -> + pure $ Right MayNotSetTentativeHeader + | otherwise -> case runExcept $ forecastFor immForecast announcingSlot of + -- We cannot reach the announcing block's slot from the immutable + -- tip, so we cannot verify this certificate; decline to pipeline + -- instead. Blocking until the window advances is not an option, + -- since ChainSel is single-threaded and is the only thing that + -- could advance it. + -- + -- Rare, because it needs the volatile window --- at most @k@ blocks + -- --- to span more slots than the stability window the forecast + -- ranges over. + -- + -- TODO forecasting from the immutable tip is the reason this case + -- exists at all, and it is avoidable: ChainSync and the leadership + -- check already forecast to this very slot, from an anchor at or + -- after the immutable tip. Caching that 'LedgerView' on the header + -- alongside the already-cached predecessor slot would make this + -- branch unreachable by construction. + Left _outsideForecastRange -> pure $ Right MayNotSetTentativeHeader + Right leiosLedgerView -> case getLeiosCommitteeFromView (Proxy @blk) leiosLedgerView of + Nothing -> reject cert $ LeiosForecastMissingCommittee rbHash + Just (committee, threshold) -> + case verifyLeiosCert committee threshold rbHash cert of + Left invalid -> + reject cert $ LeiosForecastInvalidCertificate rbHash invalid + Right _weight -> do + atomically $ + modifyTVar cdbLeiosValidClaims $ + LeiosValidClaims.insertValidClaim announcingSlot rbHash + pure $ Right MaySetTentativeHeader + where + reject cert why = + pure $ Left $ LeiosCertificateForecastRejected cert predSlot why + + +-- | Record the invalid block in the given map and change its fingerprint +addInvalidBlock :: + (IOLike m, StandardHash blk) => + StrictTVar m (WithFingerprint (InvalidBlocks blk)) -> + ExtValidationError blk -> + RealPoint blk -> + m () +addInvalidBlock varInvalid e (RealPoint slot hash) = atomically $ + modifyTVar varInvalid $ \(WithFingerprint invalid fp) -> + WithFingerprint + (Map.insert hash (InvalidBlockInfo e slot) invalid) + (succ fp) + -- | 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 -- containing the corresponding block because its block number is (weakly) older @@ -748,9 +891,11 @@ chainSelectionForBlock :: ChainDbEnv m blk -> BlockCache blk -> Header blk -> + -- | See 'TentativeHeaderPermission'; only 'chainSelAddBlock' may grant it. + TentativeHeaderPermission -> InvalidBlockPunishment m -> Electric m () -chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ do +chainSelectionForBlock cdb@CDB{..} blockCache hdr tentativeHeaderPermission punish = electric $ do (invalid, curChain, weights) <- atomically $ (,,) @@ -796,7 +941,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ do let traceNoChange = traceWith addBlockTracer $ StoreButDontChange p - chainSelEnv = mkChainSelEnv cdb blockCache weights curChain (Just (p, punish)) + chainSelEnv = mkChainSelEnv cdb blockCache weights curChain tentativeHeaderPermission (Just (p, punish)) case NE.nonEmpty chainDiffs of Just chainDiffs' -> do @@ -1188,6 +1333,7 @@ data ChainSelEnv m blk = ChainSelEnv , blockCache :: BlockCache blk , weights :: PerasWeightSnapshot blk , curChain :: AnchoredFragment (Header blk) + , tentativeHeaderPermission :: TentativeHeaderPermission , punish :: Maybe (RealPoint blk, InvalidBlockPunishment m) -- ^ The block that this chain selection invocation is processing, and the -- punish action for the peer that sent that block; see @@ -1207,6 +1353,21 @@ data ChainSelEnv m blk = ChainSelEnv -- 'InvalidBlockPunishment' combinators. } +-- | Whether a chain selection may set the tentative header +-- +-- Only the chain selection that a block's /arrival/ triggers may, ie +-- 'chainSelAddBlock' handling a 'ChainSelAddBlock'. That is what lets +-- \"pipelined\" imply \"arrived during this execution, and so was checked by +-- 'precheckLeiosCert'\". Every other trigger reconsiders blocks that have been +-- in the VolatileDB for arbitrarily long, including since a previous execution: +-- an EB closure completing ('chainSelReprocessLeiosEb'), the LoE fragment +-- moving ('chainSelReprocessLoEBlocks'), or a Peras certificate boosting a +-- block ('chainSelAddPerasCert'). +data TentativeHeaderPermission + = MaySetTentativeHeader + | MayNotSetTentativeHeader + deriving (Eq, Show) + mkChainSelEnv :: IOLike m => ChainDbEnv m blk -> @@ -1216,10 +1377,11 @@ mkChainSelEnv :: PerasWeightSnapshot blk -> -- | See 'curChain' AnchoredFragment (Header blk) -> + TentativeHeaderPermission -> -- | See 'punish'. Maybe (RealPoint blk, InvalidBlockPunishment m) -> ChainSelEnv m blk -mkChainSelEnv CDB{..} blockCache weights curChain punish = +mkChainSelEnv CDB{..} blockCache weights curChain tentativeHeaderPermission punish = ChainSelEnv { lgrDB = cdbLedgerDB , bcfg = configBlock cdbTopLevelConfig @@ -1236,6 +1398,7 @@ mkChainSelEnv CDB{..} blockCache weights curChain punish = TraceAddBlockEvent . AddBlockValidation >$< cdbTracer , pipeliningTracer = TraceAddBlockEvent . PipeliningEvent >$< cdbTracer + , tentativeHeaderPermission , punish } @@ -1328,7 +1491,7 @@ chainSelection chainSelEnv chainDiffs onSuccess = setTentativeHeader :: m (Maybe (Header blk, TentativeHeaderState blk)) setTentativeHeader = do pipeliningResult <- - (\ts -> isPipelineable bcfg ts candidate) + (\ts -> isPipelineable tentativeHeaderPermission bcfg ts candidate) <$> readTVarIO varTentativeState whenJust pipeliningResult $ \(tentativeHeader, _) -> do let setTentative = SetTentativeHeader tentativeHeader @@ -1453,7 +1616,7 @@ validateCandidate chainSelEnv chainDiff@(ChainDiff rollback suffix) neHeaders on ValidateLedgerError (AnnLedgerError lastValid pt e) -> do let chainDiff' = Diff.truncate (castPoint lastValid) chainDiff traceWith validationTracer (InvalidBlock e pt) - addInvalidBlock e pt + addInvalidBlock varInvalid e pt traceWith validationTracer (ValidCandidate (Diff.getSuffix chainDiff')) -- punish the peer who sent a block if it is invalid or a block from its @@ -1496,14 +1659,6 @@ validateCandidate chainSelEnv chainDiff@(ChainDiff rollback suffix) neHeaders on traceUpdate = traceWith $ UpdateLedgerDbTraceEvent >$< validationTracer - -- \| Record the invalid block in 'cdbInvalid' and change its fingerprint. - addInvalidBlock :: ExtValidationError blk -> RealPoint blk -> m () - addInvalidBlock e (RealPoint slot hash) = atomically $ - modifyTVar varInvalid $ \(WithFingerprint invalid fp) -> - WithFingerprint - (Map.insert hash (InvalidBlockInfo e slot) invalid) - (succ fp) - {------------------------------------------------------------------------------- Diffusion pipelining -------------------------------------------------------------------------------} @@ -1515,11 +1670,13 @@ validateCandidate chainSelEnv chainDiff@(ChainDiff rollback suffix) neHeaders on -- PRECONDITION: The 'ChainDiff' fits on top of the current chain and is better. isPipelineable :: (HasHeader (Header blk), BlockSupportsDiffusionPipelining blk) => + TentativeHeaderPermission -> BlockConfig blk -> TentativeHeaderState blk -> ChainDiff (Header blk) -> Maybe (Header blk, TentativeHeaderState blk) -isPipelineable bcfg st ChainDiff{..} +isPipelineable permission bcfg st ChainDiff{..} + | permitted = Nothing | -- we apply exactly one header AF.Empty _ :> hdr <- getSuffix , Just st' <- updateTentativeHeaderState bcfg hdr st @@ -1527,6 +1684,10 @@ isPipelineable bcfg st ChainDiff{..} getRollback == 0 = Just (hdr, st') | otherwise = Nothing + where + permitted = case permission of + MayNotSetTentativeHeader -> False + MaySetTentativeHeader -> True {------------------------------------------------------------------------------- Helpers diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index 4d12b5d3cb..d7da9f03fb 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -100,6 +100,7 @@ import GHC.Generics (Generic) import LeiosDemoDb.Common (LeiosDbHandle) import LeiosDemoTypes (AcquiredLeiosEbs, EbHash) import LeiosUtils.CallTrace (SomeJsonCallTrace) +import LeiosValidClaims (ValidClaims) import NoThunks.Class (OnlyCheckWhnfNamed (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) @@ -405,6 +406,22 @@ data ChainDbEnv m blk = CDB -- from the LeiosDb, grown by 'leiosAcquiredEbsRunner' from closure-completion -- notifications (which also enqueue a 'ChainSelReprocessLeiosEb'), and pruned -- by age as a GC is scheduled. + , cdbLeiosValidClaims :: !(StrictTVar m ValidClaims) + -- ^ The Leios claims we have verified a certificate for, if the slot of the + -- announcing block is >= the slot of the imm tip. ChainSel verifies the + -- certificate in a CertRB before selecting it, and records the claim here so + -- that the several CertRBs that can make the same claim only pay for + -- verification once. Pruned as a GC is scheduled, like 'cdbAcquiredLeiosEbs'. + -- + -- It's empty upon node startup; it's fine to redo some work once per + -- execution of the node. The fundamental motivation for 'cdbValidClaims' is + -- so that ChainSel won't pipeline a CertRB whose cert's claim is false. By + -- restricting ChainSel to only potentially pipeline an RB when that RB /first + -- arrives/ (see + -- 'Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel.TentativeHeaderPermission'), + -- we avoid the risk of pipelining an invalid CertRB that was in the VolDB at + -- node startup (which could otherwise happen due to its EB closure arriving + -- during the current execution, for example). , cdbLeiosDb :: !(LeiosDbHandle m) , cdbLeiosEvictTxCache :: !(SlotNo -> m ()) -- ^ Prune the LeiosTxCache to a slot; run just before 'leiosDbGarbageCollect' From a44f831dee273feb74350ed4a9d55ff32ce2cd00 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Wed, 9 Sep 2026 17:51:45 -0400 Subject: [PATCH 06/60] PraosWithLeios: add leiosHeaderChecks to updateChainDepState --- .../Ouroboros/Consensus/Protocol/Praos.hs | 134 ++++++++++++------ .../Consensus/Protocol/Praos/Common.hs | 44 +++--- .../src/ouroboros-consensus/LeiosDemoTypes.hs | 48 ++++++- 3 files changed, 160 insertions(+), 66 deletions(-) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index 2abdc51bcd..a7bf8cc021 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -89,6 +89,7 @@ import Cardano.Slotting.EpochInfo ( EpochInfo , epochInfoEpoch , epochInfoFirst + , epochInfoSlotLength , hoistEpochInfo ) import Cardano.Slotting.Slot @@ -108,7 +109,7 @@ import Cardano.Protocol.Praos.VRF import qualified Codec.CBOR.Encoding as CBOR import Codec.Serialise (Serialise (decode, encode)) import Control.Exception (throw) -import Control.Monad (unless) +import Control.Monad (unless, when) import Control.Monad.Except (Except, runExcept, throwError) import Data.Coerce (coerce) import Data.Functor.Identity (runIdentity) @@ -116,10 +117,15 @@ import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (Proxy)) -import Data.Typeable (Typeable) -import Data.Word (Word64) +import Data.Word (Word32, Word64) import GHC.Generics (Generic) -import LeiosDemoTypes (EbAnnouncement, decodeEbAnnouncement, encodeEbAnnouncement) +import LeiosDemoTypes + ( EbAnnouncement + , decodeEbAnnouncement + , ebAnnouncementSize + , encodeEbAnnouncement + , minCertificationSlot + ) import NoThunks.Class (NoThunks) import Numeric.Natural (Natural) import Ouroboros.Consensus.Block (WithOrigin (NotOrigin)) @@ -455,20 +461,35 @@ data BasePraosValidationErr pext c !String -- error message given by Consensus Layer | NoCounterForKeyHashOCERT !(KeyHash SL.BlockIssuer) -- stake pool key hash - | TodoLeios !(HasLeiosProof pext) String - -- TODO Leios validation-error constructors belongs here, for the header - -- checks described in 'updateChainDepState'. Deferred for now: - -- 'PraosValidationErr' is used downstream (e.g. cardano-node tracers), so - -- extending it would incur downstream integration work + | -- | The header sets its cert bit, but its predecessor announced no endorser + -- block, so there is nothing for the certificate to certify. + LeiosCertWithoutAnnouncement !(HasLeiosProof (PraosExtensionHasLeios pext)) + | -- | The header sets its cert bit too soon after its predecessor's + -- announcement: the announcement, voting and diffusion periods have not all + -- elapsed. + LeiosCertTooYoung + !(HasLeiosProof (PraosExtensionHasLeios pext)) + !SlotNo -- announcing (ie predecessor's) slot + !SlotNo -- this header's slot + !SlotNo -- the earliest slot this header could have certified in + | -- | The header announces an endorser block larger than the protocol + -- parameters allow. + LeiosEbTooBig + !(HasLeiosProof (PraosExtensionHasLeios pext)) + !Word32 -- announced size + !Word32 -- maximum deriving Generic +-- | Every Leios constructor of 'BasePraosValidationErr' carries a +-- 'HasLeiosProof', so at 'PextNone' --- which is mainnet's --- none of them can +-- be constructed and the inhabited set is exactly what it was before Leios. type PraosValidationErr c = BasePraosValidationErr PextNone c -deriving instance (PraosCrypto c, Typeable pext) => Eq (BasePraosValidationErr pext c) +deriving instance (PraosCrypto c, KnownPraosExtension pext) => Eq (BasePraosValidationErr pext c) -deriving instance (PraosCrypto c, Typeable pext) => NoThunks (BasePraosValidationErr pext c) +deriving instance (PraosCrypto c, KnownPraosExtension pext) => NoThunks (BasePraosValidationErr pext c) -deriving instance (PraosCrypto c, Typeable pext) => Show (BasePraosValidationErr pext c) +deriving instance (PraosCrypto c, KnownPraosExtension pext) => Show (BasePraosValidationErr pext c) instance (PraosCrypto c, KnownPraosExtension pext) => ConsensusProtocol (BasePraos pext c) where type ChainDepState (BasePraos pext c) = BasePraosState pext @@ -476,7 +497,7 @@ instance (PraosCrypto c, KnownPraosExtension pext) => ConsensusProtocol (BasePra type CanBeLeader (BasePraos pext c) = PraosCanBeLeader c type TiebreakerView (BasePraos pext c) = PraosTiebreakerView c type LedgerView (BasePraos pext c) = Views.BasePraosLedgerView pext - type ValidationErr (BasePraos pext c) = PraosValidationErr c + type ValidationErr (BasePraos pext c) = BasePraosValidationErr pext c type ValidateView (BasePraos pext c) = Views.BaseHeaderView pext c protocolSecurityParam = praosSecurityParam . praosParams @@ -546,12 +567,6 @@ instance (PraosCrypto c, KnownPraosExtension pext) => ConsensusProtocol (BasePra -- Validate and update the chain dependent state as a result of processing a -- new header. - -- - -- This consists of: - -- - Validate the VRF checks - -- - Validate the KES checks - -- - Call 'reupdateChainDepState' - -- updateChainDepState cfg@( PraosConfig PraosParams{praosLeaderF} @@ -560,21 +575,14 @@ instance (PraosCrypto c, KnownPraosExtension pext) => ConsensusProtocol (BasePra b slot tcs = do - -- TODO enforce the Leios header checks here (needs 'PraosValidationErr' - -- constructors; see above): - -- * LeiosCertRBWithoutAnnouncement - the set cert bit requires - -- predecessor's chain-dep state has an announcement (genesis - -- chain-dep state has no announcement, so the first header can't set - -- its cert bit) - -- * LeiosCertTooYoung - check the slot gap against L - -- * LeiosEbTooBig - the maximum EB body size. NB the closure size - -- cannot be checked here: the announcement carries only the one - -- size, and it is the body size - -- * etc + -- The Leios header checks. Cheap, so they run before the signature + -- checks. -- -- NB cert/txs exclusivity is not among these: it is a property of the -- body, and 'blockMatchesHeader' already enforces it where the body is - -- in hand. + -- in hand. Nor is the EB closure's size: the announcement carries only + -- one size, and it is the body's. + leiosHeaderChecks cfg lv b slot cs -- First, we check the KES signature, which validates that the issuer is -- in fact who they say they are. @@ -589,12 +597,6 @@ instance (PraosCrypto c, KnownPraosExtension pext) => ConsensusProtocol (BasePra cs = tickedPraosStateChainDepState tcs -- Re-update the chain dependent state as a result of processing a header. - -- - -- This consists of: - -- - Update the last applied block hash. - -- - Update the evolving and (potentially) candidate nonces based on the - -- position in the epoch. - -- - Update the operational certificate counter. reupdateChainDepState _cfg@( PraosConfig PraosParams{praosRandomnessStabilisationWindow} @@ -663,7 +665,7 @@ validateVRFSignature :: Views.BasePraosLedgerView pext -> ActiveSlotCoeff -> Views.BaseHeaderView pext c -> - Except (PraosValidationErr c) () + Except (BasePraosValidationErr pext c) () validateVRFSignature eta0 (Views.plvPoolDistr -> SL.PoolDistr pd _) = doValidateVRFSignature eta0 pd @@ -676,7 +678,7 @@ doValidateVRFSignature :: Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> ActiveSlotCoeff -> Views.BaseHeaderView pext c -> - Except (PraosValidationErr c) () + Except (BasePraosValidationErr pext c) () doValidateVRFSignature eta0 pd f b = do case Map.lookup hk pd of Nothing -> throwError $ VRFKeyUnknown hk @@ -701,13 +703,61 @@ doValidateVRFSignature eta0 pd f b = do vrfLeaderVal = vrfLeaderValue (Proxy @c) vrfCert slot = Views.hvSlotNo b +-- | The Leios-specific checks on a header, called by 'updateChainDepState' +leiosHeaderChecks :: forall pext c. + KnownPraosExtension pext => + ConsensusConfig (BasePraos pext c) -> + Views.BasePraosLedgerView pext -> + Views.BaseHeaderView pext c -> + SlotNo -> + BasePraosState pext -> + Except (BasePraosValidationErr pext c) () +leiosHeaderChecks PraosConfig{praosEpochInfo} lv b slot cs = + case praosExtensionHasLeios (Proxy @pext) of + PextDoesNotHaveLeiosDecided -> pure () + PextHasLeiosDecided -> do + let SJustLeios (containsCert, mbAnn) = Views.hvLeios b + SJustLeios llv = Views.plvLeios lv + SJustLeios announcedByPredecessor = praosStateLeiosAnnouncement cs + + -- Note that the genesis state doesn't announce an EB. + when containsCert $ + case (announcedByPredecessor, praosStateLastSlot cs) of + (SJust{}, NotOrigin announcingSlot) -> do + let earliestAllowed = + minCertificationSlot + ( runIdentity $ + epochInfoSlotLength + (History.toPureEpochInfo praosEpochInfo) + slot + ) + (Views.llvAnnouncementPeriodLength llv) + (Views.llvVotePeriodLength llv) + (Views.llvDiffusionPeriodLength llv) + announcingSlot + when (slot < earliestAllowed) $ + throwError $ + LeiosCertTooYoung mkHasLeiosProof announcingSlot slot earliestAllowed + -- A state that announced an EB has necessarily applied a header, so + -- 'Origin' is the same situation as announcing nothing. + _ -> throwError $ LeiosCertWithoutAnnouncement mkHasLeiosProof + + case mbAnn of + SNothing -> pure () + SJust ann -> do + let announced = ebAnnouncementSize ann + maximum' = Views.llvMaxEbBodySize llv + when (announced > maximum') $ + throwError $ + LeiosEbTooBig mkHasLeiosProof announced maximum' + validateKESSignature :: (KnownPraosExtension pext, PraosCrypto c) => ConsensusConfig (BasePraos pext c) -> LedgerView (BasePraos pext c) -> Map (KeyHash SL.BlockIssuer) Word64 -> Views.BaseHeaderView pext c -> - Except (PraosValidationErr c) () + Except (BasePraosValidationErr pext c) () validateKESSignature _cfg@( PraosConfig PraosParams{praosMaxKESEvo, praosSlotsPerKESPeriod} @@ -740,7 +790,7 @@ doValidateKESSignature :: Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> Map (KeyHash SL.BlockIssuer) Word64 -> Views.BaseHeaderView pext c -> - Except (PraosValidationErr c) () + Except (BasePraosValidationErr pext c) () doValidateKESSignature = doValidateKESSignatureWorker UpperBoundOCERT -- | The worker underlying 'doValidateKESSignature', parameterized by whether to @@ -753,7 +803,7 @@ doValidateKESSignatureWorker :: forall pext c. Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> Map (KeyHash SL.BlockIssuer) Word64 -> Views.BaseHeaderView pext c -> - Except (PraosValidationErr c) () + Except (BasePraosValidationErr pext c) () doValidateKESSignatureWorker whetherToUpperBound praosMaxKESEvo praosSlotsPerKESPeriod stakeDistribution ocertCounters b = do c0 <= kp ?! KESBeforeStartOCERT c0 kp diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs index 7fdd34c015..95aa016aeb 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} @@ -38,7 +39,7 @@ module Ouroboros.Consensus.Protocol.Praos.Common , KnownPraosExtension (..) , SingPraosExtension (..) , StrictMaybeLeios (..) - , toHasLeiosProof + , mkHasLeiosProof , fromCodecEbAnnouncement , toCodecEbAnnouncement ) where @@ -440,17 +441,18 @@ instance KnownPraosExtension PextLeios where ----- -- | Newtype wrapper to avoid 'NoThunks' orphan -type HasLeiosProof :: PraosExtension -> Type -newtype HasLeiosProof pext = - MkHasLeiosProof (PraosExtensionHasLeios pext :~: PextHasLeios) +-- +-- We're using ':~:' at all merely so we can still use @deriving@ for exception +-- sum types. +type HasLeiosProof :: WhetherHasLeios -> Type +newtype HasLeiosProof whether = + MkHasLeiosProof (whether :~: PextHasLeios) deriving (Eq, Show) -deriving via OnlyCheckWhnf (HasLeiosProof pext) instance Typeable pext => NoThunks (HasLeiosProof pext) +deriving via OnlyCheckWhnf (HasLeiosProof whether) instance Typeable whether => NoThunks (HasLeiosProof whether) -toHasLeiosProof :: WhetherHasLeiosDecided pext -> Maybe (HasLeiosProof pext) -toHasLeiosProof = \case - PextHasLeiosDecided -> Just $ MkHasLeiosProof Refl - PextDoesNotHaveLeiosDecided -> Nothing +mkHasLeiosProof :: HasLeiosProof PextHasLeios +mkHasLeiosProof = MkHasLeiosProof Refl ----- @@ -465,35 +467,43 @@ data StrictMaybeLeios whether a where instance Functor (StrictMaybeLeios whether) where fmap f = \case SNothingLeios -> SNothingLeios - SJustLeios a -> SJustLeios $ f a + SJustLeios x -> SJustLeios $ f x + +instance Applicative (StrictMaybeLeios PextDoesNotHaveLeios) where + pure = const SNothingLeios + SNothingLeios <*> SNothingLeios = SNothingLeios + +instance Applicative (StrictMaybeLeios PextHasLeios) where + pure = SJustLeios + SJustLeios f <*> SJustLeios x = SJustLeios $ f x instance Foldable (StrictMaybeLeios whether) where foldMap f = \case SNothingLeios -> mempty - SJustLeios a -> f a + SJustLeios x -> f x instance Traversable (StrictMaybeLeios whether) where traverse f = \case SNothingLeios -> pure SNothingLeios - SJustLeios a -> SJustLeios <$> f a + SJustLeios x -> SJustLeios <$> f x instance Eq a => Eq (StrictMaybeLeios whether a) where SNothingLeios == SNothingLeios = True - SJustLeios a == SJustLeios b = a == b + SJustLeios x == SJustLeios y = x == y instance Ord a => Ord (StrictMaybeLeios whether a) where compare SNothingLeios SNothingLeios = EQ - compare (SJustLeios a) (SJustLeios b) = compare a b + compare (SJustLeios x) (SJustLeios y) = compare x y instance Show a => Show (StrictMaybeLeios whether a) where showsPrec p = \case SNothingLeios -> showString "SNothingLeios" - SJustLeios a -> showParen (p >= 11) $ showString "SJustLeios" <> showSpace <> shows a + SJustLeios x -> showParen (p >= 11) $ showString "SJustLeios" <> showSpace <> shows x instance NFData a => NFData (StrictMaybeLeios whether a) where rnf = \case SNothingLeios -> () - SJustLeios a -> rnf a + SJustLeios x -> rnf x instance (Typeable whether, NoThunks a) => NoThunks (StrictMaybeLeios whether a) where showTypeOf _ = unwords @@ -503,7 +513,7 @@ instance (Typeable whether, NoThunks a) => NoThunks (StrictMaybeLeios whether a) ] wNoThunks ctxt = \case SNothingLeios -> wNoThunks ctxt () - SJustLeios a -> wNoThunks ctxt a + SJustLeios x -> wNoThunks ctxt x ----- diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs index 5221cbb415..04f642bbf4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs @@ -2403,17 +2403,51 @@ maxTxsPerEb = -- slot has not elapsed. minCertificationGap :: DijkstraEraPParams era => SlotLength -> PParams era -> SlotNo minCertificationGap slotLength pp = + certificationGapOfPeriods + slotLength + (pp ^. ppLeiosAnnouncementPeriodLengthL) + (pp ^. ppLeiosVotePeriodLengthL) + (pp ^. ppLeiosDiffusionPeriodLengthL) + +-- | The earliest slot at which a block may certify an endorser block announced +-- in the given slot +-- +-- 'certificationGapOfPeriods' rounds up because a block is forged at its slot's +-- onset, so the answer is the first slot whose onset is far enough after the +-- announcement. In the most-extreme-but-still-nonzero case, supppose all three +-- periods are 1ms. Their 5ms total is a fraction of any realistic slot, and the +-- gap rounds up to one: an announcement at the start of slot @X@ admits a +-- CertRB in slot @X + 1@. Rounding down would give a gap of zero and admit one +-- in slot @X@ itself, which is nonsensical. +-- +-- The header checks in @updateChainDepState@ have the periods from a forecast +-- ledger view rather than a ledger state, so they cannot go through +-- 'minCertificationGap'. Sharing 'certificationGapOfPeriods' is what keeps the +-- two from drifting. +minCertificationSlot :: + SlotLength -> + -- | Announcement period length + Milliseconds32 -> + -- | Vote period length + Milliseconds32 -> + -- | Diffusion period length + Milliseconds32 -> + -- | Slot of the announcing block + SlotNo -> + SlotNo +minCertificationSlot slotLength announcement vote diffusion announcingSlot = + announcingSlot + certificationGapOfPeriods slotLength announcement vote diffusion + +-- | Aka @L@ +certificationGapOfPeriods :: + SlotLength -> Milliseconds32 -> Milliseconds32 -> Milliseconds32 -> SlotNo +certificationGapOfPeriods slotLength announcement vote diffusion = SlotNo . fromIntegral $ (totalMs + slotMs - 1) `div` slotMs where - totalMs = - 3 * ms (pp ^. ppLeiosAnnouncementPeriodLengthL) - + ms (pp ^. ppLeiosVotePeriodLengthL) - + ms (pp ^. ppLeiosDiffusionPeriodLengthL) + totalMs = 3 * ms announcement + ms vote + ms diffusion ms = toInteger . unMilliseconds32 - -- A zero-length slot is not something the ledger can express, but dividing by - -- it would be, so refuse rather than invent an answer. slotMs = case slotLengthToMillisec slotLength of - 0 -> error "minCertificationGap: zero slot length" + 0 -> error "certificationGapOfPeriods: zero slot length" n -> n -- * Utilities for prototyping From 04d469f40246803b6fe2ae53afa89420639c22c7 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Wed, 9 Sep 2026 19:29:05 -0400 Subject: [PATCH 07/60] Leios: add ChainSel events and upstream the datacon rendering from cardano-node --- .../Ouroboros/Consensus/Protocol/Praos.hs | 31 +-- .../src/ouroboros-consensus/LeiosDemoTypes.hs | 239 +++++++++++++++++- .../Storage/ChainDB/Impl/ChainSel.hs | 64 ++++- .../Consensus/Storage/ChainDB/Impl/Types.hs | 4 +- 4 files changed, 305 insertions(+), 33 deletions(-) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index a7bf8cc021..1a123c4c66 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -117,7 +117,7 @@ import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (Proxy)) -import Data.Word (Word32, Word64) +import Data.Word (Word64) import GHC.Generics (Generic) import LeiosDemoTypes ( EbAnnouncement @@ -126,6 +126,7 @@ import LeiosDemoTypes , encodeEbAnnouncement , minCertificationSlot ) +import qualified LeiosDemoTypes as Leios import NoThunks.Class (NoThunks) import Numeric.Natural (Natural) import Ouroboros.Consensus.Block (WithOrigin (NotOrigin)) @@ -461,23 +462,7 @@ data BasePraosValidationErr pext c !String -- error message given by Consensus Layer | NoCounterForKeyHashOCERT !(KeyHash SL.BlockIssuer) -- stake pool key hash - | -- | The header sets its cert bit, but its predecessor announced no endorser - -- block, so there is nothing for the certificate to certify. - LeiosCertWithoutAnnouncement !(HasLeiosProof (PraosExtensionHasLeios pext)) - | -- | The header sets its cert bit too soon after its predecessor's - -- announcement: the announcement, voting and diffusion periods have not all - -- elapsed. - LeiosCertTooYoung - !(HasLeiosProof (PraosExtensionHasLeios pext)) - !SlotNo -- announcing (ie predecessor's) slot - !SlotNo -- this header's slot - !SlotNo -- the earliest slot this header could have certified in - | -- | The header announces an endorser block larger than the protocol - -- parameters allow. - LeiosEbTooBig - !(HasLeiosProof (PraosExtensionHasLeios pext)) - !Word32 -- announced size - !Word32 -- maximum + | LeiosHeaderErr !(HasLeiosProof (PraosExtensionHasLeios pext)) Leios.LeiosHeaderErr deriving Generic -- | Every Leios constructor of 'BasePraosValidationErr' carries a @@ -737,10 +722,13 @@ leiosHeaderChecks PraosConfig{praosEpochInfo} lv b slot cs = announcingSlot when (slot < earliestAllowed) $ throwError $ - LeiosCertTooYoung mkHasLeiosProof announcingSlot slot earliestAllowed + LeiosHeaderErr mkHasLeiosProof $ + Leios.LeiosCertTooYoung announcingSlot slot earliestAllowed -- A state that announced an EB has necessarily applied a header, so -- 'Origin' is the same situation as announcing nothing. - _ -> throwError $ LeiosCertWithoutAnnouncement mkHasLeiosProof + _ -> + throwError $ + LeiosHeaderErr mkHasLeiosProof Leios.LeiosCertWithoutAnnouncement case mbAnn of SNothing -> pure () @@ -749,7 +737,8 @@ leiosHeaderChecks PraosConfig{praosEpochInfo} lv b slot cs = maximum' = Views.llvMaxEbBodySize llv when (announced > maximum') $ throwError $ - LeiosEbTooBig mkHasLeiosProof announced maximum' + LeiosHeaderErr mkHasLeiosProof $ + Leios.LeiosEbTooBig announced maximum' validateKESSignature :: (KnownPraosExtension pext, PraosCrypto c) => diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs index 04f642bbf4..777afdef1a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs @@ -128,7 +128,12 @@ import LeiosUtils.CallTrace (SomeJsonCallTrace (..), callTraceToObject) import Lens.Micro ((^.)) import NoThunks.Class (OnlyCheckWhnfNamed (..)) import qualified Numeric -import Ouroboros.Consensus.Block.Abstract (BlockProtocol) +import Ouroboros.Consensus.Block.Abstract (BlockProtocol, StandardHash) +import Ouroboros.Consensus.Block.RealPoint + ( RealPoint + , realPointHash + , realPointSlot + ) import Ouroboros.Consensus.Ledger.Basics (EmptyMK, LedgerConfig, LedgerState) import Ouroboros.Consensus.Ledger.SupportsMempool ( ByteSize32 (..) @@ -2354,8 +2359,238 @@ traceLeiosPeerForHuman = \case TraceLeiosPeerAnnouncement equiv fields -> "EB announcement from peer (" <> T.pack (show equiv) <> "): " <> T.pack (show fields) --- * Protocol limits and parameters +-- * ChainSel's Leios events and header errors +-- | Leios events from ChainSel, injected into @TraceAddBlockEvent@ +-- +-- Its own type so that constructors can be added or altered without touching +-- cardano-node, which reaches everything it needs through +-- 'traceLeiosChainSelToObject', 'traceLeiosChainSelForHuman' and the +-- @leiosChainSelNS*@ functions below. +data TraceLeiosChainSel blk + = -- | A CertRB's certificate verified, so its claim is now recorded. + -- + -- Carries the CertRB, the announcing block --- whose hash is the claim and + -- whose slot the claim is aged by --- and the resulting number of claims + -- held. + TraceLeiosValidClaim !(RealPoint blk) !(RealPoint blk) !Int + | -- | A CertRB whose predecessor is no older than the immutable tip yielded + -- no candidate at all. + -- + -- A hint rather than a fault. The predecessor is not below the immutable + -- tip, so the CertRB is not ruled out by the tip having moved past it. Two + -- innocent explanations remain: the predecessor has not arrived yet, since + -- its slot comes from the header chain and so is known before its block is; + -- or the endorser block's closure has not been acquired, so the CertRB is + -- parked. + -- + -- Carries the CertRB, its predecessor's slot and the immutable tip's slot. + TraceLeiosCertRbWithoutCandidate + !(RealPoint blk) + !(WithOrigin SlotNo) + !(WithOrigin SlotNo) + deriving (Eq, Show, Generic) + +traceLeiosChainSelToObject :: + StandardHash blk => TraceLeiosChainSel blk -> Aeson.Object +traceLeiosChainSelToObject = \case + TraceLeiosValidClaim pt announcingPt held -> + mconcat + [ "kind" .= Aeson.String "LeiosValidClaim" + , "blockSlot" .= realPointSlot pt + , "blockHash" .= T.pack (show (realPointHash pt)) + , "announcingSlot" .= realPointSlot announcingPt + , "announcingHash" .= T.pack (show (realPointHash announcingPt)) + , "claimsHeld" .= held + ] + TraceLeiosCertRbWithoutCandidate pt predSlot immTipSlot -> + mconcat + [ "kind" .= Aeson.String "LeiosCertRbWithoutCandidate" + , "blockSlot" .= realPointSlot pt + , "blockHash" .= T.pack (show (realPointHash pt)) + , "predecessorSlot" .= predSlot + , "immutableTipSlot" .= immTipSlot + ] + +traceLeiosChainSelForHuman :: StandardHash blk => TraceLeiosChainSel blk -> Text +traceLeiosChainSelForHuman = \case + TraceLeiosValidClaim pt announcingPt held -> + "Verified the Leios certificate in " + <> T.pack (show pt) + <> ", claiming the endorser block announced by " + <> T.pack (show announcingPt) + <> "; " + <> T.pack (show held) + <> " claims held" + TraceLeiosCertRbWithoutCandidate pt predSlot immTipSlot -> + "No candidate involves the CertRB " + <> T.pack (show pt) + <> ", whose predecessor is in slot " + <> T.pack (show predSlot) + <> ", at or after the immutable tip in slot " + <> T.pack (show immTipSlot) + +data LeiosChainSelNS + = LCSNSValidClaim + | LCSNSCertRbWithoutCandidate + deriving (Eq, Show, Enum, Bounded) + +leiosChainSelNSOf :: TraceLeiosChainSel blk -> LeiosChainSelNS +leiosChainSelNSOf = \case + TraceLeiosValidClaim{} -> LCSNSValidClaim + TraceLeiosCertRbWithoutCandidate{} -> LCSNSCertRbWithoutCandidate + +leiosChainSelNSInfo :: LeiosChainSelNS -> LeiosNSInfo +leiosChainSelNSInfo = \case + LCSNSValidClaim -> LeiosNSInfo ["LeiosValidClaim"] LSDebug [] + LCSNSCertRbWithoutCandidate -> + LeiosNSInfo ["LeiosCertRbWithoutCandidate"] LSWarning [] + +leiosChainSelNSPaths :: [[Text]] +leiosChainSelNSPaths = + [nsiPath (leiosChainSelNSInfo ns) | ns <- [minBound .. maxBound]] + +leiosChainSelNSByPath :: [Text] -> Maybe LeiosNSInfo +leiosChainSelNSByPath p = + lookup + p + [(nsiPath i, i) | ns <- [minBound .. maxBound], let i = leiosChainSelNSInfo ns] + +-- | Why a Leios header check rejected a header +-- +-- Wrapped by @BasePraosValidationErr@'s @LeiosHeaderErr@ constructor. Its own +-- type for the same reason as 'TraceLeiosChainSel': cardano-node reaches it +-- only through 'leiosHeaderErrToObject'. +data LeiosHeaderErr + = -- | The header sets its cert bit, but its predecessor announced no endorser + -- block, so there is nothing for the certificate to certify. + LeiosCertWithoutAnnouncement + | -- | The header sets its cert bit too soon after its predecessor's + -- announcement: the announcement, voting and diffusion periods have not all + -- elapsed. + -- + -- Carries the announcing block's slot, this header's slot, and the earliest + -- slot in which this header could have certified. + LeiosCertTooYoung !SlotNo !SlotNo !SlotNo + | -- | The header announces an endorser block larger than the protocol + -- parameters allow. Carries the announced size and the maximum. + LeiosEbTooBig !Word32 !Word32 + deriving (Eq, Show, Generic) + +deriving via + OnlyCheckWhnfNamed "LeiosHeaderErr" LeiosHeaderErr + instance + NoThunks LeiosHeaderErr + +leiosHeaderErrToObject :: LeiosHeaderErr -> Aeson.Object +leiosHeaderErrToObject = \case + LeiosCertWithoutAnnouncement -> + mconcat ["kind" .= Aeson.String "LeiosCertWithoutAnnouncement"] + LeiosCertTooYoung announcingSlot slot earliestAllowed -> + mconcat + [ "kind" .= Aeson.String "LeiosCertTooYoung" + , "announcingSlot" .= announcingSlot + , "slot" .= slot + , "earliestAllowedSlot" .= earliestAllowed + ] + LeiosEbTooBig announced maxSize -> + mconcat + [ "kind" .= Aeson.String "LeiosEbTooBig" + , "announcedEndorserBlockSize" .= announced + , "maxEndorserBlockSize" .= maxSize + ] + +-- | As 'leiosHeaderErrToObject', for the errors ChainSel and the LedgerDB raise +-- about a CertRB. +leiosExtValidationErrorToObject :: LeiosExtValidationError -> Aeson.Object +leiosExtValidationErrorToObject = \case + LeiosCertificateWithoutAnnouncement cert -> + mconcat + [ "kind" .= Aeson.String "LeiosCertificateWithoutAnnouncement" + , "certificate" .= T.pack (show cert) + ] + LeiosMissingCommittee point cert -> + mconcat + [ "kind" .= Aeson.String "LeiosMissingCommittee" + , "announcedEb" .= T.pack (show point) + , "certificate" .= T.pack (show cert) + ] + LeiosMissingThreshold -> + mconcat ["kind" .= Aeson.String "LeiosMissingThreshold"] + LeiosCertificateAfterGenesis cert point -> + mconcat + [ "kind" .= Aeson.String "LeiosCertificateAfterGenesis" + , "certificate" .= T.pack (show cert) + , "announcedEb" .= T.pack (show point) + ] + LeiosInvalidCertificate cert point rbHash verErr -> + mconcat + [ "kind" .= Aeson.String "LeiosInvalidCertificate" + , "certificate" .= T.pack (show cert) + , "announcedEb" .= T.pack (show point) + , "announcingRb" .= T.pack (prettyRbHash rbHash) + , "verificationError" .= T.pack (show verErr) + ] + LeiosCertificateForecastRejected cert predSlot why -> + mconcat $ + [ "kind" .= Aeson.String "LeiosCertificateForecastRejected" + , "certificate" .= T.pack (show cert) + , "predecessorSlot" .= predSlot + ] + <> leiosForecastRejectionFields why + +leiosForecastRejectionFields :: LeiosForecastRejection -> [Aeson.Object] +leiosForecastRejectionFields = \case + LeiosForecastAfterGenesis -> + ["reason" .= Aeson.String "AfterGenesis"] + LeiosForecastMissingCommittee rbHash -> + [ "reason" .= Aeson.String "MissingCommittee" + , "announcingRb" .= T.pack (prettyRbHash rbHash) + ] + LeiosForecastInvalidCertificate rbHash verErr -> + [ "reason" .= Aeson.String "InvalidCertificate" + , "announcingRb" .= T.pack (prettyRbHash rbHash) + , "verificationError" .= T.pack (show verErr) + ] + +leiosExtValidationErrorForHuman :: LeiosExtValidationError -> Text +leiosExtValidationErrorForHuman = \case + LeiosCertificateWithoutAnnouncement cert -> + "CertRB carries a Leios certificate but its predecessor announced no EB: " + <> T.pack (show cert) + LeiosMissingCommittee point cert -> + "CertRB for " + <> T.pack (show point) + <> " but there is no Leios committee to verify its certificate: " + <> T.pack (show cert) + LeiosMissingThreshold -> + "CertRB validation, but no quorum stake threshold in pparams" + LeiosCertificateAfterGenesis cert point -> + "CertRB for " + <> T.pack (show point) + <> " has no announcing ranking block (would certify at genesis): " + <> T.pack (show cert) + LeiosInvalidCertificate cert point rbHash verErr -> + "Invalid Leios certificate for " + <> T.pack (show point) + <> " announced by ranking block " + <> T.pack (prettyRbHash rbHash) + <> ": " + <> T.pack (show verErr) + <> " (" + <> T.pack (show cert) + <> ")" + LeiosCertificateForecastRejected cert predSlot why -> + "ChainSel's forecast-based check rejected the CertRB whose predecessor is in slot " + <> T.pack (show predSlot) + <> ": " + <> T.pack (show why) + <> " (" + <> T.pack (show cert) + <> ")" + +-- * Protocol parameters +-- -- The node-to-node limits below are constants, but no longer a policy of their -- own: they restate the LeiosFetch codec's message limit, so the buffers sized -- from them hold anything a peer can deliver. Governance raising diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index cf7bb9dfa6..7ae9ee973b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -59,6 +59,10 @@ import LeiosDemoTypes , LeiosForecastInvalidCertificate , LeiosForecastMissingCommittee ) + , TraceLeiosChainSel + ( TraceLeiosCertRbWithoutCandidate + , TraceLeiosValidClaim + ) , acquiredLeiosEbHashes , acquiredLeiosEbsSetMember , pointEbHash @@ -466,6 +470,7 @@ chainSelAddBlock cdb@CDB{..} _cctx BlockToAdd{blockToAdd = b, ..} = do cdb (BlockCache.singleton b) hdr + (Just blockPredecessorSlot) tentativeHeaderPermission blockPunish Left leiosErr -> lift $ do @@ -515,6 +520,7 @@ chainSelAddPerasCert :: , BlockSupportsDiffusionPipelining blk , InspectLedger blk , HasHardForkHistory blk + , ResolveLeiosBlock blk , HasCallStack ) => ChainDbEnv m blk -> @@ -569,6 +575,7 @@ chainSelAddPerasCert cdb@CDB{..} cert varProcessed = do cdb BlockCache.empty boostedHdr + Nothing MayNotSetTentativeHeader noPunishment @@ -746,10 +753,9 @@ precheckLeiosCert :: m (Either LeiosExtValidationError TentativeHeaderPermission) precheckLeiosCert CDB{..} predSlot b = case blockLeiosCert b of Nothing -> pure $ Right MaySetTentativeHeader - Just cert -> case (announcingRbHash b, predSlot) of - (Nothing, _) -> reject cert LeiosForecastAfterGenesis - (_, Origin) -> reject cert LeiosForecastAfterGenesis - (Just rbHash, NotOrigin announcingSlot) -> do + Just cert -> case (announcingRbHash b, blockPrevHash b, predSlot) of + (Just rbHash, BlockHash announcingHash, NotOrigin announcingSlot) -> do + let announcingPoint = RealPoint announcingSlot announcingHash (known, immTip) <- atomically $ (,) @@ -797,10 +803,21 @@ precheckLeiosCert CDB{..} predSlot b = case blockLeiosCert b of Left invalid -> reject cert $ LeiosForecastInvalidCertificate rbHash invalid Right _weight -> do - atomically $ + size <- atomically $ do modifyTVar cdbLeiosValidClaims $ LeiosValidClaims.insertValidClaim announcingSlot rbHash + LeiosValidClaims.sizeValidClaims + <$> readTVar cdbLeiosValidClaims + traceWith (TraceAddBlockEvent >$< cdbTracer) $ + AddBlockLeiosEvent $ + TraceLeiosValidClaim + (blockRealPoint b) + announcingPoint + size pure $ Right MaySetTentativeHeader + -- Certifying at genesis: all three of these say there is no announcing + -- block, so they cannot disagree. + _ -> reject cert LeiosForecastAfterGenesis where reject cert why = pure $ Left $ LeiosCertificateForecastRejected cert predSlot why @@ -886,16 +903,27 @@ chainSelectionForBlock :: , BlockSupportsDiffusionPipelining blk , InspectLedger blk , HasHardForkHistory blk + , ResolveLeiosBlock blk , HasCallStack ) => ChainDbEnv m blk -> BlockCache blk -> Header blk -> + -- | The slot of the block's predecessor, when a block /arriving/ triggered + -- this chain selection; 'Nothing' otherwise. Independent of the permission + -- below, since an arrival we could not verify is still an arrival. + Maybe (WithOrigin SlotNo) -> -- | See 'TentativeHeaderPermission'; only 'chainSelAddBlock' may grant it. TentativeHeaderPermission -> InvalidBlockPunishment m -> Electric m () -chainSelectionForBlock cdb@CDB{..} blockCache hdr tentativeHeaderPermission punish = electric $ do +chainSelectionForBlock + cdb@CDB{..} + blockCache + hdr + mbPredecessorSlot + tentativeHeaderPermission + punish = electric $ do (invalid, curChain, weights) <- atomically $ (,,) @@ -941,7 +969,14 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr tentativeHeaderPermission puni let traceNoChange = traceWith addBlockTracer $ StoreButDontChange p - chainSelEnv = mkChainSelEnv cdb blockCache weights curChain tentativeHeaderPermission (Just (p, punish)) + chainSelEnv = + mkChainSelEnv + cdb + blockCache + weights + curChain + tentativeHeaderPermission + (Just (p, punish)) case NE.nonEmpty chainDiffs of Just chainDiffs' -> do @@ -953,7 +988,18 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr tentativeHeaderPermission puni chainDiffs' (switchTo cdb weights (Just p)) -- No candidate better than our chain. - Nothing -> traceNoChange + Nothing -> do + traceNoChange + -- See 'TraceLeiosCertRbWithoutCandidate'. + whenJust mbPredecessorSlot $ \predecessorSlot -> + let immTipSlot = AF.anchorToSlotNo (AF.anchor curChain) + in when + ( headerContainsLeiosCert hdr + && predecessorSlot >= immTipSlot + ) + $ traceWith addBlockTracer + $ AddBlockLeiosEvent + $ TraceLeiosCertRbWithoutCandidate p predecessorSlot immTipSlot where -- Note that we may have extended the chain, but have not trimmed it to -- @k@ blocks/headers. That is the job of the background thread, which @@ -1676,7 +1722,7 @@ isPipelineable :: ChainDiff (Header blk) -> Maybe (Header blk, TentativeHeaderState blk) isPipelineable permission bcfg st ChainDiff{..} - | permitted = Nothing + | not permitted = Nothing | -- we apply exactly one header AF.Empty _ :> hdr <- getSuffix , Just st' <- updateTentativeHeaderState bcfg hdr st diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index d7da9f03fb..09c31238ab 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -98,7 +98,7 @@ import Data.Void (Void) import Data.Word (Word64) import GHC.Generics (Generic) import LeiosDemoDb.Common (LeiosDbHandle) -import LeiosDemoTypes (AcquiredLeiosEbs, EbHash) +import LeiosDemoTypes (AcquiredLeiosEbs, EbHash, TraceLeiosChainSel) import LeiosUtils.CallTrace (SomeJsonCallTrace) import LeiosValidClaims (ValidClaims) import NoThunks.Class (OnlyCheckWhnfNamed (..)) @@ -1017,6 +1017,8 @@ data TraceAddBlockEvent blk | -- | Herald of 'AddedToCurrentChain' or 'SwitchedToAFork'. Lists the tip of -- the new chain. ChangingSelection (Point blk) + | -- | A Leios event from ChainSel. + AddBlockLeiosEvent (TraceLeiosChainSel blk) | -- | A call-trace event emitted by the 'addBlockRunner' thread. TraceAddBlockCall SomeJsonCallTrace From 5a8be9c9366586e03f17f42b62bcf4fccb3ff931 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Wed, 9 Sep 2026 19:42:01 -0400 Subject: [PATCH 08/60] Ran CI formatters --- .../Ouroboros/Consensus/Cardano/Block.hs | 3 +- .../Ouroboros/Consensus/Shelley/HFEras.hs | 2 +- .../Consensus/Shelley/Ledger/Leios.hs | 18 +- .../Ouroboros/Consensus/Shelley/Node/Praos.hs | 2 +- .../Test/Consensus/Shelley/Dijkstra.hs | 1 - .../Ouroboros/Consensus/NodeKernel.hs | 30 ++- .../Test/Consensus/PeerSimulator/Run.hs | 2 +- .../Ouroboros/Consensus/Protocol/Praos.hs | 56 ++--- .../Consensus/Protocol/Praos/Common.hs | 34 +-- .../Consensus/Protocol/Praos/Views.hs | 1 - .../Protocol/Serialisation/Generators.hs | 8 +- .../Consensus/Protocol/Praos/Header.hs | 20 +- ouroboros-consensus.cabal | 2 +- .../BlockFetch/ClientInterface.hs | 5 +- .../Consensus/Storage/ChainDB/API.hs | 5 +- .../Storage/ChainDB/Impl/ChainSel.hs | 201 +++++++++--------- .../Test/Ouroboros/Storage/ChainDB/Unit.hs | 4 +- 17 files changed, 216 insertions(+), 178 deletions(-) diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs index b5101742af..aa7f3342bd 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs @@ -323,7 +323,8 @@ pattern EraMary :: K () (ShelleyBlock (TPraos c) MaryEra) -> EraIndex (CardanoEr pattern EraAlonzo :: K () (ShelleyBlock (TPraos c) AlonzoEra) -> EraIndex (CardanoEras c) pattern EraBabbage :: K () (ShelleyBlock (Praos c) BabbageEra) -> EraIndex (CardanoEras c) pattern EraConway :: K () (ShelleyBlock (Praos c) ConwayEra) -> EraIndex (CardanoEras c) -pattern EraDijkstra :: K () (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> EraIndex (CardanoEras c) +pattern EraDijkstra :: + K () (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> EraIndex (CardanoEras c) pattern EraByron x = EraIndex (TagByron x) pattern EraShelley x = EraIndex (TagShelley x) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs index 9a0f42ce46..532d9bcc4a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs @@ -19,9 +19,9 @@ module Ouroboros.Consensus.Shelley.HFEras import Cardano.Ledger.Dijkstra.Era (DijkstraEraBlockHeader (..)) import Cardano.Protocol.Crypto +import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec import Ouroboros.Consensus.Protocol.Praos (Praos, PraosWithLeios) import qualified Ouroboros.Consensus.Protocol.Praos as Praos -import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec import Ouroboros.Consensus.Protocol.TPraos (TPraos) import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos import Ouroboros.Consensus.Shelley.Eras diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs index 99fce47e83..3277d1de6c 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs @@ -57,17 +57,17 @@ import Ouroboros.Consensus.Ledger.Abstract (getTipSlot) import Ouroboros.Consensus.Ledger.SupportsMempool (getTransactionKeySets) import Ouroboros.Consensus.Ledger.Tables (stowLedgerTables, unstowLedgerTables) import Ouroboros.Consensus.Protocol.Praos - ( ConsensusConfig (..) + ( BasePraosState (..) + , ConsensusConfig (..) , Praos , PraosCrypto - , PraosWithLeios , PraosParams (..) - , BasePraosState (..) + , PraosWithLeios , Ticked (..) , WhetherToUpperBoundOCERT (..) ) -import Ouroboros.Consensus.Protocol.Praos.Common (StrictMaybeLeios (..)) import qualified Ouroboros.Consensus.Protocol.Praos as PP +import Ouroboros.Consensus.Protocol.Praos.Common (StrictMaybeLeios (..)) import Ouroboros.Consensus.Protocol.Praos.Views (plvPoolDistr) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Eras @@ -88,17 +88,17 @@ import Ouroboros.Consensus.Shelley.Ledger.Ledger ( LedgerState (..) , shelleyLedgerGlobals ) +import Ouroboros.Consensus.Shelley.Ledger.Mempool + ( GenTx (ShelleyTx) + , mkShelleyTx + , mkShelleyValidatedTx + ) import Ouroboros.Consensus.Shelley.Protocol.Abstract ( pHeaderIssuer , pHeaderLeiosContainsCert , pHeaderLeiosEbAnnouncement , pHeaderSlot ) -import Ouroboros.Consensus.Shelley.Ledger.Mempool - ( GenTx (ShelleyTx) - , mkShelleyTx - , mkShelleyValidatedTx - ) import Ouroboros.Consensus.Storage.LedgerDB.Forker ( OCINStaleness (..) , ResolveLeiosBlock (..) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs index c946e003bb..75bfbaa41d 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs @@ -35,8 +35,8 @@ import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Node.Common ( ShelleyLeaderCredentials (..) ) -import Ouroboros.Consensus.Shelley.Protocol.Praos () import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoHasLeios) +import Ouroboros.Consensus.Shelley.Protocol.Praos () import Ouroboros.Consensus.Util.IOLike (IOLike) {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Dijkstra.hs b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Dijkstra.hs index c89877be01..85bc5860f0 100644 --- a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Dijkstra.hs +++ b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Dijkstra.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 776ae48709..13ea454cce 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -188,7 +188,13 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel -- ^ The node's mempool , getTopLevelConfig :: TopLevelConfig blk -- ^ The node's top-level static configuration - , getFetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk (BlockFetchClientInterface.MatchedBlock blk) m + , getFetchClientRegistry :: + FetchClientRegistry + (ConnectionId addrNTN) + (HeaderWithTime blk) + blk + (BlockFetchClientInterface.MatchedBlock blk) + m -- ^ The fetch client registry, used for the block fetch clients. , getKeepAliveRegistry :: KeepAliveRegistry (ConnectionId addrNTN) m -- ^ The keep-alive registry, used by block-fetch decision logic to read @@ -682,8 +688,19 @@ data InternalState m addrNTN addrNTC blk = IS , systemTime :: SystemTime m , chainDB :: ChainDB m blk , blockFetchInterface :: - BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk (BlockFetchClientInterface.MatchedBlock blk) m - , fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk (BlockFetchClientInterface.MatchedBlock blk) m + BlockFetchConsensusInterface + (ConnectionId addrNTN) + (HeaderWithTime blk) + blk + (BlockFetchClientInterface.MatchedBlock blk) + m + , fetchClientRegistry :: + FetchClientRegistry + (ConnectionId addrNTN) + (HeaderWithTime blk) + blk + (BlockFetchClientInterface.MatchedBlock blk) + m , varChainSyncHandles :: ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk , varGsmState :: StrictTVar m GSM.GsmState , mempool :: Mempool m blk @@ -781,7 +798,12 @@ initInternalState chainDbView = BlockFetchClientInterface.defaultChainDbView chainDB blockFetchInterface :: - BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk (BlockFetchClientInterface.MatchedBlock blk) m + BlockFetchConsensusInterface + (ConnectionId addrNTN) + (HeaderWithTime blk) + blk + (BlockFetchClientInterface.MatchedBlock blk) + m blockFetchInterface = BlockFetchClientInterface.mkBlockFetchConsensusInterface (dbfTracer tracers) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs index 0ac8e04077..fe2dfae1fd 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs @@ -36,6 +36,7 @@ import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol ) +import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface import Ouroboros.Consensus.MiniProtocol.ChainSync.Client ( CSJConfig (..) , CSJEnabledConfig (..) @@ -46,7 +47,6 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client , ChainSyncLoPBucketEnabledConfig (..) , viewChainSyncState ) -import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.Node.GsmState as GSM import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..)) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index 1a123c4c66..fd1e9c54f2 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -12,7 +12,6 @@ {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE ViewPatterns #-} @@ -71,6 +70,14 @@ import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Slot (Duration (Duration), (+*)) import qualified Cardano.Ledger.State as SL import Cardano.Protocol.Crypto (Crypto, KES, StandardCrypto, VRF) +import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec +import qualified Cardano.Protocol.Praos.BlockHeader as PraosCodec +import Cardano.Protocol.Praos.VRF + ( InputVRF + , mkInputVRF + , vrfLeaderValue + , vrfNonceValue + ) import qualified Cardano.Protocol.TPraos.API as SL import Cardano.Protocol.TPraos.BlockHeader ( BoundedNatural (bvValue) @@ -98,14 +105,6 @@ import Cardano.Slotting.Slot , WithOrigin , unSlotNo ) -import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec -import qualified Cardano.Protocol.Praos.BlockHeader as PraosCodec -import Cardano.Protocol.Praos.VRF - ( InputVRF - , mkInputVRF - , vrfLeaderValue - , vrfNonceValue - ) import qualified Codec.CBOR.Encoding as CBOR import Codec.Serialise (Serialise (decode, encode)) import Control.Exception (throw) @@ -322,7 +321,8 @@ data BasePraosState pext = PraosState , praosStateLastEpochBlockNonce :: !Nonce -- ^ Nonce corresponding to the LAB nonce of the last block of the previous -- epoch - , praosStateLeiosAnnouncement :: !(StrictMaybeLeios (PraosExtensionHasLeios pext) (StrictMaybe EbAnnouncement)) + , praosStateLeiosAnnouncement :: + !(StrictMaybeLeios (PraosExtensionHasLeios pext) (StrictMaybe EbAnnouncement)) -- ^ The Leios 'EbAnnouncement' from the most recently applied header on -- this chain — overwritten on every header tick (so a header with no -- announcement clears the field). The 'ResolveLeiosBlock' instance for @@ -342,14 +342,15 @@ instance KnownPraosExtension pext => ToCBOR (BasePraosState pext) where instance KnownPraosExtension pext => FromCBOR (BasePraosState pext) where fromCBOR = decode -countOfFieldsInPraosState :: forall pext proxy a. (KnownPraosExtension pext, Num a) => proxy pext -> a +countOfFieldsInPraosState :: + forall pext proxy a. (KnownPraosExtension pext, Num a) => proxy pext -> a countOfFieldsInPraosState _ = - praos + leios - where - praos = 8 - leios = case praosExtensionHasLeios (Proxy @pext) of - PextDoesNotHaveLeiosDecided -> 0 - PextHasLeiosDecided -> 1 + praos + leios + where + praos = 8 + leios = case praosExtensionHasLeios (Proxy @pext) of + PextDoesNotHaveLeiosDecided -> 0 + PextHasLeiosDecided -> 1 -- | @pext@ selects the codec, so each extension's version numbers are their own -- namespace: these two are unrelated formats that merely both start counting. @@ -410,11 +411,11 @@ instance KnownPraosExtension pext => Serialise (BasePraosState pext) where <*> fromEraCBOR @ShelleyEra <*> fromEraCBOR @ShelleyEra <*> traverse - (\() -> decodeNullStrictMaybe decodeEbAnnouncement) - (case praosExtensionHasLeios (Proxy @pext) of - PextDoesNotHaveLeiosDecided -> SNothingLeios - PextHasLeiosDecided -> SJustLeios () - ) + (\() -> decodeNullStrictMaybe decodeEbAnnouncement) + ( case praosExtensionHasLeios (Proxy @pext) of + PextDoesNotHaveLeiosDecided -> SNothingLeios + PextHasLeiosDecided -> SJustLeios () + ) data instance Ticked (BasePraosState pext) = TickedPraosState { tickedPraosStateChainDepState :: BasePraosState pext @@ -472,7 +473,8 @@ type PraosValidationErr c = BasePraosValidationErr PextNone c deriving instance (PraosCrypto c, KnownPraosExtension pext) => Eq (BasePraosValidationErr pext c) -deriving instance (PraosCrypto c, KnownPraosExtension pext) => NoThunks (BasePraosValidationErr pext c) +deriving instance + (PraosCrypto c, KnownPraosExtension pext) => NoThunks (BasePraosValidationErr pext c) deriving instance (PraosCrypto c, KnownPraosExtension pext) => Show (BasePraosValidationErr pext c) @@ -689,7 +691,8 @@ doValidateVRFSignature eta0 pd f b = do slot = Views.hvSlotNo b -- | The Leios-specific checks on a header, called by 'updateChainDepState' -leiosHeaderChecks :: forall pext c. +leiosHeaderChecks :: + forall pext c. KnownPraosExtension pext => ConsensusConfig (BasePraos pext c) -> Views.BasePraosLedgerView pext -> @@ -784,7 +787,8 @@ doValidateKESSignature = doValidateKESSignatureWorker UpperBoundOCERT -- | The worker underlying 'doValidateKESSignature', parameterized by whether to -- enforce the OCERT counter's upper bound (see 'WhetherToUpperBoundOCERT'). -doValidateKESSignatureWorker :: forall pext c. +doValidateKESSignatureWorker :: + forall pext c. (KnownPraosExtension pext, PraosCrypto c) => WhetherToUpperBoundOCERT -> Word64 -> diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs index 95aa016aeb..39811b672c 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs @@ -66,6 +66,7 @@ import qualified Cardano.Protocol.TPraos.OCert as OCert import Cardano.Slotting.Slot (SlotNo) import Control.DeepSeq (NFData (..)) import qualified Control.Tracer as Tracer +import qualified Data.ByteString as BS import Data.Function (on) import Data.Kind (Constraint, Type) import Data.Map.Strict (Map) @@ -415,15 +416,15 @@ data SingPraosExtension pext where -- | A 'Bool' isomorph for better type errors data WhetherHasLeios = PextHasLeios | PextDoesNotHaveLeios -data WhetherHasLeiosDecided pext = - (PraosExtensionHasLeios pext ~ PextHasLeios) => PextHasLeiosDecided - | - (PraosExtensionHasLeios pext ~ PextDoesNotHaveLeios) => PextDoesNotHaveLeiosDecided +data WhetherHasLeiosDecided pext + = PraosExtensionHasLeios pext ~ PextHasLeios => PextHasLeiosDecided + | PraosExtensionHasLeios pext ~ PextDoesNotHaveLeios => PextDoesNotHaveLeiosDecided type KnownPraosExtension :: PraosExtension -> Constraint class (Typeable pext, Typeable (PraosExtensionHasLeios pext)) => KnownPraosExtension pext where type PraosExtensionHasLeios pext :: WhetherHasLeios praosExtensionHasLeios :: proxy pext -> WhetherHasLeiosDecided pext + -- | When possible, use 'praosExtensionHasLeios' instead, since it's less -- informative singPraosExtension :: proxy pext -> SingPraosExtension pext @@ -445,11 +446,14 @@ instance KnownPraosExtension PextLeios where -- We're using ':~:' at all merely so we can still use @deriving@ for exception -- sum types. type HasLeiosProof :: WhetherHasLeios -> Type -newtype HasLeiosProof whether = - MkHasLeiosProof (whether :~: PextHasLeios) +newtype HasLeiosProof whether + = MkHasLeiosProof (whether :~: PextHasLeios) deriving (Eq, Show) -deriving via OnlyCheckWhnf (HasLeiosProof whether) instance Typeable whether => NoThunks (HasLeiosProof whether) +deriving via + OnlyCheckWhnf (HasLeiosProof whether) + instance + Typeable whether => NoThunks (HasLeiosProof whether) mkHasLeiosProof :: HasLeiosProof PextHasLeios mkHasLeiosProof = MkHasLeiosProof Refl @@ -457,6 +461,7 @@ mkHasLeiosProof = MkHasLeiosProof Refl ----- type StrictMaybeLeios :: WhetherHasLeios -> Type -> Type + -- | Like 'StrictMaybe', but it's @SJust@ if and only if 'PraosExtensionHasLeios' data StrictMaybeLeios whether a where -- | Encoding and decoding this is a complete noop. @@ -497,23 +502,24 @@ instance Ord a => Ord (StrictMaybeLeios whether a) where instance Show a => Show (StrictMaybeLeios whether a) where showsPrec p = \case - SNothingLeios -> showString "SNothingLeios" - SJustLeios x -> showParen (p >= 11) $ showString "SJustLeios" <> showSpace <> shows x + SNothingLeios -> showString "SNothingLeios" + SJustLeios x -> showParen (p >= 11) $ showString "SJustLeios" <> showSpace <> shows x instance NFData a => NFData (StrictMaybeLeios whether a) where rnf = \case - SNothingLeios -> () - SJustLeios x -> rnf x + SNothingLeios -> () + SJustLeios x -> rnf x instance (Typeable whether, NoThunks a) => NoThunks (StrictMaybeLeios whether a) where - showTypeOf _ = unwords + showTypeOf _ = + unwords [ "StrictMaybeLeios" , "(" ++ show (typeRep (Proxy @whether)) ++ ")" , "(" ++ showTypeOf (Proxy @a) ++ ")" ] wNoThunks ctxt = \case - SNothingLeios -> wNoThunks ctxt () - SJustLeios x -> wNoThunks ctxt x + SNothingLeios -> wNoThunks ctxt () + SJustLeios x -> wNoThunks ctxt x ----- diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs index e18e72362e..82504dff4e 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs @@ -121,7 +121,6 @@ data BaseHeaderView pext crypto = HeaderView -- ^ KES Signature of the header } - {------------------------------------------------------------------------------- Ledger view -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs index 51dbfaecd4..1af5c6e8ae 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs @@ -36,11 +36,11 @@ import qualified Ouroboros.Consensus.Protocol.Praos as Praos import Ouroboros.Consensus.Protocol.Praos.Common ( KnownPraosExtension (praosExtensionHasLeios) , StrictMaybeLeios (SJustLeios, SNothingLeios) - , toCodecEbAnnouncement , WhetherHasLeiosDecided - ( PextDoesNotHaveLeiosDecided - , PextHasLeiosDecided - ) + ( PextDoesNotHaveLeiosDecided + , PextHasLeiosDecided + ) + , toCodecEbAnnouncement ) import Ouroboros.Consensus.Protocol.Praos.Views (extendHeaderBodyWithLeios) import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators () diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs index b07647c569..7a41db2425 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs @@ -66,6 +66,16 @@ import Cardano.Ledger.Keys , hashKey , signedDSIGN ) +import Cardano.Protocol.Praos.BlockHeader + ( Header + , HeaderBody (..) + , pattern Header + ) +import Cardano.Protocol.Praos.VRF + ( InputVRF + , mkInputVRF + , vrfLeaderValue + ) import Cardano.Protocol.TPraos.BlockHeader ( HashHeader (..) , PrevHash (..) @@ -98,16 +108,6 @@ import Ouroboros.Consensus.Protocol.Praos ( BasePraosValidationErr (..) , PraosValidationErr ) -import Cardano.Protocol.Praos.BlockHeader - ( Header - , HeaderBody (..) - , pattern Header - ) -import Cardano.Protocol.Praos.VRF - ( InputVRF - , mkInputVRF - , vrfLeaderValue - ) import Ouroboros.Consensus.Protocol.TPraos (StandardCrypto) import Test.QuickCheck ( Gen diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index cca0d1522f..6d8ea48ba2 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -1164,7 +1164,7 @@ library protocol cardano-ledger-binary, cardano-ledger-core, cardano-ledger-shelley ^>=1.20, - cardano-protocol >= 0.1.1 && <0.2, + cardano-protocol >=0.1.1 && <0.2, cardano-protocol-tpraos ^>=1.6, cardano-slotting, cborg, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs index 0fedec98ea..e6aec34d8e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs @@ -69,7 +69,10 @@ data ChainDbView m blk = ChainDbView , getIsFetched :: STM m (Point blk -> Bool) , getMaxSlotNo :: STM m MaxSlotNo , addBlockAsync :: - InvalidBlockPunishment m -> WithOrigin SlotNo -> blk -> m (AddBlockPromise m blk) + InvalidBlockPunishment m -> + WithOrigin SlotNo -> + blk -> + m (AddBlockPromise m blk) , getChainSelStarvation :: STM m ChainSelStarvation , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 7e90528397..2333e7d0d8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -144,7 +144,10 @@ import System.FS.API.Types (FsError) -- to conform to the unified interface we provide here. data ChainDB m blk = ChainDB { addBlockAsync :: - InvalidBlockPunishment m -> WithOrigin SlotNo -> blk -> m (AddBlockPromise m blk) + InvalidBlockPunishment m -> + WithOrigin SlotNo -> + blk -> + m (AddBlockPromise m blk) -- ^ Add a block to the heap of blocks -- -- We do /not/ assume that the block is valid (under the legder rules); diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index 7ae9ee973b..c93fdaeda4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -55,14 +55,14 @@ import LeiosDemoTypes , HasLeiosVoting (getLeiosCommitteeFromView) , LeiosExtValidationError (LeiosCertificateForecastRejected) , LeiosForecastRejection - ( LeiosForecastAfterGenesis - , LeiosForecastInvalidCertificate - , LeiosForecastMissingCommittee - ) + ( LeiosForecastAfterGenesis + , LeiosForecastInvalidCertificate + , LeiosForecastMissingCommittee + ) , TraceLeiosChainSel - ( TraceLeiosCertRbWithoutCandidate - , TraceLeiosValidClaim - ) + ( TraceLeiosCertRbWithoutCandidate + , TraceLeiosValidClaim + ) , acquiredLeiosEbHashes , acquiredLeiosEbsSetMember , pointEbHash @@ -76,6 +76,7 @@ import qualified LeiosValidClaims import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Config +import Ouroboros.Consensus.Forecast (Forecast (forecastAt, forecastFor)) import Ouroboros.Consensus.Fragment.Diff (ChainDiff (..)) import qualified Ouroboros.Consensus.Fragment.Diff as Diff import Ouroboros.Consensus.HardFork.Abstract @@ -84,7 +85,6 @@ import Ouroboros.Consensus.HeaderValidation ( HeaderWithTime (..) , mkHeadersWithTime ) -import Ouroboros.Consensus.Forecast (Forecast (forecastAt, forecastFor)) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect @@ -571,13 +571,14 @@ chainSelAddPerasCert cdb@CDB{..} cert varProcessed = do -- Trigger chain selection for the boosted block. lift $ lift $ traceWith tracer $ ChainSelectionForBoostedBlock certRound boostedBlock - lift $ chainSelectionForBlock - cdb - BlockCache.empty - boostedHdr - Nothing - MayNotSetTentativeHeader - noPunishment + lift $ + chainSelectionForBlock + cdb + BlockCache.empty + boostedHdr + Nothing + MayNotSetTentativeHeader + noPunishment -- Deliver promise indicating that we processed the cert. lift $ atomically $ putTMVar varProcessed () @@ -721,7 +722,6 @@ chainSelReprocessLoEBlocks cdb@CDB{..} varProcessed = lift $ do atomically $ putTMVar varProcessed () - -- | Verify the certificate in a CertRB before chain selection considers it -- -- ChainSel would otherwise only discover an invalid certificate once it applied @@ -822,7 +822,6 @@ precheckLeiosCert CDB{..} predSlot b = case blockLeiosCert b of reject cert why = pure $ Left $ LeiosCertificateForecastRejected cert predSlot why - -- | Record the invalid block in the given map and change its fingerprint addInvalidBlock :: (IOLike m, StandardHash blk) => @@ -924,95 +923,95 @@ chainSelectionForBlock mbPredecessorSlot tentativeHeaderPermission punish = electric $ do - (invalid, curChain, weights) <- - atomically $ - (,,) - <$> (forgetFingerprint <$> readTVar cdbInvalid) - <*> Query.getCurrentChain cdb - <*> (forgetFingerprint <$> Query.getPerasWeightSnapshot cdb) + (invalid, curChain, weights) <- + atomically $ + (,,) + <$> (forgetFingerprint <$> readTVar cdbInvalid) + <*> Query.getCurrentChain cdb + <*> (forgetFingerprint <$> Query.getPerasWeightSnapshot cdb) - -- The current chain we're working with here is not longer than @k@ blocks - -- (see 'getCurrentChain' and 'cdbChain'), which is easier to reason about - -- when doing chain selection, etc. - assert (fromIntegral (AF.length curChain) <= unNonZero k) pure () + -- The current chain we're working with here is not longer than @k@ blocks + -- (see 'getCurrentChain' and 'cdbChain'), which is easier to reason about + -- when doing chain selection, etc. + assert (fromIntegral (AF.length curChain) <= unNonZero k) pure () - let - immBlockNo :: WithOrigin BlockNo - immBlockNo = AF.anchorBlockNo curChain + let + immBlockNo :: WithOrigin BlockNo + immBlockNo = AF.anchorBlockNo curChain - if - -- The chain might have grown since we added the block such that the - -- block is older than the immutable tip. - | olderThanImmTip hdr immBlockNo -> do - traceWith addBlockTracer $ IgnoreBlockOlderThanImmTip p + if + -- The chain might have grown since we added the block such that the + -- block is older than the immutable tip. + | olderThanImmTip hdr immBlockNo -> do + traceWith addBlockTracer $ IgnoreBlockOlderThanImmTip p - -- The block is invalid - | Just (InvalidBlockInfo reason _) <- Map.lookup (headerHash hdr) invalid -> do - traceWith addBlockTracer $ IgnoreInvalidBlock p reason + -- The block is invalid + | Just (InvalidBlockInfo reason _) <- Map.lookup (headerHash hdr) invalid -> do + traceWith addBlockTracer $ IgnoreInvalidBlock p reason - -- We wouldn't know the block is invalid if its prefix was invalid, - -- hence 'InvalidBlockPunishment.BlockItself'. - InvalidBlockPunishment.enact - punish - InvalidBlockPunishment.BlockItself + -- We wouldn't know the block is invalid if its prefix was invalid, + -- hence 'InvalidBlockPunishment.BlockItself'. + InvalidBlockPunishment.enact + punish + InvalidBlockPunishment.BlockItself - -- Try to select a chain involving the block. - | otherwise -> do - -- Construct all 'ChainDiff's involving the block. - chainDiffs <- - constructPreferableCandidates - cdb - weights - curChain - (Map.singleton (headerHash hdr) hdr) - (headerRealPoint hdr) - - let traceNoChange = traceWith addBlockTracer $ StoreButDontChange p - - chainSelEnv = - mkChainSelEnv - cdb - blockCache - weights - curChain - tentativeHeaderPermission - (Just (p, punish)) - - case NE.nonEmpty chainDiffs of - Just chainDiffs' -> do - -- Find the best valid candidate and, if valid, perform a - -- switch. Log if none were found. - flip whenNothing traceNoChange - =<< chainSelection - chainSelEnv - chainDiffs' - (switchTo cdb weights (Just p)) - -- No candidate better than our chain. - Nothing -> do - traceNoChange - -- See 'TraceLeiosCertRbWithoutCandidate'. - whenJust mbPredecessorSlot $ \predecessorSlot -> - let immTipSlot = AF.anchorToSlotNo (AF.anchor curChain) - in when - ( headerContainsLeiosCert hdr - && predecessorSlot >= immTipSlot - ) - $ traceWith addBlockTracer - $ AddBlockLeiosEvent - $ TraceLeiosCertRbWithoutCandidate p predecessorSlot immTipSlot - where - -- Note that we may have extended the chain, but have not trimmed it to - -- @k@ blocks/headers. That is the job of the background thread, which - -- will first copy the blocks/headers to trim (from the end of the - -- fragment) from the VolatileDB to the ImmutableDB. + -- Try to select a chain involving the block. + | otherwise -> do + -- Construct all 'ChainDiff's involving the block. + chainDiffs <- + constructPreferableCandidates + cdb + weights + curChain + (Map.singleton (headerHash hdr) hdr) + (headerRealPoint hdr) + + let traceNoChange = traceWith addBlockTracer $ StoreButDontChange p + + chainSelEnv = + mkChainSelEnv + cdb + blockCache + weights + curChain + tentativeHeaderPermission + (Just (p, punish)) + + case NE.nonEmpty chainDiffs of + Just chainDiffs' -> do + -- Find the best valid candidate and, if valid, perform a + -- switch. Log if none were found. + flip whenNothing traceNoChange + =<< chainSelection + chainSelEnv + chainDiffs' + (switchTo cdb weights (Just p)) + -- No candidate better than our chain. + Nothing -> do + traceNoChange + -- See 'TraceLeiosCertRbWithoutCandidate'. + whenJust mbPredecessorSlot $ \predecessorSlot -> + let immTipSlot = AF.anchorToSlotNo (AF.anchor curChain) + in when + ( headerContainsLeiosCert hdr + && predecessorSlot >= immTipSlot + ) + $ traceWith addBlockTracer + $ AddBlockLeiosEvent + $ TraceLeiosCertRbWithoutCandidate p predecessorSlot immTipSlot + where + -- Note that we may have extended the chain, but have not trimmed it to + -- @k@ blocks/headers. That is the job of the background thread, which + -- will first copy the blocks/headers to trim (from the end of the + -- fragment) from the VolatileDB to the ImmutableDB. - SecurityParam k = configSecurityParam cdbTopLevelConfig + SecurityParam k = configSecurityParam cdbTopLevelConfig - p :: RealPoint blk - p = headerRealPoint hdr + p :: RealPoint blk + p = headerRealPoint hdr - addBlockTracer :: Tracer m (TraceAddBlockEvent blk) - addBlockTracer = TraceAddBlockEvent >$< cdbTracer + addBlockTracer :: Tracer m (TraceAddBlockEvent blk) + addBlockTracer = TraceAddBlockEvent >$< cdbTracer -- | Construct all candidates involving the given block (represented by a -- 'RealPoint') that are preferable to the current chain. @@ -1730,10 +1729,10 @@ isPipelineable permission bcfg st ChainDiff{..} getRollback == 0 = Just (hdr, st') | otherwise = Nothing - where - permitted = case permission of - MayNotSetTentativeHeader -> False - MaySetTentativeHeader -> True + where + permitted = case permission of + MayNotSetTentativeHeader -> False + MaySetTentativeHeader -> True {------------------------------------------------------------------------------- Helpers diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs index 8b151a1468..2ce05cfa00 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs @@ -414,7 +414,9 @@ class SupportsUnitTest m where addBlock :: -- | The slot of the block's predecessor - WithOrigin SlotNo -> Block m -> m (Block m) + WithOrigin SlotNo -> + Block m -> + m (Block m) newFollower :: m (FollowerId m) From df8197b1d61c2017cb4c7b01afbf18f75b5c40ab Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Wed, 9 Sep 2026 20:55:05 -0400 Subject: [PATCH 09/60] Thin out Claude's latest comments --- .../Ouroboros/Consensus/Protocol/Praos.hs | 7 ++++--- .../Ouroboros/Consensus/Protocol/Praos/Views.hs | 13 ++----------- .../src/ouroboros-consensus/LeiosDemoTypes.hs | 2 -- .../Consensus/HardFork/Combinator/Leios.hs | 2 -- 4 files changed, 6 insertions(+), 18 deletions(-) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index fd1e9c54f2..2ede3b820d 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -466,9 +466,10 @@ data BasePraosValidationErr pext c | LeiosHeaderErr !(HasLeiosProof (PraosExtensionHasLeios pext)) Leios.LeiosHeaderErr deriving Generic --- | Every Leios constructor of 'BasePraosValidationErr' carries a --- 'HasLeiosProof', so at 'PextNone' --- which is mainnet's --- none of them can --- be constructed and the inhabited set is exactly what it was before Leios. +-- | The one Leios constructor (the embedder) of 'BasePraosValidationErr' +-- carries a 'HasLeiosProof', so at 'PextNone' --- which is mainnet's /before/ +-- Leios\/Dijkstra --- none of them can be constructed and the inhabited set is +-- exactly what it was before Leios. type PraosValidationErr c = BasePraosValidationErr PextNone c deriving instance (PraosCrypto c, KnownPraosExtension pext) => Eq (BasePraosValidationErr pext c) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs index 82504dff4e..f49e9eff04 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs @@ -138,10 +138,6 @@ data BasePraosLedgerView pext = PraosLedgerView , plvProtocolVersion :: !ProtVer -- ^ Current protocol version , plvLeios :: !(StrictMaybeLeios (PraosExtensionHasLeios pext) LeiosLedgerView) - -- ^ The Leios data, statically absent unless the extension has Leios. - -- - -- One field rather than one per datum, so the committee and the parameters - -- cannot disagree about whether Leios is enabled. } deriving instance Show (BasePraosLedgerView pext) @@ -174,12 +170,8 @@ data LeiosLedgerView = LeiosLedgerView -- Nothing can be certified against it: the committee is empty and the quorum is -- the entire weight. This is the truth rather than a placeholder, both before -- the Leios era and during its first epochs, until a snapshot seated by the new --- era's rules rotates in. --- --- The remaining parameters have no counterpart in such a state, so they admit --- anything. They only bound an endorser block, whose contents are checked again --- against the era's parameters proper, whereas an over-permissive committee --- would be unsound. +-- era's rules rotates in. And so the other parameter values don't actually +-- matter. initialLeiosLedgerView :: LeiosLedgerView initialLeiosLedgerView = LeiosLedgerView @@ -211,7 +203,6 @@ instance ForecastsLeios PextNone era where instance SL.DijkstraEraForecast era => ForecastsLeios PextLeios era where forecastToLeiosPart _ = SJustLeios . forecastToLeiosLedgerView --- | Build a 'BasePraosLedgerView' from a ledger 'SL.Forecast' forecastToBasePraosLedgerView :: forall pext t era. (ForecastsLeios pext era, SL.EraForecast era) => diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs index 777afdef1a..884de0dbe4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs @@ -1382,8 +1382,6 @@ class HasLeiosVoting blk where -- it forecasts the view instead. The two must agree wherever both are -- available: this is the same committee 'getLeiosCommittee' would return for -- a state at the forecast slot. - -- The proxy fixes the block type: 'LedgerView' is a non-injective family, so - -- the view alone does not determine it. getLeiosCommitteeFromView :: proxy blk -> LedgerView (BlockProtocol blk) -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Leios.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Leios.hs index b680e8084b..ff6ccdd24a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Leios.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Leios.hs @@ -72,8 +72,6 @@ instance (\(Current _ wlv) -> K (getLeiosCommitteeFromView (eraProxy wlv) (unwrapLedgerView wlv))) (Telescope.tip tele) where - -- The wrapper is a newtype, hence injective, so matching on it is what - -- recovers the era that the non-injective 'LedgerView' loses. eraProxy :: WrapLedgerView blk -> Proxy blk eraProxy _ = Proxy From 669de1d33586730b07a3631becf6370579825a73 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Thu, 10 Sep 2026 18:40:42 -0400 Subject: [PATCH 10/60] Integrate changes to upstream cardano-ledger PR --- .../Consensus/Protocol/Praos/Views.hs | 19 ++++++++++--------- ouroboros-consensus.cabal | 1 + 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs index f49e9eff04..3e63e6540a 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs @@ -30,6 +30,7 @@ import Cardano.Ledger.BaseTypes ) import Cardano.Ledger.Chain (ChainChecksPParams (..)) import Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey) +import qualified Cardano.Ledger.Dijkstra.Forecast as Dijkstra import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Ledger.State (LeiosCommittee, emptyLeiosCommittee) import Cardano.Protocol.Crypto (KES, VRF) @@ -187,7 +188,7 @@ type ForecastsLeios :: PraosExtension -> Type -> Constraint -- | The Leios part of an era's forecast, as this extension sees it. -- --- Reading that part needs 'SL.DijkstraEraForecast', which the extensions +-- Reading that part needs 'Dijkstra.DijkstraEraForecast', which the extensions -- without Leios must not demand of their eras. 'KnownPraosExtension' cannot -- serve here: refining @pext@ says nothing about @era@, and it is an @era@ -- dictionary that is missing. @@ -200,7 +201,7 @@ class ForecastsLeios pext era where instance ForecastsLeios PextNone era where forecastToLeiosPart _ _ = SNothingLeios -instance SL.DijkstraEraForecast era => ForecastsLeios PextLeios era where +instance Dijkstra.DijkstraEraForecast era => ForecastsLeios PextLeios era where forecastToLeiosPart _ = SJustLeios . forecastToLeiosLedgerView forecastToBasePraosLedgerView :: @@ -221,15 +222,15 @@ forecastToBasePraosLedgerView f = forecastToLeiosLedgerView :: forall t era. - SL.DijkstraEraForecast era => + Dijkstra.DijkstraEraForecast era => SL.Forecast t era -> LeiosLedgerView forecastToLeiosLedgerView f = LeiosLedgerView - { llvCommittee = f ^. SL.leiosCommitteeForecastL @era @t - , llvQuorumStakeThreshold = f ^. SL.leiosQuorumStakeThresholdForecastL @era @t - , llvAnnouncementPeriodLength = f ^. SL.leiosAnnouncementPeriodLengthForecastL @era @t - , llvVotePeriodLength = f ^. SL.leiosVotePeriodLengthForecastL @era @t - , llvDiffusionPeriodLength = f ^. SL.leiosDiffusionPeriodLengthForecastL @era @t - , llvMaxEbBodySize = f ^. SL.maxEndorserBlockReferencesSizeForecastL @era @t + { llvCommittee = f ^. Dijkstra.leiosCommitteeForecastL @era @t + , llvQuorumStakeThreshold = f ^. Dijkstra.leiosQuorumStakeThresholdForecastL @era @t + , llvAnnouncementPeriodLength = f ^. Dijkstra.leiosAnnouncementPeriodLengthForecastL @era @t + , llvVotePeriodLength = f ^. Dijkstra.leiosVotePeriodLengthForecastL @era @t + , llvDiffusionPeriodLength = f ^. Dijkstra.leiosDiffusionPeriodLengthForecastL @era @t + , llvMaxEbBodySize = f ^. Dijkstra.maxEndorserBlockReferencesSizeForecastL @era @t } diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 6d8ea48ba2..f26fd23dcd 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -1163,6 +1163,7 @@ library protocol cardano-crypto-class:cardano-crypto-class, cardano-ledger-binary, cardano-ledger-core, + cardano-ledger-dijkstra, cardano-ledger-shelley ^>=1.20, cardano-protocol >=0.1.1 && <0.2, cardano-protocol-tpraos ^>=1.6, From 045bbec83ff345147a51bb5f531343cd7ca6bc2e Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Thu, 10 Sep 2026 19:46:31 -0400 Subject: [PATCH 11/60] ThreadNet.Leios: fix flaky test via discard --- .../test/cardano-test/Test/ThreadNet/Leios.hs | 21 ++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Leios.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Leios.hs index 252243430e..35c5a7775a 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Leios.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Leios.hs @@ -377,13 +377,20 @@ prop_leios seed = -- an RB can finalise the previous EB (via a cert) while announcing the -- next one. With continuous tx flow, a certifying block rebases the -- mempool onto the post-certified-EB ledger state and announces a fresh EB - -- from the survivors. Unless the run produced no certifying blocks at all, - -- at least one should exercise the combined path. - propCertifyAndAnnounce = - (not (null announcedAndCertifiedSlots)) - & counterexample "no block both certified and announced" - & counterexample ("certifying block slots: " <> show certificateBlocks) - & counterexample ("announced-and-certified slots: " <> show announcedAndCertifiedSlots) + -- from the survivors. A run that certified nothing at all cannot exercise the + -- combined path, so it is discarded rather than passed vacuously. That needs + -- every gap between consecutive blocks to fall short of 'minCertGap', which + -- at @f = 1/20@ over 200 slots is around one run in several hundred: ~10 + -- blocks, so ~9 gaps, each reaching 14 slots with probability + -- @0.95^14 ~ 0.49@. + propCertifyAndAnnounce + | null certificateBlocks = discard + | otherwise = + (not (null announcedAndCertifiedSlots)) + & counterexample "no block both certified and announced" + & counterexample ("certifying block slots: " <> show certificateBlocks) + & counterexample + ("announced-and-certified slots: " <> show announcedAndCertifiedSlots) -- In an honest net every acquired closure must apply against the announcing -- RB's ledger state, because 'partitionMempool' cuts both the RB's and the From c2dcdd39a693f06f894a032471771b800f68c50f Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 18 Sep 2026 16:47:52 -0400 Subject: [PATCH 12/60] consensus: enrich HeaderWithTime and improve its construction This commit prepares to enrich HeaderWithTime with additional information. That information is always available when the header is validated. That was also the case with the RelativeTime already in this data type, but that RelativeTime was convenient to tack on in a few key places rather than more fundamentally. This new field will not be, so this commit bites-the-bullet and does the more complete integration that the introdction of HeaderWithTime was able to workaround. This is a desirable refactor in general, but the concrete motivation for doing it now is to remove the possibility of a forecast failure within ChainSel's logic for validating the Leios cert in an arriving block. This design allows for us to always decorate validated headers with semantically-derived annotations _without_ storing those annotations on disk, which is desirable since the annotations themselves do not influence the hash that is used to locate and integrity-check on-disk content. --- ...ick.frisby_validated_header_annotations.md | 29 ++++ .../Ouroboros/Consensus/HeaderValidation.hs | 72 ++-------- .../Consensus/Storage/ChainDB/Impl.hs | 19 +-- .../Storage/ChainDB/Impl/ChainSel.hs | 75 +++++----- .../Consensus/Storage/LedgerDB/API.hs | 2 +- .../Consensus/Storage/LedgerDB/Forker.hs | 134 ++++++++++++++---- .../Consensus/Storage/LedgerDB/V1.hs | 3 +- .../Consensus/Storage/LedgerDB/V2.hs | 3 +- .../MiniProtocol/LocalStateQuery/Server.hs | 6 +- .../Storage/LedgerDB/StateMachine.hs | 10 +- 10 files changed, 209 insertions(+), 144 deletions(-) create mode 100644 changelog.d/20260918_170000_nick.frisby_validated_header_annotations.md diff --git a/changelog.d/20260918_170000_nick.frisby_validated_header_annotations.md b/changelog.d/20260918_170000_nick.frisby_validated_header_annotations.md new file mode 100644 index 0000000000..c76e938267 --- /dev/null +++ b/changelog.d/20260918_170000_nick.frisby_validated_header_annotations.md @@ -0,0 +1,29 @@ + + +### Breaking + +- Removed `mkHeaderWithTime` and `mkHeadersWithTime`. They rebuilt the annotations after the fact from an near-enough ledger states, which the new annotation can't tolerate. The two components that validate now emit `HeaderWithTime`s directly: the ChainSync client, and ChainSel by way of the LedgerDB. + +- `ValidateResult`'s `ValidateSuccessful` and `ValidateLedgerError` now carry the validated headers of the blocks that were successfully applied, which isn't necessarily all of the blocks that were given in the `ValidateLedgerError` case. + +- `SuccessForkerAction` gained a block type parameter and receives that fragment, this being the only point at which it and the `Forker` are both in hand. + +- `applyBlock` returns the block it applied alongside the resulting state, and `applyThenPush` returns that block's header and the state it pushed, so that a caller which passed a reference need not resolve it a second time. + +- `ChainSel`'s `ValidationResult`, `chainSelection` and `initialChainSelection` traffic in `ChainDiff (HeaderWithTime blk)` and `AnchoredFragment (HeaderWithTime blk)` rather than plain headers. + + diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs index 0590ed7bd8..325e8300d6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs @@ -67,8 +67,7 @@ module Ouroboros.Consensus.HeaderValidation -- * Header with time , HeaderWithTime (..) - , mkHeaderWithTime - , mkHeadersWithTime + , forgetValidation ) where import Cardano.Binary (enforceSize) @@ -95,11 +94,6 @@ import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (RelativeTime) import Ouroboros.Consensus.Config -import Ouroboros.Consensus.HardFork.Abstract - ( HasHardForkHistory (hardForkSummary) - ) -import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry -import Ouroboros.Consensus.Ledger.Basics import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Ticked import Ouroboros.Consensus.Util (whenJust) @@ -606,8 +600,11 @@ deriving instance StandardHash blk => NoThunks (TipInfoIsEBB blk) -- helpful, since it's possible that some other chain would translate that same -- slot to a different time. -- --- TODO rename this type, eg to @EnrichedHeader@: it no longer merely adds a --- time, and the @hwt@ prefix on its fields is similarly outdated. +-- TODO rename this type, eg to @ValidatedHeader@, and the @hwt@ prefix on its +-- fields to match: it no longer merely adds a time. \"Validated\" rather than +-- \"enriched\" because that names where these can come from -- every field +-- beyond the header itself is a by-product of validating it, so the only +-- places able to build one are the two that validate. data HeaderWithTime blk = HeaderWithTime { hwtHeader :: !(Header blk) , hwtSlotRelativeTime :: !RelativeTime @@ -657,57 +654,14 @@ instance instance GetHeader1 HeaderWithTime where getHeader1 = hwtHeader --- | Convert 'Header' to 'HeaderWithTime' --- --- PREREQ: The given ledger must be able to translate the slot of the given --- header. --- --- This is INLINEed since the summary can usually be reused. -mkHeaderWithTime :: - ( HasHardForkHistory blk - , HasHeader (Header blk) - ) => - LedgerConfig blk -> - LedgerState blk mk -> - -- | The slot of the header's predecessor - WithOrigin SlotNo -> - Header blk -> - HeaderWithTime blk -{-# INLINE mkHeaderWithTime #-} -mkHeaderWithTime cfg lst = \predSlot hdr -> - let summary = hardForkSummary cfg lst - slot = realPointSlot $ headerRealPoint hdr - qry = Qry.slotToWallclock slot - (slotTime, _) = Qry.runQueryPure qry summary - in HeaderWithTime - { hwtHeader = hdr - , hwtSlotRelativeTime = slotTime - , hwtPredecessorSlot = predSlot - } - --- | Convert a fragment of 'Header's to 'HeaderWithTime's --- --- Each header's predecessor is the header before it on the fragment, except --- for the oldest, whose predecessor is the fragment's anchor. --- --- PREREQ: as 'mkHeaderWithTime', for every header on the fragment. -mkHeadersWithTime :: - ( HasHardForkHistory blk - , HasHeader (Header blk) - , Typeable blk - ) => - LedgerConfig blk -> - LedgerState blk mk -> - AF.AnchoredFragment (Header blk) -> - AF.AnchoredFragment (HeaderWithTime blk) -mkHeadersWithTime cfg lst frag = +-- | Discard what validating the headers revealed +forgetValidation :: + HasHeader (Header blk) => + AF.AnchoredFragment (HeaderWithTime blk) -> + AF.AnchoredFragment (Header blk) +forgetValidation frag = AF.fromOldestFirst (AF.castAnchor (AF.anchor frag)) $ - zipWith - (mkHeaderWithTime cfg lst) - (AF.anchorToSlotNo (AF.anchor frag) : map (NotOrigin . blockSlot) hdrs) - hdrs - where - hdrs = AF.toOldestFirst frag + map hwtHeader (AF.toOldestFirst frag) {------------------------------------------------------------------------------- Serialisation diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index 784938ac6e..5d8fa72e71 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -60,10 +60,8 @@ import LeiosDemoTypes import LeiosValidClaims (emptyValidClaims) import NoThunks.Class import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract -import Ouroboros.Consensus.HeaderValidation (mkHeadersWithTime) -import Ouroboros.Consensus.Ledger.Extended (ledgerState) +import Ouroboros.Consensus.HeaderValidation (forgetValidation) import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol @@ -231,7 +229,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do varAcquiredLeiosEbs <- newTVarIO (acquiredLeiosEbsFromList initialAcquiredLeiosEbs) varLeiosValidClaims <- newTVarIO emptyValidClaims - chain <- + chainWithTime <- ChainSel.initialChainSelection immutableDB volatileDB @@ -245,16 +243,9 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do traceWith initChainSelTracer InitialChainSelected LedgerDB.tryFlush lgrDB - curLedger <- atomically $ LedgerDB.getVolatileTip lgrDB - let lcfg = configLedger (Args.cdbsTopLevelConfig cdbSpecificArgs) - - -- the volatile tip ledger state can translate the slots of the volatile - -- headers - chainWithTime = - mkHeadersWithTime - lcfg - (ledgerState curLedger) - chain + -- Initial chain selection validated these headers, so they already carry + -- what validation reveals; see 'HeaderWithTime'. + let chain = forgetValidation chainWithTime varChain <- newTVarWithInvariantIO checkInternalChain $ InternalChain chain chainWithTime varTentativeState <- newTVarIO $ initialTentativeHeaderState (Proxy @blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index c93fdaeda4..999c162617 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -83,7 +83,7 @@ import Ouroboros.Consensus.HardFork.Abstract import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.HeaderValidation ( HeaderWithTime (..) - , mkHeadersWithTime + , forgetValidation ) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended @@ -156,7 +156,9 @@ initialChainSelection :: STM m AcquiredLeiosEbsSet -> LoE () -> PerasWeightSnapshot blk -> - m (AnchoredFragment (Header blk)) + -- | The selected chain, whose headers carry what validating them revealed; + -- see 'Ouroboros.Consensus.HeaderValidation.HeaderWithTime'. + m (AnchoredFragment (HeaderWithTime blk)) initialChainSelection immutableDB volatileDB @@ -204,15 +206,18 @@ initialChainSelection let curChain :: AnchoredFragment (Header blk) curChain = Empty (AF.castAnchor i) + curChainWithTime :: AnchoredFragment (HeaderWithTime blk) + curChainWithTime = Empty (AF.castAnchor i) + case NE.nonEmpty [ (chain, reason) | chain <- chains , ShouldSwitch reason <- [preferAnchoredCandidate bcfg weights curChain chain] ] of -- If there are no candidates, no chain selection is needed - Nothing -> pure curChain + Nothing -> pure curChainWithTime Just chains' -> - fromMaybe curChain <$> chainSelection' curChain chains' + fromMaybe curChainWithTime <$> chainSelection' curChain chains' where bcfg :: BlockConfig blk bcfg = configBlock cfg @@ -266,7 +271,7 @@ initialChainSelection -- @i@. NonEmpty (AnchoredFragment (Header blk), ReasonForSwitch' blk) -> -- \^ Candidates anchored at @i@ - m (Maybe (AnchoredFragment (Header blk))) + m (Maybe (AnchoredFragment (HeaderWithTime blk))) chainSelection' curChain candidates = assert (all ((curpt ==) . castPoint . AF.anchorPoint . fst) candidates) $ assert (all (shouldSwitch . preferAnchoredCandidate bcfg weights curChain . fst) candidates) $ do @@ -275,7 +280,7 @@ initialChainSelection <$> chainSelection cse (first Diff.extend <$> candidates) - (\_ _ -> MkSuccessForkerAction $ join . atomically . forkerCommit) + (\_ _ -> MkSuccessForkerAction $ \_infos -> join . atomically . forkerCommit) where curpt = AF.anchorPoint curChain chainSelEnv = do @@ -1225,8 +1230,8 @@ switchTo :: ChainDiff (Header blk) -> ReasonForSwitch' blk -> -- | Forker at the tip of the above ChainDiff - SuccessForkerAction m (ExtLedgerState blk) -switchTo CDB{..} weights triggerPt chainDiff reason = MkSuccessForkerAction $ \forker -> do + SuccessForkerAction m (ExtLedgerState blk) blk +switchTo CDB{..} weights triggerPt chainDiff reason = MkSuccessForkerAction $ \validated forker -> do traceWith addBlockTracer $ ChangingSelection $ castPoint $ @@ -1240,15 +1245,11 @@ switchTo CDB{..} weights triggerPt chainDiff reason = MkSuccessForkerAction $ \f Nothing -> error "chainDiff doesn't fit onto current chain" Just newChain -> do - let lcfg = configLedger cdbTopLevelConfig - diffWithTime = - -- the new ledger state can translate the slots of the new - -- headers - ChainDiff (Diff.getRollback chainDiff) $ - mkHeadersWithTime - lcfg - (ledgerState newLedger) - (Diff.getSuffix chainDiff) + let diffWithTime = + -- Validating these blocks is what produced the annotations, so + -- this is the fragment validation handed us; see + -- 'HeaderWithTime'. + ChainDiff (Diff.getRollback chainDiff) validated newChainWithTime = case Diff.apply curChainWithTime diffWithTime of Nothing -> error "chainDiff failed for HeaderWithTime" @@ -1466,11 +1467,12 @@ chainSelection :: -- | The candidates NonEmpty (ChainDiff (Header blk), ReasonForSwitch' blk) -> -- | The continuation to run on succesfully validating a candidate. - (ChainDiff (Header blk) -> ReasonForSwitch' blk -> SuccessForkerAction m (ExtLedgerState blk)) -> + (ChainDiff (Header blk) -> ReasonForSwitch' blk -> SuccessForkerAction m (ExtLedgerState blk) blk) -> -- | The (valid) chain diff and corresponding LedgerDB that was selected, -- or 'Nothing' if there is no valid chain diff preferred over the current - -- chain. - m (Maybe (ChainDiff (Header blk), ReasonForSwitch' blk)) + -- chain. Its headers carry what validating them revealed; see + -- 'ValidationResult'. + m (Maybe (ChainDiff (HeaderWithTime blk), ReasonForSwitch' blk)) chainSelection chainSelEnv chainDiffs onSuccess = assert ( all @@ -1490,6 +1492,10 @@ chainSelection chainSelEnv chainDiffs onSuccess = [(ChainDiff (Header blk), ReasonForSwitch' blk)] -> [(ChainDiff (Header blk), ReasonForSwitch' blk)] sortCandidates = sortBy ((flip $ compareChainDiffs bcfg weights curChain) `on` fst) + forgetDiffValidation :: ChainDiff (HeaderWithTime blk) -> ChainDiff (Header blk) + forgetDiffValidation (ChainDiff rollback' suffix') = + ChainDiff rollback' (forgetValidation suffix') + -- 1. Take the first candidate from the list of sorted candidates -- 2. Validate it -- - If it is fully valid -> return it @@ -1498,7 +1504,7 @@ chainSelection chainSelEnv chainDiffs onSuccess = -- [Ouroboros] below. go :: [(ChainDiff (Header blk), ReasonForSwitch' blk)] -> - m (Maybe (ChainDiff (Header blk), ReasonForSwitch' blk)) + m (Maybe (ChainDiff (HeaderWithTime blk), ReasonForSwitch' blk)) go [] = pure Nothing go ((candidate, reason) : candidates0) = do case NE.nonEmpty (AF.toOldestFirst $ getSuffix candidate) of @@ -1508,7 +1514,8 @@ chainSelection chainSelEnv chainDiffs onSuccess = validateCandidate chainSelEnv candidate neHeaders (onSuccess candidate reason) >>= \case FullyValid candidate' -> -- The entire candidate is valid - assert (Diff.getTip candidate == Diff.getTip candidate') $ pure (Just (candidate, reason)) + assert (Diff.getTip candidate == castPoint (Diff.getTip candidate')) $ + pure (Just (candidate', reason)) ValidPrefix candidate' -> do whenJust mTentativeHeader clearTentativeHeader -- Prefix of the candidate because it contained rejected blocks @@ -1526,7 +1533,7 @@ chainSelection chainSelEnv chainDiffs onSuccess = -- current chain. let newReason = preferAnchoredCandidate bcfg weights curChain (Diff.getSuffix candidate') let candidates2 = case newReason of - ShouldSwitch reason' -> (candidate', reason') : candidates1 + ShouldSwitch reason' -> (forgetDiffValidation candidate', reason') : candidates1 ShouldNotSwitch{} -> candidates1 go (sortCandidates candidates2) where @@ -1607,13 +1614,16 @@ chainSelection chainSelEnv chainDiffs onSuccess = -- peer's valid chain. -- | Result of 'validateCandidate'. +-- +-- The headers are the validated ones, since validating them is what +-- produced the extra information they carry; see 'HeaderWithTime'. data ValidationResult blk = -- | The entire candidate fragment was valid. - FullyValid (ChainDiff (Header blk)) + FullyValid (ChainDiff (HeaderWithTime blk)) | -- | The candidate fragment contained invalid blocks that had to be -- truncated from the fragment. We only return the (potentially empty) valid -- prefix. - ValidPrefix (ChainDiff (Header blk)) + ValidPrefix (ChainDiff (HeaderWithTime blk)) -- | Validate a candidate by applying its blocks to the ledger, and return a -- 'ValidatedChainDiff' for it, i.e., a chain diff along with a ledger @@ -1642,7 +1652,7 @@ validateCandidate :: ChainDiff (Header blk) -> -- | Invariant: This non-empty list of headers is the list of headers in the ChainDiff above NonEmpty (Header blk) -> - SuccessForkerAction m (ExtLedgerState blk) -> + SuccessForkerAction m (ExtLedgerState blk) blk -> m (ValidationResult blk) validateCandidate chainSelEnv chainDiff@(ChainDiff rollback suffix) neHeaders onSuccess = LedgerDB.validateFork @@ -1658,11 +1668,12 @@ validateCandidate chainSelEnv chainDiff@(ChainDiff rollback suffix) neHeaders on -- tip, which is impossible, since the candidates we construct must -- connect to the immutable tip. error "found candidate requiring rolling back past the immutable tip" - ValidateLedgerError (AnnLedgerError lastValid pt e) -> do - let chainDiff' = Diff.truncate (castPoint lastValid) chainDiff + ValidateLedgerError validated (AnnLedgerError lastValid pt e) -> do traceWith validationTracer (InvalidBlock e pt) addInvalidBlock varInvalid e pt - traceWith validationTracer (ValidCandidate (Diff.getSuffix chainDiff')) + -- 'validated' is already truncated to the blocks that were applied, + -- so there is no second truncation to keep in step with it. + traceWith validationTracer (ValidCandidate (forgetValidation validated)) -- punish the peer who sent a block if it is invalid or a block from its -- prefix is invalid @@ -1689,10 +1700,10 @@ validateCandidate chainSelEnv chainDiff@(ChainDiff rollback suffix) neHeaders on -- we should punish. (Tacit assumption made here: it's impossible -- three blocks in a row have the same slot.) - pure $ ValidPrefix chainDiff' - ValidateSuccessful -> do + pure $ ValidPrefix (ChainDiff (Diff.getRollback chainDiff) validated) + ValidateSuccessful validated -> do traceWith validationTracer (ValidCandidate suffix) - pure $ FullyValid chainDiff + pure $ FullyValid (ChainDiff (Diff.getRollback chainDiff) validated) where ChainSelEnv { lgrDB diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs index b4e8e6c4b3..7dc3bdfcfc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs @@ -342,7 +342,7 @@ data LedgerDB m l blk = LedgerDB BlockCache blk -> Word64 -> NonEmpty (Header blk) -> - SuccessForkerAction m l -> + SuccessForkerAction m l blk -> m (ValidateResult l blk) -- ^ Try to apply a sequence of blocks on top of the LedgerDB, first rolling -- back as many blocks as the passed @Word64@. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs index bd0776ea36..c8ad0ba2b1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs @@ -103,12 +103,22 @@ import LeiosDemoTypes import NoThunks.Class import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config (configLedger) -import Ouroboros.Consensus.HeaderValidation (headerStateChainDep) +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (hardForkSummary)) +import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry +import Ouroboros.Consensus.HeaderValidation + ( AnnTip (..) + , HasAnnTip + , HeaderState (..) + , HeaderWithTime (..) + , annTipHash + , headerStateChainDep + ) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx) import Ouroboros.Consensus.Ledger.Tables.Utils ( calculateDifference + , forgetLedgerTables , prependDiffs , trackingToDiffs ) @@ -123,6 +133,8 @@ import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache as BlockCache import Ouroboros.Consensus.Util.CallStack +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike @@ -339,7 +351,7 @@ data ValidateArgs m l blk = ValidateArgs -- ^ Get the current set of previously applied blocks , withForkerAtFromTip :: !(forall r. Word64 -> (Forker m l -> m r) -> m (Either GetForkerError r)) -- ^ Create a forker from the tip - , onSuccess :: !(SuccessForkerAction m l) + , onSuccess :: !(SuccessForkerAction m l blk) -- ^ Continuation to run when the validation was successful , trace :: !(TraceValidateEvent blk -> m ()) -- ^ A tracer for validate events @@ -359,6 +371,10 @@ data ValidateArgs m l blk = ValidateArgs validate :: forall m l blk. ( IOLike m + , HasHardForkHistory blk + , GetHeader blk + , HasAnnTip blk + , GetTip (LedgerState blk) , HasCallStack , ApplyBlock l blk , ResolveLeiosBlock blk @@ -401,12 +417,14 @@ validate evs args = do } = args rewrap :: - Either GetForkerError (Either (AnnLedgerError l blk) ()) -> + Either + GetForkerError + (Either (AnnLedgerError l blk) (), AnchoredFragment (HeaderWithTime blk)) -> ValidateResult l blk - rewrap (Right (Left e)) = ValidateLedgerError e + rewrap (Right (Left e, validated)) = ValidateLedgerError validated e rewrap (Left (PointTooOld (Just e))) = ValidateExceededRollBack e rewrap (Left _) = error "Unreachable, validating will always rollback from the tip" - rewrap (Right (Right ())) = ValidateSuccessful + rewrap (Right (Right (), validated)) = ValidateSuccessful validated mkAps :: Set (RealPoint blk) -> @@ -428,13 +446,17 @@ validate evs args = do validBlockPoints :: ValidateResult l blk -> [RealPoint blk] -> [RealPoint blk] validBlockPoints = \case ValidateExceededRollBack _ -> const [] - ValidateSuccessful -> id - ValidateLedgerError e -> takeWhile (/= annLedgerErrRef e) + ValidateSuccessful _ -> id + ValidateLedgerError _ e -> takeWhile (/= annLedgerErrRef e) -- | Switch to a fork by rolling back a number of blocks and then pushing the -- new blocks. switch :: ( ApplyBlock l blk + , HasHardForkHistory blk + , GetHeader blk + , HasAnnTip blk + , GetTip (LedgerState blk) , MonadSTM m , ResolveLeiosBlock blk , HasLeiosVoting blk @@ -451,13 +473,17 @@ switch :: -- | New blocks to apply NonEmpty (Ap m l blk) -> ResolveBlock m blk -> - SuccessForkerAction m l -> - m (Either GetForkerError (Either (AnnLedgerError l blk) ())) + SuccessForkerAction m l blk -> + m + ( Either + GetForkerError + (Either (AnnLedgerError l blk) (), AnchoredFragment (HeaderWithTime blk)) + ) switch leiosDb withForkerAtFromTip evs cfg numRollbacks trace newBlocks doResolve onSuccess = do withForkerAtFromTip numRollbacks $ \fo -> do let start = PushStart . toRealPoint . NE.head $ newBlocks goal = PushGoal . toRealPoint . NE.last $ newBlocks - ePush <- + (ePush, validated) <- applyThenPushMany leiosDb (trace . StartedPushingBlockToTheLedgerDb start goal) @@ -467,8 +493,10 @@ switch leiosDb withForkerAtFromTip evs cfg numRollbacks trace newBlocks doResolv fo doResolve case ePush of - Left err -> pure (Left err) - Right () -> fmap Right $ applySuccessForkerAction onSuccess fo + Left err -> pure (Left err, validated) + Right () -> do + applySuccessForkerAction onSuccess validated fo + pure (Right (), validated) {------------------------------------------------------------------------------- Apply blocks @@ -522,7 +550,7 @@ applyBlockToForker :: blk -> m (Either (AnnLedgerError l blk) (l DiffMK)) applyBlockToForker leiosDb mode evs cfg fo blk = - applyBlock leiosDb evs cfg ap fo noResolution + fmap (fmap snd) $ applyBlock leiosDb evs cfg ap fo noResolution where ap = case mode of ValidateBlock -> ApplyVal blk @@ -549,9 +577,10 @@ applyBlock :: Ap m l blk -> Forker m l -> ResolveBlock m blk -> - m (Either (AnnLedgerError l blk) (l DiffMK)) + -- | The block that was resolved, alongside the result of applying it. + m (Either (AnnLedgerError l blk) (blk, l DiffMK)) applyBlock leiosDb evs cfg ap fo doResolveBlock = case ap of - ReapplyVal b -> do + ReapplyVal b -> fmap (fmap (\st -> (b, st))) $ do case blockLeiosCert b of Nothing -> -- Not a CertRB: ordinary Praos block @@ -593,7 +622,7 @@ applyBlock leiosDb evs cfg ap fo doResolveBlock = case ap of let lsAfterEB = extSt{ledgerState = lcaStateAfterEB} blockDiff = tickThenReapply evs cfg b lsAfterEB in pure (Right (prependDiffs lcaClosureDiff blockDiff)) - ApplyVal b -> do + ApplyVal b -> fmap (fmap (\st -> (b, st))) $ do case blockLeiosCert b of Nothing -> do -- Not a CertRB: ordinary Praos block @@ -682,6 +711,7 @@ applyBlock leiosDb evs cfg ap fo doResolveBlock = case ap of -- push the resulting ledger state to the forker. applyThenPush :: ( ApplyBlock l blk + , GetHeader blk , MonadSTM m , ResolveLeiosBlock blk , HasLeiosVoting blk @@ -694,16 +724,23 @@ applyThenPush :: Ap m l blk -> Forker m l -> ResolveBlock m blk -> - m (Either (AnnLedgerError l blk) ()) + -- | The header of the block that was applied and the resulting state + m (Either (AnnLedgerError l blk) (Header blk, l DiffMK)) applyThenPush leiosDb evs cfg ap fo doResolve = do eLerr <- applyBlock leiosDb evs cfg ap fo doResolve case eLerr of Left err -> pure (Left err) - Right st -> Right <$> forkerPush fo st + Right (b, st) -> do + forkerPush fo st + pure $ Right (getHeader b, st) -- | Apply and push a sequence of blocks (oldest first). applyThenPushMany :: ( ApplyBlock l blk + , HasHardForkHistory blk + , GetHeader blk + , HasAnnTip blk + , GetTip (LedgerState blk) , MonadSTM m , ResolveLeiosBlock blk , HasLeiosVoting blk @@ -717,16 +754,45 @@ applyThenPushMany :: [Ap m l blk] -> Forker m l -> ResolveBlock m blk -> - m (Either (AnnLedgerError l blk) ()) -applyThenPushMany leiosDb trace evs cfg aps fo doResolveBlock = pushAndTrace aps + m (Either (AnnLedgerError l blk) (), AnchoredFragment (HeaderWithTime blk)) +applyThenPushMany leiosDb trace evs cfg aps fo doResolveBlock = do + -- The forker's state before any push, ie at the fork point. Thereafter each + -- push reports the state it produced, so the forker is read only this once. + initialState <- atomically (forkerGetLedgerState fo) + pushAndTrace (AF.Empty (anchorOf initialState)) initialState aps where - pushAndTrace [] = pure $ Right () - pushAndTrace (ap : aps') = do + lcfg = configLedger (getExtLedgerCfg cfg) + + anchorOf st = case headerStateTip (headerState st) of + Origin -> AF.AnchorGenesis + NotOrigin annTip -> + AF.Anchor (annTipSlotNo annTip) (annTipHash annTip) (annTipBlockNo annTip) + + pushAndTrace acc _predecessorState [] = pure (Right (), acc) + pushAndTrace acc predecessorState (ap : aps') = do trace $ Pushing . toRealPoint $ ap res <- applyThenPush leiosDb evs cfg ap fo doResolveBlock case res of - Left err -> pure (Left err) - Right () -> pushAndTrace aps' + Left err -> pure (Left err, acc) + Right (hdr, st) -> do + -- Every annotation comes from the state the block's predecessor left + -- behind. Only validation sees it: it exists inside the forker until + -- the caller commits, which is why these originate here. + let predecessorLedger = ledgerState predecessorState + !hwt = + HeaderWithTime + { hwtHeader = hdr + , hwtSlotRelativeTime = + -- The summary is the one from the state this block just + -- produced, and this block's slot is that state's tip + -- slot, which a summary can always translate. + fst $ + Qry.runQueryPure + (Qry.slotToWallclock (blockSlot hdr)) + (hardForkSummary lcfg (ledgerState st)) + , hwtPredecessorSlot = getTipSlot predecessorLedger + } + pushAndTrace (acc AF.:> hwt) (forgetLedgerTables st) aps' {------------------------------------------------------------------------------- Finding blocks @@ -1006,14 +1072,26 @@ resolveAndApplyLeiosClosure leiosDb lcfg ebHash readValues extraKeys lsBase = do -- commonly used as "how to close a @res@", which is *NOT* the case -- here. So it's preferable to use this more perspicious type in -- signatures. -newtype SuccessForkerAction m l = MkSuccessForkerAction - { applySuccessForkerAction :: Forker m l -> m () +newtype SuccessForkerAction m l blk = MkSuccessForkerAction + { applySuccessForkerAction :: + AnchoredFragment (HeaderWithTime blk) -> Forker m l -> m () + -- ^ Run with the blocks that were applied, as validated headers anchored at + -- the fork point. This is the only point at which they and the forker are + -- both in hand. } -- | When validating a sequence of blocks, these are the possible outcomes. +-- +-- 'ValidateSuccessful' and 'ValidateLedgerError' carry the blocks that were +-- applied, as validated headers anchored at the fork point -- so the fragment +-- is the accepted prefix, and is empty when nothing was applied. +-- +-- Validation builds these because it is the only place that sees what they +-- record: each annotation is a projection of the state the previous block +-- left behind, which exists only inside the forker until the caller commits. data ValidateResult l blk - = ValidateSuccessful - | ValidateLedgerError (AnnLedgerError l blk) + = ValidateSuccessful (AnchoredFragment (HeaderWithTime blk)) + | ValidateLedgerError (AnchoredFragment (HeaderWithTime blk)) (AnnLedgerError l blk) | ValidateExceededRollBack ExceededRollback {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs index 7c0f760724..39b3912320 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs @@ -275,6 +275,7 @@ implGetHeaderStateHistory env = do implValidate :: forall m l blk. ( IOLike m + , HasHardForkHistory blk , LedgerSupportsProtocol blk , HasCallStack , StandardHash l @@ -289,7 +290,7 @@ implValidate :: BlockCache blk -> Word64 -> NonEmpty (Header blk) -> - SuccessForkerAction m l -> + SuccessForkerAction m l blk -> m (ValidateResult l blk) implValidate h ldbEnv tr cache rollbacks hdrs onSuccess = -- Open a connection scoped to this call: the 'LeiosDbReader' diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs index b782ea8cb7..02bfb844d4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs @@ -299,6 +299,7 @@ implGetHeaderStateHistory env = do implValidate :: forall m l blk. ( IOLike m + , HasHardForkHistory blk , HasCallStack , ApplyBlock l blk , StandardHash l @@ -313,7 +314,7 @@ implValidate :: BlockCache blk -> Word64 -> NonEmpty (Header blk) -> - SuccessForkerAction m l -> + SuccessForkerAction m l blk -> m (ValidateResult l blk) implValidate h ldbEnv tr cache rollbacks hdrs onSuccess = validate (ledgerDbCfgComputeLedgerEvents $ ldbCfg ldbEnv) $ diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs index ac93cf6b8e..37c1198fc7 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs @@ -278,13 +278,13 @@ initLedgerDB s c = do BlockCache.empty 0 (NE.map getHeader chain) - (MkSuccessForkerAction $ join . atomically . LedgerDB.forkerCommit) + (MkSuccessForkerAction $ \_vhdrs -> join . atomically . LedgerDB.forkerCommit) case result of - LedgerDB.ValidateSuccessful -> do + LedgerDB.ValidateSuccessful{} -> do pure () LedgerDB.ValidateExceededRollBack _ -> error "impossible: rollback was 0" - LedgerDB.ValidateLedgerError _ -> + LedgerDB.ValidateLedgerError{} -> error "impossible: there were no invalid blocks" pure ldb diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs index bdabff2ebf..52dd5b417b 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs @@ -635,9 +635,9 @@ openLedgerDB flavArgs env cfg fs = do BlockCache.empty 0 (NE.map getHeader volBlocks') - (MkSuccessForkerAction $ Monad.join . atomically . forkerCommit) + (MkSuccessForkerAction $ \_vhdrs -> Monad.join . atomically . forkerCommit) case vr of - ValidateSuccessful -> pure () + ValidateSuccessful{} -> pure () _ -> error "Couldn't restart the chain, failed to apply volatile blocks!" pure (ldb, od, getNumOpenHandles) @@ -691,7 +691,7 @@ instance RunModel Model (StateT Environment IO) where modifyTVar (dbBlocks chainDb) $ repeatedly (uncurry Map.insert) (map (\b -> (blockRealPoint b, b)) $ NE.toList blks) - vr <- validateFork ldb (const $ pure ()) BlockCache.empty n (NE.map getHeader blks) $ MkSuccessForkerAction $ \forker -> do + vr <- validateFork ldb (const $ pure ()) BlockCache.empty n (NE.map getHeader blks) $ MkSuccessForkerAction $ \_vhdrs forker -> do atomically $ modifyTVar (dbChain chainDb) $ (reverse (map blockRealPoint $ NE.toList blks) ++) . drop (fromIntegral n) @@ -702,9 +702,9 @@ instance RunModel Model (StateT Environment IO) where garbageCollect ldb . fromWithOrigin 0 $ pointSlot immTipPoint atomically $ writeTVar (dbImmTip chainDb) $ castPoint immTipPoint case vr of - ValidateSuccessful -> pure $ Right () + ValidateSuccessful{} -> pure $ Right () ValidateExceededRollBack{} -> pure $ Left ErrorValidateExceededRollback - ValidateLedgerError (AnnLedgerError p _ err) -> error ("Unexpected ledger error" <> show err <> " on point " <> show p) + ValidateLedgerError _ (AnnLedgerError p _ err) -> error ("Unexpected ledger error" <> show err <> " on point " <> show p) perform state@(Model _ _ secParam) (DropAndRestore n salt) lk = do Environment _ testInternals chainDb _ _ _ _ <- get lift $ do From 252ccad75cdf76f8c64857c1bb275bf08e3bb55e Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 18 Sep 2026 17:18:36 -0400 Subject: [PATCH 13/60] ChainSel: avoid forecasting for Leios cert --- ...nick.frisby_leios_cert_predecessor_view.md | 34 +++++ .../byron/Ouroboros/Consensus/Byron/Node.hs | 4 +- .../Ouroboros/Consensus/ByronDual/Node.hs | 4 +- .../Cardano/Tools/DBSynthesizer/Forging.hs | 11 +- .../Ouroboros/Consensus/NodeKernel/Forge.hs | 34 +++-- .../Test/ThreadNet/Network.hs | 19 ++- .../Consensus/Genesis/Tests/LoE/CaughtUp.hs | 4 +- .../HardFork/Combinator/Node/InitStorage.hs | 4 +- .../Ouroboros/Consensus/HeaderStateHistory.hs | 91 ++++++++++-- .../Ouroboros/Consensus/HeaderValidation.hs | 72 ++++++++-- .../Consensus/Ledger/SupportsProtocol.hs | 31 ++++ .../BlockFetch/ClientInterface.hs | 17 ++- .../MiniProtocol/ChainSync/Client.hs | 26 +++- .../ChainSync/Client/HistoricityCheck.hs | 2 +- .../Consensus/Storage/ChainDB/API.hs | 67 ++++++++- .../Storage/ChainDB/Impl/ChainSel.hs | 134 +++++++----------- .../Consensus/Storage/ChainDB/Impl/Types.hs | 11 +- .../Consensus/Storage/ChainDB/Init.hs | 13 +- .../Consensus/Storage/LedgerDB/Forker.hs | 42 +++--- .../Consensus/Storage/LedgerDB/V1.hs | 16 ++- .../Consensus/Storage/LedgerDB/V2.hs | 18 ++- .../Test/Util/Header.hs | 19 ++- .../MiniProtocol/LocalStateQuery/Server.hs | 2 +- .../Storage/ChainDB/FollowerPromptness.hs | 6 +- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 12 +- 25 files changed, 493 insertions(+), 200 deletions(-) create mode 100644 changelog.d/20260918_193000_nick.frisby_leios_cert_predecessor_view.md diff --git a/changelog.d/20260918_193000_nick.frisby_leios_cert_predecessor_view.md b/changelog.d/20260918_193000_nick.frisby_leios_cert_predecessor_view.md new file mode 100644 index 0000000000..0b5085b8f2 --- /dev/null +++ b/changelog.d/20260918_193000_nick.frisby_leios_cert_predecessor_view.md @@ -0,0 +1,34 @@ + + +### Breaking + +- `HeaderWithTime` gained `hwtLedgerViewOfPredecessor`, the ledger view at the slot of the header's predecessor. + +- `HeaderStateWithTime` gained `hswtLedgerView`, the ledger view at the tip of its `HeaderState`, likewise mandatory. + +- `mkHeaderStateWithTimeFromSummary` takes the corresponding `LedgerState`. + +- The ChainDB's add API takes a `Predecessor blk`: either `NoPredecessor`, or the predecessor's slot together with the ledger view at that slot. + `trivialPredecessor` builds one for blocks whose `LedgerView` is `()`, which is the only way to supply a view without having genuinely calculated one. + +- `MatchedBlock`'s `matchedBlockPredecessorSlot` became `matchedBlockPredecessor`, carrying what the matched header records about the block's predecessor. + +- `InitChainDB`'s `addBlock` became `addTheFirstEbb :: blk -> m ()`. That interface only ever seeds an empty chain — both implementations add a single genesis EBB — so it no longer accepts anything about a predecessor. + +### Non-Breaking + +- Added `ledgerViewOfTip`, the ledger view at a `LedgerState`'s own tip slot. It asks the state's own forecast for the slot that forecast is anchored at, which every implementation answers by projection, so it costs no TICKF and no ticked state. + +- `precheckLeiosCert` now returns `Either LeiosExtValidationError ()`: it can no longer fail to reach a verdict. + + diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs index 79c47d0809..d81fcf57ef 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs @@ -298,11 +298,11 @@ instance NodeInitStorage ByronBlock where -- If the current chain is empty, produce a genesis EBB and add it to the -- ChainDB. Only an EBB can have Genesis (= empty chain) as its predecessor. - nodeInitChainDB cfg InitChainDB{getCurrentLedger, addBlock} = do + nodeInitChainDB cfg InitChainDB{getCurrentLedger, addTheFirstEbb} = do tip <- ledgerTipPoint <$> getCurrentLedger case tip of BlockPoint{} -> return () - GenesisPoint -> addBlock Origin genesisEBB + GenesisPoint -> addTheFirstEbb genesisEBB where genesisEBB = forgeEBB (getByronBlockConfig cfg) (SlotNo 0) (BlockNo 0) GenesisHash diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs index 846b2bcfb4..6c553e0f65 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs @@ -243,11 +243,11 @@ protocolInfoDualByron abstractGenesis@ByronSpecGenesis{..} params credss = instance NodeInitStorage DualByronBlock where -- Just like Byron, we need to start with an EBB - nodeInitChainDB cfg InitChainDB{getCurrentLedger, addBlock} = do + nodeInitChainDB cfg InitChainDB{getCurrentLedger, addTheFirstEbb} = do tip <- ledgerTipPoint <$> getCurrentLedger case tip of BlockPoint{} -> return () - GenesisPoint -> addBlock Origin genesisEBB + GenesisPoint -> addTheFirstEbb genesisEBB where genesisEBB :: DualByronBlock genesisEBB = diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs index 64ea48f5f9..db1223ab45 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs @@ -81,6 +81,7 @@ import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API as ChainDB ( AddBlockResult (..) , ChainDB + , Predecessor (..) , addBlockAsync , blockProcessed , getCurrentChain @@ -421,7 +422,15 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg votingKey genTxs leio -- Add the block to the chain DB (synchronously) and verify adoption let noPunish = InvalidBlockPunishment.noPunishment - result <- lift $ ChainDB.addBlockAsync chainDB noPunish (pointSlot bcPrevPoint) newBlock + -- 'unticked' is the state at 'bcPrevPoint', ie at this block's + -- predecessor, so its view is the one at the predecessor's slot. + let predecessor = case pointSlot bcPrevPoint of + Origin -> ChainDB.NoPredecessor + NotOrigin slot -> + ChainDB.Predecessor + slot + (ledgerViewOfTip (configLedger cfg) (ledgerState unticked)) + result <- lift $ ChainDB.addBlockAsync chainDB noPunish predecessor newBlock mbCurTip <- lift $ atomically $ ChainDB.blockProcessed result when (mbCurTip /= SuccesfullyAddedBlock (blockPoint newBlock)) $ diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs index 18d2c6ebd2..836e79fb6d 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs @@ -239,7 +239,18 @@ forge forgeEventTracer forgeStateInfoTracer leiosTracer forgeCCtx cfg chainDB me , Block.fbLeiosTracer = leiosTracer , Block.fbLeiosVoteState = leiosVoteState } - , ledgerTipPoint (ledgerState unticked) + , ForgingOnTopOf + { forgingOnTopOfPoint = ledgerTipPoint (ledgerState unticked) + , -- 'unticked' is the state at 'bcPrevPoint', ie at the block we + -- are extending, so its view is the one at that block's slot. + forgingOnTopOfPredecessor = + case pointSlot bcPrevPoint of + Origin -> ChainDB.NoPredecessor + NotOrigin slot -> + ChainDB.Predecessor + slot + (ledgerViewOfTip (configLedger cfg) (ledgerState unticked)) + } , snapshotMempoolSize mempoolSnapshot , rbTxsSize ) @@ -256,7 +267,7 @@ forge forgeEventTracer forgeStateInfoTracer leiosTracer forgeCCtx cfg chainDB me trace $ TraceForgedBlock currentSlot - forgingOnTopOf + (forgingOnTopOfPoint forgingOnTopOf) newBlock snapSize rbTxsSize @@ -281,7 +292,7 @@ forge forgeEventTracer forgeStateInfoTracer leiosTracer forgeCCtx cfg chainDB me chainDB mempool currentSlot - (pointSlot bcPrevPoint) + (forgingOnTopOfPredecessor forgingOnTopOf) (Block.fbRbTxs forgeBlockArgs) (Block.fbEbTxs forgeBlockArgs) newBlock @@ -487,6 +498,13 @@ mkCurrentBlockContext currentSlot c = case c of -- block no and same predecessor. else BlockContext (blockNo hdr) $ castPoint $ AF.headPoint c' +-- | The block a forge is extending +data ForgingOnTopOf blk = ForgingOnTopOf + { forgingOnTopOfPoint :: !(Point blk) + , forgingOnTopOfPredecessor :: !(ChainDB.Predecessor blk) + -- ^ What the ChainDB needs to know about it when the forged block is added. + } + -- | Add a forged block to the ChainDB, tracing whether it was adopted, and -- removing its transactions from the mempool if it turned out to be invalid. addBlockToChainDB :: @@ -495,14 +513,14 @@ addBlockToChainDB :: ChainDB m blk -> Mempool m blk -> SlotNo -> - -- | The slot of the block we are extending, from the 'BlockContext' this - -- block was forged against. - WithOrigin SlotNo -> + -- | The block we are extending, from the 'BlockContext' this block was + -- forged against. + ChainDB.Predecessor blk -> [Validated (GenTx blk)] -> [Validated (GenTx blk)] -> blk -> WithEarlyExit m () -addBlockToChainDB trace chainDB mempool currentSlot predSlot rbTxs ebTxs newBlock = do +addBlockToChainDB trace chainDB mempool currentSlot predecessor rbTxs ebTxs newBlock = do let noPunish = InvalidBlockPunishment.noPunishment -- no way to punish yourself -- Make sure that if an async exception is thrown while a block is -- added to the chain db, we will remove txs from the mempool. @@ -512,7 +530,7 @@ addBlockToChainDB trace chainDB mempool currentSlot predSlot rbTxs ebTxs newBloc -- 'uninterruptibleMask_' to make sure that async exceptions do not -- interrupt it. uninterruptibleMask_ $ do - result <- lift $ ChainDB.addBlockAsync chainDB noPunish predSlot newBlock + result <- lift $ ChainDB.addBlockAsync chainDB noPunish predecessor newBlock -- Block until we have processed the block mbCurTip <- lift $ atomically $ ChainDB.blockProcessed result diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index 680238038e..b6489724e0 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -990,7 +990,24 @@ runThreadNetwork -- ChainDB will reject it as invalid, and -- 'Test.ThreadNet.General.prop_general' will eventually fail -- because of a block rejection. - void $ ChainDB.addBlock chainDB InvalidBlockPunishment.noPunishment (pointSlot p) ebb + -- The EBB extends 'p', so its predecessor's view comes from + -- the ledger state there. Asking the ChainDB rather than + -- reusing 'tickedLdgSt', whose view is the one at the current + -- slot and so differs across an epoch boundary. + predecessor <- case pointSlot p of + Origin -> pure ChainDB.NoPredecessor + NotOrigin slot -> + atomically (ChainDB.getPastLedger chainDB p) >>= \case + -- The EBB extends this very point, so its ledger + -- is certainly still within the last k. + Nothing -> + error "JIT EBB: no ledger at the tip it extends" + Just st -> + pure $ + ChainDB.Predecessor + slot + (ledgerViewOfTip (configLedger pInfoConfig) (ledgerState st)) + void $ ChainDB.addBlock chainDB InvalidBlockPunishment.noPunishment predecessor ebb pure blk -- This variable holds the number of the earliest slot in which the diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs index 8672336df9..3272829c82 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs @@ -108,7 +108,9 @@ run = withRegistry \registry -> do varGetLoEFragment chainDB <- openChainDB registry (join $ readTVarIO varGetLoEFragment) - let addBlk = ChainDB.addBlock_ chainDB Punishment.noPunishment + let addBlk = + ChainDB.addBlock_ chainDB Punishment.noPunishment + . ChainDB.trivialPredecessor chainSyncHandles <- atomically newChainSyncClientHandleCollection diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node/InitStorage.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node/InitStorage.hs index 87f35ce4cc..3ffa895716 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node/InitStorage.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node/InitStorage.hs @@ -68,8 +68,8 @@ instance CanHardFork xs => NodeInitStorage (HardForkBlock xs) where nodeInitChainDB cfg' InitChainDB - { addBlock = \predSlot -> - addBlock initChainDB predSlot + { addTheFirstEbb = + addTheFirstEbb initChainDB . injectNS' (Proxy @I) index , getCurrentLedger = return currentLedger } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs index 112397e464..eb0843f303 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs @@ -40,7 +40,7 @@ import Control.Monad.Except (Except) import Data.Coerce (Coercible) import qualified Data.List.NonEmpty as NE import GHC.Generics (Generic) -import NoThunks.Class (NoThunks) +import NoThunks.Class (NoThunks (..), allNoThunks) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (RelativeTime) import Ouroboros.Consensus.Config @@ -51,6 +51,7 @@ import Ouroboros.Consensus.HeaderValidation hiding (validateHeader) import qualified Ouroboros.Consensus.HeaderValidation as HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffs) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Util.CallStack (HasCallStack) @@ -101,6 +102,7 @@ cast :: (ChainDepState (BlockProtocol blk)) (ChainDepState (BlockProtocol blk')) , TipInfo blk ~ TipInfo blk' + , LedgerView (BlockProtocol blk) ~ LedgerView (BlockProtocol blk') ) => HeaderStateHistory blk -> HeaderStateHistory blk' cast (HeaderStateHistory history) = @@ -150,24 +152,78 @@ rewind p (HeaderStateHistory history) = do HeaderStateWithTime -------------------------------------------------------------------------------} --- | A 'HeaderState' together with the 'RelativeTime' corresponding to the tip --- slot of the state. For a state at 'Origin', we use the same time as for slot --- 0. +-- | A 'HeaderState' together with what the ChainSync client needs about the +-- corresponding ledger state, which that client has no other way to reach. For +-- a state at 'Origin', both are as for slot 0. +-- +-- TODO rename this type, eg to @ValidatedHeaderState@, and its fields to +-- match: it no longer merely adds a time. Compare the same TODO on +-- 'HeaderWithTime'. data HeaderStateWithTime blk = HeaderStateWithTime { hswtHeaderState :: !(HeaderState blk) , hswtSlotTime :: !RelativeTime + -- ^ The 'RelativeTime' corresponding to the tip slot of the state. + , hswtLedgerView :: !(LedgerView (BlockProtocol blk)) + -- ^ The ledger view at the tip slot of the state. + -- + -- The ChainSync client copies this onto the /next/ header it validates, as + -- that header's 'hwtLedgerViewOfPredecessor', for Leios. } deriving stock Generic -deriving stock instance +-- | 'hswtLedgerView' is excluded from these three: it is a projection of the +-- ledger state the rest was built from, so it is no part of this value's +-- identity, and 'LedgerView' has no 'Eq' or 'NoThunks' instance to require. +instance (BlockSupportsProtocol blk, HasAnnTip blk) => Eq (HeaderStateWithTime blk) -deriving stock instance + where + hswt1 == hswt2 = + hswtHeaderState hswt1 == hswtHeaderState hswt2 + && hswtSlotTime hswt1 == hswtSlotTime hswt2 + where + -- Positional on purpose: adding a field to 'HeaderStateWithTime' breaks + -- this binding, which is the prompt to decide whether the new field + -- belongs in this method. 'hswtLedgerView' deliberately does not; see its + -- Haddock. + HeaderStateWithTime _dummy _ _ = hswt1 + +instance (BlockSupportsProtocol blk, HasAnnTip blk) => Show (HeaderStateWithTime blk) -deriving anyclass instance + where + showsPrec p hswt = + showParen (p > 10) $ + showString "HeaderStateWithTime " + . showsPrec 11 (hswtHeaderState hswt) + . showString " " + . showsPrec 11 (hswtSlotTime hswt) + . showString " " + where + -- Positional on purpose: adding a field to 'HeaderStateWithTime' breaks + -- this binding, which is the prompt to decide whether the new field + -- belongs in this method. 'hswtLedgerView' deliberately does not; see its + -- Haddock. + HeaderStateWithTime _dummy _ _ = hswt + +instance (BlockSupportsProtocol blk, HasAnnTip blk) => NoThunks (HeaderStateWithTime blk) + where + showTypeOf _ = "HeaderStateWithTime" + wNoThunks ctxt hswt = + allNoThunks + [ noThunks ctxt' (hswtHeaderState hswt) + , noThunks ctxt' (hswtSlotTime hswt) + ] + where + ctxt' = "HeaderStateWithTime" : ctxt + + -- Positional on purpose: adding a field to 'HeaderStateWithTime' breaks + -- this binding, which is the prompt to decide whether the new field + -- belongs in this method. 'hswtLedgerView' deliberately does not; see its + -- Haddock. + HeaderStateWithTime _dummy _ _ = hswt instance Anchorable (WithOrigin SlotNo) (HeaderStateWithTime blk) (HeaderStateWithTime blk) where asAnchor = id @@ -178,24 +234,31 @@ castHeaderStateWithTime :: (ChainDepState (BlockProtocol blk)) (ChainDepState (BlockProtocol blk')) , TipInfo blk ~ TipInfo blk' + , LedgerView (BlockProtocol blk) ~ LedgerView (BlockProtocol blk') ) => HeaderStateWithTime blk -> HeaderStateWithTime blk' castHeaderStateWithTime hswt = HeaderStateWithTime { hswtHeaderState = castHeaderState $ hswtHeaderState hswt , hswtSlotTime = hswtSlotTime hswt + , hswtLedgerView = hswtLedgerView hswt } mkHeaderStateWithTimeFromSummary :: - (HasCallStack, HasAnnTip blk) => + (HasCallStack, LedgerSupportsProtocol blk) => -- | Must be able to convert the tip slot of the 'HeaderState' to a time. Summary (HardForkIndices blk) -> + LedgerConfig blk -> + -- | Must be the ledger state paired with the given 'HeaderState'; its view is + -- what 'hswtLedgerView' records. + LedgerState blk mk -> HeaderState blk -> HeaderStateWithTime blk -mkHeaderStateWithTimeFromSummary summary hst = +mkHeaderStateWithTimeFromSummary summary lcfg lst hst = HeaderStateWithTime { hswtHeaderState = hst , hswtSlotTime = slotTime + , hswtLedgerView = ledgerViewOfTip lcfg lst } where (slotTime, _) = Qry.runQueryPure qry summary @@ -203,12 +266,12 @@ mkHeaderStateWithTimeFromSummary summary hst = slot = fromWithOrigin 0 $ pointSlot $ headerStatePoint hst mkHeaderStateWithTime :: - (HasCallStack, HasHardForkHistory blk, HasAnnTip blk) => + (HasCallStack, HasHardForkHistory blk, LedgerSupportsProtocol blk) => LedgerConfig blk -> ExtLedgerState blk mk -> HeaderStateWithTime blk mkHeaderStateWithTime lcfg (ExtLedgerState lst hst) = - mkHeaderStateWithTimeFromSummary summary hst + mkHeaderStateWithTimeFromSummary summary lcfg lst hst where -- A summary can always translate the tip slot of the ledger state it was -- created from. @@ -236,7 +299,9 @@ validateHeader :: Except (HeaderError blk) (HeaderStateHistory blk) validateHeader cfg lv hdr slotTime history = do st' <- HeaderValidation.validateHeader cfg lv hdr st - return $ append (HeaderStateWithTime st' slotTime) history + -- 'lv' is the view at this header's slot, which is what the new entry + -- records; see 'hswtLedgerView'. + return $ append (HeaderStateWithTime st' slotTime lv) history where st :: Ticked (HeaderState blk) st = @@ -258,7 +323,7 @@ fromChain :: forall blk. ( ApplyBlock (ExtLedgerState blk) blk , HasHardForkHistory blk - , HasAnnTip blk + , LedgerSupportsProtocol blk ) => TopLevelConfig blk -> -- | Initial ledger state diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs index 325e8300d6..3db4c4ec2e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs @@ -90,7 +90,7 @@ import Data.Typeable (Typeable) import Data.Void (Void) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) -import NoThunks.Class (NoThunks) +import NoThunks.Class (NoThunks (..), allNoThunks) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (RelativeTime) import Ouroboros.Consensus.Config @@ -614,18 +614,70 @@ data HeaderWithTime blk = HeaderWithTime -- The header commits only to its predecessor's hash, so this is knowledge -- of that chain rather than of the header. It is nonetheless unambiguous, -- since every chain carrying this header carries the same predecessor. + , hwtLedgerViewOfPredecessor :: !(LedgerView (BlockProtocol blk)) + -- ^ The ledger view at 'hwtPredecessorSlot'. + -- + -- Only a CertRB needs it, and only to identify the Leios committee that was + -- relevant to its /predecessor/'s slot, since that's the announcement the + -- cert is carries certify. + -- + -- Always present, because the only way to build a 'HeaderWithTime' is to + -- validate the header: the ChainSync client does so against a forecast and + -- keeps the view in its 'HeaderStateHistory', and ChainSel does so by + -- applying the block. } deriving Generic -deriving stock instance - Eq (Header blk) => - Eq (HeaderWithTime blk) -deriving stock instance - Show (Header blk) => - Show (HeaderWithTime blk) -deriving anyclass instance - NoThunks (Header blk) => - NoThunks (HeaderWithTime blk) +-- The 'LedgerView' is excluded from all three of these instances. It is a +-- cache of something derivable, so it says nothing about header identity, and +-- it has no 'Eq' or 'NoThunks' instance of its own; 'Eq' in particular would +-- drag a stake-distribution comparison into every header comparison. + +instance Eq (Header blk) => Eq (HeaderWithTime blk) where + hwt1 == hwt2 = + hwtHeader hwt1 == hwtHeader hwt2 + && hwtSlotRelativeTime hwt1 == hwtSlotRelativeTime hwt2 + && hwtPredecessorSlot hwt1 == hwtPredecessorSlot hwt2 + where + -- Positional on purpose: adding a field to 'HeaderWithTime' breaks this + -- binding, which is the prompt to decide whether the new field belongs in + -- this method. 'hwtLedgerViewOfPredecessor' deliberately does not; see the + -- note above these instances. + HeaderWithTime _dummy _ _ _ = hwt1 + +instance Show (Header blk) => Show (HeaderWithTime blk) where + showsPrec p hwt = + showParen (p > 10) $ + showString "HeaderWithTime " + . showsPrec 11 (hwtHeader hwt) + . showString " " + . showsPrec 11 (hwtSlotRelativeTime hwt) + . showString " " + . showsPrec 11 (hwtPredecessorSlot hwt) + . showString " " + where + -- Positional on purpose: adding a field to 'HeaderWithTime' breaks this + -- binding, which is the prompt to decide whether the new field belongs in + -- this method. 'hwtLedgerViewOfPredecessor' deliberately does not; see the + -- note above these instances. + HeaderWithTime _dummy _ _ _ = hwt + +instance NoThunks (Header blk) => NoThunks (HeaderWithTime blk) where + showTypeOf _ = "HeaderWithTime" + wNoThunks ctxt hwt = + allNoThunks + [ noThunks ctxt' (hwtHeader hwt) + , noThunks ctxt' (hwtSlotRelativeTime hwt) + , noThunks ctxt' (hwtPredecessorSlot hwt) + ] + where + ctxt' = "HeaderWithTime" : ctxt + + -- Positional on purpose: adding a field to 'HeaderWithTime' breaks this + -- binding, which is the prompt to decide whether the new field belongs in + -- this method. 'hwtLedgerViewOfPredecessor' deliberately does not; see the + -- note above these instances. + HeaderWithTime _dummy _ _ _ = hwt type instance HeaderHash (HeaderWithTime blk) = HeaderHash (Header blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs index 1babfe531d..6f3ae7d3b6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs @@ -5,6 +5,7 @@ module Ouroboros.Consensus.Ledger.SupportsProtocol ( GenesisWindow (..) , LedgerSupportsProtocol (..) + , ledgerViewOfTip ) where import Control.Monad.Except @@ -17,6 +18,36 @@ import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Protocol.Abstract -- | Link protocol to ledger + +-- | The ledger view at the given ledger state's own tip slot +-- +-- This is 'protocolLedgerView' without the ticking. It asks the state's own +-- forecast for the slot that forecast is anchored at, which satisfies +-- 'forecastFor''s precondition and which every implementation answers by +-- projecting the state it already holds -- no TICKF, no ticked state, no +-- ledger tables. So it is cheap enough to call once per entry of a @k@-deep +-- history. +-- +-- Total: the only way 'forecastFor' can fail is by being asked for a slot +-- outside the forecast's range, and the forecast's own anchor is always in range. +ledgerViewOfTip :: + forall blk mk. + LedgerSupportsProtocol blk => + LedgerConfig blk -> + LedgerState blk mk -> + LedgerView (BlockProtocol blk) +ledgerViewOfTip cfg st = + case runExcept $ forecastFor forecast slot of + Right lv -> lv + Left err -> + error $ + "ledgerViewOfTip: forecast refused its own anchor: " <> show err + where + forecast = ledgerViewForecastAt cfg st + -- At genesis there is no tip slot; slot 0 is the first slot any header could + -- occupy, and the forecast's anchor is 'Origin', so it is in range. + slot = fromWithOrigin (SlotNo 0) $ getTipSlot st + class ( BlockSupportsProtocol blk , UpdateLedger blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs index e6aec34d8e..4137edcf99 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs @@ -40,6 +40,7 @@ import Ouroboros.Consensus.Protocol.Abstract (shouldSwitch) import Ouroboros.Consensus.Storage.ChainDB.API ( AddBlockPromise , ChainDB + , Predecessor (..) ) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment @@ -70,7 +71,7 @@ data ChainDbView m blk = ChainDbView , getMaxSlotNo :: STM m MaxSlotNo , addBlockAsync :: InvalidBlockPunishment m -> - WithOrigin SlotNo -> + Predecessor blk -> blk -> m (AddBlockPromise m blk) , getChainSelStarvation :: STM m ChainSelStarvation @@ -142,8 +143,8 @@ readFetchModeDefault -- against. data MatchedBlock blk = MatchedBlock { matchedBlock :: !blk - , matchedBlockPredecessorSlot :: !(WithOrigin SlotNo) - -- ^ 'hwtPredecessorSlot' of that header + , matchedBlockPredecessor :: !(Predecessor blk) + -- ^ What the matched header records about the block's predecessor } mkBlockFetchConsensusInterface :: @@ -182,7 +183,11 @@ mkBlockFetchConsensusInterface Just MatchedBlock { matchedBlock = b - , matchedBlockPredecessorSlot = hwtPredecessorSlot hwt + , matchedBlockPredecessor = + case hwtPredecessorSlot hwt of + Origin -> NoPredecessor + NotOrigin slot -> + Predecessor slot (hwtLedgerViewOfPredecessor hwt) } | otherwise = Nothing @@ -215,7 +220,7 @@ mkBlockFetchConsensusInterface MatchedBlock blk -> m () mkAddFetchedBlock_ pipeliningPunishment enabledPipelining _pt matched = void $ do - let MatchedBlock blk predSlot = matched + let MatchedBlock blk predecessor = matched disconnect <- InvalidBlockPunishment.mkPunishThisThread -- A BlockFetch peer can either send an entire range or none of the -- range; anything else will incur a disconnect. And in 'FetchDeadline' @@ -251,7 +256,7 @@ mkBlockFetchConsensusInterface addBlockAsync chainDB punishment - predSlot + predecessor blk readFetchedMaxSlotNo :: STM m MaxSlotNo diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs index 7e19540ec5..0d9433dae1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs @@ -1190,20 +1190,32 @@ withTime fragment (HeaderStateHistory history) = (AF.castAnchor $ AF.anchor fragment) $ fmap enrichHeader $ zip3 - ( AF.anchorToSlotNo (AF.anchor fragment) - : map (NotOrigin . blockSlot) (AF.toOldestFirst fragment) - ) + predecessors (AF.toOldestFirst fragment) (AF.toOldestFirst history) where + -- What each header's predecessor contributes, which for the oldest header is + -- the anchor. The history is in lockstep with the fragment, so its entries + -- shifted by one are the predecessors'. + predecessors = + (AF.anchorToSlotNo (AF.anchor fragment), hswtLedgerView (AF.anchor history)) + : zipWith + (\hdr hswt -> (NotOrigin (blockSlot hdr), hswtLedgerView hswt)) + (AF.toOldestFirst fragment) + (AF.toOldestFirst history) + enrichHeader :: - (WithOrigin SlotNo, Header blk, HeaderStateWithTime blk) -> + ( (WithOrigin SlotNo, LedgerView (BlockProtocol blk)) + , Header blk + , HeaderStateWithTime blk + ) -> HeaderWithTime blk - enrichHeader (predSlot, hdr, hsWt) = + enrichHeader ((predSlot, predLedgerView), hdr, hsWt) = HeaderWithTime { hwtHeader = hdr , hwtSlotRelativeTime = hswtSlotTime hsWt , hwtPredecessorSlot = predSlot + , hwtLedgerViewOfPredecessor = predLedgerView } {------------------------------------------------------------------------------- @@ -1958,6 +1970,10 @@ checkValid cfgEnv intEnv hdr hdrSlotTime theirTip kis ledgerView = do { hwtHeader = hdr , hwtSlotRelativeTime = hdrSlotTime , hwtPredecessorSlot = AF.headSlot theirFrag + , hwtLedgerViewOfPredecessor = + hswtLedgerView $ + -- NB that this is the history _before_ applying hdr + HeaderStateHistory.current theirHeaderStateHistory } theirFrag' = theirFrag :> validatedHdr -- Advance the most recent intersection if we have the same diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/HistoricityCheck.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/HistoricityCheck.hs index 93f61ea88b..3d6e8bae34 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/HistoricityCheck.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/HistoricityCheck.hs @@ -165,7 +165,7 @@ mkCheck systemTime getCurrentGsmState cshc = HistoricalChainSyncMessage -> HeaderStateWithTime blk -> m (Either HistoricityException ()) - judgeRollback msg (HeaderStateWithTime headerState slotTime) = do + judgeRollback msg (HeaderStateWithTime headerState slotTime _ledgerView) = do arrivalTime <- systemTimeCurrent systemTime let actualRollbackAge = arrivalTime `diffRelTime` slotTime pure $ diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 2333e7d0d8..61c4f2c04b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -10,6 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Storage.ChainDB.API @@ -19,6 +20,10 @@ module Ouroboros.Consensus.Storage.ChainDB.API , getTipBlockNo -- * Adding a block + , Predecessor (..) + , mapPredecessor + , predecessorSlot + , trivialPredecessor , AddBlockPromise (..) , AddBlockResult (..) , addBlock @@ -91,6 +96,7 @@ import Ouroboros.Consensus.HeaderStateHistory import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Protocol.Abstract (LedgerView) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment import Ouroboros.Consensus.Storage.Common @@ -142,10 +148,57 @@ import System.FS.API.Types (FsError) -- -- The ChainDB instantiates all the various type parameters of these databases -- to conform to the unified interface we provide here. +-- | What the caller knows about the block's predecessor +-- +-- ChainSel needs the ledger view at the predecessor's slot, because that is the +-- committee a CertRB's certificate must satisfy: the announcing block is the +-- block's predecessor. +-- +-- The view is not something the header yields; it is a function of that slot +-- and of a ledger state that can forecast to it. What validating the +-- predecessor's header establishes is that such a forecast succeeded, so a +-- view for that slot was necessarily in hand. Pairing the two here records +-- that: a caller that validated the predecessor can supply both, and there is +-- no state in which it has the slot but must go looking for the view. +data Predecessor blk + = -- | The block is the first on its chain, so there is no predecessor and + -- nothing could have been announced for it to certify. + NoPredecessor + | Predecessor !SlotNo !(LedgerView (BlockProtocol blk)) + +-- | Reinterpret a 'Predecessor' at another block type +mapPredecessor :: + (LedgerView (BlockProtocol blk) -> LedgerView (BlockProtocol blk')) -> + Predecessor blk -> + Predecessor blk' +mapPredecessor f = \case + NoPredecessor -> NoPredecessor + Predecessor slot lv -> Predecessor slot (f lv) + +-- | The slot of the predecessor, if there is one +predecessorSlot :: Predecessor blk -> WithOrigin SlotNo +predecessorSlot = \case + NoPredecessor -> Origin + Predecessor slot _ -> NotOrigin slot + +-- | The predecessor of a block whose protocol has no ledger view +-- +-- Restricted to those blocks, which is what makes it sound: the view carries +-- no information, so supplying it asserts nothing. For a block with a real +-- ledger view the caller has to have one, which in practice means it forecast +-- to the predecessor's slot while validating that header. +trivialPredecessor :: + LedgerView (BlockProtocol blk) ~ () => + WithOrigin SlotNo -> + Predecessor blk +trivialPredecessor = \case + Origin -> NoPredecessor + NotOrigin slot -> Predecessor slot () + data ChainDB m blk = ChainDB { addBlockAsync :: InvalidBlockPunishment m -> - WithOrigin SlotNo -> + Predecessor blk -> blk -> m (AddBlockPromise m blk) -- ^ Add a block to the heap of blocks @@ -524,7 +577,7 @@ data AddBlockResult blk -- | Add a block synchronously: wait until the block has been written to disk -- (see 'blockWrittenToDisk'). addBlockWaitWrittenToDisk :: - IOLike m => ChainDB m blk -> InvalidBlockPunishment m -> WithOrigin SlotNo -> blk -> m Bool + IOLike m => ChainDB m blk -> InvalidBlockPunishment m -> Predecessor blk -> blk -> m Bool addBlockWaitWrittenToDisk chainDB punish predSlot blk = do promise <- addBlockAsync chainDB punish predSlot blk atomically $ blockWrittenToDisk promise @@ -540,7 +593,7 @@ addBlock :: IOLike m => ChainDB m blk -> InvalidBlockPunishment m -> - WithOrigin SlotNo -> + Predecessor blk -> blk -> m (AddBlockResult blk) addBlock chainDB punish predSlot blk = do @@ -552,7 +605,7 @@ addBlock chainDB punish predSlot blk = do -- -- Note: this is a partial function, only to support tests. addBlock_ :: - IOLike m => ChainDB m blk -> InvalidBlockPunishment m -> WithOrigin SlotNo -> blk -> m () + IOLike m => ChainDB m blk -> InvalidBlockPunishment m -> Predecessor blk -> blk -> m () addBlock_ cdb punish predSlot = void . addBlock cdb punish predSlot -- | Alias for naming consistency. @@ -651,7 +704,7 @@ toChain chainDB = withRegistry $ \registry -> fromChain :: forall m blk. - (IOLike m, HasHeader blk) => + (IOLike m, HasHeader blk, LedgerView (BlockProtocol blk) ~ ()) => m (ChainDB m blk) -> Chain blk -> m (ChainDB m blk) @@ -660,7 +713,9 @@ fromChain openDB chain = do -- Adding a whole chain oldest-first, so each block's predecessor is the one -- added just before it. mapM_ (uncurry (addBlock_ chainDB noPunishment)) $ - zip (Origin : map (NotOrigin . blockSlot) blks) blks + zip + (map trivialPredecessor (Origin : map (NotOrigin . blockSlot) blks)) + blks return chainDB where blks = Chain.toOldestFirst chain diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index 999c162617..0900f73366 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -32,7 +32,6 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel import Cardano.Ledger.BaseTypes (unNonZero) import Control.Exception (assert) import Control.Monad (forM_, join, void, when) -import Control.Monad.Except (runExcept) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict import Control.Tracer (Tracer, nullTracer, traceWith, (>$<)) @@ -76,7 +75,6 @@ import qualified LeiosValidClaims import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Config -import Ouroboros.Consensus.Forecast (Forecast (forecastAt, forecastFor)) import Ouroboros.Consensus.Fragment.Diff (ChainDiff (..)) import qualified Ouroboros.Consensus.Fragment.Diff as Diff import Ouroboros.Consensus.HardFork.Abstract @@ -99,6 +97,8 @@ import Ouroboros.Consensus.Storage.ChainDB.API , BlockComponent (..) , ChainType (..) , LoE (..) + , Predecessor (..) + , predecessorSlot ) import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment ( InvalidBlockPunishment @@ -334,7 +334,7 @@ addBlockAsync :: (IOLike m, HasHeader blk) => ChainDbEnv m blk -> InvalidBlockPunishment m -> - WithOrigin SlotNo -> + Predecessor blk -> blk -> m (AddBlockPromise m blk) addBlockAsync CDB{cdbTracer, cdbChainSelQueue} = @@ -469,14 +469,14 @@ chainSelAddBlock cdb@CDB{..} _cctx BlockToAdd{blockToAdd = b, ..} = do encloseWith (traceEv >$< addBlockTracer) $ VolatileDB.putBlock cdbVolatileDB b lift $ deliverWrittenToDisk True - lift (precheckLeiosCert cdb blockPredecessorSlot b) >>= \case - Right tentativeHeaderPermission -> + lift (precheckLeiosCert cdb blockPredecessor b) >>= \case + Right () -> chainSelectionForBlock cdb (BlockCache.singleton b) hdr - (Just blockPredecessorSlot) - tentativeHeaderPermission + (Just (predecessorSlot blockPredecessor)) + MaySetTentativeHeader blockPunish Left leiosErr -> lift $ do let e = ExtValidationErrorLeios leiosErr @@ -727,7 +727,7 @@ chainSelReprocessLoEBlocks cdb@CDB{..} varProcessed = lift $ do atomically $ putTMVar varProcessed () --- | Verify the certificate in a CertRB before chain selection considers it +-- | Verify the certificate in a CertRB before chain selection -- -- ChainSel would otherwise only discover an invalid certificate once it applied -- the block. That only reason that's too late is because downstream peers' @@ -737,13 +737,12 @@ chainSelReprocessLoEBlocks cdb@CDB{..} varProcessed = lift $ do -- lengths to ensure is only possible if the adversary has already defeated the -- network). -- --- Only positive verdicts are cached; see 'LeiosValidClaims'. +-- The committee is the one at the announcing block's slot, and the announcing +-- block is this block's predecessor, so the caller's 'Predecessor' already +-- carries the view this needs. That avoids a dead "failed forecast" branch +-- here. -- --- 'Left' means the CertRB is invalid. 'Right' says whether its header may be --- pipelined, which it may only if this function verified the certificate (or --- had already verified one making the same claim): every way of declining to --- reach a verdict yields 'MayNotSetTentativeHeader' rather than a crash or an --- unchecked pipelining. +-- Only positive verdicts are cached; see 'LeiosValidClaims'. precheckLeiosCert :: forall m blk. ( IOLike m @@ -752,80 +751,46 @@ precheckLeiosCert :: , HasLeiosVoting blk ) => ChainDbEnv m blk -> - -- | The slot of the block's predecessor, ie of the announcing block - WithOrigin SlotNo -> + Predecessor blk -> blk -> - m (Either LeiosExtValidationError TentativeHeaderPermission) -precheckLeiosCert CDB{..} predSlot b = case blockLeiosCert b of - Nothing -> pure $ Right MaySetTentativeHeader - Just cert -> case (announcingRbHash b, blockPrevHash b, predSlot) of - (Just rbHash, BlockHash announcingHash, NotOrigin announcingSlot) -> do + m (Either LeiosExtValidationError ()) +precheckLeiosCert CDB{..} predecessor b = case blockLeiosCert b of + Nothing -> pure $ Right () + Just cert -> case (announcingRbHash b, blockPrevHash b, predecessor) of + (Just rbHash, BlockHash announcingHash, Predecessor announcingSlot announcingView) -> do let announcingPoint = RealPoint announcingSlot announcingHash - (known, immTip) <- + known <- atomically $ - (,) - <$> (LeiosValidClaims.memberValidClaim rbHash <$> readTVar cdbLeiosValidClaims) - <*> (ledgerState <$> LedgerDB.getImmutableTip cdbLedgerDB) - let immForecast = ledgerViewForecastAt (configLedger cdbTopLevelConfig) immTip + LeiosValidClaims.memberValidClaim rbHash <$> readTVar cdbLeiosValidClaims if - -- We've already validated cert that makes the same claim as this one, - -- so we already know it's safe to pipeline this header, even if /this/ - -- cert is invalid. - | known -> pure $ Right MaySetTentativeHeader - -- The announcing block precedes the immutable tip, so it is on a fork - -- below it and no candidate through this CertRB can ever be selected. - -- There is nothing to protect, and the forecast's precondition forbids - -- looking that far back anyway. - -- - -- There's only a small window in which BlockFetch would have requested - -- this block and that it would arrive too late to be effective; the - -- imminent 'chainSelectionForBlock' will similarly ignore it, because - -- it's unreachable from our current selection. - | NotOrigin announcingSlot < forecastAt immForecast -> - pure $ Right MayNotSetTentativeHeader - | otherwise -> case runExcept $ forecastFor immForecast announcingSlot of - -- We cannot reach the announcing block's slot from the immutable - -- tip, so we cannot verify this certificate; decline to pipeline - -- instead. Blocking until the window advances is not an option, - -- since ChainSel is single-threaded and is the only thing that - -- could advance it. - -- - -- Rare, because it needs the volatile window --- at most @k@ blocks - -- --- to span more slots than the stability window the forecast - -- ranges over. - -- - -- TODO forecasting from the immutable tip is the reason this case - -- exists at all, and it is avoidable: ChainSync and the leadership - -- check already forecast to this very slot, from an anchor at or - -- after the immutable tip. Caching that 'LedgerView' on the header - -- alongside the already-cached predecessor slot would make this - -- branch unreachable by construction. - Left _outsideForecastRange -> pure $ Right MayNotSetTentativeHeader - Right leiosLedgerView -> case getLeiosCommitteeFromView (Proxy @blk) leiosLedgerView of - Nothing -> reject cert $ LeiosForecastMissingCommittee rbHash - Just (committee, threshold) -> - case verifyLeiosCert committee threshold rbHash cert of - Left invalid -> - reject cert $ LeiosForecastInvalidCertificate rbHash invalid - Right _weight -> do - size <- atomically $ do - modifyTVar cdbLeiosValidClaims $ - LeiosValidClaims.insertValidClaim announcingSlot rbHash - LeiosValidClaims.sizeValidClaims - <$> readTVar cdbLeiosValidClaims - traceWith (TraceAddBlockEvent >$< cdbTracer) $ - AddBlockLeiosEvent $ - TraceLeiosValidClaim - (blockRealPoint b) - announcingPoint - size - pure $ Right MaySetTentativeHeader + -- We've already validated a cert that makes the same claim as this one, + -- so there is nothing left to check, even if /this/ cert is invalid. + | known -> pure $ Right () + | otherwise -> case getLeiosCommitteeFromView (Proxy @blk) announcingView of + Nothing -> reject cert $ LeiosForecastMissingCommittee rbHash + Just (committee, threshold) -> + case verifyLeiosCert committee threshold rbHash cert of + Left invalid -> + reject cert $ LeiosForecastInvalidCertificate rbHash invalid + Right _weight -> do + size <- atomically $ do + modifyTVar cdbLeiosValidClaims $ + LeiosValidClaims.insertValidClaim announcingSlot rbHash + LeiosValidClaims.sizeValidClaims + <$> readTVar cdbLeiosValidClaims + traceWith (TraceAddBlockEvent >$< cdbTracer) $ + AddBlockLeiosEvent $ + TraceLeiosValidClaim + (blockRealPoint b) + announcingPoint + size + pure $ Right () -- Certifying at genesis: all three of these say there is no announcing -- block, so they cannot disagree. _ -> reject cert LeiosForecastAfterGenesis where reject cert why = - pure $ Left $ LeiosCertificateForecastRejected cert predSlot why + pure $ Left $ LeiosCertificateForecastRejected cert (predecessorSlot predecessor) why -- | Record the invalid block in the given map and change its fingerprint addInvalidBlock :: @@ -995,15 +960,15 @@ chainSelectionForBlock Nothing -> do traceNoChange -- See 'TraceLeiosCertRbWithoutCandidate'. - whenJust mbPredecessorSlot $ \predecessorSlot -> + whenJust mbPredecessorSlot $ \predSlot -> let immTipSlot = AF.anchorToSlotNo (AF.anchor curChain) in when ( headerContainsLeiosCert hdr - && predecessorSlot >= immTipSlot + && predSlot >= immTipSlot ) $ traceWith addBlockTracer $ AddBlockLeiosEvent - $ TraceLeiosCertRbWithoutCandidate p predecessorSlot immTipSlot + $ TraceLeiosCertRbWithoutCandidate p predSlot immTipSlot where -- Note that we may have extended the chain, but have not trimmed it to -- @k@ blocks/headers. That is the job of the background thread, which @@ -1669,11 +1634,10 @@ validateCandidate chainSelEnv chainDiff@(ChainDiff rollback suffix) neHeaders on -- connect to the immutable tip. error "found candidate requiring rolling back past the immutable tip" ValidateLedgerError validated (AnnLedgerError lastValid pt e) -> do + let chainDiff' = Diff.truncate (castPoint lastValid) chainDiff traceWith validationTracer (InvalidBlock e pt) addInvalidBlock varInvalid e pt - -- 'validated' is already truncated to the blocks that were applied, - -- so there is no second truncation to keep in step with it. - traceWith validationTracer (ValidCandidate (forgetValidation validated)) + traceWith validationTracer (ValidCandidate (Diff.getSuffix chainDiff')) -- punish the peer who sent a block if it is invalid or a block from its -- prefix is invalid diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index 09c31238ab..b81a09a200 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -114,6 +114,7 @@ import Ouroboros.Consensus.Peras.SelectView (WeightedSelectView) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API ( AddBlockPromise (..) + , Predecessor (..) , AddBlockResult (..) , AddPerasCertPromise (..) , ChainDbError (..) @@ -624,8 +625,8 @@ data BlockToAdd m blk = BlockToAdd { blockPunish :: !(InvalidBlockPunishment m) -- ^ Executed immediately upon determining this block or one from its prefix -- is invalid. - , blockPredecessorSlot :: !(WithOrigin SlotNo) - -- ^ The slot of this block's predecessor. + , blockPredecessor :: !(Predecessor blk) + -- ^ What the adder knows about this block's predecessor. -- -- Leios uses this to validate the certificate in a CertRB /before/ chain -- selection, which is necessary for The Recovery Path. @@ -673,16 +674,16 @@ addBlockToAdd :: Tracer m (TraceAddBlockEvent blk) -> ChainSelQueue m blk -> InvalidBlockPunishment m -> - WithOrigin SlotNo -> + Predecessor blk -> blk -> m (AddBlockPromise m blk) -addBlockToAdd tracer (ChainSelQueue{varChainSelQueue, varChainSelPoints}) punish predSlot blk = do +addBlockToAdd tracer (ChainSelQueue{varChainSelQueue, varChainSelPoints}) punish predecessor blk = do varBlockWrittenToDisk <- newEmptyTMVarIO varBlockProcessed <- newEmptyTMVarIO let !toAdd = BlockToAdd { blockPunish = punish - , blockPredecessorSlot = predSlot + , blockPredecessor = predecessor , blockToAdd = blk , varBlockWrittenToDisk , varBlockProcessed diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Init.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Init.hs index ac3b5dee20..cf43332768 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Init.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Init.hs @@ -10,7 +10,6 @@ module Ouroboros.Consensus.Storage.ChainDB.Init , map ) where -import Ouroboros.Consensus.Block (SlotNo, WithOrigin) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) @@ -21,8 +20,10 @@ import Prelude hiding (map) -- | Restricted interface to the 'ChainDB' used on node initialization data InitChainDB m blk = InitChainDB - { addBlock :: WithOrigin SlotNo -> blk -> m () - -- ^ Add a block to the DB, given the slot of its predecessor + { addTheFirstEbb :: blk -> m () + -- ^ Add the EBB that begins the chain + -- + -- Only chains starting in Byron with EBBs enabled calls this, and only once. , getCurrentLedger :: m (LedgerState blk EmptyMK) -- ^ Return the current ledger state } @@ -32,8 +33,8 @@ fromFull :: ChainDB m blk -> InitChainDB m blk fromFull db = InitChainDB - { addBlock = - ChainDB.addBlock_ db InvalidBlockPunishment.noPunishment + { addTheFirstEbb = + ChainDB.addBlock_ db InvalidBlockPunishment.noPunishment ChainDB.NoPredecessor , getCurrentLedger = atomically $ ledgerState <$> ChainDB.getCurrentLedger db } @@ -46,6 +47,6 @@ map :: InitChainDB m blk' map f g db = InitChainDB - { addBlock = \predSlot -> addBlock db predSlot . f + { addTheFirstEbb = addTheFirstEbb db . f , getCurrentLedger = g <$> getCurrentLedger db } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs index c8ad0ba2b1..6d955c86dc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs @@ -103,11 +103,13 @@ import LeiosDemoTypes import NoThunks.Class import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config (configLedger) +import qualified Ouroboros.Network.AnchoredFragment as AF +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (hardForkSummary)) import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry +import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol, ledgerViewOfTip) import Ouroboros.Consensus.HeaderValidation ( AnnTip (..) - , HasAnnTip , HeaderState (..) , HeaderWithTime (..) , annTipHash @@ -133,8 +135,6 @@ import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache as BlockCache import Ouroboros.Consensus.Util.CallStack -import Ouroboros.Network.AnchoredFragment (AnchoredFragment) -import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike @@ -372,14 +372,11 @@ validate :: forall m l blk. ( IOLike m , HasHardForkHistory blk - , GetHeader blk - , HasAnnTip blk - , GetTip (LedgerState blk) , HasCallStack , ApplyBlock l blk + , LedgerSupportsProtocol blk , ResolveLeiosBlock blk , HasLeiosVoting blk - , HasLedgerTables (LedgerState blk) , l ~ ExtLedgerState blk ) => ComputeLedgerEvents -> @@ -421,10 +418,10 @@ validate evs args = do GetForkerError (Either (AnnLedgerError l blk) (), AnchoredFragment (HeaderWithTime blk)) -> ValidateResult l blk - rewrap (Right (Left e, validated)) = ValidateLedgerError validated e + rewrap (Right (Left e, lvs)) = ValidateLedgerError lvs e rewrap (Left (PointTooOld (Just e))) = ValidateExceededRollBack e rewrap (Left _) = error "Unreachable, validating will always rollback from the tip" - rewrap (Right (Right (), validated)) = ValidateSuccessful validated + rewrap (Right (Right (), lvs)) = ValidateSuccessful lvs mkAps :: Set (RealPoint blk) -> @@ -454,13 +451,10 @@ validate evs args = do switch :: ( ApplyBlock l blk , HasHardForkHistory blk - , GetHeader blk - , HasAnnTip blk - , GetTip (LedgerState blk) , MonadSTM m + , LedgerSupportsProtocol blk , ResolveLeiosBlock blk , HasLeiosVoting blk - , HasLedgerTables (LedgerState blk) , l ~ ExtLedgerState blk ) => LeiosDbReader m -> @@ -483,7 +477,7 @@ switch leiosDb withForkerAtFromTip evs cfg numRollbacks trace newBlocks doResolv withForkerAtFromTip numRollbacks $ \fo -> do let start = PushStart . toRealPoint . NE.head $ newBlocks goal = PushGoal . toRealPoint . NE.last $ newBlocks - (ePush, validated) <- + (ePush, lvs) <- applyThenPushMany leiosDb (trace . StartedPushingBlockToTheLedgerDb start goal) @@ -493,10 +487,10 @@ switch leiosDb withForkerAtFromTip evs cfg numRollbacks trace newBlocks doResolv fo doResolve case ePush of - Left err -> pure (Left err, validated) + Left err -> pure (Left err, lvs) Right () -> do - applySuccessForkerAction onSuccess validated fo - pure (Right (), validated) + applySuccessForkerAction onSuccess lvs fo + pure (Right (), lvs) {------------------------------------------------------------------------------- Apply blocks @@ -738,13 +732,10 @@ applyThenPush leiosDb evs cfg ap fo doResolve = do applyThenPushMany :: ( ApplyBlock l blk , HasHardForkHistory blk - , GetHeader blk - , HasAnnTip blk - , GetTip (LedgerState blk) , MonadSTM m + , LedgerSupportsProtocol blk , ResolveLeiosBlock blk , HasLeiosVoting blk - , HasLedgerTables (LedgerState blk) , l ~ ExtLedgerState blk ) => LeiosDbReader m -> @@ -791,6 +782,7 @@ applyThenPushMany leiosDb trace evs cfg aps fo doResolveBlock = do (Qry.slotToWallclock (blockSlot hdr)) (hardForkSummary lcfg (ledgerState st)) , hwtPredecessorSlot = getTipSlot predecessorLedger + , hwtLedgerViewOfPredecessor = ledgerViewOfTip lcfg predecessorLedger } pushAndTrace (acc AF.:> hwt) (forgetLedgerTables st) aps' @@ -1086,9 +1078,11 @@ newtype SuccessForkerAction m l blk = MkSuccessForkerAction -- applied, as validated headers anchored at the fork point -- so the fragment -- is the accepted prefix, and is empty when nothing was applied. -- --- Validation builds these because it is the only place that sees what they --- record: each annotation is a projection of the state the previous block --- left behind, which exists only inside the forker until the caller commits. +-- Validation reports these because it is the only place that sees them: each +-- is a projection of the state the previous block left behind, which exists +-- only inside the forker until the caller commits. See +-- 'Ouroboros.Consensus.HeaderValidation.hwtLedgerViewOfPredecessor' for what +-- the caller does with them. data ValidateResult l blk = ValidateSuccessful (AnchoredFragment (HeaderWithTime blk)) | ValidateLedgerError (AnchoredFragment (HeaderWithTime blk)) (AnnLedgerError l blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs index 39b3912320..3e8bd1c57a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs @@ -37,7 +37,6 @@ import Ouroboros.Consensus.HeaderStateHistory ( HeaderStateHistory (..) , mkHeaderStateWithTimeFromSummary ) -import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol @@ -248,9 +247,8 @@ implGetPastLedgerState env point = do implGetHeaderStateHistory :: ( MonadSTM m , l ~ ExtLedgerState blk - , IsLedger (LedgerState blk) , HasHardForkHistory blk - , HasAnnTip blk + , LedgerSupportsProtocol blk ) => LedgerDBEnv m l blk -> STM m (HeaderStateHistory blk) implGetHeaderStateHistory env = do @@ -260,10 +258,14 @@ implGetHeaderStateHistory env = do -- This summary can convert all tip slots of the ledger states in the -- @ledgerDb@ as these are not newer than the tip slot of the current -- ledger state (Property 17.1 in the Consensus report). - summary = hardForkSummary (configLedger $ getExtLedgerCfg $ ledgerDbCfg $ ldbCfg env) currentLedgerState - mkHeaderStateWithTime' = - mkHeaderStateWithTimeFromSummary summary - . headerState + lcfg = configLedger $ getExtLedgerCfg $ ledgerDbCfg $ ldbCfg env + summary = hardForkSummary lcfg currentLedgerState + mkHeaderStateWithTime' extLedgerState = + mkHeaderStateWithTimeFromSummary + summary + lcfg + (ledgerState extLedgerState) + (headerState extLedgerState) pure . HeaderStateHistory . AS.bimap mkHeaderStateWithTime' mkHeaderStateWithTime' diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs index 02bfb844d4..40ff54bbae 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs @@ -274,9 +274,8 @@ implGetPastLedgerState env point = implGetHeaderStateHistory :: ( MonadSTM m , l ~ ExtLedgerState blk - , IsLedger (LedgerState blk) , HasHardForkHistory blk - , HasAnnTip blk + , LedgerSupportsProtocol blk ) => LedgerDBEnv m l blk -> STM m (HeaderStateHistory blk) implGetHeaderStateHistory env = do @@ -285,11 +284,16 @@ implGetHeaderStateHistory env = do -- This summary can convert all tip slots of the ledger states in the -- @ledgerDb@ as these are not newer than the tip slot of the current -- ledger state (Property 17.1 in the Consensus report). - summary = hardForkSummary (configLedger $ getExtLedgerCfg $ ledgerDbCfg $ ldbCfg env) currentLedgerState - mkHeaderStateWithTime' = - mkHeaderStateWithTimeFromSummary summary - . headerState - . state + lcfg = configLedger $ getExtLedgerCfg $ ledgerDbCfg $ ldbCfg env + summary = hardForkSummary lcfg currentLedgerState + mkHeaderStateWithTime' stateRef = + mkHeaderStateWithTimeFromSummary + summary + lcfg + (ledgerState extLedgerState) + (headerState extLedgerState) + where + extLedgerState = state stateRef pure . HeaderStateHistory . AS.bimap mkHeaderStateWithTime' mkHeaderStateWithTime' diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Header.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Header.hs index cb5e5f252a..5f9f08db5f 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Header.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Header.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} module Test.Util.Header ( -- * Enriching headers with a relative slot time @@ -11,7 +12,8 @@ import Cardano.Slotting.EpochInfo.API (epochInfoSlotToRelativeTime) import Data.Functor.Identity (runIdentity) import Data.Typeable (Typeable) import Ouroboros.Consensus.Block - ( Header + ( BlockProtocol + , Header , SlotNo , WithOrigin (NotOrigin) , blockSlot @@ -22,6 +24,7 @@ import Ouroboros.Consensus.HardFork.Combinator.Abstract , immutableEpochInfo ) import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) +import Ouroboros.Consensus.Protocol.Abstract (LedgerView) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF @@ -39,6 +42,7 @@ attachSlotTimeToFragment :: ( AF.HasHeader (Header blk) , Typeable blk , ImmutableEraParams blk + , LedgerView (BlockProtocol blk) ~ () ) => TopLevelConfig blk -> AnchoredFragment (Header blk) -> @@ -52,8 +56,18 @@ attachSlotTimeToFragment cfg frag = where hdrs = AF.toOldestFirst frag +-- | Build a 'HeaderWithTime' without validating the header +-- +-- Restricted to blocks whose 'LedgerView' is trivial, which is what makes this +-- sound: 'hwtLedgerViewOfPredecessor' is meant to be a by-product of +-- validating the header, and here there is no information for it to carry. A +-- block with a real ledger view has to go through the ChainSync client or +-- ChainSel. attachSlotTime :: - (AF.HasHeader (Header blk), ImmutableEraParams blk) => + ( AF.HasHeader (Header blk) + , ImmutableEraParams blk + , LedgerView (BlockProtocol blk) ~ () + ) => TopLevelConfig blk -> -- | The slot of the header's predecessor WithOrigin SlotNo -> @@ -65,6 +79,7 @@ attachSlotTime cfg predSlot hdr = , hwtSlotRelativeTime = runIdentity $ epochInfoSlotToRelativeTime ei (blockSlot hdr) , hwtPredecessorSlot = predSlot + , hwtLedgerViewOfPredecessor = () } where ei = immutableEpochInfo cfg diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs index 37c1198fc7..a90c407126 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs @@ -282,7 +282,7 @@ initLedgerDB s c = do case result of LedgerDB.ValidateSuccessful{} -> do pure () - LedgerDB.ValidateExceededRollBack _ -> + LedgerDB.ValidateExceededRollBack{} -> error "impossible: rollback was 0" LedgerDB.ValidateLedgerError{} -> error "impossible: there were no invalid blocks" diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs index 2bb7f6baf4..19bb05becc 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs @@ -163,7 +163,11 @@ runFollowerPromptnessTest FollowerPromptnessTestSetup{..} = withRegistry \regist let addBlocks tipSlot = \case [] -> pure tipSlot blk : blks -> do - ChainDB.addBlock_ chainDB Punishment.noPunishment tipSlot blk + ChainDB.addBlock_ + chainDB + Punishment.noPunishment + (ChainDB.trivialPredecessor tipSlot) + blk addBlocks (NotOrigin (blockSlot blk)) blks addUpdates tipSlot = \case [] -> pure () diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index 39c45cbaab..bdb9a431b4 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs @@ -17,6 +17,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -356,6 +357,9 @@ type AllComponents blk = type TestConstraints blk = ( ConsensusProtocol (BlockProtocol blk) + , -- The test blocks have no ledger view, which is what lets this test build + -- 'HeaderWithTime's without validating; see 'Test.Util.Header.attachSlotTime'. + LedgerView (BlockProtocol blk) ~ () , LedgerSupportsProtocol blk , LedgerSupportsPeras blk , BlockSupportsDiffusionPipelining blk @@ -488,7 +492,7 @@ run cfg env@ChainDBEnv{varDB, ..} cmd = ChainDBState m blk -> WithOrigin SlotNo -> blk -> m (Point blk) advanceAndAdd ChainDBState{chainDB} predSlot blk = do -- `blockProcessed` always returns 'Just' - res <- addBlock chainDB InvalidBlockPunishment.noPunishment predSlot blk + res <- addBlock chainDB InvalidBlockPunishment.noPunishment (trivialPredecessor predSlot) blk return $ case res of FailedToAddBlock f -> error $ "advanceAndAdd: block not added - " ++ f SuccesfullyAddedBlock pt -> pt @@ -1248,14 +1252,14 @@ generator loe genBlock m@Model{..} = genAddBlock :: Gen (Cmd blk it flr) genAddBlock = do (blk, gapBlks) <- genBlock m - pure $ AddBlock blk (predecessorSlot gapBlks blk) gapBlks + pure $ AddBlock blk (genPredecessorSlot gapBlks blk) gapBlks -- Every block the generators build sits on top of a block they have already -- built, so its predecessor is either genesis or one of the blocks below, -- even when it is a gap block that will never be added to the ChainDB or one -- whose predecessor the model has since garbage-collected. - predecessorSlot :: Persistent [blk] -> blk -> WithOrigin SlotNo - predecessorSlot (Persistent gapBlks) blk = case blockPrevHash blk of + genPredecessorSlot :: Persistent [blk] -> blk -> WithOrigin SlotNo + genPredecessorSlot (Persistent gapBlks) blk = case blockPrevHash blk of GenesisHash -> Origin BlockHash h -> case Map.lookup h generated of Nothing -> error "genAddBlock: predecessor was never generated" From 96c170b446a913bf3a4c47826369bd876fcda21b Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 18 Sep 2026 18:17:11 -0400 Subject: [PATCH 14/60] Fix formatting and hlint --- .../Ouroboros/Consensus/Shelley/Ledger/Leios.hs | 1 - .../Ouroboros/Consensus/Protocol/Praos/Views.hs | 2 +- .../Ouroboros/Consensus/HeaderStateHistory.hs | 1 - .../Ouroboros/Consensus/Storage/ChainDB/API.hs | 2 +- .../Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs | 2 +- .../Ouroboros/Consensus/Storage/LedgerDB/Forker.hs | 10 ++++++---- 6 files changed, 9 insertions(+), 9 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs index 3277d1de6c..cf3843b8d9 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs index 3e63e6540a..54440b2320 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs @@ -29,8 +29,8 @@ import Cardano.Ledger.BaseTypes , UnitInterval ) import Cardano.Ledger.Chain (ChainChecksPParams (..)) -import Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey) import qualified Cardano.Ledger.Dijkstra.Forecast as Dijkstra +import Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey) import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Ledger.State (LeiosCommittee, emptyLeiosCommittee) import Cardano.Protocol.Crypto (KES, VRF) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs index eb0843f303..5b9d976ded 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 61c4f2c04b..ae7fdc458c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -96,8 +96,8 @@ import Ouroboros.Consensus.HeaderStateHistory import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended -import Ouroboros.Consensus.Protocol.Abstract (LedgerView) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) +import Ouroboros.Consensus.Protocol.Abstract (LedgerView) import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Storage.ImmutableDB.API (SeekBlockError (..)) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index b81a09a200..c532b285ee 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -114,13 +114,13 @@ import Ouroboros.Consensus.Peras.SelectView (WeightedSelectView) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API ( AddBlockPromise (..) - , Predecessor (..) , AddBlockResult (..) , AddPerasCertPromise (..) , ChainDbError (..) , ChainSelectionPromise (..) , ChainType , LoE + , Predecessor (..) , StreamFrom , StreamTo , UnknownRange diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs index 6d955c86dc..4212cd1a78 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs @@ -103,11 +103,8 @@ import LeiosDemoTypes import NoThunks.Class import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config (configLedger) -import qualified Ouroboros.Network.AnchoredFragment as AF -import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (hardForkSummary)) import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry -import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol, ledgerViewOfTip) import Ouroboros.Consensus.HeaderValidation ( AnnTip (..) , HeaderState (..) @@ -118,6 +115,7 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx) +import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol, ledgerViewOfTip) import Ouroboros.Consensus.Ledger.Tables.Utils ( calculateDifference , forgetLedgerTables @@ -137,6 +135,8 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache as BlockCac import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import qualified Ouroboros.Network.AnchoredFragment as AF {------------------------------------------------------------------------------- Forker @@ -1066,7 +1066,9 @@ resolveAndApplyLeiosClosure leiosDb lcfg ebHash readValues extraKeys lsBase = do -- signatures. newtype SuccessForkerAction m l blk = MkSuccessForkerAction { applySuccessForkerAction :: - AnchoredFragment (HeaderWithTime blk) -> Forker m l -> m () + AnchoredFragment (HeaderWithTime blk) -> + Forker m l -> + m () -- ^ Run with the blocks that were applied, as validated headers anchored at -- the fork point. This is the only point at which they and the forker are -- both in hand. From 8a873bc8109459c5aad811e761d23754256cea82 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Mon, 21 Sep 2026 09:05:28 -0400 Subject: [PATCH 15/60] ValidClaims: add design for ValidClaims startup logic to preserve Liveness --- .../explanations/valid_claims_startup.md | 71 +++++++++++++++++++ docs/website/sidebars.js | 1 + 2 files changed, 72 insertions(+) create mode 100644 docs/website/contents/explanations/valid_claims_startup.md diff --git a/docs/website/contents/explanations/valid_claims_startup.md b/docs/website/contents/explanations/valid_claims_startup.md new file mode 100644 index 0000000000..172c0d2ede --- /dev/null +++ b/docs/website/contents/explanations/valid_claims_startup.md @@ -0,0 +1,71 @@ +# Leios Valid Claims at Startup + +Part of: [System Overview](index.md) + +TODO this design alternative isn't yet implemented + +## Problem + +A CertRB already in the VolatileDB at startup never passes through `chainSelAddBlock` again — `isMember` short-circuits it and BlockFetch won't re-fetch it — so nothing hands it the ledger view its certificate must be checked against. +Its claim stays unverified for the run, which closes the Recovery Path for the EB it certifies; where that is the only remaining route to that EB, the block can never become selectable. + +## Policy + +At startup, a CertRB we can't vouch for is treated as a block we don't have; we re-acquire it by the ordinary path, which carries the view as a matter of course. +Concretely: **forget every CertRB that isn't on the selection after initial chain selection.** + +Forgetting means *unknown but still stored*. +A forgotten block is absent to every query — whether we hold it, whether it's fetched, what its predecessor's successors are, and reads by hash. +Its bytes stay, and the store still recognises the hash if the block is added again: that add writes nothing and simply starts admitting the block. +The adding caller sees an ordinary successful add either way. + +## Mechanism + +The VolatileDB gains an in-memory set of forgotten hashes. +It is empty when the VolatileDB is opened, and stays empty until something calls the forget operation — which the ChainDB can only do once initial chain selection has produced a selection to keep. + +- `getBlockInfo`, `filterByPredecessor` and `getBlockComponent` treat a hash in that set as absent. + Everything derived from them inherits it: `getIsMember`, `ChainDB.getIsFetched`, and `chainSelAddBlock`'s `isMember`. +- The index entry itself is untouched, so re-admission restores exactly the original file and offset. +- `putBlockImpl`'s existing dedup is the one exception — it consults `currentRevMap` directly, so it still finds the block, writes nothing, and removes the hash from the forgotten set. +- A new VolatileDB operation takes the CertRBs to keep and forgets every other cert-carrying block in its index. + The ChainDB calls it once, after initial chain selection, passing the CertRBs on the resulting selection. + The VolatileDB thus needs no notion of a selection, and the ChainDB needs no way to enumerate the index. +- Two trace points: the batch forgotten at startup, and each re-add that re-admits one. + The second is what tells you the path fired. + +## Correctness + +**Liveness — a forgotten CertRB C is recovered exactly when it is wanted.** +If C is on a chain we would select, some current peer's candidate runs through it, so ChainSync delivers C's header and its ancestors', validated incrementally from our intersection — no forecast horizon arises, because the header state advances header by header. +`getIsFetched` reports C absent, so BlockFetch requests it in that candidate's range. +`chainSelAddBlock` reads `isMember` before calling `putBlock`, so it sees absent and proceeds; `putBlock` writes nothing and re-admits C; `precheckLeiosCert` then runs with the `Predecessor` BlockFetch derived from C's own validated header, which is the ledger view at C's predecessor's slot — the announcing slot, and so exactly the view the certificate must satisfy. +Conversely, if no peer ever offers C again, no chain we would select contains C, so C is unselectable and its claim is worthless. + +**Progress.** +Forgetting happens once, at startup; re-admission is permanent. +The set only shrinks during a run, so there is no cycle between the two. + +**Safety.** +A node need not preserve everything across a restart; it must not lose *too much*, and the measure of "too much" is what recovery costs. +Resyncing from genesis is always correct and always intolerable downtime. +This policy sits near the other end: it leaves the entire selected chain untouched, and what it discards is bounded by the VolatileDB's off-selection contents — normally a handful of fork blocks. +Each is recoverable from the network by the ordinary fetch path, and only fetched when some chain we would actually select needs it. +So the information lost is bounded, and its recovery is both cheap and demand-driven. +A block we forged is covered by this like any other and needs no separate treatment. + +What remains are three invariants the mechanism must uphold regardless, because breaking them damages the running node rather than merely costing a re-fetch: + +- **Nothing on the selection is forgotten.** + Otherwise `filterByPredecessor` loses an edge of the chain whose headers `cdbChain` still holds, and `copyToImmutableDB` throws when `getKnownBlockComponent` can't find a block it is copying. +- **No second copy reaches disk.** + `putBlockImpl` dedups against `currentRevMap`, which retains the entry, so a re-add appends nothing. + The duplicate that would make `validateFile` hit `DuplicatedBlock` and truncate a file at the next startup is never created. +- **No reader holds a forgotten hash.** + Every by-hash read takes its hash from the index or the selection, so making forgotten blocks absent to reads strands nobody. + Low risk, and contained: no consumer of the node's interfaces (which excludes direct access of its on-disk files) can learn a forgotten block's hash, so none can request one. + The exposure is confined to ChainDB-internal readers — a sweep that is not yet finished. + +**Downstream consumers.** +DBImmutaliser is the only interesting one: it opens the VolatileDB and nothing more, so it never calls the forget operation and the set stays empty for it — it sees the whole index, unchanged. +Any other tool that opens the VolatileDB directly is in the same position. diff --git a/docs/website/sidebars.js b/docs/website/sidebars.js index 2b4d1914e2..d83d05d379 100644 --- a/docs/website/sidebars.js +++ b/docs/website/sidebars.js @@ -28,6 +28,7 @@ const sidebars = { 'explanations/ledger_interaction', 'explanations/queries', 'explanations/node_tasks', + 'explanations/valid_claims_startup', ] } ], From 8512b64116cb282d5d645065109a939df1364d60 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Mon, 21 Sep 2026 10:02:50 -0400 Subject: [PATCH 16/60] ValidClaims: implement valid_claims_startup.md The VolatileDB gains a forgotten set; off-selection CertRBs are forgotten after initial chain selection so the ordinary fetch path re-validates their claims. --- .../explanations/valid_claims_startup.md | 47 +++++++++++++++- .../Consensus/Storage/ChainDB/Impl.hs | 9 +++ .../Consensus/Storage/VolatileDB/API.hs | 25 +++++++++ .../Consensus/Storage/VolatileDB/Impl.hs | 56 ++++++++++++++++--- .../Storage/VolatileDB/Impl/State.hs | 5 ++ .../Storage/VolatileDB/Impl/Types.hs | 5 ++ .../Test/Ouroboros/Storage/VolatileDB/Mock.hs | 1 + .../Ouroboros/Storage/VolatileDB/Model.hs | 8 +++ 8 files changed, 145 insertions(+), 11 deletions(-) diff --git a/docs/website/contents/explanations/valid_claims_startup.md b/docs/website/contents/explanations/valid_claims_startup.md index 172c0d2ede..624b2f0646 100644 --- a/docs/website/contents/explanations/valid_claims_startup.md +++ b/docs/website/contents/explanations/valid_claims_startup.md @@ -2,8 +2,6 @@ Part of: [System Overview](index.md) -TODO this design alternative isn't yet implemented - ## Problem A CertRB already in the VolatileDB at startup never passes through `chainSelAddBlock` again — `isMember` short-circuits it and BlockFetch won't re-fetch it — so nothing hands it the ledger view its certificate must be checked against. @@ -69,3 +67,48 @@ What remains are three invariants the mechanism must uphold regardless, because **Downstream consumers.** DBImmutaliser is the only interesting one: it opens the VolatileDB and nothing more, so it never calls the forget operation and the set stays empty for it — it sees the whole index, unchanged. Any other tool that opens the VolatileDB directly is in the same position. + +## Alternative Designs + +### Forget by deleting + +This design would isolate the changes to the VolDB to all happen at startup. +However, it also introduces a non-trivial concept to the VolDB: mutation. + +In particular, the forgotten state could be eliminated by *actually* forgetting — deleting those blocks from disk, so that "we do not have it" needs no new semantics at all. +That would introduce non-append mutation to the VolatileDB's design, which is not a small step. +The affected files would have to be rewritten, and the durability that doing so would need is deliberately out of reach — `fsync` is _intentionally_ so far not even offered by the filesystem API the VolatileDB is implemented against. +That's because `fsync` is unacceptable during the node's normal behavior. +On the other hand, `fsync` would tolerable as part of startup, but nothing else has justified adding it to the interfaces. + +### Leverage LeiosDB + +This design was rejected for the following reason. + +We could properly persist each verified Leios cert — in the LeiosDb, say — and load `ValidClaims` from it at startup, so that the verdict survives the restart and no CertRB need be forgotten. +However, that cannot replace the forgotten state, because correctness would require the persisted claim to be durable before the block is: `chainSelAddBlock` would have to verify the cert _and persist it_ before `putBlock`, putting a synchronous SQLite commit on the block-add path, once per new claim — contending with exactly the EB and closure traffic that is already requiring some redesign of the LeiosDb, since it's bottlenecking some devnets. + +Notes: +- Switching to this design would also require some bespoke migration logic for a node that upgrades to it, since its first subsequent restart couldn't populate `ValidClaims` from the _new_ persistent store. + That migration logic would be comparable to the startup scan that initialized the forgotten state. +- Demoting this design to an optimization layered on top of the forgotten state would free its writes to be lazy and best-effort, but then it merely avoids only the CertRB re-fetches that arise from forgetting them. + +### React to MsgRollForward + +This design was implemented and then reverted, so we have some concrete insights into it. + +A CertRB's header is revalidated by every peer whose candidate chain runs through it, and a validated header carries the ledger view at its predecessor's slot. +That is the announcing slot, and so exactly the view the claimed certificate must satisfy. +The ChainSync client therefore can hand that view to the ChainDB, which could read the block _it already holds_ and verify the certificate. +However, `verifyLeiosCert` costs milliseconds, so that verification cannot run on the ChainSync client's thread: it needs a work queue and a background thread to drain it, plus a new edge from the network layer into the ChainDB's internals to fill the queue. + +That concurrency was the most painful part of the implementation, and none of it is incidental. +Every peer's client discovers the same work at about the same time, so the producers have to deduplicate — keying the queue by CertRB is what collapses tens of identical items into one. +The queue consumer's lifetime has to be the node's rather than a peer's: anything simpler, such as letting one client do the work while the others skip it, silently loses the job when that client's peer disconnects mid-verification, because the other clients that already skipped it don't get a second chance. +The forgotten state introduces none of this: it reaches the same verified claim through the ordinary fetch-and-add path, which already carries that view, already deduplicates across peers in BlockFetch, and already runs off the ChainSync threads — in exchange for re-fetching a handful of off-selection blocks. + +Notes: +- The reverted work included a benchmark that measures `verifyLeiosCert` at roughly 0.9ms plus 1.9us per signer — about 2ms for a committee of 1000 and 9ms for one of 5000. + Those would be significant additions to the established costs of header validation. +- This design does cover one corner case the forgotten state does not: a candidate chain whose blocks BlockFetch never fetches, where the header alone would settle the claim (since it triggers reading the previously-fetched CertRB from disk). + That only matters for acquiring - via The Recovery Path — an EB certified by a CertRB even before we want to select it, so the loss is merely latency, but not on the scale that the The Recovery Path should prioritize. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index 5d8fa72e71..25134c234f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -50,6 +50,7 @@ import Control.Tracer import Data.Functor ((<&>)) import qualified Data.Map.Strict as Map import Data.Maybe.Strict (StrictMaybe (..)) +import qualified Data.Set as Set import GHC.Stack (HasCallStack) import LeiosDemoDb.Common (scanCompleteEbClosuresNotOlderThanSlot, withReader) import LeiosDemoTypes @@ -247,6 +248,14 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do -- what validation reveals; see 'HeaderWithTime'. let chain = forgetValidation chainWithTime + -- Cause this execution of the node (ie since the latest restart) to + -- re-fetch CertRBs that aren't on the initial selection. See + -- docs/website/contents/explanations/valid_claims_startup.md for why. + VolatileDB.forgetLeiosCertsAtStartUpExcept volatileDB $ + Set.fromList $ + map headerHash $ + AF.toOldestFirst chain + varChain <- newTVarWithInvariantIO checkInternalChain $ InternalChain chain chainWithTime varTentativeState <- newTVarIO $ initialTentativeHeaderState (Proxy @blk) varTentativeHeader <- newTVarIO SNothing diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/API.hs index 6e82b74f7d..6d00181219 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/API.hs @@ -95,6 +95,31 @@ data VolatileDB m blk = VolatileDB -- Keyed by 'EbHash' to match the acquired-EB set that drives reprocessing. -- -- TODO(EbAnnouncement): see the note on 'biLeiosAnnouncedEb'. + , forgetLeiosCertsAtStartUpExcept :: HasCallStack => Set (HeaderHash blk) -> m () + -- ^ Forget every block carrying a Leios certificate ('biHasLeiosCert') except + -- the given ones. + -- + -- The VolDB knows that a /forgotten/ block is stored but it otherwise behaves + -- as if the block is absent: its bytes stay on disk, and this DB still + -- recognises its hash if the block is added again, but every query answers as + -- though we do not hold it --- 'getBlockInfo', 'filterByPredecessor' and + -- 'getBlockComponent' alike. 'putBlock' is the one exception: a re-add of a + -- forgotten block writes nothing and simply starts admitting that it is + -- present. One could interpret "forgotten" as /hidden until added again/. + -- + -- See docs\/website\/contents\/explanations\/valid_claims_startup.md for why + -- /forgetten/ is a worthwhile state to include in the design. + -- + -- Only 'putBlock' un-forgets a block. Forgotten blocks are garbage collected. + -- + -- PRECONDITION: called at most once, during node start-up, before the ChainDB + -- has revealed its initial chain selection to anything --- not to a + -- downstream peer, not to a local client, not even to another component of + -- this node. Forgetting is only sound while nobody can already be aware of a + -- forgotten block, and no one can be before that reveal. + -- + -- PRECONDITION: forgetting a block on the initial selection would break the + -- ChainDB, so the caller must not ask for that. , garbageCollect :: HasCallStack => SlotNo -> m () -- ^ Try to remove all blocks with a slot number less than the given -- one. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs index 143a5410fe..450acced1d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs @@ -138,6 +138,7 @@ import Data.Maybe.Strict (StrictMaybe (..), strictMaybeToMaybe) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as Text +import Data.Typeable (Typeable) import Data.Word (Word64) import GHC.Stack (HasCallStack) import LeiosDemoTypes (EbHash, pointEbHash) @@ -242,6 +243,7 @@ openDB VolatileDbArgs{volHasFS = SomeHasFS hasFS, ..} = do , filterByPredecessor = filterByPredecessorImpl env , getBlockInfo = getBlockInfoImpl env , getLeiosAnnouncers = getLeiosAnnouncersImpl env + , forgetLeiosCertsAtStartUpExcept = forgetLeiosCertsAtStartUpExceptImpl env , getMaxSlotNo = getMaxSlotNoImpl env } return volatileDB @@ -278,12 +280,14 @@ getBlockComponentImpl :: HeaderHash blk -> m (Maybe b) getBlockComponentImpl env@VolatileDBEnv{codecConfig, checkIntegrity} blockComponent hash = - withOpenState env $ \hasFS OpenState{currentRevMap} -> + withOpenState env $ \hasFS OpenState{currentRevMap, currentForgotten} -> case Map.lookup hash currentRevMap of - Nothing -> return Nothing - Just internalBlockInfo -> - Just - <$> getBlockComponent hasFS internalBlockInfo blockComponent + -- Treat forgotten block as absent despite being present; see + -- 'forgetLeiosCertsAtStartUpExcept'. + Just internalBlockInfo + | not (Set.member hash currentForgotten) -> + Just <$> getBlockComponent hasFS internalBlockInfo blockComponent + _ -> return Nothing where getBlockComponent :: forall b' h. @@ -397,9 +401,15 @@ putBlockImpl env@VolatileDBEnv{maxBlocksPerFile, tracer, codecConfig} blk = appendOpenState env $ \hasFS -> do - OpenState{currentRevMap, currentWriteHandle} <- get + st@OpenState{currentRevMap, currentWriteHandle} <- get if Map.member biHash currentRevMap - then + then do + -- Already stored. If it was forgotten, un-forget it it; see + -- 'forgetLeiosCertsAtStartUpExcept'. Either way no bytes are written, + -- which is what keeps a second on-disk copy from ever existing. + when (Set.member biHash (currentForgotten st)) $ do + lift $ lift $ traceWith tracer $ ReadmittedForgottenBlock biHash + put st{currentForgotten = Set.delete biHash (currentForgotten st)} lift $ lift $ traceWith tracer $ BlockAlreadyHere biHash else do let bytes = CBOR.toLazyByteString $ encodeDisk codecConfig blk @@ -573,6 +583,7 @@ garbageCollectFile hasFS (fileId, fileInfo) = do , currentRevMap = currentRevMap' , currentSuccMap = currentSuccMap' , currentLeiosAnnouncerMap = currentLeiosAnnouncerMap' + , currentForgotten = currentForgotten st `Set.difference` hashes } filterByPredecessorImpl :: @@ -581,7 +592,13 @@ filterByPredecessorImpl :: VolatileDBEnv m blk -> STM m (ChainHash blk -> Set (HeaderHash blk)) filterByPredecessorImpl = getterSTM $ \st hash -> - fromMaybe Set.empty (Map.lookup hash (currentSuccMap st)) + let succs = fromMaybe Set.empty (Map.lookup hash (currentSuccMap st)) + in -- Guarded because this one filters the result rather than testing a + -- single hash, so without it every query would unnecessarily walk its + -- successor set. + if Set.null (currentForgotten st) + then succs + else succs `Set.difference` currentForgotten st getBlockInfoImpl :: forall m blk. @@ -589,7 +606,28 @@ getBlockInfoImpl :: VolatileDBEnv m blk -> STM m (HeaderHash blk -> Maybe (BlockInfo blk)) getBlockInfoImpl = getterSTM $ \st hash -> - ibiBlockInfo <$> Map.lookup hash (currentRevMap st) + if Set.member hash (currentForgotten st) + then Nothing + else ibiBlockInfo <$> Map.lookup hash (currentRevMap st) + +-- | Forget every cert-carrying block but the given ones; see +-- 'forgetLeiosCertsAtStartUpExcept'. +forgetLeiosCertsAtStartUpExceptImpl :: + forall m blk. + (IOLike m, StandardHash blk, Typeable blk) => + VolatileDBEnv m blk -> + Set (HeaderHash blk) -> + m () +forgetLeiosCertsAtStartUpExceptImpl env keep = + appendOpenState env $ \_hasFS -> do + st <- get + let forgotten = + Map.keysSet $ + Map.filterWithKey + (\h ibi -> biHasLeiosCert (ibiBlockInfo ibi) && not (Set.member h keep)) + (currentRevMap st) + lift $ lift $ traceWith (tracer env) $ ForgotLeiosCertBlocks (Set.size forgotten) + put st{currentForgotten = currentForgotten st `Set.union` forgotten} getLeiosAnnouncersImpl :: forall m blk. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs index ceec9dea56..abeacd4602 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs @@ -48,6 +48,7 @@ import Data.List as List (foldl') import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe.Strict (StrictMaybe (..)) +import Data.Set (Set) import qualified Data.Set as Set import Data.Typeable (Typeable) import Data.Word (Word64) @@ -109,6 +110,9 @@ data OpenState blk h = OpenState -- ^ The successors for each block. , currentLeiosAnnouncerMap :: !(LeiosAnnouncerIndex blk) -- ^ The blocks (RBs) announcing each endorser block. + , currentForgotten :: !(Set (HeaderHash blk)) + -- ^ Blocks that are stored but that the DB does not admit to holding; see + -- 'forgetLeiosCertsAtStartUpExcept'. Empty until that function is called. , currentMaxSlotNo :: !MaxSlotNo -- ^ Highest stored SlotNo. -- @@ -415,6 +419,7 @@ mkOpenStateHelper ccfg hasFS checkIntegrity validationPolicy tracer maxBlocksPer , currentRevMap = currentRevMap' , currentSuccMap = currentSuccMap' , currentLeiosAnnouncerMap = currentAnnouncerMap' + , currentForgotten = Set.empty , currentMaxSlotNo = FileInfo.maxSlotNoInFiles (Index.elems currentMap') } where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/Types.hs index 5e44c54fa0..89fad08870 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/Types.hs @@ -98,6 +98,11 @@ deriving instance StandardHash blk => Show (ParseError blk) data TraceEvent blk = DBAlreadyClosed | BlockAlreadyHere (HeaderHash blk) + | -- | How many cert-carrying blocks 'forgetLeiosCertsAtStartUpExcept' just forgot. + ForgotLeiosCertBlocks Int + | -- | A forgotten block was added again, so it is known once more. This is + -- the event that shows the re-acquisition path actually firing. + ReadmittedForgottenBlock (HeaderHash blk) | Truncate (ParseError blk) FsPath BlockOffset | InvalidFileNames [FsPath] | DBClosed diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Mock.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Mock.hs index 0ed3214269..e83134655e 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Mock.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Mock.hs @@ -45,6 +45,7 @@ openDBMock maxBlocksPerFile ccfg = do , filterByPredecessor = querySTME $ filterByPredecessorModel , getBlockInfo = querySTME $ getBlockInfoModel , getLeiosAnnouncers = querySTME $ getLeiosAnnouncersModel + , forgetLeiosCertsAtStartUpExcept = const $ updateE_ forgetLeiosCertsAtStartUpExceptModel , getMaxSlotNo = querySTME $ getMaxSlotNoModel } where diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Model.hs index 63115ad5bd..2546e746ea 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Model.hs @@ -19,6 +19,7 @@ module Test.Ouroboros.Storage.VolatileDB.Model , garbageCollectModel , getBlockComponentModel , getBlockInfoModel + , forgetLeiosCertsAtStartUpExceptModel , getLeiosAnnouncersModel , getMaxSlotNoModel , isOpenModel @@ -387,6 +388,13 @@ getLeiosAnnouncersModel :: Either (VolatileDBError blk) (EbHash -> Set (Point blk)) getLeiosAnnouncersModel dbm = whenOpen dbm $ const Set.empty +-- | The model uses no-op Leios extractors (see 'getBlockInfoModel'), so no +-- block carries a certificate and there is never anything to forget. +forgetLeiosCertsAtStartUpExceptModel :: + DBModel blk -> + Either (VolatileDBError blk) (DBModel blk) +forgetLeiosCertsAtStartUpExceptModel dbm = whenOpen dbm dbm + getMaxSlotNoModel :: HasHeader blk => DBModel blk -> From a136059b39800eaa8c9e3ad7efc2ccb478a4c5f1 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 22 Sep 2026 09:51:17 -0400 Subject: [PATCH 17/60] valid_claims_startup.md: add Claude's TODO, needs human rewrite --- docs/website/contents/explanations/valid_claims_startup.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/docs/website/contents/explanations/valid_claims_startup.md b/docs/website/contents/explanations/valid_claims_startup.md index 624b2f0646..82c23bbd7c 100644 --- a/docs/website/contents/explanations/valid_claims_startup.md +++ b/docs/website/contents/explanations/valid_claims_startup.md @@ -93,6 +93,13 @@ Notes: That migration logic would be comparable to the startup scan that initialized the forgotten state. - Demoting this design to an optimization layered on top of the forgotten state would free its writes to be lazy and best-effort, but then it merely avoids only the CertRB re-fetches that arise from forgetting them. +TODO rewrite this subsection: resting the rejection on the durability ordering is too strong, because that ordering is escapable. +Give the claims their own store, co-located with the blocks so that a block and its claim commit in one transaction, and batching the commits then costs only the blocks of an unflushed batch — never a persisted CertRB whose claim is missing. +So the hole stays closed at any batch size, and both designs end up accepting the same loss, namely re-fetching recent blocks after a crash. +The escape needs co-location, which is why it is unavailable to the LeiosDb as such: a block in the VolatileDB and a claim in SQLite are two stores and cannot commit together. +What it takes instead is a transactional VolatileDB, giving up append-only writes, the no-journal recovery property, and file-speed reads on the block path, plus a read path that consults the pending batch. +The rejection therefore belongs on that cost, not on correctness: both designs get their blocks back from the network, and only this one also pays for ACID to get there. + ### React to MsgRollForward This design was implemented and then reverted, so we have some concrete insights into it. From 2a7e72a122084f20edfc9dc3ef2f29d2cd1903cf Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 22 Sep 2026 09:56:48 -0400 Subject: [PATCH 18/60] ValidClaims: refactor for better testing surface --- ouroboros-consensus.cabal | 1 + .../ouroboros-consensus/LeiosValidClaims.hs | 74 ++++++++++++++++++- .../Storage/ChainDB/Impl/ChainSel.hs | 63 +++++++--------- .../test/consensus-test/Main.hs | 1 + 4 files changed, 100 insertions(+), 39 deletions(-) diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index f26fd23dcd..0cb0e449bc 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -775,6 +775,7 @@ test-suite consensus-test Test.LeiosTxCache.Reference Test.LeiosUtils.CallTrace Test.LeiosUtils.TimeBoundedLoop + Test.LeiosValidClaims Test.LeiosVoteState Test.LeiosVoting diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosValidClaims.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosValidClaims.hs index 50cf5ca820..7e6888c47c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosValidClaims.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosValidClaims.hs @@ -20,6 +20,11 @@ module LeiosValidClaims , memberValidClaim , pruneValidClaims , sizeValidClaims + + -- * Deciding a CertRB's claim + , Announcing (..) + , ClaimVerdict (..) + , decideClaim ) where import Cardano.Slotting.Slot (SlotNo) @@ -29,8 +34,20 @@ import qualified Data.Map.Strict as Strict (Map) import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import GHC.Generics (Generic) -import LeiosDemoTypes (RbHash) +import LeiosDemoTypes + ( LeiosCert + , LeiosCommittee + , LeiosForecastRejection + ( LeiosForecastAfterGenesis + , LeiosForecastInvalidCertificate + , LeiosForecastMissingCommittee + ) + , RbHash + , Weight + , verifyLeiosCert + ) import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) +import Ouroboros.Consensus.Block (RealPoint (..), StandardHash) -- | Claims known to be certified, indexed both by claim and by the slot of the -- announcing block, the latter so that pruning is a range operation. @@ -86,3 +103,58 @@ pruneValidClaims immTipSlot vc = sizeValidClaims :: ValidClaims -> Int sizeValidClaims = Map.size . slotOfClaim + +{------------------------------------------------------------------------------- + Deciding a CertRB's claim +-------------------------------------------------------------------------------} + +-- | What the caller knows about the block that announced the EB a CertRB +-- certifies, which is that CertRB's predecessor. +data Announcing blk + = -- | There is no announcing block: the CertRB's predecessor is genesis, so + -- it would certify at genesis. + AnnouncingAtGenesis + | -- | The announcing block's slot, the claim its hash identifies, and the + -- committee the ledger view seats at that slot --- 'Nothing' when the view + -- has no committee or no threshold, which for a CertRB is itself a protocol + -- violation rather than a gap in what we know. + Announcing !(RealPoint blk) !RbHash !(Maybe (LeiosCommittee, Weight)) + +deriving stock instance StandardHash blk => Show (Announcing blk) + +-- | What to do about a CertRB's claim. +data ClaimVerdict blk + = -- | An equal claim is already recorded, so this certificate need not be + -- checked at all --- not even if it is itself invalid. + -- + -- Recall that this verdict is only for maintaining the set of + -- 'ValidClaims'; every cert is fully validated before /being selected/, but + -- different code does that. + ClaimAlreadyEstablished + | -- | The claim is established as of the given announcing slot, and belongs + -- in 'ValidClaims'. + ClaimEstablished !(RealPoint blk) !RbHash + | ClaimRejected !LeiosForecastRejection + +deriving stock instance StandardHash blk => Show (ClaimVerdict blk) + +deriving stock instance StandardHash blk => Eq (ClaimVerdict blk) + +-- | Decide a CertRB's claim: the whole of what ChainSel's cert precheck decides, +-- with none of what it reads or writes. +-- +-- Verification is skipped when an equal claim is already recorded, which is +-- what makes the several /valid/ CertRBs making one claim still cost only one +-- full precheck. +decideClaim :: ValidClaims -> Announcing blk -> LeiosCert -> ClaimVerdict blk +decideClaim vc announcing cert = case announcing of + AnnouncingAtGenesis -> ClaimRejected LeiosForecastAfterGenesis + Announcing announcingPoint rbHash mbCommittee + | memberValidClaim rbHash vc -> ClaimAlreadyEstablished + | otherwise -> case mbCommittee of + Nothing -> ClaimRejected $ LeiosForecastMissingCommittee rbHash + Just (committee, threshold) -> + case verifyLeiosCert committee threshold rbHash cert of + Left invalid -> + ClaimRejected $ LeiosForecastInvalidCertificate rbHash invalid + Right _weight -> ClaimEstablished announcingPoint rbHash diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index 0900f73366..fd4f3956cc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -53,11 +53,6 @@ import LeiosDemoTypes , EbHash , HasLeiosVoting (getLeiosCommitteeFromView) , LeiosExtValidationError (LeiosCertificateForecastRejected) - , LeiosForecastRejection - ( LeiosForecastAfterGenesis - , LeiosForecastInvalidCertificate - , LeiosForecastMissingCommittee - ) , TraceLeiosChainSel ( TraceLeiosCertRbWithoutCandidate , TraceLeiosValidClaim @@ -65,7 +60,6 @@ import LeiosDemoTypes , acquiredLeiosEbHashes , acquiredLeiosEbsSetMember , pointEbHash - , verifyLeiosCert ) import LeiosUtils.CallTrace ( CallCtx @@ -756,39 +750,32 @@ precheckLeiosCert :: m (Either LeiosExtValidationError ()) precheckLeiosCert CDB{..} predecessor b = case blockLeiosCert b of Nothing -> pure $ Right () - Just cert -> case (announcingRbHash b, blockPrevHash b, predecessor) of - (Just rbHash, BlockHash announcingHash, Predecessor announcingSlot announcingView) -> do - let announcingPoint = RealPoint announcingSlot announcingHash - known <- - atomically $ - LeiosValidClaims.memberValidClaim rbHash <$> readTVar cdbLeiosValidClaims - if - -- We've already validated a cert that makes the same claim as this one, - -- so there is nothing left to check, even if /this/ cert is invalid. - | known -> pure $ Right () - | otherwise -> case getLeiosCommitteeFromView (Proxy @blk) announcingView of - Nothing -> reject cert $ LeiosForecastMissingCommittee rbHash - Just (committee, threshold) -> - case verifyLeiosCert committee threshold rbHash cert of - Left invalid -> - reject cert $ LeiosForecastInvalidCertificate rbHash invalid - Right _weight -> do - size <- atomically $ do - modifyTVar cdbLeiosValidClaims $ - LeiosValidClaims.insertValidClaim announcingSlot rbHash - LeiosValidClaims.sizeValidClaims - <$> readTVar cdbLeiosValidClaims - traceWith (TraceAddBlockEvent >$< cdbTracer) $ - AddBlockLeiosEvent $ - TraceLeiosValidClaim - (blockRealPoint b) - announcingPoint - size - pure $ Right () - -- Certifying at genesis: all three of these say there is no announcing - -- block, so they cannot disagree. - _ -> reject cert LeiosForecastAfterGenesis + Just cert -> do + claims <- atomically $ readTVar cdbLeiosValidClaims + case LeiosValidClaims.decideClaim claims (announcingOf b) cert of + LeiosValidClaims.ClaimAlreadyEstablished -> pure $ Right () + LeiosValidClaims.ClaimRejected why -> reject cert why + LeiosValidClaims.ClaimEstablished announcingPoint rbHash -> do + size <- atomically $ do + modifyTVar cdbLeiosValidClaims $ + LeiosValidClaims.insertValidClaim (realPointSlot announcingPoint) rbHash + LeiosValidClaims.sizeValidClaims <$> readTVar cdbLeiosValidClaims + traceWith (TraceAddBlockEvent >$< cdbTracer) $ + AddBlockLeiosEvent $ + TraceLeiosValidClaim (blockRealPoint b) announcingPoint size + pure $ Right () where + -- What this block says about its announcing predecessor. The three indicators + -- of certifying at genesis cannot disagree, so any of them decides it. + announcingOf :: blk -> LeiosValidClaims.Announcing blk + announcingOf blk' = case (announcingRbHash blk', blockPrevHash blk', predecessor) of + (Just rbHash, BlockHash announcingHash, Predecessor announcingSlot announcingView) -> + LeiosValidClaims.Announcing + (RealPoint announcingSlot announcingHash) + rbHash + (getLeiosCommitteeFromView (Proxy @blk) announcingView) + _ -> LeiosValidClaims.AnnouncingAtGenesis + reject cert why = pure $ Left $ LeiosCertificateForecastRejected cert (predecessorSlot predecessor) why diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index 3a227c5431..8e55fd56f2 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -33,6 +33,7 @@ import qualified Test.LeiosTxCache.Optimized.MutableHashTable (tests) import qualified Test.LeiosTxCache.Reference (tests) import qualified Test.LeiosUtils.CallTrace (tests) import qualified Test.LeiosUtils.TimeBoundedLoop (tests) +import qualified Test.LeiosValidClaims (tests) import qualified Test.LeiosVoteState (tests) import qualified Test.LeiosVoting (tests) import Test.Tasty From 43c6c2308456435dc18e65c6dfbd3b73aa247068 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 22 Sep 2026 09:57:17 -0400 Subject: [PATCH 19/60] ValidClaims: add TODO for currentForgotten data structure --- .../Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs index abeacd4602..6e8afadaea 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs @@ -113,6 +113,11 @@ data OpenState blk h = OpenState , currentForgotten :: !(Set (HeaderHash blk)) -- ^ Blocks that are stored but that the DB does not admit to holding; see -- 'forgetLeiosCertsAtStartUpExcept'. Empty until that function is called. + -- + -- TODO: an @IntMap BitField@, one entry per file, would be constant-size and + -- would let garbage collection drop a 'FileId' instead of a 'Set.difference'. + -- It costs at least enriching the parser to retain a block's index within its + -- file, which nothing records today. , currentMaxSlotNo :: !MaxSlotNo -- ^ Highest stored SlotNo. -- From 8ff2fc8732638628e8d403c7683d91cf96250f29 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 22 Sep 2026 10:14:14 -0400 Subject: [PATCH 20/60] ValidClaims: add pure tests --- .../Storage/ChainDB/Impl/ChainSel.hs | 6 +- .../test/consensus-test/Main.hs | 1 + .../consensus-test/Test/LeiosValidClaims.hs | 244 ++++++++++++++++++ 3 files changed, 247 insertions(+), 4 deletions(-) create mode 100644 ouroboros-consensus/test/consensus-test/Test/LeiosValidClaims.hs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index fd4f3956cc..a21a9860e2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -754,7 +754,8 @@ precheckLeiosCert CDB{..} predecessor b = case blockLeiosCert b of claims <- atomically $ readTVar cdbLeiosValidClaims case LeiosValidClaims.decideClaim claims (announcingOf b) cert of LeiosValidClaims.ClaimAlreadyEstablished -> pure $ Right () - LeiosValidClaims.ClaimRejected why -> reject cert why + LeiosValidClaims.ClaimRejected why -> do + pure $ Left $ LeiosCertificateForecastRejected cert (predecessorSlot predecessor) why LeiosValidClaims.ClaimEstablished announcingPoint rbHash -> do size <- atomically $ do modifyTVar cdbLeiosValidClaims $ @@ -776,9 +777,6 @@ precheckLeiosCert CDB{..} predecessor b = case blockLeiosCert b of (getLeiosCommitteeFromView (Proxy @blk) announcingView) _ -> LeiosValidClaims.AnnouncingAtGenesis - reject cert why = - pure $ Left $ LeiosCertificateForecastRejected cert (predecessorSlot predecessor) why - -- | Record the invalid block in the given map and change its fingerprint addInvalidBlock :: (IOLike m, StandardHash blk) => diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index 8e55fd56f2..27b483992a 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -95,6 +95,7 @@ tests = , Test.LeiosTxCache.Optimized.tests , Test.LeiosTxCache.Optimized.MutableHashTable.tests , Test.LeiosTxCache.Reference.tests + , Test.LeiosValidClaims.tests , Test.LeiosVoteState.tests , Test.LeiosVoting.tests , Test.LeiosUtils.CallTrace.tests diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosValidClaims.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosValidClaims.hs new file mode 100644 index 0000000000..7a101cf00d --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosValidClaims.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Tests for 'LeiosValidClaims': the claim cache and the verdict ChainSel +-- reaches about a CertRB's certificate. +module Test.LeiosValidClaims (tests) where + +import Cardano.Crypto.DSIGN (signDSIGN) +import qualified Data.Map.Strict as Map +import Data.Ratio ((%)) +import LeiosDemoTypes + ( LeiosCert + , LeiosCommittee + , LeiosForecastRejection (..) + , LeiosSeatId (..) + , RbHash + , Weight + , aggregateLeiosCert + ) +import LeiosValidClaims + ( Announcing (..) + , ClaimVerdict (..) + , ValidClaims + , decideClaim + , emptyValidClaims + , insertValidClaim + , memberValidClaim + , pruneValidClaims + , sizeValidClaims + ) +import Ouroboros.Consensus.Block (RealPoint (..), SlotNo (..)) +import Test.Cardano.Crypto.Leios.Gen (TestCommittee (..), genCommittee) +import Test.LeiosDemoDb (genRbHash) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) +import Test.Util.TestBlock (TestBlock, TestHash (..)) + +tests :: TestTree +tests = + testGroup + "LeiosValidClaims" + [ testGroup + "ValidClaims" + [ testProperty "agrees with a Map model under inserts and prunes" prop_model + , testProperty "insert is idempotent and keeps the first slot" prop_insertIdempotent + , testProperty "prune keeps the immutable tip's own announcement" prop_pruneIsStrict + ] + , testGroup + "decideClaim" + [ testProperty "certifying at genesis is rejected" prop_genesisRejected + , testProperty "a known claim short-circuits even an invalid cert" prop_knownShortCircuits + , testProperty "a view with no committee is rejected" prop_noCommitteeRejected + , testProperty "a cert over another claim is rejected" prop_wrongMessageRejected + , testProperty "an unmeetable threshold is rejected" prop_thresholdRejected + , testProperty "a good cert establishes exactly its own claim" prop_goodCertEstablishes + ] + ] + +{------------------------------------------------------------------------------- + ValidClaims against a model +-------------------------------------------------------------------------------} + +-- | The claim cache is a 'Map' from claim to announcing slot, with pruning +-- dropping everything announced strictly below a slot. +type Model = Map.Map RbHash SlotNo + +data Op = Insert SlotNo RbHash | Prune SlotNo + deriving Show + +-- | Draws claims from a small pool, so that inserts collide and prunes bite. +genOps :: [RbHash] -> Gen [Op] +genOps pool = + listOf $ + oneof + [ Insert <$> genSlot <*> elements pool + , Prune <$> genSlot + ] + where + genSlot = SlotNo <$> choose (0, 20) + +-- | Shrinks the list of operations and the slots they mention; the claims +-- themselves stay as drawn, since they come from a fixed pool. +shrinkOps :: [Op] -> [[Op]] +shrinkOps = shrinkList shrinkOp + where + shrinkOp = \case + Insert (SlotNo s) rbHash -> [Insert (SlotNo s') rbHash | s' <- shrink s] + Prune (SlotNo s) -> [Prune (SlotNo s') | s' <- shrink s] + +applyOp :: (ValidClaims, Model) -> Op -> (ValidClaims, Model) +applyOp (vc, m) = \case + Insert slot rbHash -> + ( insertValidClaim slot rbHash vc + , Map.insertWith (\_new old -> old) rbHash slot m + ) + Prune slot -> + ( pruneValidClaims slot vc + , Map.filter (>= slot) m + ) + +prop_model :: Property +prop_model = + forAllShrink (vectorOf 4 genRbHash) (const []) $ \pool -> + forAllShrink (genOps pool) shrinkOps $ \ops -> + let (vc, m) = foldl applyOp (emptyValidClaims, Map.empty) ops + in conjoin + [ counterexample "size" $ sizeValidClaims vc === Map.size m + , conjoin + [ counterexample ("member " <> show rbHash) $ + memberValidClaim rbHash vc === Map.member rbHash m + | rbHash <- pool + ] + ] + +prop_insertIdempotent :: Property +prop_insertIdempotent = + forAll genRbHash $ \rbHash -> + forAll (choose (0, 20)) $ \s0 -> + forAll (choose (0, 20)) $ \s1 -> + let vc1 = insertValidClaim (SlotNo s0) rbHash emptyValidClaims + vc2 = insertValidClaim (SlotNo s1) rbHash vc1 + in conjoin + [ counterexample "size" $ sizeValidClaims vc2 === 1 + , -- The first slot decides, so pruning at it keeps the claim + -- whatever the second insert asked for. + counterexample "first slot wins" $ + memberValidClaim rbHash (pruneValidClaims (SlotNo s0) vc2) + ] + +-- | Pruning is strict below the immutable tip, so a claim announced /at/ the tip +-- survives --- it is the tip's own announcement, which a CertRB extending the +-- tip certifies. +prop_pruneIsStrict :: Property +prop_pruneIsStrict = + forAll genRbHash $ \rbHash -> + forAll (choose (1, 20)) $ \s -> + let vc = insertValidClaim (SlotNo s) rbHash emptyValidClaims + in conjoin + [ counterexample "at the tip: kept" $ + memberValidClaim rbHash (pruneValidClaims (SlotNo s) vc) + , counterexample "below the tip: dropped" $ + not $ + memberValidClaim rbHash (pruneValidClaims (SlotNo (s + 1)) vc) + ] + +{------------------------------------------------------------------------------- + decideClaim +-------------------------------------------------------------------------------} + +-- | A CertRB's certificate need not be valid for most of these, which is the +-- point: the verdict is reachable without a node. +mkCert :: TestCommittee -> RbHash -> LeiosCert +mkCert TestCommittee{committee, allKeys} msg = + case aggregateLeiosCert committee sigs of + Right cert -> cert + Left e -> error $ "mkCert: aggregation failed: " <> show e + where + sigs = + Map.fromList + [ (LeiosSeatId (fromIntegral i), signDSIGN () msg sk) + | (i, sk) <- zip [0 :: Int ..] allKeys + ] + +-- | Every seat of 'genCommittee' has weight @1/n@, so the whole committee +-- signing meets a threshold of 1. +wholeCommittee :: Weight +wholeCommittee = 1 % 1 + +announcingAt :: SlotNo -> RbHash -> Maybe (LeiosCommittee, Weight) -> Announcing TestBlock +announcingAt slot = Announcing (RealPoint slot (TestHash (pure 0))) + +prop_genesisRejected :: Property +prop_genesisRejected = + forAll genCommittee $ \tc -> + forAll genRbHash $ \rbHash -> + decideClaim @TestBlock emptyValidClaims AnnouncingAtGenesis (mkCert tc rbHash) + === ClaimRejected LeiosForecastAfterGenesis + +prop_knownShortCircuits :: Property +prop_knownShortCircuits = + forAll genCommittee $ \tc -> + forAll genRbHash $ \rbHash -> + forAll genRbHash $ \otherHash -> + rbHash /= otherHash ==> + let vc = insertValidClaim (SlotNo 7) rbHash emptyValidClaims + -- Signed over the wrong claim, so it would not verify. + badCert = mkCert tc otherHash + in decideClaim + vc + (announcingAt (SlotNo 7) rbHash (Just (tc.committee, wholeCommittee))) + badCert + === ClaimAlreadyEstablished + +prop_noCommitteeRejected :: Property +prop_noCommitteeRejected = + forAll genCommittee $ \tc -> + forAll genRbHash $ \rbHash -> + decideClaim + emptyValidClaims + (announcingAt (SlotNo 7) rbHash Nothing) + (mkCert tc rbHash) + === ClaimRejected (LeiosForecastMissingCommittee rbHash) + +prop_wrongMessageRejected :: Property +prop_wrongMessageRejected = + forAll genCommittee $ \tc -> + forAll genRbHash $ \rbHash -> + forAll genRbHash $ \otherHash -> + rbHash /= otherHash ==> + case decideClaim + emptyValidClaims + (announcingAt (SlotNo 7) rbHash (Just (tc.committee, wholeCommittee))) + (mkCert tc otherHash) of + ClaimRejected (LeiosForecastInvalidCertificate h _) -> h === rbHash + verdict -> counterexample (show verdict) False + +prop_thresholdRejected :: Property +prop_thresholdRejected = + forAll genCommittee $ \tc -> + forAll genRbHash $ \rbHash -> + -- More weight than the whole committee can supply. + case decideClaim + emptyValidClaims + (announcingAt (SlotNo 7) rbHash (Just (tc.committee, 2 % 1))) + (mkCert tc rbHash) of + ClaimRejected (LeiosForecastInvalidCertificate h _) -> h === rbHash + verdict -> counterexample (show verdict) False + +prop_goodCertEstablishes :: Property +prop_goodCertEstablishes = + forAll genCommittee $ \tc -> + forAll genRbHash $ \rbHash -> + forAll (choose (0, 20)) $ \s -> + let point :: RealPoint TestBlock + point = RealPoint (SlotNo s) (TestHash (pure 0)) + in decideClaim + emptyValidClaims + (Announcing point rbHash (Just (tc.committee, wholeCommittee))) + (mkCert tc rbHash) + === ClaimEstablished point rbHash From c48865078d87c020d14c3453e98a7363ee1ec904 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 22 Sep 2026 12:39:48 -0400 Subject: [PATCH 21/60] ValidClaims: add unit tests, via new LeiosTestBlock It's like TestBlock, except it can carry Leios certs. The certs themselves aren't mocked, but the underlying committee selection is. The block also includes some non-trivial txs, even though _these_ tests don't yet need that. But the next feature I'm adding will. --- ...nick.frisby_leios_valid_claims_internal.md | 24 + ouroboros-consensus.cabal | 4 +- .../Consensus/Storage/ChainDB/Impl.hs | 1 + .../Consensus/Storage/ChainDB/Impl/Types.hs | 4 + .../Test/Util/LeiosTestBlock.hs | 930 ++++++++++++++++++ .../test/consensus-test/Main.hs | 2 + .../consensus-test/Test/LeiosValidClaims.hs | 2 +- .../Test/LeiosValidClaimsChainDB.hs | 403 ++++++++ 8 files changed, 1368 insertions(+), 2 deletions(-) create mode 100644 changelog.d/20260922_124500_nick.frisby_leios_valid_claims_internal.md create mode 100644 ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs create mode 100644 ouroboros-consensus/test/consensus-test/Test/LeiosValidClaimsChainDB.hs diff --git a/changelog.d/20260922_124500_nick.frisby_leios_valid_claims_internal.md b/changelog.d/20260922_124500_nick.frisby_leios_valid_claims_internal.md new file mode 100644 index 0000000000..d73c287073 --- /dev/null +++ b/changelog.d/20260922_124500_nick.frisby_leios_valid_claims_internal.md @@ -0,0 +1,24 @@ + + +### Breaking + +- The ChainDB's `Internal` record, which `Ouroboros.Consensus.Storage.ChainDB.Impl` exposes for testing, gained `intLeiosValidClaims`. It reads the set of Leios claims ChainSel has verified so far; nothing outside the ChainDB needed that until now, since ChainSel reads `cdbLeiosValidClaims` directly. + + + + diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 0cb0e449bc..a2f6047afe 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -529,6 +529,7 @@ library unstable-consensus-testlib Test.Util.InvertedMap Test.Util.LedgerStateOnlyTables Test.Util.LeiosHash + Test.Util.LeiosTestBlock Test.Util.LogicalClock Test.Util.MockChain Test.Util.Orphans.Arbitrary @@ -571,7 +572,7 @@ library unstable-consensus-testlib bytestring, cardano-binary:{cardano-binary, testlib}, cardano-crypto-class, - cardano-ledger-binary:testlib, + cardano-ledger-binary:{cardano-ledger-binary, testlib}, cardano-ledger-core, cardano-prelude, cardano-slotting, @@ -776,6 +777,7 @@ test-suite consensus-test Test.LeiosUtils.CallTrace Test.LeiosUtils.TimeBoundedLoop Test.LeiosValidClaims + Test.LeiosValidClaimsChainDB Test.LeiosVoteState Test.LeiosVoting diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index 25134c234f..5932e1af78 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -352,6 +352,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do maxBound , intAddBlockRunner = getEnv h (Background.addBlockRunner addBlockTestFuse) , intKillBgThreads = varKillBgThreads + , intLeiosValidClaims = getEnvSTM h (readTVar . cdbLeiosValidClaims) } traceWith tracer $ diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index c532b285ee..6a89a3bc17 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -473,6 +473,10 @@ data Internal m blk = Internal -- thread. , intKillBgThreads :: StrictTVar m (m ()) -- ^ A handle to kill the background threads. + , intLeiosValidClaims :: STM m ValidClaims + -- ^ Merely reads 'cdbLeiosValidClaims'; /so far/, tests are the only code + -- /outside/ of the ChainDB that needs to do that (recall that ChainSel is + -- inside the ChainDB). } {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs new file mode 100644 index 0000000000..72eea2e6fd --- /dev/null +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs @@ -0,0 +1,930 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | A test block that carries Leios announcements and certificates. +-- +-- Its protocol enforces no leader schedule, so a test is free to mint any +-- interesting chain shape. On the other hand, the txs and certificates it +-- carries are real. Its ledger view seats a committee that varies by epoch +-- (according to the test's by fiat updates) and is forecastable only within a +-- configured range (just like the Cardano ledger/protocol), so a forecast taken +-- at the wrong slot yields the wrong committee instead of passing unnoticed. +-- +-- No chain may exceed 'maxLeiosTestChainLength' blocks, since the block hash is +-- a path from genesis and must fit a fixed size. +-- +-- A header can be made to disagree with its body, by setting its body hash or +-- its certificate bit by hand. 'blockMatchesHeader' then rejects the pairing, +-- exactly as the Shelley envelope check does. +module Test.Util.LeiosTestBlock + ( -- * Block + ContainsCert (..) + , Header + ( LeiosTestHeader + , lthAnnouncement + , lthBodyHash + , lthContainsCert + , lthHash + , lthIssuer + , lthSlot + , lthValidity + ) + , LeiosTestBlock (..) + , LeiosTestBody (..) + , LeiosTestTx (..) + , LeiosTestTxError (..) + , applyLeiosTestTx + , containsCertOf + , hashLeiosTestBody + , maxLeiosTestChainLength + + -- * Building chains + , announcing + , certifying + , firstLeiosBlock + , forkLeiosBlock + , invalidate + , issuedBy + , setBody + , successorLeiosBlock + , withTxs + + -- * Ledger + , LedgerState (LeiosTestLedger, ltlsCommittee, ltlsState, ltlsTip) + , LeiosTestBlockError (..) + , LeiosTestLedgerConfig (..) + , Ticked (TickedLeiosTestLedger) + , leiosTestInitExtLedger + , leiosTestInitLedger + , leiosTestLedgerConfig + + -- * Protocol + , LeiosTestProtocol + , LeiosTestView (..) + + -- * Node configuration + , singleNodeLeiosTestConfig + ) where + +import Cardano.Binary (DecoderError, decodeMaybe, encodeMaybe, enforceSize) +import Cardano.Ledger.Binary (decodeFull', serialize', shelleyProtVer) +import Cardano.Slotting.EpochInfo (epochInfoEpoch, fixedEpochInfo) +import Codec.CBOR.Decoding (Decoder) +import qualified Codec.CBOR.Decoding as CBOR +import Codec.CBOR.Encoding (Encoding) +import qualified Codec.CBOR.Encoding as CBOR +import Codec.Serialise (Serialise (..), serialise) +import Control.Monad (foldM, guard, replicateM, replicateM_) +import Control.Monad.Except (throwError) +import Data.String (fromString) +import qualified Data.Binary.Get as Get +import qualified Data.Binary.Put as Put +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Short as SBS +import Data.Foldable (for_) +import Data.Functor.Identity (runIdentity) +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Proxy +import Data.Ratio (denominator, numerator, (%)) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..)) +import Data.Void (Void) +import Data.Word (Word64) +import GHC.Generics (Generic) +import LeiosDemoLogic.Announcements.ElBimap (ElId (MkElId)) +import LeiosDemoTypes + ( BytesSize + , HasLeiosVoting (..) + , LeiosCert + , LeiosCommittee + , LeiosPoint (..) + , RbHash (MkRbHash) + , Weight + , decodeEbHash + , encodeEbHash + ) +import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime +import Ouroboros.Consensus.Config +import Ouroboros.Consensus.Config.SupportsNode +import Ouroboros.Consensus.Forecast +import Ouroboros.Consensus.HardFork.Abstract +import Ouroboros.Consensus.HardFork.Combinator.Abstract + ( ImmutableEraParams (immutableEraParams) + ) +import qualified Ouroboros.Consensus.HardFork.History as HardFork +import Ouroboros.Consensus.HeaderValidation +import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ledger.Inspect +import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) +import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Ledger.Tables.Utils +import Ouroboros.Consensus.Node.NetworkProtocolVersion +import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Storage.ChainDB (SerialiseDiskConstraints) +import Ouroboros.Consensus.Storage.LedgerDB +import Ouroboros.Consensus.Storage.Serialisation +import Ouroboros.Consensus.Util (ShowProxy (..)) +import Ouroboros.Consensus.Util.Condense +import Ouroboros.Consensus.Util.IndexedMemPack +import Ouroboros.Consensus.Util.Orphans () +import Ouroboros.Network.Magic (NetworkMagic (..)) +import Test.Util.Orphans.ToExpr () +import Test.Util.TestBlock (TestHash (..), Validity (..), unTestHash) + +{------------------------------------------------------------------------------- + Block +-------------------------------------------------------------------------------} + +-- | Whether the header claims the body carries a Leios certificate. +-- +-- The builders keep this in step with the body; setting it by hand is how a +-- test produces a header that 'blockMatchesHeader' will reject. +data ContainsCert = ContainsCert | DoesNotContainCert + deriving stock (Eq, Show, Generic) + deriving anyclass (Serialise, NoThunks) + +-- | What a truthful header would say about this body. +containsCertOf :: LeiosTestBody -> ContainsCert +containsCertOf body = case ltbCert body of + Nothing -> DoesNotContainCert + Just _ -> ContainsCert + +data LeiosTestBody = LeiosTestBody + { ltbCert :: !(Maybe LeiosCert) + , ltbTxs :: ![LeiosTestTx] + -- ^ Applied in order. A CertRB's own body is empty; its transactions live + -- in the endorser block its certificate attests to. + } + deriving stock (Eq, Show, Generic) + deriving anyclass NoThunks + +-- | A transaction: assertions about the ledger state, then writes to it. +-- +-- An assertion of 'Nothing' requires the key to be absent, and of @'Just' c@ +-- requires it to hold @c@. The writes must be non-empty, and each must either +-- introduce a key or /raise/ the value it holds. So a transaction that applies +-- changes the state, and --- because the change is monotone --- no series of +-- them can restore an earlier state. That mirrors the Cardano ledger, where a +-- consumed UTxO can never reappear, since its key commits to the transaction +-- that created it. +data LeiosTestTx = LeiosTestTx + { ltxAsserts :: !(IntMap (Maybe Char)) + , ltxWrites :: !(IntMap Char) + } + deriving stock (Eq, Show, Generic) + deriving anyclass (Serialise, NoThunks) + +data LeiosTestTxError + = -- | The key, what was asserted, and what was there. + AssertionViolated !Int !(Maybe Char) !(Maybe Char) + | WritesNothing + | -- | The key, the value it holds, and the value written, which does not + -- exceed it. + NonAscendingWrite !Int !Char !Char + deriving stock (Eq, Show, Generic) + deriving anyclass NoThunks + +applyLeiosTestTx :: + LeiosTestTx -> IntMap Char -> Either LeiosTestTxError (IntMap Char) +applyLeiosTestTx LeiosTestTx{ltxAsserts, ltxWrites} st + | (key, expected) : _ <- violations = + Left $ AssertionViolated key expected (IntMap.lookup key st) + | IntMap.null ltxWrites = Left WritesNothing + | (key, old, new) : _ <- nonAscending = Left $ NonAscendingWrite key old new + | otherwise = Right $ IntMap.union ltxWrites st + where + violations = + [ (key, expected) + | (key, expected) <- IntMap.toList ltxAsserts + , IntMap.lookup key st /= expected + ] + nonAscending = + [ (key, old, new) + | (key, new) <- IntMap.toList ltxWrites + , Just old <- [IntMap.lookup key st] + , old >= new + ] + +-- | A test block with some interesting Leios shapes +-- +-- See the LIMIT on 'Header' 'LeiosTestBlock' for the most surprising +-- limitation. +data LeiosTestBlock = LeiosTestBlock + { ltbHeader :: !(Header LeiosTestBlock) + , ltbBody :: !LeiosTestBody + } + deriving stock (Eq, Show, Generic) + deriving anyclass NoThunks + +-- | The hash is a path through the tree of forks, exactly as +-- 'Test.Util.TestBlock.TestHash': it is an identity assigned by the test rather +-- than a digest of the contents, which is what lets a header disagree with its +-- body. +-- +-- LIMIT: no chain may exceed 'maxLeiosTestChainLength' blocks. The path is as +-- long as the chain, and 'ConvertRawHash' requires a fixed-size hash, so +-- 'toRawHash' throws beyond that. +data instance Header LeiosTestBlock = LeiosTestHeader + { lthHash :: !TestHash + , lthSlot :: !SlotNo + , lthIssuer :: !Word64 + -- ^ Stands in for the block issuer, so that 'headerElId' is a real election + -- identity rather than a stub. + , lthAnnouncement :: !(Maybe (LeiosPoint, BytesSize)) + , lthBodyHash :: !Word64 + -- ^ What binds this header to a body; see 'blockMatchesHeader'. + , lthContainsCert :: !ContainsCert + , lthValidity :: !Validity + } + deriving stock (Eq, Show, Generic) + deriving anyclass NoThunks + +-- | Enough of a digest for a test: the header must not be free to accept any +-- body. +hashLeiosTestBody :: LeiosTestBody -> Word64 +hashLeiosTestBody = BL.foldl' step 5381 . serialise + where + step acc w = acc * 33 + fromIntegral w + +type instance HeaderHash LeiosTestBlock = TestHash + +instance StandardHash LeiosTestBlock + +instance ShowProxy LeiosTestBlock +instance ShowProxy (Header LeiosTestBlock) + +instance HasHeader (Header LeiosTestBlock) where + getHeaderFields hdr = + HeaderFields + { headerFieldHash = lthHash hdr + , headerFieldSlot = lthSlot hdr + , -- One less than the path length, so the first block after genesis is + -- 'BlockNo' 0, as 'expectedFirstBlockNo' defaults to. + headerFieldBlockNo = + fromIntegral . subtract 1 . NE.length . unTestHash $ lthHash hdr + } + +instance HasHeader LeiosTestBlock where + getHeaderFields = getBlockHeaderFields + +instance GetHeader LeiosTestBlock where + getHeader = ltbHeader + + -- The same envelope the Shelley header checks: the header commits to the + -- body, its cheap cert bit agrees with what the body carries, and a CertRB + -- carries a certificate instead of transactions. + blockMatchesHeader hdr blk = + lthBodyHash hdr == hashLeiosTestBody body + && lthContainsCert hdr == containsCertOf body + && not (bodyHasCert && bodyHasTxs) + where + body = ltbBody blk + bodyHasCert = case containsCertOf body of + ContainsCert -> True + DoesNotContainCert -> False + bodyHasTxs = not $ null $ ltbTxs body + + headerIsEBB = const Nothing + +instance GetPrevHash LeiosTestBlock where + headerPrevHash hdr = + case NE.nonEmpty . NE.tail . unTestHash . lthHash $ hdr of + Nothing -> GenesisHash + Just prevHash -> BlockHash (TestHash prevHash) + +instance Condense LeiosTestBlock where + condense blk = + mconcat + [ "(H:" + , condense (blockHash blk) + , ",S:" + , condense (blockSlot blk) + , ",B:" + , condense (unBlockNo (blockNo blk)) + , case ltbCert (ltbBody blk) of + Nothing -> "" + Just _ -> ",cert" + , ")" + ] + +instance Condense (Header LeiosTestBlock) where + condense = condense . flip LeiosTestBlock (LeiosTestBody Nothing []) + +{------------------------------------------------------------------------------- + Building chains +-------------------------------------------------------------------------------} + +-- | The first block of the given fork, in slot 1. +firstLeiosBlock :: Word64 -> LeiosTestBlock +firstLeiosBlock forkNo = mkLeiosTestBlock (TestHash (forkNo :| [])) 1 + +-- | The successor of the given block: @b -> b ++ [0]@, one slot later. +successorLeiosBlock :: LeiosTestBlock -> LeiosTestBlock +successorLeiosBlock blk = + mkLeiosTestBlock + (TestHash (NE.cons 0 (unTestHash (blockHash blk)))) + (succ (blockSlot blk)) + +-- | A sibling of the given block: same slot and same predecessor, different +-- hash. This is how a test equivocates. +forkLeiosBlock :: LeiosTestBlock -> LeiosTestBlock +forkLeiosBlock blk = + blk + { ltbHeader = hdr{lthHash = TestHash (succ f :| h)} + } + where + hdr = ltbHeader blk + TestHash (f :| h) = lthHash hdr + +mkLeiosTestBlock :: TestHash -> SlotNo -> LeiosTestBlock +mkLeiosTestBlock hash slot = + LeiosTestBlock + { ltbHeader = + LeiosTestHeader + { lthHash = hash + , lthSlot = slot + , lthIssuer = 0 + , lthAnnouncement = Nothing + , lthBodyHash = hashLeiosTestBody body + , lthContainsCert = containsCertOf body + , lthValidity = Valid + } + , ltbBody = body + } + where + body = LeiosTestBody Nothing [] + +-- | Replace the body, keeping the header truthful about it. A test that wants +-- a header that lies sets the header's fields itself. +setBody :: LeiosTestBody -> LeiosTestBlock -> LeiosTestBlock +setBody body blk = + blk + { ltbHeader = + (ltbHeader blk) + { lthBodyHash = hashLeiosTestBody body + , lthContainsCert = containsCertOf body + } + , ltbBody = body + } + +-- | Announce an endorser block on this block's header. +announcing :: LeiosPoint -> BytesSize -> LeiosTestBlock -> LeiosTestBlock +announcing point size blk = + blk{ltbHeader = (ltbHeader blk){lthAnnouncement = Just (point, size)}} + +-- | Carry this certificate, and say so in the header. +certifying :: LeiosCert -> LeiosTestBlock -> LeiosTestBlock +certifying cert blk = setBody (ltbBody blk){ltbCert = Just cert} blk + +-- | Carry these transactions. +withTxs :: [LeiosTestTx] -> LeiosTestBlock -> LeiosTestBlock +withTxs txs blk = setBody (ltbBody blk){ltbTxs = txs} blk + +issuedBy :: Word64 -> LeiosTestBlock -> LeiosTestBlock +issuedBy issuer blk = blk{ltbHeader = (ltbHeader blk){lthIssuer = issuer}} + +-- | Make the ledger reject this block. +invalidate :: LeiosTestBlock -> LeiosTestBlock +invalidate blk = blk{ltbHeader = (ltbHeader blk){lthValidity = Invalid}} + +{------------------------------------------------------------------------------- + Leios +-------------------------------------------------------------------------------} + +instance ResolveLeiosBlock LeiosTestBlock where + blockLeiosCert = ltbCert . ltbBody + + announcingRbHash blk = case blockPrevHash blk of + GenesisHash -> Nothing + BlockHash h -> Just $ MkRbHash $ toRawHash (Proxy @LeiosTestBlock) h + + headerContainsLeiosCert hdr = case lthContainsCert hdr of + ContainsCert -> True + DoesNotContainCert -> False + + headerLeiosAnnouncement = lthAnnouncement + + headerElId hdr = + MkElId (lthSlot hdr) (SBS.pack [fromIntegral (lthIssuer hdr)]) + +-- | The committee lives in the ledger view, which the forecast computes from +-- the ledger config; the ledger /state/ carries none, so the voting-path +-- methods have nothing to offer. The harness does not vote. +instance HasLeiosVoting LeiosTestBlock where + getLeiosCommittee = fmap fst . ltlsCommittee + getCurrentThreshold = fmap snd . ltlsCommittee + getMinCertificationGap _ _ = Nothing + getLeiosCommitteeFromView _ = ltvCommittee + +{------------------------------------------------------------------------------- + Protocol +-------------------------------------------------------------------------------} + +-- | No leader schedule, no header crypto, no chain-dependent state: the only +-- thing this protocol contributes is the ledger view. +data LeiosTestProtocol + +-- | What Leios needs of the ledger view, and nothing else. +newtype LeiosTestView = LeiosTestView + { ltvCommittee :: Maybe (LeiosCommittee, Weight) + } + deriving stock Generic + deriving anyclass NoThunks + +instance Show LeiosTestView where + show (LeiosTestView mbCommittee) = case mbCommittee of + Nothing -> "LeiosTestView{no committee}" + Just (_committee, threshold) -> + -- The committee's own 'Show' would dwarf every counterexample it appears in. + "LeiosTestView{committee = , threshold = " <> show threshold <> "}" + +data instance ConsensusConfig LeiosTestProtocol = LeiosTestProtocolConfig + { ltpcSecurityParam :: !SecurityParam + } + deriving stock Generic + deriving anyclass NoThunks + +instance ConsensusProtocol LeiosTestProtocol where + type ChainDepState LeiosTestProtocol = () + type IsLeader LeiosTestProtocol = () + type CanBeLeader LeiosTestProtocol = () + type LedgerView LeiosTestProtocol = LeiosTestView + type ValidationErr LeiosTestProtocol = Void + type ValidateView LeiosTestProtocol = () + + protocolSecurityParam = ltpcSecurityParam + + -- Every node leads in every slot; the test itself decides what actually gets + -- minted. + checkIsLeader _ _ _ _ = Just () + + tickChainDepState _ _ _ _ = TickedTrivial + updateChainDepState _ _ _ _ = pure () + reupdateChainDepState _ _ _ _ = () + +type instance BlockProtocol LeiosTestBlock = LeiosTestProtocol + +instance BlockSupportsProtocol LeiosTestBlock where + validateView _ _ = () + +{------------------------------------------------------------------------------- + Ledger +-------------------------------------------------------------------------------} + +data instance LedgerState LeiosTestBlock mk = LeiosTestLedger + { ltlsTip :: !(Point LeiosTestBlock) + , ltlsState :: !(IntMap Char) + , ltlsCommittee :: !(Maybe (LeiosCommittee, Weight)) + -- ^ The committee seated for this state's slot. + -- + -- Transactions never affect it; it is merely a cache of the oracle that + -- 'ltlcCommittees' is. Keeping it here is what keeps 'getLeiosCommittee' in + -- agreement with 'getLeiosCommitteeFromView': both are that oracle applied + -- to the same slot. + } + deriving stock (Eq, Show, Generic) + deriving anyclass NoThunks + +newtype instance Ticked (LedgerState LeiosTestBlock) mk = TickedLeiosTestLedger + { getTickedLeiosTestLedger :: LedgerState LeiosTestBlock mk + } + deriving stock Generic + deriving anyclass NoThunks + +data LeiosTestBlockError + = -- | The block does not fit onto the ledger's tip. + LeiosTestInvalidHash + (ChainHash LeiosTestBlock) + (ChainHash LeiosTestBlock) + | -- | The block is marked invalid; see 'invalidate'. + LeiosTestInvalidBlock + | -- | One of the block's transactions does not apply. + LeiosTestInvalidTx !LeiosTestTxError + deriving stock (Eq, Show, Generic) + deriving anyclass NoThunks + +-- | The committee schedule is a function of the epoch, so a test can put a +-- committee change wherever it likes, and the forecast range is finite, so a +-- test can reach 'OutsideForecastRange' on demand. +data LeiosTestLedgerConfig = LeiosTestLedgerConfig + { ltlcHardForkParams :: !HardFork.EraParams + , ltlcForecastRange :: !SlotNo + , ltlcCommittees :: EpochNo -> Maybe (LeiosCommittee, Weight) + } + deriving NoThunks via OnlyCheckWhnfNamed "LeiosTestLedgerConfig" LeiosTestLedgerConfig + +instance Show LeiosTestLedgerConfig where + show LeiosTestLedgerConfig{ltlcHardForkParams, ltlcForecastRange} = + "LeiosTestLedgerConfig " + <> show ltlcHardForkParams + <> " " + <> show ltlcForecastRange + <> " " + +leiosTestLedgerConfig :: + HardFork.EraParams -> + SlotNo -> + (EpochNo -> Maybe (LeiosCommittee, Weight)) -> + LeiosTestLedgerConfig +leiosTestLedgerConfig = LeiosTestLedgerConfig + +type instance LedgerCfg (LedgerState LeiosTestBlock) = LeiosTestLedgerConfig + +-- | The genesis ledger, seeded with the given state so that a test's first tx +-- can have non-trivial assertions. +leiosTestInitLedger :: + LeiosTestLedgerConfig -> IntMap Char -> LedgerState LeiosTestBlock ValuesMK +leiosTestInitLedger cfg st = LeiosTestLedger GenesisPoint st (committeeAt cfg 0) + +leiosTestInitExtLedger :: + LeiosTestLedgerConfig -> IntMap Char -> ExtLedgerState LeiosTestBlock ValuesMK +leiosTestInitExtLedger cfg st = + ExtLedgerState + { ledgerState = leiosTestInitLedger cfg st + , headerState = genesisHeaderState () + } + +-- | No UTxO HD for this block, at least not yet +type instance TxIn (LedgerState LeiosTestBlock) = Void + +-- | No UTxO HD for this block, at least not yet +type instance TxOut (LedgerState LeiosTestBlock) = Void + +instance LedgerTablesAreTrivial (LedgerState LeiosTestBlock) where + convertMapKind (LeiosTestLedger tip st c) = LeiosTestLedger tip st c + +instance LedgerTablesAreTrivial (Ticked (LedgerState LeiosTestBlock)) where + convertMapKind (TickedLeiosTestLedger x) = + TickedLeiosTestLedger $ convertMapKind x + +deriving via + TrivialLedgerTables (LedgerState LeiosTestBlock) + instance + HasLedgerTables (LedgerState LeiosTestBlock) +deriving via + TrivialLedgerTables (LedgerState LeiosTestBlock) + instance + HasLedgerTables (Ticked (LedgerState LeiosTestBlock)) +deriving via + TrivialLedgerTables (LedgerState LeiosTestBlock) + instance + CanStowLedgerTables (LedgerState LeiosTestBlock) +deriving via + TrivialLedgerTables (LedgerState LeiosTestBlock) + instance + CanUpgradeLedgerTables (LedgerState LeiosTestBlock) +deriving via + TrivialLedgerTables (LedgerState LeiosTestBlock) + instance + SerializeTablesWithHint (LedgerState LeiosTestBlock) +deriving via + Void + instance + IndexedMemPack (LedgerState LeiosTestBlock EmptyMK) Void + +instance GetTip (LedgerState LeiosTestBlock) where + getTip = castPoint . ltlsTip + +instance GetTip (Ticked (LedgerState LeiosTestBlock)) where + getTip = castPoint . ltlsTip . getTickedLeiosTestLedger + +instance IsLedger (LedgerState LeiosTestBlock) where + type LedgerErr (LedgerState LeiosTestBlock) = LeiosTestBlockError + + type + AuxLedgerEvent (LedgerState LeiosTestBlock) = + VoidLedgerEvent (LedgerState LeiosTestBlock) + + applyChainTickLedgerResult _events cfg slot st = + pureLedgerResult $ + TickedLeiosTestLedger + (noNewTickingDiffs st){ltlsCommittee = committeeAt cfg slot} + +instance ApplyBlock (LedgerState LeiosTestBlock) LeiosTestBlock where + applyBlockLedgerResultWithValidation + _validation + _events + cfg + blk + (TickedLeiosTestLedger LeiosTestLedger{ltlsTip, ltlsState}) + | blockPrevHash blk /= pointHash ltlsTip = + throwError $ LeiosTestInvalidHash (pointHash ltlsTip) (blockPrevHash blk) + | Invalid <- lthValidity (ltbHeader blk) = + throwError LeiosTestInvalidBlock + | otherwise = case foldM (flip applyLeiosTestTx) ltlsState txs of + Left err -> throwError $ LeiosTestInvalidTx err + Right st -> + pure + $ pureLedgerResult + . trackingToDiffs + $ LeiosTestLedger (blockPoint blk) st (committeeAt cfg (blockSlot blk)) + where + txs = ltbTxs (ltbBody blk) + + applyBlockLedgerResult = defaultApplyBlockLedgerResult + reapplyBlockLedgerResult = + defaultReapplyBlockLedgerResult + (error . ("reapplying a block failed: " ++) . show) + + getBlockKeySets = const trivialLedgerTables + +instance UpdateLedger LeiosTestBlock + +instance InspectLedger LeiosTestBlock + +instance HasAnnTip LeiosTestBlock + +instance BasicEnvelopeValidation LeiosTestBlock + +instance ValidateEnvelope LeiosTestBlock + +instance LedgerSupportsPeras LeiosTestBlock + +instance LedgerSupportsProtocol LeiosTestBlock where + protocolLedgerView _cfg = + LeiosTestView . ltlsCommittee . getTickedLeiosTestLedger + + ledgerViewForecastAt cfg st = + Forecast + { forecastAt = at + , forecastFor = \for -> + let maxFor = succWithOrigin at + ltlcForecastRange cfg + in if for >= maxFor + then + throwError + OutsideForecastRange + { outsideForecastAt = at + , outsideForecastMaxFor = maxFor + , outsideForecastFor = for + } + else pure $ viewAt cfg for + } + where + at = getTipSlot st + +-- | The committee the schedule seats for the epoch that contains this slot. +viewAt :: LeiosTestLedgerConfig -> SlotNo -> LeiosTestView +viewAt cfg = LeiosTestView . committeeAt cfg + +committeeAt :: LeiosTestLedgerConfig -> SlotNo -> Maybe (LeiosCommittee, Weight) +committeeAt cfg slot = ltlcCommittees cfg epoch + where + epoch = + runIdentity $ + epochInfoEpoch + ( fixedEpochInfo + (HardFork.eraEpochSize (ltlcHardForkParams cfg)) + (HardFork.eraSlotLength (ltlcHardForkParams cfg)) + ) + slot + +instance HasHardForkHistory LeiosTestBlock where + type HardForkIndices LeiosTestBlock = '[LeiosTestBlock] + hardForkSummary = neverForksHardForkSummary ltlcHardForkParams + +instance ImmutableEraParams LeiosTestBlock where + immutableEraParams = ltlcHardForkParams . topLevelConfigLedger + +{------------------------------------------------------------------------------- + Configuration +-------------------------------------------------------------------------------} + +data instance BlockConfig LeiosTestBlock = LeiosTestBlockConfig + deriving stock (Show, Generic) + deriving anyclass NoThunks + +data instance CodecConfig LeiosTestBlock = LeiosTestCodecConfig + deriving stock (Show, Generic) + deriving anyclass NoThunks + +data instance StorageConfig LeiosTestBlock = LeiosTestStorageConfig + deriving stock (Show, Generic) + deriving anyclass NoThunks + +instance HasNetworkProtocolVersion LeiosTestBlock + +instance ConfigSupportsNode LeiosTestBlock where + getSystemStart = const (SystemStart dummyDate) + where + dummyDate = UTCTime (fromGregorian 2019 8 13) 0 + + getNetworkMagic = const (NetworkMagic 42) + +singleNodeLeiosTestConfig :: + LeiosTestLedgerConfig -> + SecurityParam -> + TopLevelConfig LeiosTestBlock +singleNodeLeiosTestConfig ledgerConfig k = + TopLevelConfig + { topLevelConfigProtocol = LeiosTestProtocolConfig k + , topLevelConfigLedger = ledgerConfig + , topLevelConfigBlock = LeiosTestBlockConfig + , topLevelConfigCodec = LeiosTestCodecConfig + , topLevelConfigStorage = LeiosTestStorageConfig + , topLevelConfigCheckpoints = emptyCheckpointsMap + , topLevelConfigVotingKeys = [] + } + +{------------------------------------------------------------------------------- + NestedCtxt +-------------------------------------------------------------------------------} + +data instance NestedCtxt_ LeiosTestBlock f a where + CtxtLeiosTestBlock :: NestedCtxt_ LeiosTestBlock f (f LeiosTestBlock) + +deriving instance Show (NestedCtxt_ LeiosTestBlock f a) + +instance TrivialDependency (NestedCtxt_ LeiosTestBlock f) where + type TrivialIndex (NestedCtxt_ LeiosTestBlock f) = f LeiosTestBlock + hasSingleIndex CtxtLeiosTestBlock CtxtLeiosTestBlock = Refl + indexIsTrivial = CtxtLeiosTestBlock + +instance SameDepIndex (NestedCtxt_ LeiosTestBlock f) +instance HasNestedContent f LeiosTestBlock + +{------------------------------------------------------------------------------- + Serialisation +-------------------------------------------------------------------------------} + +-- | The header is encoded first and unwrapped, so that 'getBinaryBlockInfo' can +-- name its bytes exactly. +instance Serialise LeiosTestBlock where + encode (LeiosTestBlock hdr body) = encode hdr <> encode body + decode = LeiosTestBlock <$> decode <*> decode + +instance Serialise (Header LeiosTestBlock) where + encode LeiosTestHeader{..} = + encode lthHash + <> encode lthSlot + <> encode lthIssuer + <> encodeMaybe encodeLeiosPointAndSize lthAnnouncement + <> encode lthBodyHash + <> encode lthContainsCert + <> encode lthValidity + decode = do + lthHash <- decode + lthSlot <- decode + lthIssuer <- decode + mbAnnouncement <- decodeMaybe decodeLeiosPointAndSize + lthBodyHash <- decode + lthContainsCert <- decode + lthValidity <- decode + pure + LeiosTestHeader + { lthHash + , lthSlot + , lthIssuer + , lthAnnouncement = mbAnnouncement + , lthBodyHash + , lthContainsCert + , lthValidity + } + +-- | What a header announces: the endorser block's slot and hash, and the size +-- it claims for the body, as one flat list. +-- +-- 'EbHash' deliberately has no 'Serialise' instance --- the fixed-size codec is +-- a hash's only path --- so the hash goes through the codec 'LeiosDemoTypes' +-- exports. +encodeLeiosPointAndSize :: (LeiosPoint, BytesSize) -> Encoding +encodeLeiosPointAndSize (MkLeiosPoint ebSlot ebHash, size) = + CBOR.encodeListLen 3 + <> encode ebSlot + <> encodeEbHash ebHash + <> encode size + +decodeLeiosPointAndSize :: Decoder s (LeiosPoint, BytesSize) +decodeLeiosPointAndSize = do + enforceSize (fromString "LeiosPointAndSize") 3 + ebSlot <- decode + ebHash <- decodeEbHash + size <- decode + pure (MkLeiosPoint ebSlot ebHash, size) + +-- | The certificate rides on the ledger's own encoding, which is the one real +-- nodes use. +instance Serialise LeiosTestBody where + encode (LeiosTestBody mbCert txs) = + encode (serialize' shelleyProtVer <$> mbCert) <> encode txs + decode = do + mbBytes <- decode + LeiosTestBody <$> traverse dec mbBytes <*> decode + where + dec bytes = case decodeFull' shelleyProtVer bytes of + Right cert -> pure cert + Left err -> fail $ "LeiosTestBody: " <> show err + +instance HasBinaryBlockInfo LeiosTestBlock where + getBinaryBlockInfo blk = + BinaryBlockInfo + { headerOffset = 0 + , headerSize = fromIntegral . BL.length . serialise . ltbHeader $ blk + } + +-- | The cap this block's hash imposes on chain length; see the LIMIT on +-- 'Header' 'LeiosTestBlock'. +maxLeiosTestChainLength :: Int +maxLeiosTestChainLength = 100 + +instance ConvertRawHash LeiosTestBlock where + -- The length, and one 'Word64' per path component. + hashSize _ = 8 * fromIntegral (1 + maxLeiosTestChainLength) + toRawHash _ (TestHash h) + | len > maxLeiosTestChainLength = + error $ + "LeiosTestBlock: chain longer than " + <> show maxLeiosTestChainLength + <> " blocks" + | otherwise = BL.toStrict . Put.runPut $ do + Put.putWord64le (fromIntegral len) + for_ h Put.putWord64le + replicateM_ (maxLeiosTestChainLength - len) $ Put.putWord64le 0 + where + len = length h + fromRawHash _ bs = flip Get.runGet (BL.fromStrict bs) $ do + len <- fromIntegral <$> Get.getWord64le + (NE.nonEmpty -> Just h, rs) <- + splitAt len <$> replicateM maxLeiosTestChainLength Get.getWord64le + guard $ all (0 ==) rs + pure $ TestHash h + +instance Serialise (AnnTip LeiosTestBlock) where + encode = defaultEncodeAnnTip encode + decode = defaultDecodeAnnTip decode + +instance Serialise (ExtLedgerState LeiosTestBlock EmptyMK) where + encode = encodeExtLedgerState encode encode encode + decode = decodeExtLedgerState decode decode decode + +instance Serialise (RealPoint LeiosTestBlock) where + encode = encodeRealPoint encode + decode = decodeRealPoint decode + +instance EncodeDisk LeiosTestBlock LeiosTestBlock +instance DecodeDisk LeiosTestBlock (BL.ByteString -> Either DecoderError LeiosTestBlock) where + decodeDisk _ = const . Right <$> decode + +instance EncodeDisk LeiosTestBlock (Header LeiosTestBlock) +instance DecodeDisk LeiosTestBlock (BL.ByteString -> Header LeiosTestBlock) where + decodeDisk _ = const <$> decode + +instance EncodeDisk LeiosTestBlock (AnnTip LeiosTestBlock) +instance DecodeDisk LeiosTestBlock (AnnTip LeiosTestBlock) + +instance ReconstructNestedCtxt Header LeiosTestBlock + +-- | The committee rides on the ledger's own encoding, as the certificate does. +instance Serialise (LedgerState LeiosTestBlock EmptyMK) where + encode (LeiosTestLedger tip st mbCommittee) = + encode tip <> encode st <> encode (flatten <$> mbCommittee) + where + flatten (committee, weight) = + ( serialize' shelleyProtVer committee + , numerator weight + , denominator weight + ) + decode = do + tip <- decode + st <- decode + mbFlat <- decode + LeiosTestLedger tip st <$> traverse unflatten mbFlat + where + unflatten (bytes, num, den) = case decodeFull' shelleyProtVer bytes of + Right committee -> pure (committee, num % den) + Left err -> fail $ "LeiosTestLedger: " <> show err + +instance EncodeDisk LeiosTestBlock (LedgerState LeiosTestBlock EmptyMK) +instance DecodeDisk LeiosTestBlock (LedgerState LeiosTestBlock EmptyMK) + +instance EncodeDiskDep (NestedCtxt Header) LeiosTestBlock +instance DecodeDiskDep (NestedCtxt Header) LeiosTestBlock + +-- at least because ChainDepState LeiosTestProtocol ~ () +instance EncodeDisk LeiosTestBlock () +instance DecodeDisk LeiosTestBlock () + +instance SerialiseDiskConstraints LeiosTestBlock + +deriving via + SelectViewDiffusionPipelining LeiosTestBlock + instance + BlockSupportsDiffusionPipelining LeiosTestBlock diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index 27b483992a..947c69a82d 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -34,6 +34,7 @@ import qualified Test.LeiosTxCache.Reference (tests) import qualified Test.LeiosUtils.CallTrace (tests) import qualified Test.LeiosUtils.TimeBoundedLoop (tests) import qualified Test.LeiosValidClaims (tests) +import qualified Test.LeiosValidClaimsChainDB (tests) import qualified Test.LeiosVoteState (tests) import qualified Test.LeiosVoting (tests) import Test.Tasty @@ -96,6 +97,7 @@ tests = , Test.LeiosTxCache.Optimized.MutableHashTable.tests , Test.LeiosTxCache.Reference.tests , Test.LeiosValidClaims.tests + , Test.LeiosValidClaimsChainDB.tests , Test.LeiosVoteState.tests , Test.LeiosVoting.tests , Test.LeiosUtils.CallTrace.tests diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosValidClaims.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosValidClaims.hs index 7a101cf00d..cc651cb33c 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosValidClaims.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosValidClaims.hs @@ -6,7 +6,7 @@ -- | Tests for 'LeiosValidClaims': the claim cache and the verdict ChainSel -- reaches about a CertRB's certificate. -module Test.LeiosValidClaims (tests) where +module Test.LeiosValidClaims (mkCert, tests, wholeCommittee) where import Cardano.Crypto.DSIGN (signDSIGN) import qualified Data.Map.Strict as Map diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosValidClaimsChainDB.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosValidClaimsChainDB.hs new file mode 100644 index 0000000000..b620058b41 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosValidClaimsChainDB.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | ValidClaims as ChainSel drives it, against a real ChainDB over a mocked +-- filesystem. +-- +-- The blocks are 'LeiosTestBlock's, so the certificates are real but the chains +-- are whatever the test says they are. +-- +-- Each CertRB is judged against the ledger view the test passes to +-- 'ChainDB.addBlock'. In a node that value is not supplied but derived: +-- BlockFetch reads it off the matched header ('matchedBlockPredecessor'). +-- These tests take it as given, so they cover what ChainSel does with the +-- view, not whether the view ChainSel is handed is the right one. +module Test.LeiosValidClaimsChainDB (tests) where + +import Cardano.Ledger.BaseTypes (knownNonZeroBounded) +import Control.Monad.IOSim (IOSim, runSimOrThrow) +import Control.ResourceRegistry (forkLinkedThread, withRegistry) +import Control.Tracer (nullTracer) +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.IntMap.Strict as IntMap +import Data.Maybe (isJust) +import qualified LeiosDemoDb as LeiosDb +import LeiosDemoTypes + ( EbHash + , LeiosPoint (..) + , RbHash (MkRbHash) + ) +import LeiosValidClaims (memberValidClaim, sizeValidClaims) +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime (slotLengthFromSec) +import Ouroboros.Consensus.Config (SecurityParam (..)) +import qualified Ouroboros.Consensus.HardFork.History as HardFork +import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB, Predecessor (..)) +import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB +import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as Punishment +import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDBImpl +import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB +import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo) +import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Network.BlockFetch.ConsensusInterface (WithFingerprint (..)) +import System.FS.Sim.MockFS (MockFS) +import Test.Cardano.Crypto.Leios.Gen (TestCommittee (..), genCommittee) +import Test.LeiosValidClaims (mkCert, wholeCommittee) +import Test.QuickCheck.Gen (unGen) +import Test.QuickCheck.Random (mkQCGen) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Util.ChainDB +import Test.Util.LeiosHash (unsafeEbHashFromBytes) +import Test.Util.LeiosTestBlock +import Test.Util.Orphans.IOLike () + +tests :: TestTree +tests = + testGroup + "LeiosValidClaims (ChainDB)" + [ testCase "one announcer, one verification" test_establishOncePerAnnouncer + , testCase "an invalid certificate establishes nothing" test_invalidCert + , testCase "a view with no committee establishes nothing" test_noCommittee + , testCase "an established claim admits a bad certificate" test_knownClaimShortCircuits + , testCase "an off-selection CertRB is forgotten and re-acquired" test_forgetAndReacquire + , testCase "a CertRB with an unacquired EB is parked, then forgotten" test_unacquiredCertRBAtStartUp + ] + +type Blk = LeiosTestBlock + +{------------------------------------------------------------------------------- + The chains these tests use +-------------------------------------------------------------------------------} + +-- The announced endorser block is never given to the node: nothing plants its +-- closure in the LeiosDB. So every CertRB below is parked as soon as it is +-- added and none is ever selected, since ChainSel skips a CertRB whose EB has +-- not been acquired. +-- +-- The tests remain interesting for two reasons. A claim is verified on the +-- add path, before and regardless of whether the block making it can be +-- selected, so establishing a claim, reusing an established one, and rejecting +-- a bad certificate are all fully exercised. And the startup policy keys off +-- the /selection/, so a parked CertRB is exactly the off-selection CertRB the +-- policy exists for --- parking hands us that state rather than making us +-- contrive it. +-- +-- What it does cost: nothing here shows a re-admitted CertRB going on to be +-- selected and used. That needs the closure planted in the LeiosDB. + +-- | The announcer: slot 1, no certificate of its own, announces an EB. +announcer :: Blk +announcer = + announcing (MkLeiosPoint 1 ebHash) 100 (firstLeiosBlock 0) + where + ebHash = unsafeEbHashFromBytes $ BS8.take 32 (BS8.pack "eb" <> BS8.replicate 32 '\0') + +-- | The claim a CertRB extending 'announcer' makes. +announcerClaim :: RbHash +announcerClaim = MkRbHash $ toRawHash (Proxy @Blk) (blockHash announcer) + +-- | A CertRB over 'announcer', with a certificate that verifies. +certRB :: Blk +certRB = certifying (mkCert testCommittee announcerClaim) (successorLeiosBlock announcer) + +-- | A second CertRB over the same announcer, making the same claim. It carries +-- the same certificate, which is legitimate: the signed message is the +-- announcer's hash, not the certifying block's. +certRBSibling :: Blk +certRBSibling = forkLeiosBlock certRB + +-- | A longer chain that shares nothing with 'announcer'. It carries no +-- certificate, so nothing parks it and it is the chain that actually gets +-- selected, which is what leaves 'certRB' off the selection at a restart. +better1, better2, better3 :: Blk +better1 = firstLeiosBlock 1 +better2 = successorLeiosBlock better1 +better3 = successorLeiosBlock better2 + +{------------------------------------------------------------------------------- + Certificates +-------------------------------------------------------------------------------} + +-- | One committee for every epoch of every test. Drawn from a fixed seed, so +-- these are unit tests rather than properties. +testCommittee :: TestCommittee +testCommittee = unGen genCommittee (mkQCGen 42) 10 + +{------------------------------------------------------------------------------- + The node under test +-------------------------------------------------------------------------------} + +data Node m = Node + { nChainDB :: ChainDB m Blk + , nInternal :: ChainDBImpl.Internal m Blk + } + +ledgerConfig :: LeiosTestLedgerConfig +ledgerConfig = + leiosTestLedgerConfig + eraParams + -- Generously wide: these tests are not about the forecast horizon. + 100 + (const (Just (testCommittee.committee, wholeCommittee))) + +eraParams :: HardFork.EraParams +eraParams = HardFork.defaultEraParams securityParam (slotLengthFromSec 1) + +-- | Larger than every chain these tests build, so nothing becomes immutable and +-- every block stays in the VolatileDB, where forgetting can reach it. +securityParam :: SecurityParam +securityParam = SecurityParam $ knownNonZeroBounded @8 + +-- | Open a ChainDB over the given mocked filesystems, run the body, and close +-- it. Calling this twice over the same 'NodeDBs' is a node restart. +withNode :: + NodeDBs (StrictTMVar (IOSim s) MockFS) -> + LeiosDb.LeiosDbHandle (IOSim s) -> + (Node (IOSim s) -> IOSim s a) -> + IOSim s a +withNode mcdbNodeDBs mcdbLeiosDb body = + withRegistry $ \registry -> do + let mcdbTopLevelConfig = singleNodeLeiosTestConfig ledgerConfig securityParam + mcdbChunkInfo = simpleChunkInfo (HardFork.eraEpochSize eraParams) + mcdbInitLedger = leiosTestInitExtLedger ledgerConfig IntMap.empty + mcdbRegistry = registry + args = + ChainDB.updateTracer nullTracer $ + fromMinimalChainDbArgs MinimalChainDbArgs{..} + bracket + (ChainDBImpl.openDBInternal args False) + (ChainDB.closeDB . fst) + $ \(nChainDB, nInternal) -> do + _ <- + forkLinkedThread registry "AddBlockRunner" $ + ChainDBImpl.intAddBlockRunner nInternal + body Node{nChainDB, nInternal} + +withFreshNode :: (Node (IOSim s) -> IOSim s a) -> IOSim s a +withFreshNode body = do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + withNode nodeDBs leiosDb body + +-- | Add a block the way BlockFetch would: with the ledger view forecast at its +-- predecessor's slot. +addWithCommittee :: Node (IOSim s) -> Blk -> Blk -> IOSim s () +addWithCommittee node predecessor blk = + addBlockWith + node + ( Predecessor + (blockSlot predecessor) + (LeiosTestView (Just (testCommittee.committee, wholeCommittee))) + ) + blk + +addBlockWith :: Node (IOSim s) -> Predecessor Blk -> Blk -> IOSim s () +addBlockWith Node{nChainDB} predecessor = + ChainDB.addBlock_ nChainDB Punishment.noPunishment predecessor + +-- | Add a block that extends genesis. +addAtGenesis :: Node (IOSim s) -> Blk -> IOSim s () +addAtGenesis node = addBlockWith node NoPredecessor + +claimCount :: Node (IOSim s) -> IOSim s Int +claimCount Node{nInternal} = + sizeValidClaims <$> atomically (ChainDBImpl.intLeiosValidClaims nInternal) + +claimEstablished :: Node (IOSim s) -> RbHash -> IOSim s Bool +claimEstablished Node{nInternal} rbHash = + memberValidClaim rbHash <$> atomically (ChainDBImpl.intLeiosValidClaims nInternal) + +-- | Whether ChainSel has rejected this block. +isInvalid :: Node (IOSim s) -> Blk -> IOSim s Bool +isInvalid Node{nChainDB} blk = do + isInvalidBlock <- atomically (ChainDB.getIsInvalidBlock nChainDB) + pure $ isJust $ forgetFingerprint isInvalidBlock (blockHash blk) + +isFetched :: Node (IOSim s) -> Blk -> IOSim s Bool +isFetched Node{nChainDB} blk = + ($ blockPoint blk) <$> atomically (ChainDB.getIsFetched nChainDB) + +tipPoint :: Node (IOSim s) -> IOSim s (Point Blk) +tipPoint Node{nChainDB} = atomically $ ChainDB.getTipPoint nChainDB + +{------------------------------------------------------------------------------- + Tests +-------------------------------------------------------------------------------} + +-- | The claim is established once, and the second CertRB making it rides on +-- that verdict rather than being verified again. +test_establishOncePerAnnouncer :: Assertion +test_establishOncePerAnnouncer = do + let (afterCertRB, established, afterSibling) = runSimOrThrow $ + withFreshNode $ \node -> do + addAtGenesis node announcer + addWithCommittee node announcer certRB + n1 <- claimCount node + member <- claimEstablished node announcerClaim + addWithCommittee node announcer certRBSibling + n2 <- claimCount node + pure (n1, member, n2) + assertEqual "the CertRB establishes its claim" 1 afterCertRB + assertBool "and it is the announcer's claim" established + assertEqual "the sibling adds no claim" 1 afterSibling + +-- | A certificate over another claim establishes nothing, and the block does +-- not get selected. +test_invalidCert :: Assertion +test_invalidCert = do + let (claims, rejected) = runSimOrThrow $ + withFreshNode $ \node -> do + addAtGenesis node announcer + addWithCommittee node announcer poisoned + (,) <$> claimCount node <*> isInvalid node poisoned + assertEqual "no claim is established" 0 claims + assertBool "the CertRB is rejected" rejected + where + -- Signed over the wrong message: the certifying block's own hash. + wrongClaim = MkRbHash $ toRawHash (Proxy @Blk) (blockHash certRB) + poisoned = + certifying (mkCert testCommittee wrongClaim) (successorLeiosBlock announcer) + +-- | A CertRB whose announcing view seats no committee establishes nothing. +test_noCommittee :: Assertion +test_noCommittee = do + let (claims, tip) = runSimOrThrow $ + withFreshNode $ \node -> do + addAtGenesis node announcer + addBlockWith + node + (Predecessor (blockSlot announcer) (LeiosTestView Nothing)) + certRB + (,) <$> claimCount node <*> tipPoint node + assertEqual "no claim is established" 0 claims + assertEqual "the CertRB is not selected" (blockPoint announcer) tip + +-- | Once the claim is established, a CertRB making it is admitted without its +-- own certificate being checked. This is the only way the cache is observable +-- from outside: a verification that does happen and one that is skipped are +-- otherwise indistinguishable. +test_knownClaimShortCircuits :: Assertion +test_knownClaimShortCircuits = do + let (established, rejected) = runSimOrThrow $ + withFreshNode $ \node -> do + addAtGenesis node announcer + addWithCommittee node announcer certRB + addWithCommittee node announcer poisonedSibling + (,) + <$> claimEstablished node announcerClaim + <*> isInvalid node poisonedSibling + assertBool "the good CertRB establishes the claim" established + assertBool "the bad one is not rejected" (not rejected) + where + wrongClaim = MkRbHash $ toRawHash (Proxy @Blk) (blockHash certRB) + poisonedSibling = + certifying (mkCert testCommittee wrongClaim) (forkLeiosBlock certRBSibling) + +-- | The policy of @valid_claims_startup.md@: a CertRB that is in the +-- VolatileDB but off the selection at startup is treated as a block we do not +-- have, so the ordinary add path can re-establish its claim. +test_forgetAndReacquire :: Assertion +test_forgetAndReacquire = do + let (beforeRestart, afterRestart, afterThirdOpen) = runSimOrThrow $ do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + + before <- withNode nodeDBs leiosDb $ \node -> do + addAtGenesis node announcer + addWithCommittee node announcer certRB + claims <- claimCount node + -- Switch away, so the CertRB is off the selection at shutdown. + addAtGenesis node better1 + addWithCommittee node better1 better2 + addWithCommittee node better2 better3 + tip <- tipPoint node + pure (claims, tip) + + restarted <- withNode nodeDBs leiosDb $ \node -> do + claimsAtStartUp <- claimCount node + certRBForgotten <- not <$> isFetched node certRB + -- The announcer is off the selection too, but carries no + -- certificate, so it is not forgotten. + announcerKept <- isFetched node announcer + -- Re-acquire the CertRB the way BlockFetch would. + addWithCommittee node announcer certRB + reestablished <- claimEstablished node announcerClaim + readmitted <- isFetched node certRB + pure + ( claimsAtStartUp + , certRBForgotten + , announcerKept + , reestablished + , readmitted + ) + + -- A third open sees a VolatileDB that was written to twice for the same + -- block; it must not have been truncated. + third <- withNode nodeDBs leiosDb $ \node -> + (,) <$> tipPoint node <*> isFetched node announcer + + pure (before, restarted, third) + + let (claimsBefore, tipBefore) = beforeRestart + assertEqual "the claim is established before the restart" 1 claimsBefore + assertEqual + "the better chain is selected" + (blockPoint better3) + tipBefore + + let ( claimsAtStartUp + , certRBForgotten + , announcerKept + , reestablished + , readmitted + ) = afterRestart + assertEqual "no claim survives the restart" 0 claimsAtStartUp + assertBool "the off-selection CertRB is forgotten" certRBForgotten + assertBool "the off-selection announcer is kept" announcerKept + assertBool "re-acquiring the CertRB re-establishes the claim" reestablished + assertBool "and re-admits the block" readmitted + + let (tipThird, announcerThird) = afterThirdOpen + assertEqual + "the third open still selects the better chain" + (blockPoint better3) + tipThird + assertBool "and still holds the announcer" announcerThird + +-- | A CertRB is selectable only once its EB's closure has been acquired. With +-- an empty LeiosDB it is parked when it arrives and ignored again by initial +-- chain selection, so it is never on the selection and the startup policy +-- forgets it --- which is what lets its claim be re-established later. +-- +-- NOT COVERED HERE: the other side of that policy, a CertRB that /is/ on the +-- selection and so must be kept. Reaching that state means planting the +-- closure in the LeiosDB, which this harness cannot do yet. +test_unacquiredCertRBAtStartUp :: Assertion +test_unacquiredCertRBAtStartUp = do + let (tipBefore, (fetched, tip, claims)) = runSimOrThrow $ do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + + before <- withNode nodeDBs leiosDb $ \node -> do + addAtGenesis node announcer + addWithCommittee node announcer certRB + tipPoint node + + after' <- withNode nodeDBs leiosDb $ \node -> + (,,) + <$> isFetched node certRB + <*> tipPoint node + <*> claimCount node + pure (before, after') + assertEqual + "the CertRB is parked, not selected" + (blockPoint announcer) + tipBefore + assertBool "the CertRB is forgotten" (not fetched) + assertEqual "the announcer is the selection" (blockPoint announcer) tip + assertEqual "no claim survives the restart" 0 claims From bfe70fb0e0d695898921f35f40baf167412c2bd0 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 22 Sep 2026 13:32:15 -0400 Subject: [PATCH 22/60] Leios: preparatory changes for the new test harness --- ...nick.frisby_leios_valid_claims_internal.md | 11 +- .../Ouroboros/Consensus/NodeKernel.hs | 27 ++ .../test/consensus-test/Main.hs | 2 + ouroboros-consensus.cabal | 9 +- .../src/ouroboros-consensus/LeiosDemoLogic.hs | 19 +- .../ouroboros-consensus/LeiosValidClaims.hs | 66 +++- .../Consensus/Storage/ChainDB/API.hs | 11 + .../Consensus/Storage/ChainDB/Impl.hs | 4 +- .../Storage/ChainDB/Impl/Background.hs | 5 +- .../Storage/ChainDB/Impl/ChainSel.hs | 24 +- .../Consensus/Storage/ChainDB/Impl/Types.hs | 6 +- .../Test/Util/LeiosTestBlock.hs | 321 +++++++++++++++++- .../consensus-test/Test/LeiosDemoLogic.hs | 9 +- .../Test/LeiosDemoLogic/Invariants.hs | 12 +- .../consensus-test/Test/LeiosValidClaims.hs | 11 +- .../Test/LeiosValidClaimsChainDB.hs | 13 +- 16 files changed, 484 insertions(+), 66 deletions(-) diff --git a/changelog.d/20260922_124500_nick.frisby_leios_valid_claims_internal.md b/changelog.d/20260922_124500_nick.frisby_leios_valid_claims_internal.md index d73c287073..d7453aa5f9 100644 --- a/changelog.d/20260922_124500_nick.frisby_leios_valid_claims_internal.md +++ b/changelog.d/20260922_124500_nick.frisby_leios_valid_claims_internal.md @@ -7,14 +7,15 @@ For top level release notes, leave all the headers commented out. ### Breaking -- The ChainDB's `Internal` record, which `Ouroboros.Consensus.Storage.ChainDB.Impl` exposes for testing, gained `intLeiosValidClaims`. It reads the set of Leios claims ChainSel has verified so far; nothing outside the ChainDB needed that until now, since ChainSel reads `cdbLeiosValidClaims` directly. +- The `ChainDB` gained `getLeiosValidClaims`, which reads the current ValidClaims value with a fingerprint that changes whenever a claim is added. - +### Non-Breaking + +- The Leios fetch logic now only fetches an endorser block once some verified claim announced it, and the node wakes that logic when a claim arrives after the offer did. This is deliberately stricter than the Recovery Path rule it stands in for --- notably it ignores offers heralded only by LeiosNotify --- and is expected to be weakened. + +### Breaking + +- A peer's offers are now `PeerOffer`, recording the size it offered an EB's body at (if it offered the body) and whether it offered the closure. Now that they're independent offers, `AlsoOfferedTxsClosure` is accordingly `WhetherTxsClosureOffered`, with `TxsClosureOffered` and `TxsClosureNotOffered`. + +- `recordEbBodyOffer` no longer lists a body as one to fetch, and takes no `LeiosOutstanding`. It gained two siblings: `recordEbClosureOffer`, and `recordCertRbOffer` for a CertRB roll-forward, which offers both the body and the closure. None of the three lists any EB bodies to fetch (since that's only justified by an announcement, not an offer). + +- `ValidClaims`' `certifiedEbs` maps each election to the whole `AnnouncementFields` rather than just its `EbHash`. That is what lets `focusCertifiedEb` --- which moves a verified certificate's election onto the EB it names --- also list that body to fetch, via the new `listEbBodyToFetch`. + +- `LeiosNotifyPeerState` holds what one LeiosNotify client remembers of its peer --- its latest-pruned slot, its announcements and its offers. `checkLeiosBlockOffer` and `checkLeiosClosureOffer` accept or reject an offer against it, reporting `ExnLeiosInvalidOffer`, and `pruneLeiosNotifyPeerStateToImmTip` prunes it, replacing `prunePeerStateToImmTip`. + +- `NodeKernelArgs` and `NodeKernel` gained `LeiosMinOfferLead`, how much younger than the node's own immutable tip an EB must be for it to be offered (aka relayed) when acquired. + +- The LeiosNotify server decides whether a peer hears about what this node stored, consulting `Leios.leiosOfferRelayDecision` as it turns a `LeiosEbNotification` into an offer. The LeiosDb reports what it stored and has no opinion about relaying, so none of this reaches its API. + +### Non-Breaking + +- A peer may only offer an EB it has announced to us over LeiosNotify, may offer its body once and its closure once, and may not offer one older than our immutable tip. Each of those costs it the connection, which is what stops an offer from being an independent way to make us track an EB, unconstrained by valid elections/announcements. The three checks are consistent by construction: the announcements that pruning to the immutable tip drops are exactly those whose offers that same tip rejects as too old. + +- The body offer and the closure offer are independent: either may arrive first, or alone. So a LeiosNotify server never has to synthesise a body offer ahead of a closure offer, and neither `MsgLeiosBlockTxsOffer` nor `AcquiredEbTxs` need a size argument. (If we were to add size argument, then closure offers could again imply body offers. Note that lacking credits is the _only_ reason the body might not have been offered to the peer before the closure would be.) + +- This node likewise offers an EB to a peer only if it sent a matching announcement to that peer, since that is what it demands of its own upstream peers. The LeiosNotify server records what it has enqueued to each peer as it enqueues it, so a peer that joins after an announcement was relayed --- or whose queue had no credits when it was --- is not then offered what it was never given announcements for. + +- Neither a LeiosNotify offer nor a CertRB's MsgRollForward lists anything to fetch any more. That is instead seeded when the focus of an election moves onto an EB, which happens for the first-seen announcement (via LeiosNotify, or via ChainSync of the announcing block) or for the verification of a certificate. So nothing lists an EB on the strength of a claim we have not yet verified. Offers only say which peers can serve what, so the candidates we pursue are bounded by elections and certifications rather than by peers. + +- The announcements on the chain the node has already selected at startup are deliberately not replayed either, though those blocks never roll forward and so are never announced to it again. Between them those two listing paths still reach every EB it could come to need: a CertRB on that chain has its EB already, since it could not have been selected otherwise, and one that is not on that chain is re-fetched if some chain the node would select needs it, at which point verifying its certificate sets the focus and lists it. The only cost is that the `LeiosTxCache` has no entry for those EBs, so their txs read as absent and a later EB that shares one re-fetches it; acceptable consequence of a restart. + +- The fetch logic asks a peer for an EB only at the size that peer offered it at. A peer that offered another size holds a different EB, so asking it would only earn a body that fails the arrival size check; its offer is kept rather than dropped, since a later focus change could make it the one we want. + +- A node offers an EB only if it was still at least `leiosMinOfferLead` younger than the node's immutable tip, and disconnects a peer that offers one below the local immutable tip. The default is an hour's worth of current mainnet slots, which should almost always cover the gap between two honest node's imm tip's ages. A value approaching the distance between a node's immutable tip and its selection suppresses every offer, which is why the test networks need to configure their own, smaller value. + +### Patch + +- `Cardano.Tools.DBAnalyser.Leios` now imports the `AnnouncementFields` accessors it uses, so `unstable-cardano-tools` builds again. diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Leios.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Leios.hs index 90f96fe7b8..1858790153 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Leios.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Leios.hs @@ -42,6 +42,8 @@ import LeiosDemoTypes , HasLeiosVoting (..) , LeiosExtValidationError (..) , LeiosPoint + , announcementEbBodySize + , announcementLeiosPoint , pointEbHash , verifyLeiosCert ) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index c74b833048..e7993a1d69 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -243,27 +243,28 @@ synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir (confDbDir "leios.vol.db") (confDbDir "leios.imm.db") $ \leiosDbHandle -> - withReader leiosDbHandle $ \leiosDbReader -> withWriter leiosDbHandle $ \leiosDbWriter -> - ChainDB.withDB (ChainDB.updateTracer dbTracer (mkDbArgs leiosDbHandle)) $ \chainDB -> do - slotNo <- do - tip <- atomically (ChainDB.getTipPoint chainDB) - pure $ case pointSlot tip of - Origin -> 0 - At s -> succ s + withReader leiosDbHandle $ \leiosDbReader -> + withWriter leiosDbHandle $ \leiosDbWriter -> + ChainDB.withDB (ChainDB.updateTracer dbTracer (mkDbArgs leiosDbHandle)) $ \chainDB -> do + slotNo <- do + tip <- atomically (ChainDB.getTipPoint chainDB) + pure $ case pointSlot tip of + Origin -> 0 + At s -> succ s - putStrLn $ "--> starting at: " ++ show slotNo - runForge - epochSize - slotNo - synthLimit - chainDB - forgers - pInfoConfig - confVotingKey - (genTxs pInfoConfig) - leiosDbReader - leiosDbWriter - leiosTracer + putStrLn $ "--> starting at: " ++ show slotNo + runForge + epochSize + slotNo + synthLimit + chainDB + forgers + pInfoConfig + confVotingKey + (genTxs pInfoConfig) + leiosDbReader + leiosDbWriter + leiosTracer else do putStrLn "--> no forgers found; leaving possibly existing ChainDB untouched" pure $ ForgeResult 0 diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Leios.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Leios.hs index 5a1f298b10..690b788683 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Leios.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Leios.hs @@ -87,11 +87,11 @@ import LeiosDemoDb ) import LeiosDemoTypes ( LeiosNotVotedReason (..) - , announcementEbHash , LeiosPoint (..) , LeiosVote (..) , RbHash (..) , TraceLeiosKernel (..) + , announcementEbHash , hashLeiosEb , minCertificationGap , prettyEbHash diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index ee358daab5..b9065c3f0f 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} @@ -60,7 +59,7 @@ import qualified Control.Concurrent.Class.MonadSTM as LazySTM import Control.Concurrent.Class.MonadSTM.Strict (readTChan) import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar as TVar.Unchecked import Control.DeepSeq (NFData) -import Control.Monad (forM_, forever, void, when) +import Control.Monad (forM_, forever, when) import Control.Monad.Class.MonadTime.SI (MonadTime) import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.Monad.Except (runExceptT) @@ -358,6 +357,27 @@ data Handlers m addr blk = Handlers LeiosFetchServerPeer LeiosPoint LeiosEb LeiosTx m () } +-- | One peer's outgoing LeiosNotify queue, and what it has been announced. +-- +-- The two travel together so that the pure step the central relay logic uses +-- to enqueue an announcement is also what records it; see 'qav'. +data OutgoingLeiosNotify blk = MkOutgoingLeiosNotify + { olnMessages :: + !( Seq.Seq + ( LeiosDemoOnlyTestNotify.Message + (LeiosNotify LeiosPoint (Header blk) LeiosVote) + LeiosDemoOnlyTestNotify.StBusy + LeiosDemoOnlyTestNotify.StIdle + ) + ) + , olnAnnounced :: !(Set.Set LeiosPoint) + -- ^ The endorser blocks whose announcement we have enqueued to this peer, + -- pruned to our immutable tip; see 'offer'. + } + +emptyOutgoingLeiosNotify :: OutgoingLeiosNotify blk +emptyOutgoingLeiosNotify = MkOutgoingLeiosNotify Seq.empty Set.empty + mkHandlers :: forall m blk addrNTN addrNTC. ( IOLike m @@ -499,7 +519,29 @@ mkHandlers -- Per-upstream-peer announcement accountability (dedup and -- equivocation counting). The pipelined-client handler is a stateless -- callback, so this state lives in a (single-threaded) ref. - peerStateVar <- Prim.newMutVar (SlotNo 0, Announcements.emptyPeerState) + peerStateVar <- Prim.newMutVar Leios.emptyLeiosNotifyPeerState + -- Run one of the offer checks, committing what it accepted or + -- disconnecting the peer. + -- + -- Pruning first is what keeps the too-old bound on the immutable tip + -- itself rather than on wherever this peer's last announcement left + -- it. It cannot strand a legal offer: the announcements a prune + -- drops are those of elections below the immutable tip, an announced + -- point's slot is its election's slot, and so an offer relying on one + -- is rejected as too old by the very tip that dropped it. + let checkOffer :: + ( Leios.LeiosNotifyPeerState blk -> + Either Leios.ExnLeiosInvalidOffer (Leios.LeiosNotifyPeerState blk) + ) -> + m () + checkOffer runCheck = do + immLedger <- atomically $ ChainDB.getImmutableLedger getChainDB + peerSt <- + Leios.pruneLeiosNotifyPeerStateToImmTip immLedger + <$> Prim.readMutVar peerStateVar + case runCheck peerSt of + Left err -> throwIO err + Right peerSt' -> Prim.writeMutVar peerStateVar peerSt' pure $ leiosNotifyClientPeerPipelined ( atomically $ @@ -522,7 +564,7 @@ mkHandlers Nothing -> throwIO Leios.ExnLeiosBlockAnnouncementMissing Just x -> pure x immLedger <- atomically $ ChainDB.getImmutableLedger getChainDB - (latestPruneSlot, peerSt0) <- Prim.readMutVar peerStateVar + peerSt0 <- Prim.readMutVar peerStateVar res <- runExceptT $ Announcements.onAnnouncement @@ -553,29 +595,45 @@ mkHandlers (Just age) ancHdr ) - peerSt0 + (Leios.lnpsAnnouncements peerSt0) anc - peerSt1 <- case res of + announcements <- case res of Left err -> throwIO $ Leios.ReactToAnnouncementError err Right x -> pure x - let (!latestPruneSlot', !peerSt2) = - Leios.prunePeerStateToImmTip immLedger latestPruneSlot peerSt1 - Prim.writeMutVar peerStateVar (latestPruneSlot', peerSt2) + Prim.writeMutVar peerStateVar $! + Leios.pruneLeiosNotifyPeerStateToImmTip + immLedger + peerSt0{Leios.lnpsAnnouncements = announcements} MsgLeiosBlockOffer point ebBytesSize -> do traceWith tracer $ MkTraceLeiosPeer $ "MsgLeiosBlockOffer " <> Leios.prettyLeiosPoint point - -- TODO punish peer for a too-old offer, modulo clock/immtip skew. - Leios.recordEbBodyOffer - (getLeiosOutstanding, getLeiosReady) - peerVars - Leios.TxsClosureNotAlsoOffered - (point, ebBytesSize) - MsgLeiosBlockTxsOffer p -> do - traceWith tracer $ MkTraceLeiosPeer $ "MsgLeiosBlockTxsOffer " <> Leios.prettyLeiosPoint p - -- A closure offer implies the body too. - MVar.modifyMVar_ (Leios.offerings peerVars) $ - pure . Map.insertWith Leios.mergeOffer p Leios.TxsClosureAlsoOffered - void $ MVar.tryPutMVar getLeiosReady () + checkOffer $ Leios.checkLeiosBlockOffer point ebBytesSize + Leios.recordEbBodyOffer getLeiosReady peerVars (point, ebBytesSize) + MsgLeiosBlockTxsOffer point -> do + traceWith tracer $ MkTraceLeiosPeer $ "MsgLeiosBlockTxsOffer " <> Leios.prettyLeiosPoint point + checkOffer $ Leios.checkLeiosClosureOffer point + Leios.recordEbClosureOffer getLeiosReady peerVars point MsgLeiosVotes vs -> do + -- TODO no LeiosNotify message may simply be ignored, or + -- the peer can send it without bound. Votes still can be: + -- 'addVote' silently returns 'AlreadyKnown' for a + -- duplicate, and says nothing at all about a vote for an + -- election we have no interest in. They want the same + -- shape the announcements have: + -- + -- * the age limits announcements use, a sending bound + -- comfortably below a receiving bound, so that an + -- honest relayer never trips ours; + -- + -- * a bitfield per /election/ per peer --- not per + -- announcement, since the committee is seated by the + -- election's slot --- so that a peer that votes twice + -- as one committee member is disconnected; + -- + -- * the same bitfield per election centrally, so that a + -- vote we have already seen from elsewhere, or one + -- that equivocates, is silently not relayed rather + -- than relayed on to everyone. + -- -- No peer-level trace here: 'TraceLeiosVoteAcquired' below -- reports every vote with structured fields, and votes are -- the one Leios message whose count scales with committee @@ -620,13 +678,33 @@ mkHandlers -- this peer with those components too, rather than the pump draining -- fresh per-peer subscriptions. credits <- TVar.Unchecked.newTVarIO (0 :: Int) - queue <- TVar.Unchecked.newTVarIO Seq.empty + queue <- TVar.Unchecked.newTVarIO emptyOutgoingLeiosNotify - -- The view the central relay logic uses to enqueue announcements + -- The view the central relay logic uses to enqueue announcements. + -- + -- It also records what it announced, which is what lets an offer be + -- held back until this peer has been told the endorser block exists: + -- we require exactly that of our own upstream peers, so offering one + -- we never announced would have an honest peer disconnect us. The + -- record is written here, by the same pure step that enqueues, so it + -- cannot claim an announcement that never went out --- in particular + -- the central logic drops the announcement outright when this peer + -- has no credits, and then this does not record it. let qav = Announcements.MkQueueAnnouncementView credits - (\q anc -> q Seq.|> MsgLeiosBlockAnnouncement (Leios.ancHeader anc)) + ( \out anc -> + let fields = Leios.ancAnnouncementFields anc + in MkOutgoingLeiosNotify + { olnMessages = + olnMessages out + Seq.|> MsgLeiosBlockAnnouncement (Leios.ancHeader anc) + , olnAnnounced = + Set.insert + (Leios.announcementLeiosPoint fields) + (olnAnnounced out) + } + ) queue let @@ -642,42 +720,85 @@ mkHandlers TVar.Unchecked.writeTVar credits $! n + 1 pure LeiosDemoOnlyTestNotify.NotExcessiveRequests next = atomically $ do - q <- TVar.Unchecked.readTVar queue - case Seq.viewl q of + out <- TVar.Unchecked.readTVar queue + case Seq.viewl (olnMessages out) of Seq.EmptyL -> LazySTM.retry - msg Seq.:< q' -> do - TVar.Unchecked.writeTVar queue q' + msg Seq.:< msgs' -> do + TVar.Unchecked.writeTVar queue out{olnMessages = msgs'} pure msg + -- 'Nothing' when the notification it consumed is one we must not + -- relay (eg because it'd be too old): the caller commits that + -- anyway, so the channel drains. pumpNext :: STM m - ( LeiosDemoOnlyTestNotify.Message - (LeiosNotify LeiosPoint (Header blk) LeiosVote) - LeiosDemoOnlyTestNotify.StBusy - LeiosDemoOnlyTestNotify.StIdle + ( Maybe + ( LeiosDemoOnlyTestNotify.Message + (LeiosNotify LeiosPoint (Header blk) LeiosVote) + LeiosDemoOnlyTestNotify.StBusy + LeiosDemoOnlyTestNotify.StIdle + ) ) - pumpNext = + pumpNext = do + pruneAnnounced ( readTChan chan >>= \case AcquiredEb point ebSize -> - pure $ MsgLeiosBlockOffer point ebSize + offer point $ MsgLeiosBlockOffer point ebSize AcquiredEbTxs point -> - pure $ MsgLeiosBlockTxsOffer point - ) - <|> (getNextVote <&> \vote -> MsgLeiosVotes [vote]) + offer point $ MsgLeiosBlockTxsOffer point + ) + <|> (getNextVote <&> \vote -> Just $ MsgLeiosVotes [vote]) + + -- Keep 'olnAnnounced' to our immutable tip, so it does not grow for + -- the life of the connection. Nothing below that is ever offered + -- anyway, since the relay decision holds offers back to + -- 'leiosMinOfferLead' above it. + -- + -- Runs for every message the pump produces --- offers, suppressed + -- notifications and votes alike --- rather than only for the ones + -- that consult the record, since it is announcements that grow it + -- and a peer can be relayed those without our acquiring anything. + pruneAnnounced = do + immTipSlot <- withOrigin (SlotNo 0) id <$> getImmTipSlot nodeKernel + out <- TVar.Unchecked.readTVar queue + TVar.Unchecked.writeTVar queue $ + out + { olnAnnounced = + Set.dropWhileAntitone + ((< immTipSlot) . Leios.pointSlotNo) + (olnAnnounced out) + } + + -- An offer goes out only if it is fresh enough to relay and this + -- peer has been told the announcement it is for. + relayDecision = + Leios.leiosOfferRelayDecision + (getLeiosMinOfferLead nodeKernel) + (getImmTipSlot nodeKernel) + offer point msg = do + shouldRelay <- relayDecision (Leios.pointSlotNo point) + case shouldRelay of + Announcements.DoNotRelay -> pure Nothing + Announcements.DoRelay -> do + out <- TVar.Unchecked.readTVar queue + pure $ if Set.member point (olnAnnounced out) then Just msg else Nothing pump = ( do MVar.modifyMVar_ getLeiosCentralState $ pure . Announcements.insertPeerCentral peer qav forever $ atomically $ do - msg <- pumpNext + mMsg <- pumpNext c <- TVar.Unchecked.readTVar credits -- FIXME: Is this dropping messages when we run out of credits? - when (c > 0) $ do - TVar.Unchecked.writeTVar credits $! c - 1 - q <- TVar.Unchecked.readTVar queue - TVar.Unchecked.writeTVar queue (q Seq.|> msg) + forM_ mMsg $ \msg -> + when (c > 0) $ do + TVar.Unchecked.writeTVar credits $! c - 1 + out <- TVar.Unchecked.readTVar queue + TVar.Unchecked.writeTVar + queue + out{olnMessages = olnMessages out Seq.|> msg} ) `finally` ( MVar.modifyMVar_ getLeiosCentralState $ pure . Announcements.deletePeerCentral peer diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index 9b015c2014..3754539e01 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs @@ -110,6 +110,7 @@ import Data.Set (Set) import Data.Time (NominalDiffTime) import Data.Typeable (Typeable) import LeiosDemoDb (LeiosDbHandle) +import qualified LeiosDemoLogic as Leios import LeiosDemoTypes (SerializedEbBody) import LeiosTxCache ( LeiosTxCache @@ -1015,6 +1016,7 @@ mkNodeKernelArgs , leiosDB , leiosTxCache , leiosFetchRng = lfRng + , leiosMinOfferLead = Leios.defaultLeiosMinOfferLead } -- | We allow the user running the node to customise the 'NodeKernelArgs' diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 0899482003..9e4e4493ca 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -10,7 +10,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Ouroboros.Consensus.NodeKernel @@ -236,7 +235,8 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel -- @LeiosFetchDynamicEnv@ and @LeiosFetchState@ data structures. -- -- See 'LeiosPeerVars' for the write patterns. - getLeiosDB :: LeiosDbHandle m + getLeiosMinOfferLead :: Leios.LeiosMinOfferLead + , getLeiosDB :: LeiosDbHandle m -- ^ Factory for opening per-thread readers and writers of the Leios demo DB -- and subscribing to EB-notification events. , getLeiosVoteState :: LeiosVoteState m @@ -309,6 +309,7 @@ data NodeKernelArgs m addrNTN addrNTC blk = NodeKernelArgs -- ^ Seeds the LeiosFetch decision loop's PRNG (see 'Leios.leiosFetchPrng'), -- which shuffles job assignment to peers. An independent split of the node -- generator, like 'keepAliveRng' / 'peerSharingRng'. + , leiosMinOfferLead :: Leios.LeiosMinOfferLead } initNodeKernel :: @@ -340,6 +341,7 @@ initNodeKernel , getDiffusionPipeliningSupport , miniProtocolParameters , leiosDB + , leiosMinOfferLead } = do -- using a lazy 'TVar', 'BlockForging' does not have a 'NoThunks' instance. blockForgingVar :: LazySTM.TMVar m [MkBlockForging m blk] <- LazySTM.newTMVarIO [] @@ -653,7 +655,7 @@ initNodeKernel MVar.modifyMVar_ getLeiosOutstanding $ \outstanding -> pure $! Map.foldlWithKey' - (\acc elId ebHash -> Leios.focusElection elId ebHash acc) + (\acc _elId fields -> Leios.focusCertifiedEb fields acc) outstanding arrived void $ MVar.tryPutMVar getLeiosReady () @@ -682,6 +684,7 @@ initNodeKernel , getSharedTxStateVar = sharedTxStateVar , getTxCountersVar = txCountersVar , getTxDecisionPolicy = txDecisionPolicy miniProtocolParameters + , getLeiosMinOfferLead = leiosMinOfferLead , getLeiosDB = leiosDB , getLeiosVoteState = leiosVoteState , getLeiosPeersVars = getLeiosPeersVars @@ -761,6 +764,7 @@ data InternalState m addrNTN addrNTC blk = IS -- ^ Accumulator for Leios votes; assembles certificates once a -- point's tally crosses 'minCertificationThreshold'. Source of -- 'fbLeiosVoteState' threaded into 'ForgeBlockArgs'. + , leiosMinOfferLead :: Leios.LeiosMinOfferLead } initInternalState :: @@ -791,6 +795,7 @@ initInternalState , leiosDB , leiosTxCache , leiosFetchRng + , leiosMinOfferLead } = do varGsmState <- do let GsmNodeKernelArgs{..} = gsmArgs diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index b6489724e0..32e1526edb 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -88,6 +88,7 @@ import Data.Void (Void) import GHC.Generics import GHC.Stack import qualified LeiosDemoDb +import qualified LeiosDemoLogic as Leios import LeiosDemoOnlyTestFetch (LeiosFetch) import LeiosDemoOnlyTestNotify (LeiosNotify) import qualified LeiosDemoTypes @@ -1176,6 +1177,10 @@ runThreadNetwork , leiosDB = leiosDbHandle , leiosTxCache , leiosFetchRng = lfRng + , -- These runs are a couple of hundred slots long with the + -- immutable tip near genesis, so the real lead would hold + -- back every offer there is. + leiosMinOfferLead = Leios.MkLeiosMinOfferLead 0 } nodeKernel <- initNodeKernel nodeKernelArgs diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs index 7b0c6e76d9..05fed26604 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -24,8 +25,13 @@ -- say --- that it never delivers. module Test.Consensus.Leios.Environment ( PeerEnv (..) + , announceEb , connectPeer + , heardOffers + , heardUnannouncedOffers , newPeerEnv + , offerEb + , offerEbTxs , plantEb , serveChain , serveChainThrough @@ -57,11 +63,15 @@ import LeiosDemoOnlyTestFetch , Message (..) , leiosFetchServerPeer ) +import LeiosDemoOnlyTestNotify (LeiosNotify (StBusy, StIdle)) +import qualified LeiosDemoOnlyTestNotify as Notify import LeiosDemoTypes - ( EbHash + ( BytesSize + , EbHash , LeiosEb (..) , LeiosPoint (..) , LeiosTx (..) + , LeiosVote , TxHash , hashLeiosEb ) @@ -73,6 +83,7 @@ import Ouroboros.Consensus.Node.ExitPolicy (NodeToNodeInitiatorResult) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Network.Channel (createConnectedChannels) import Ouroboros.Network.ConnectionId (ConnectionId (..)) +import Ouroboros.Network.Context (ResponderContext (..)) import Ouroboros.Network.ControlMessage (ControlMessage (..)) import Ouroboros.Network.Driver.Simple (runPeer) import Ouroboros.Network.Mock.Chain (Chain) @@ -114,14 +125,47 @@ data PeerEnv m = PeerEnv -- ^ The last block of 'peChain' this peer hands over; see -- 'serveChainThrough'. , peEbs :: StrictTVar m (Map EbHash (LeiosEb, Map TxHash BS.ByteString)) + , peNotifications :: PlainSTM.StrictTVar m [LeiosNotification] + -- ^ What this peer has yet to say over LeiosNotify, in order. + , peHeard :: PlainSTM.StrictTVar m [LeiosNotification] + -- ^ What the node has said to this peer over LeiosNotify, in order. The + -- node is the upstream peer on this second LeiosNotify connection, which is + -- how a test sees what it relays. } +-- | One thing a peer says over LeiosNotify. +type LeiosNotification = + Notify.Message (LeiosNotify LeiosPoint (Header Blk) LeiosVote) StBusy StIdle + newPeerEnv :: IOSim s (PeerEnv (IOSim s)) newPeerEnv = do peChain <- PlainSTM.newTVarIO (initChainProducerState Chain.Genesis) peServeThrough <- newTVarIO GenesisPoint peEbs <- newTVarIO Map.empty - pure PeerEnv{peChain, peServeThrough, peEbs} + peNotifications <- PlainSTM.newTVarIO [] + peHeard <- PlainSTM.newTVarIO [] + pure PeerEnv{peChain, peServeThrough, peEbs, peNotifications, peHeard} + +-- | The endorser blocks the node offered this peer without having first +-- announced them to it. +-- +-- That is the rule the node itself enforces on its upstream peers, so any +-- answer but the empty list is the node doing what it would disconnect a peer +-- for. +heardUnannouncedOffers :: PeerEnv (IOSim s) -> IOSim s [LeiosPoint] +heardUnannouncedOffers PeerEnv{peHeard} = + go [] <$> atomically (PlainSTM.readTVar peHeard) + where + go :: [LeiosPoint] -> [LeiosNotification] -> [LeiosPoint] + go _announced [] = [] + go announced (msg : rest) = case msg of + Notify.MsgLeiosBlockAnnouncement hdr -> + go (maybe id ((:) . fst) (lthAnnouncement hdr) announced) rest + Notify.MsgLeiosBlockOffer point _size + | point `notElem` announced -> point : go announced rest + Notify.MsgLeiosBlockTxsOffer point + | point `notElem` announced -> point : go announced rest + _ -> go announced rest -- | Make this the chain the peer serves, all of it. Switching to one that is -- not an extension rolls the node back, as a real peer's would. @@ -142,6 +186,48 @@ serveChainThrough PeerEnv{peChain, peServeThrough} through chain = PlainSTM.modifyTVar peChain $ switchFork chain writeTVar peServeThrough through +-- | Have this peer announce, over LeiosNotify, the endorser block this header +-- announces. +-- +-- This is what an offer from this peer has to be backed by; the peer's own +-- chain has nothing to do with it. +announceEb :: PeerEnv (IOSim s) -> Header Blk -> IOSim s () +announceEb PeerEnv{peNotifications} hdr = + atomically $ + PlainSTM.modifyTVar peNotifications (<> [Notify.MsgLeiosBlockAnnouncement hdr]) + +-- | Have this peer offer this endorser block over LeiosNotify. +-- +-- Offering is not announcing: this says only that the peer has the body, and +-- an honest peer says it only after its own 'Notify.MsgLeiosBlockAnnouncement' +-- for that endorser block. +offerEb :: PeerEnv (IOSim s) -> LeiosPoint -> BytesSize -> IOSim s () +offerEb PeerEnv{peNotifications} point size = + atomically $ + PlainSTM.modifyTVar peNotifications (<> [Notify.MsgLeiosBlockOffer point size]) + +-- | Have this peer offer this endorser block's closure over LeiosNotify. +-- +-- Independent of 'offerEb': either may be sent first, or alone. Like it, this +-- is not an announcement, so an honest peer says it only after its own +-- 'Notify.MsgLeiosBlockAnnouncement' for that endorser block. +offerEbTxs :: PeerEnv (IOSim s) -> LeiosPoint -> IOSim s () +offerEbTxs PeerEnv{peNotifications} point = + atomically $ + PlainSTM.modifyTVar peNotifications (<> [Notify.MsgLeiosBlockTxsOffer point]) + +-- | The endorser blocks the node has offered this peer, in order. +heardOffers :: PeerEnv (IOSim s) -> IOSim s [LeiosPoint] +heardOffers PeerEnv{peHeard} = + atomically $ + foldMap offered <$> PlainSTM.readTVar peHeard + where + offered :: LeiosNotification -> [LeiosPoint] + offered = \case + Notify.MsgLeiosBlockOffer point _size -> [point] + Notify.MsgLeiosBlockTxsOffer point -> [point] + _ -> [] + -- | Make this endorser block, and its closure, available from this peer. plantEb :: PeerEnv (IOSim s) -> LeiosEb -> [(TxHash, BS.ByteString)] -> IOSim s () @@ -150,15 +236,15 @@ plantEb PeerEnv{peEbs} eb closure = modifyTVar peEbs $ Map.insert (hashLeiosEb eb) (eb, Map.fromList closure) --- | Run one peer against the node: the node's ChainSync, BlockFetch and Leios --- fetch clients, each against this environment's server. +-- | Run one peer against the node: the node's ChainSync, BlockFetch, +-- LeiosNotify, and LeiosFetch clients, each against this environment's server +-- AND the node's LeiosNotify server against this environment's client (to +-- observe what the node relays). -- -- The other mini-protocols are simply never started. Nothing in the node -- starts them on its own, and a protocol that is not running cannot time out. --- LeiosNotify is one of them: the node learns of an endorser block from the --- CertRB header that certifies it, so this environment has nothing to say --- over that protocol. connectPeer :: + forall s. NodeUnderTest (IOSim s) -> ResourceRegistry (IOSim s) -> PeerAddr -> @@ -168,11 +254,16 @@ connectPeer nut registry addr penv = do (csClient, csServer) <- createConnectedChannels (bfClient, bfServer) <- createConnectedChannels (kaClient, kaServer) <- createConnectedChannels + (lnClient, lnServer) <- createConnectedChannels + (lnDownClient, lnDownServer) <- createConnectedChannels (lfClient, lfServer) <- createConnectedChannels let codecs = peerCodecs nut apps = peerApps nut + record :: LeiosNotification -> IOSim s () + record msg = atomically $ PlainSTM.modifyTVar (peHeard penv) (<> [msg]) + fork name action = void $ forkLinkedThread registry name $ do say (name <> " starting") r <- action @@ -208,6 +299,26 @@ connectPeer nut registry addr penv = do runPeer (sayTracer ("ka " <> show addr)) (NTN.cKeepAliveCodec codecs) kaServer $ keepAliveServerPeer keepAliveServer + fork ("LeiosNotify client " <> show addr) $ + void $ + NTN.aLeiosNotifyClient apps version (initiatorCtx addr) lnClient + fork ("LeiosNotify server " <> show addr) $ + void $ + runPeer (sayTracer ("ln " <> show addr)) (NTN.cLeiosNotifyCodec codecs) lnServer $ + Notify.leiosNotifyServerPeer (nextNotification penv) + + -- The other direction of LeiosNotify: the node is the upstream peer, and + -- this environment client records everything it says. Nothing here ever + -- stops asking for more. + fork ("LeiosNotify server (node) " <> show addr) $ + void $ + NTN.aLeiosNotifyServer apps version (responderCtx addr) lnDownServer + fork ("LeiosNotify client (env) " <> show addr) $ + void $ + runPeer (sayTracer ("ln-down " <> show addr)) (NTN.cLeiosNotifyCodec codecs) lnDownClient $ + Notify.leiosNotifyClientPeer + (pure (Right record) :: IOSim s (Either () (LeiosNotification -> IOSim s ()))) + fork ("LeiosFetch client " <> show addr) $ void $ NTN.aLeiosFetchClient apps version (initiatorCtx addr) lfClient @@ -220,6 +331,15 @@ connectPeer nut registry addr penv = do The servers -------------------------------------------------------------------------------} +-- | The next thing this peer has to say, blocking until it has something. +nextNotification :: PeerEnv (IOSim s) -> IOSim s LeiosNotification +nextNotification PeerEnv{peNotifications} = atomically $ do + PlainSTM.readTVar peNotifications >>= \case + [] -> retry + notification : rest -> do + PlainSTM.writeTVar peNotifications rest + pure notification + -- | Answers every keep-alive, forever. keepAliveServer :: KeepAliveServer (IOSim s) () keepAliveServer = @@ -386,3 +506,7 @@ initiatorCtx addr = , eicIsBigLedgerPeer = IsBigLedgerPeer , eicExtraFlags = IsNotTrustable } + +-- | The node's side of a connection on which the node is the upstream peer. +responderCtx :: PeerAddr -> ResponderContext PeerAddr +responderCtx addr = ResponderContext{rcConnectionId = ConnectionId addr addr} diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/NodeUnderTest.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/NodeUnderTest.hs index 76c4232fba..e36d09c16c 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/NodeUnderTest.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/NodeUnderTest.hs @@ -33,20 +33,25 @@ import qualified Data.IntMap.Strict as IntMap import Data.Time.Calendar (fromGregorian) import Data.Time.Clock (UTCTime (..)) import qualified LeiosDemoDb as LeiosDb +import qualified LeiosDemoLogic as Leios import LeiosTxCache (nullLeiosTxCache) import Ouroboros.Consensus.BlockchainTime - ( BlockchainTime (..) - , CurrentSlot (..) + ( BackoffDelay (..) + , BlockchainTime + , HardForkBlockchainTimeArgs (..) , SystemStart (..) , SystemTime + , hardForkBlockchainTime ) import Ouroboros.Consensus.BlockchainTime.WallClock.Default (defaultSystemTime) import Ouroboros.Consensus.Config ( DiffusionPipeliningSupport (..) , SecurityParam (..) , TopLevelConfig + , configLedger ) import qualified Ouroboros.Consensus.HardFork.History as HardFork +import Ouroboros.Consensus.Ledger.Extended (ledgerState) import Ouroboros.Consensus.Mempool (MempoolCapacityBytesOverride (..)) import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck @@ -91,11 +96,19 @@ type Blk = LeiosTestBlock data NodeUnderTestConfig = NodeUnderTestConfig { nutcLedgerConfig :: LeiosTestLedgerConfig , nutcSecurityParam :: SecurityParam + , nutcMinOfferLead :: Leios.LeiosMinOfferLead + -- ^ See 'leiosMinOfferLead'. These tests run a handful of slots, so the + -- real hour would hold back every offer they make. } defaultNodeUnderTestConfig :: LeiosTestLedgerConfig -> SecurityParam -> NodeUnderTestConfig -defaultNodeUnderTestConfig = NodeUnderTestConfig +defaultNodeUnderTestConfig nutcLedgerConfig nutcSecurityParam = + NodeUnderTestConfig + { nutcLedgerConfig + , nutcSecurityParam + , nutcMinOfferLead = Leios.MkLeiosMinOfferLead 2 + } -- | The peer address these tests use: a peer is just a number. newtype PeerAddr = PeerAddr Int @@ -132,7 +145,8 @@ withNodeUnderTest cfg nodeDBs leiosDb chainDBTracer body = (ChainDBImpl.openDB chainDbArgs) ChainDB.closeDB $ \chainDB -> withRegistry $ \kernelRegistry -> do - kernelArgs <- mkNodeKernelArgs cfg kernelRegistry chainDB leiosDb + btime <- mkBlockchainTime cfg kernelRegistry chainDB + kernelArgs <- mkNodeKernelArgs cfg kernelRegistry chainDB leiosDb btime kernel <- initNodeKernel kernelArgs body NodeUnderTest @@ -144,12 +158,28 @@ withNodeUnderTest cfg nodeDBs leiosDb chainDBTracer body = NTN.mkHandlers kernelArgs kernel TxSubmissionLogicV2 } --- | A slot clock that never knows the slot, which nothing the node under test --- does depends on: it neither forges nor votes, BlockFetch then simply stays in --- bulk-sync mode, and the LeiosFetch logic defaults to putting /every/ offer in --- its high-priority tier, ie oldest first. -stubBlockchainTime :: BlockchainTime (IOSim s) -stubBlockchainTime = BlockchainTime{getCurrentSlot = pure CurrentSlotUnknown} +-- | The node's slot clock, derived from the ledger as a real node's is. +-- +-- A stub that never knows the slot would do for everything else the node under +-- test does --- it neither forges nor votes --- but the LeiosNotify client +-- does not start until the immutable tip can forecast to the current slot, so +-- a peer's notifications would never be read. +mkBlockchainTime :: + NodeUnderTestConfig -> + ResourceRegistry (IOSim s) -> + ChainDB (IOSim s) Blk -> + IOSim s (BlockchainTime (IOSim s)) +mkBlockchainTime cfg registry chainDB = + hardForkBlockchainTime + HardForkBlockchainTimeArgs + { hfbtBackoffDelay = pure (BackoffDelay 1) + , hfbtGetLedgerState = ledgerState <$> ChainDB.getCurrentLedger chainDB + , hfbtLedgerConfig = configLedger (topLevelConfigOf cfg) + , hfbtRegistry = registry + , hfbtSystemTime = nutSystemTime + , hfbtTracer = nullTracer + , hfbtMaxClockRewind = 0 + } -- | The node, with no credentials: it neither forges nor votes, so a test only -- has to account for what it does with what the environment sends it. @@ -158,8 +188,9 @@ mkNodeKernelArgs :: ResourceRegistry (IOSim s) -> ChainDB (IOSim s) Blk -> LeiosDb.LeiosDbHandle (IOSim s) -> + BlockchainTime (IOSim s) -> IOSim s (NodeKernelArgs (IOSim s) PeerAddr () Blk) -mkNodeKernelArgs cfg registry chainDB leiosDB = do +mkNodeKernelArgs cfg registry chainDB leiosDB btime = do publicPeerSelectionStateVar <- makePublicPeerSelectionStateVar pure NodeKernelArgs @@ -167,7 +198,7 @@ mkNodeKernelArgs cfg registry chainDB leiosDB = do , registry , cfg = topLevelConfigOf cfg , featureFlags = mempty - , btime = stubBlockchainTime + , btime , systemTime = nutSystemTime , chainDB , initChainDB = \_ _ -> pure () @@ -182,12 +213,11 @@ mkNodeKernelArgs cfg registry chainDB leiosDB = do , miniProtocolParameters = defaultMiniProtocolParameters , blockFetchConfiguration = BlockFetchConfiguration - { -- The slot clock is stubbed, so the node is always in bulk-sync - -- mode; one peer at a time would let a peer that never answers - -- starve every other peer, and indefinitely: the environment - -- runs the mini-protocols without time limits, so nothing here - -- ever disconnects a peer that a real node would eventually - -- give up on. + { -- One peer at a time lets a peer that never answers starve every + -- other peer, and indefinitely: the environment runs the + -- mini-protocols without time limits, so nothing here ever + -- disconnects a peer that a real node would eventually give up + -- on. bfcMaxConcurrencyBulkSync = 4 , bfcMaxConcurrencyDeadline = 4 , bfcMaxRequestsInflight = 10 @@ -220,6 +250,7 @@ mkNodeKernelArgs cfg registry chainDB leiosDB = do , leiosDB , leiosTxCache = nullLeiosTxCache , leiosFetchRng = mkStdGen 4 + , leiosMinOfferLead = nutcMinOfferLead cfg } topLevelConfigOf :: NodeUnderTestConfig -> TopLevelConfig Blk diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs index ccc4f50a5b..b8006d5c95 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -32,19 +33,9 @@ import qualified Data.Map.Strict as Map import Data.Ratio ((%)) import qualified LeiosDemoDb as LeiosDb import qualified LeiosDemoLogic as Leios -import LeiosDemoTypes - ( BytesSize - , LeiosCert - , LeiosEb - , LeiosPoint (..) - , LeiosSeatId (..) - , RbHash (MkRbHash) - , TxHash - , Weight - , aggregateLeiosCert - ) +import LeiosDemoLogic.Announcements (ShouldRelay (..)) import LeiosDemoLogic.Announcements.ElBimap (ElId) -import LeiosDemoTypes (PeerId (..), offerings) +import LeiosDemoTypes (BytesSize, LeiosCert, LeiosEb, LeiosPoint (..), LeiosSeatId (..), PeerId (..), RbHash (MkRbHash), TxHash, Weight, aggregateLeiosCert, offerings) import LeiosValidClaims (isCertifiedEb, memberValidClaim, sizeValidClaims) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (slotLengthFromSec) @@ -76,9 +67,56 @@ tests = [ testCase "a forgotten CertRB is re-acquired and selected" test_forgottenCertRBIsSelectedAgain + , testCase + "a certified endorser block is fetched though a rival took the focus first" + test_certifiedRivalIsFetched , testCase "a peer claiming two certified endorser blocks for one election is dropped" test_twoCertificationClaimsIsDropped + , testCase + "a peer offering an endorser block it never announced is dropped" + (test_unannouncedOfferIsDropped (\peer -> offerEb peer endorserPoint endorserSize)) + , testCase + "a peer offering the closure of one it never announced is dropped" + (test_offerSequence PeerDropped (`offerEbTxs` endorserPoint)) + , testCase + "a peer offering one endorser block's body twice is dropped" + ( test_offerSequence PeerDropped $ \peer -> do + announceEb peer (getHeader announcer) + offerEb peer endorserPoint endorserSize + offerEb peer endorserPoint endorserSize + ) + , testCase + "a peer offering one endorser block's closure twice is dropped" + ( test_offerSequence PeerDropped $ \peer -> do + announceEb peer (getHeader announcer) + offerEbTxs peer endorserPoint + offerEbTxs peer endorserPoint + ) + , testCase + "a peer may offer a size no announcement claimed" + ( test_offerSequence PeerKept $ \peer -> do + announceEb peer (getHeader announcer) + offerEb peer endorserPoint (endorserSize + 1) + ) + , testCase + "a peer may offer the closure without offering the body" + ( test_offerSequence PeerKept $ \peer -> do + announceEb peer (getHeader announcer) + offerEbTxs peer endorserPoint + ) + , testCase + "a peer re-offering one the fetch logic already evicted is dropped" + test_reofferAfterEviction + , testCase + "every offer the node makes a peer follows its announcement to that peer" + test_offerFollowsAnnouncementPerPeer + , testCase + "an endorser block too near the immutable tip is not offered onward" + (test_offeredOnlyAboveTheLead DoNotRelay) + , testCase + "one far enough above it is" + (test_offeredOnlyAboveTheLead DoRelay) ] type Blk = LeiosTestBlock @@ -171,6 +209,40 @@ decoyCertRB = decoyChain :: [Blk] decoyChain = [decoyAnnouncer, decoyCertRB] +-- | An endorser block announced in slot 2 rather than slot 1. Since nothing +-- in these tests becomes immutable, that is the difference between being +-- inside 'nutcMinOfferLead' of the immutable tip and being clear of it. +freshEb :: LeiosEb +freshClosure :: [(TxHash, BS8.ByteString)] +freshSize :: BytesSize +(freshEb, freshClosure, freshSize) = mkLeiosTestEb [freshTx] + +-- | Writes where 'endorsedTx' does not, so this is a different endorser block. +freshTx :: LeiosTestTx +freshTx = + LeiosTestTx + { ltxAsserts = IntMap.singleton 2 Nothing + , ltxWrites = IntMap.singleton 2 'c' + } + +freshPoint :: LeiosPoint +freshPoint = leiosTestEbPoint 2 freshEb + +-- | 'freshEb' announced and then certified, on a fork of its own. The +-- announcing block is in slot 2, so it takes a block ahead of it to get +-- there. +freshChain :: [Blk] +freshChain = [freshRoot, freshAnnouncer, freshCertRB] + where + freshRoot = firstLeiosBlock 3 + freshAnnouncer = + announcing freshPoint freshSize $ + successorLeiosBlock freshRoot + freshCertRB = + certifying + (mkCert testCommittee (MkRbHash (toRawHash (Proxy @Blk) (blockHash freshAnnouncer)))) + (successorLeiosBlock freshAnnouncer) + -- | A chain that shares nothing with the announcer and carries no -- certificates, so the node can select it without needing any endorser block. betterChain :: [Blk] @@ -335,6 +407,60 @@ test_forgottenCertRBIsSelectedAgain = do (not (arRivalCertRbHeld after')) assertBool "so the rival is never certified" (not (arRivalCertified after')) +-- | The node offers an endorser block to its downstream peers only once the +-- endorser block's slot is 'nutcMinOfferLead' above the node's own immutable +-- tip, so that a peer whose immutable tip is a little ahead of ours does not +-- disconnect us for offering below it. +-- +-- Nothing here ever becomes immutable --- 'securityParam' sees to that --- so +-- the immutable tip stays at genesis and the lead alone decides. The endorser +-- block of 'announcer' is in slot 1, inside it; 'freshEb' is in slot 2, clear +-- of it. Either way the node acquires the endorser block, which is what makes +-- this a test of the relaying and not of the fetching. +test_offeredOnlyAboveTheLead :: ShouldRelay -> Assertion +test_offeredOnlyAboveTheLead shouldRelay = do + let simTrace = runSimTrace scenario + case traceResult False simTrace of + Left err -> + assertFailure $ + unlines $ + show err : lastN 60 (selectTraceEventsSay' simTrace) + Right heard -> + assertEqual + ("the node relays " <> show point <> "?") + (case shouldRelay of DoRelay -> True; DoNotRelay -> False) + (point `elem` heard) + where + (point, eb, closure, chain) = case shouldRelay of + DoNotRelay -> (endorserPoint, endorserBlock, endorserClosure, [announcer, certRB]) + DoRelay -> (freshPoint, freshEb, freshClosure, freshChain) + + scenario :: forall s. IOSim s [LeiosPoint] + scenario = do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + holder <- newPeerEnv + listener <- newPeerEnv + + (chainDBTracer, getTraces) <- recordingTracerTVar + + withNodeUnderTest nodeConfig nodeDBs leiosDb chainDBTracer $ \nut -> + withRegistry $ \registry -> do + connectPeer nut registry (PeerAddr 0) holder + connectPeer nut registry (PeerAddr 1) listener + + -- The one peer holds everything, so the node acquires the endorser + -- block and selects the chain that certifies it. + plantEb holder eb closure + serveChain holder $ chainOf chain + awaitWith getTraces "the certified chain is selected" $ + tipIsSTM nut (last chain) + + -- Whatever the node was going to say to the other peer, it has had + -- the chance to. + threadDelay 5 + heardOffers listener + -- | What the test measures of the restarted node. data AfterRestart = AfterRestart { arForgotten :: Bool @@ -343,6 +469,62 @@ data AfterRestart = AfterRestart , arRivalCertRbHeld :: Bool } +-- | An election whose focus is already on one endorser block must still end up +-- fetching the one a verified certificate names. +-- +-- The node sees the rival announcement first, so the election focuses on +-- 'decoyEb' and the later announcement of 'endorserBlock' --- same election --- +-- does not take the focus, and so does not list it either. Only the +-- certificate moves the focus, and by then something must already have listed +-- 'endorserBlock' as one to fetch, or the CertRB is parked forever. +-- +-- Today the CertRB's own roll-forward is what lists it, on the strength of a +-- claim nothing has verified yet. That is due to change, since an unverified +-- claim should not make us track an endorser block --- at which point the +-- listing has to come from the focus moving instead, and this test is what +-- says the endorser block is still fetched either way. +test_certifiedRivalIsFetched :: Assertion +test_certifiedRivalIsFetched = do + assertEqual + "the two announcements are for one election" + theElection + (headerElId (getHeader decoyAnnouncer)) + let simTrace = runSimTrace scenario + case traceResult False simTrace of + Right () -> pure () + outcome -> + assertFailure $ + unlines $ + ("expected the certified chain to be selected, but: " <> show outcome) + : lastN 40 (selectTraceEventsSay' simTrace) + where + scenario :: forall s. IOSim s () + scenario = do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + holder <- newPeerEnv + rival <- newPeerEnv + + (chainDBTracer, getTraces) <- recordingTracerTVar + + withNodeUnderTest nodeConfig nodeDBs leiosDb chainDBTracer $ \nut -> + withRegistry $ \registry -> do + connectPeer nut registry (PeerAddr 0) holder + connectPeer nut registry (PeerAddr 1) rival + + -- The rival's announcement is the first this election sees, so it is + -- the one the election focuses on. The rival never holds that + -- endorser block, so nothing ever certifies it. + serveChain rival $ chainOf [decoyAnnouncer] + awaitWith getTraces "the rival announcement is selected" $ + tipIsSTM nut decoyAnnouncer + + -- Only then the chain that announces and certifies the other one. + plantEb holder endorserBlock endorserClosure + serveChain holder $ chainOf ([announcer, certRB] <> afterCertRB) + awaitWith getTraces "the certified chain is selected" $ + tipIsSTM nut (last afterCertRB) + -- | A peer may claim a certificate for at most one endorser block per -- election, and the second claim costs it the connection. -- @@ -390,6 +572,163 @@ test_twoCertificationClaimsIsDropped = do serveChainThrough peer GenesisPoint $ chainOf [decoyAnnouncer, decoyCertRB] threadDelay 30 +-- | A peer may offer over LeiosNotify only an endorser block it has itself +-- announced there. The size it names is its own business, and its body offer +-- and closure offer are independent, but neither may be sent for something it +-- never announced. +-- +-- This peer serves no chain at all and says one thing: the offer. Since it +-- never announced the endorser block, that alone must cost it the connection. +test_unannouncedOfferIsDropped :: + (forall s. PeerEnv (IOSim s) -> IOSim s ()) -> Assertion +test_unannouncedOfferIsDropped = test_offerSequence PeerDropped + +-- | Requesting an endorser block's body evicts the offer that prompted it, so +-- the fetch logic's per-peer offers cannot say what a peer has already +-- offered us. +-- +-- Which is why the peer's offers are remembered beside its announcements, in +-- the LeiosNotify client: an offer it repeats after that eviction still costs +-- it the connection. This test waits for the eviction before repeating it. +test_reofferAfterEviction :: Assertion +test_reofferAfterEviction = do + let simTrace = runSimTrace scenario + case traceResult False simTrace of + Left (FailureException e) | isInvalidOffer e -> pure () + outcome -> + assertFailure $ + unlines $ + ("expected the peer to be dropped, but: " <> show outcome) + : lastN 40 (selectTraceEventsSay' simTrace) + where + isInvalidOffer :: SomeException -> Bool + isInvalidOffer e + | Just (ExceptionInLinkedThread _ inner) <- fromException e = + isInvalidOffer inner + | Just (_ :: Leios.ExnLeiosInvalidOffer) <- fromException e = True + | otherwise = False + + scenario :: forall s. IOSim s () + scenario = do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + peer <- newPeerEnv + + (chainDBTracer, getTraces) <- recordingTracerTVar + + withNodeUnderTest nodeConfig nodeDBs leiosDb chainDBTracer $ \nut -> + withRegistry $ \registry -> do + connectPeer nut registry (PeerAddr 0) peer + + -- The announcement focuses the election, so the body offer is one the + -- node acts on: it asks this peer for the body --- which this peer + -- never plants, so the request stays outstanding --- and drops the + -- offer that prompted it. + announceEb peer (getHeader announcer) + offerEb peer endorserPoint endorserSize + awaitPollingWith getTraces "the body offer is recorded" $ + ebOfferedBy nut (PeerAddr 0) endorserPoint + awaitPollingWith getTraces "and then evicted" $ + not <$> ebOfferedBy nut (PeerAddr 0) endorserPoint + + offerEb peer endorserPoint endorserSize + threadDelay 30 + +-- | A peer that joins after we relayed an announcement must not then be sent +-- an offer of that endorser block: by the rule this node itself enforces, an +-- offer that its announcement did not precede costs the sender the connection. +-- +-- The node relays the announcement while only the holder is connected, so the +-- listener misses it, and only then does the endorser block become available +-- to fetch --- which is what sets the offer going after the listener has +-- joined. It uses 'freshEb' rather than the slot-1 one, since only an endorser +-- block clear of 'nutcMinOfferLead' is offered onward at all. +test_offerFollowsAnnouncementPerPeer :: Assertion +test_offerFollowsAnnouncementPerPeer = do + let simTrace = runSimTrace scenario + case traceResult False simTrace of + Right unannounced -> + assertEqual "offers the node made without announcing first" [] unannounced + outcome -> + assertFailure $ + unlines $ + ("expected the run to finish, but: " <> show outcome) + : lastN 40 (selectTraceEventsSay' simTrace) + where + scenario :: forall s. IOSim s [LeiosPoint] + scenario = do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + holder <- newPeerEnv + listener <- newPeerEnv + + (chainDBTracer, getTraces) <- recordingTracerTVar + + withNodeUnderTest nodeConfig nodeDBs leiosDb chainDBTracer $ \nut -> + withRegistry $ \registry -> do + -- The holder alone is connected while the node learns of, and relays, + -- the announcement. It withholds the endorser block itself. + connectPeer nut registry (PeerAddr 0) holder + serveChain holder $ chainOf freshChain + awaitPollingWith getTraces "the announcement has been processed" $ + ebOfferedBy nut (PeerAddr 0) freshPoint + + -- Only now does the listener join, so the announcement is behind it. + connectPeer nut registry (PeerAddr 1) listener + threadDelay 5 + + -- And only now can the node acquire the body, which is what makes it + -- /consider/ offering the endorser block onward. + plantEb holder freshEb freshClosure + awaitWith getTraces "the certified chain is selected" $ + tipIsSTM nut (last freshChain) + threadDelay 5 + + heardUnannouncedOffers listener + +-- | Whether the peer survives what it said over LeiosNotify. +data OfferOutcome = PeerDropped | PeerKept + deriving Show + +-- | Run a peer that says only what the given action queues, and check whether +-- that costs it the connection. +-- +-- The peer serves no chain at all, so everything the node knows of it came +-- over LeiosNotify. +test_offerSequence :: + OfferOutcome -> (forall s. PeerEnv (IOSim s) -> IOSim s ()) -> Assertion +test_offerSequence expected saysIt = do + let simTrace = runSimTrace scenario + case (expected, traceResult False simTrace) of + (PeerDropped, Left (FailureException e)) | isInvalidOffer e -> pure () + (PeerKept, Right ()) -> pure () + (_, outcome) -> + assertFailure $ + unlines $ + ("expected " <> show expected <> ", but: " <> show outcome) + : lastN 40 (selectTraceEventsSay' simTrace) + where + isInvalidOffer :: SomeException -> Bool + isInvalidOffer e + | Just (ExceptionInLinkedThread _ inner) <- fromException e = + isInvalidOffer inner + | Just (_ :: Leios.ExnLeiosInvalidOffer) <- fromException e = True + | otherwise = False + + scenario :: forall s. IOSim s () + scenario = do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + peer <- newPeerEnv + + (chainDBTracer, _getTraces) <- recordingTracerTVar + + withNodeUnderTest nodeConfig nodeDBs leiosDb chainDBTracer $ \nut -> + withRegistry $ \registry -> do + connectPeer nut registry (PeerAddr 0) peer + saysIt peer + threadDelay 30 + {------------------------------------------------------------------------------- Watching the node -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs index 753110bfea..1e30e521b7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs @@ -149,6 +149,10 @@ type CompletedEbs = [LeiosPoint] -- 'TxLocation' in another EB. See 'writeEbBody'. type LocalFill = (TxOffset, TxLocation) +-- | What we have just stored. +-- +-- Whether a peer hears about it is the LeiosNotify server's decision, not the +-- database's; see @Leios.leiosOfferRelayDecision@. data LeiosEbNotification = AcquiredEb LeiosPoint BytesSize | AcquiredEbTxs LeiosPoint diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs index 0a700cf8e3..df4f4f58dd 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs @@ -293,7 +293,7 @@ imInsertEbBody stateVar notificationChan point eb fills = do then do modifyTVar stateVar $ \s -> s{imCompletedEbs = Set.insert point (imCompletedEbs s)} - writeTChan notificationChan (AcquiredEbTxs point) + writeTChan notificationChan $ AcquiredEbTxs point pure [point] else pure [] pure (completed, IntMap.keys accepted) @@ -362,7 +362,7 @@ imInsertTxs stateVar notificationChan point offBytes = atomically $ do -- Emit a closure-completion notification for each newly-complete EB. The -- ChainDB subscribes to these to grow the acquired-EB-closures set it owns. forM_ completed $ \p -> - writeTChan notificationChan (AcquiredEbTxs p) + writeTChan notificationChan $ AcquiredEbTxs p pure completed -- | Implements 'scanCompleteEbClosuresNotOlderThanSlot': the already-completed EBs diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs index e889d2e8ff..fde6509c4d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs @@ -168,7 +168,11 @@ newLeiosDBSQLite tracer volLeiosDbPath immLeiosDbPath = -- | 'newLeiosDBSQLite' with an explicit GC sweep batch size: how many EBs -- the writer evicts per turn, between the jobs it serves. newLeiosDBSQLiteWithGcBatchSize :: - Tracer IO TraceLeiosDb -> FilePath -> FilePath -> Int64 -> IO (LeiosDbHandle IO) + Tracer IO TraceLeiosDb -> + FilePath -> + FilePath -> + Int64 -> + IO (LeiosDbHandle IO) newLeiosDBSQLiteWithGcBatchSize tracer volLeiosDbPath immLeiosDbPath gcBatchSize = do -- The database opens before whoever owns these directories creates them. mapM_ (createDirectoryIfMissing True . takeDirectory) [volLeiosDbPath, immLeiosDbPath] @@ -1193,7 +1197,8 @@ startWriter tracer statsVar notificationChan sweepDoorbell gcBatchSize volPath i sealedVar <- newTVarIO Nothing sweepStateVar <- newTVarIO SweepIdle jobsServedVar <- newTVarIO (0 :: Int) - let notify = atomically . writeTChan notificationChan + let notify :: LeiosEbNotification -> IO () + notify = atomically . writeTChan notificationChan -- Statements before connections; an open statement holds the close off. closeConnections = do @@ -1572,7 +1577,7 @@ sqlInsertEbBody tracer conn notify point eb fills = do else pure [] pure (completed, reverse filledOffs) notify $ AcquiredEb point ebBytesSize - forM_ completedNow $ \p -> notify (AcquiredEbTxs p) + forM_ completedNow $ notify . AcquiredEbTxs pure (completedNow, filledOffs) where ebHashRaw = ebHashBytes point.pointEbHash @@ -1650,7 +1655,7 @@ sqlInsertTxs _tracer conn notify point offBytes = do dbStep1 stMarkPointNotified pure [MkLeiosPoint slot point.pointEbHash | slot <- completedSlots] -- Emit a closure-completion notification for each completed EB - forM_ completed $ \p -> notify (AcquiredEbTxs p) + forM_ completed $ notify . AcquiredEbTxs pure completed where Conn{connVolStmts} = conn diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs index 0ff97d19fd..b00145d8ff 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs @@ -1,8 +1,10 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} @@ -13,7 +15,7 @@ module LeiosDemoLogic (module LeiosDemoLogic) where -import Cardano.Slotting.Slot (SlotNo (..)) +import Cardano.Slotting.Slot (SlotNo (..), withOrigin) import Control.Concurrent.Class.MonadMVar (MVar) import qualified Control.Concurrent.Class.MonadMVar as MVar import Control.Concurrent.Class.MonadSTM.Strict (StrictTVar) @@ -65,6 +67,8 @@ import LeiosDemoLogic.Announcements , ShouldRelay (..) , TraceLeiosNotifyEvent (..) , TraceLeiosNotifyPeerEvent (..) + , announcementsInSlot + , emptyPeerState , prunePeerState ) import qualified LeiosDemoLogic.Announcements as Announcements @@ -75,10 +79,8 @@ import LeiosDemoLogic.Announcements.Validate ) import qualified LeiosDemoOnlyTestFetch as LF import LeiosDemoTypes - ( AlsoOfferedTxsClosure (..) - , AnnouncementEquivocation (..) + ( AnnouncementEquivocation (..) , AnnouncementFields (..) - , announcementLeiosPoint , AnnouncementSource (..) , BytesSize , EbHash (..) @@ -97,6 +99,8 @@ import LeiosDemoTypes , TraceLeiosKernel (..) , TraceLeiosPeer (..) , TxHash (..) + , WhetherTxsClosureOffered (..) + , announcementLeiosPoint , encodeLeiosEbSize , fetchArrivalEvicted , fetchArrivalExtra @@ -170,16 +174,14 @@ traceException tracer toTrace action = -- slot, the announcing RB header's hash, and the announced EB hash. Evicted -- bodies\/txs are discarded; they can be useful for debugging/etc. recordAnnouncementInTxCache :: - forall blk m. - (ConvertRawHash blk, HasHeader (Header blk), IOLike m) => + IOLike m => LeiosTxCache m () () SerializedEbBody -> - AnnouncingHeader blk -> + -- | The announcing block's hash. + RbHash -> LeiosPoint -> m () -recordAnnouncementInTxCache txCache ancHdr point = +recordAnnouncementInTxCache txCache rbh point = void $ txCache.insertAnnouncement point.pointSlotNo rbh point.pointEbHash - where - rbh = MkRbHash (toRawHash (Proxy @blk) (headerHash (ancHeader ancHdr))) -- | Register a locally-forged EB in the tx-cache: its announcement, its -- body, and each of its txs as already-applied (the forger drew them from its @@ -369,7 +371,7 @@ leiosFetchLogicIteration :: -- | The current slot, or 'Nothing' when it is not yet known (i.e. we are -- syncing), in which case we fetch freshest-last instead of freshest-first. Maybe SlotNo -> - Map (PeerId pid) (Map LeiosPoint AlsoOfferedTxsClosure) -> + Map (PeerId pid) (Map LeiosPoint Leios.PeerOffer) -> -- | Which peers are big-ledger peers (a peer absent from this map is treated as -- 'IsNotBigLedgerPeer'). Map (PeerId pid) IsBigLedgerPeer -> @@ -382,7 +384,8 @@ leiosFetchLogicIteration :: leiosFetchLogicIteration env mbCurrentSlot offerings bigLedgerPeers = \acc0 -> -- One pass per peer. Bodies and tx-closure jobs compete on equal footing, -- ranked by each EB's slot in 'ebState' (its greatest announcement slot), so - -- the freshest EBs are fetched first regardless of which half they still need. + -- the freshest EBs are fetched first whether it is the body or the closure + -- they still need. -- Each peer's 'assignPeer' yields only its own requests and dead offers; fold -- those into the per-peer maps here. Map.foldlWithKey' @@ -465,7 +468,7 @@ assignPeer :: Maybe SlotNo -> IsBigLedgerPeer -> PeerId pid -> - Map LeiosPoint AlsoOfferedTxsClosure -> + Map LeiosPoint Leios.PeerOffer -> LeiosOutstanding pid -> (LeiosOutstanding pid, Seq LeiosFetchRequest, Set LeiosPoint) assignPeer env mbCurrentSlot isBig peerId offers acc = @@ -497,52 +500,58 @@ assignPeer env mbCurrentSlot isBig peerId offers acc = -- imm-tip). This is an ephemeral state, mid prune, but go ahead and -- prune it now. pruneThisOffer - Just (Leios.MkEbState slot _onset fetchState0) -> case (fetchState0, offerKind) of + Just (Leios.MkEbState slot _onset fetchState) -> case (fetchState, Leios.poClosure offerKind) of (Leios.BodyImminent, _) -> -- Our forge is producing this EB, so we hold the whole datum (even -- though it might not be inserted yet): never request it, and the -- peer's offer is dead. pruneThisOffer - (Leios.NoBody, TxsClosureNotAlsoOffered) -> + (Leios.NoBody, TxsClosureNotOffered) -> -- Body-only offer: request the body. If that's all that was -- offered, prune it. - let (acc2, dec2) = assignBody peerId ebHash slot (acc1, dec1) + let (acc2, dec2) = assignBody peerId ebHash slot offerKind (acc1, dec1) in (acc2, dec2, Set.insert point drops) - (Leios.NoBody, TxsClosureAlsoOffered) -> + (Leios.NoBody, TxsClosureOffered) -> -- Request the body now, but keep the offer: we will request the -- closure from this peer once we hold the body. - let (acc2, dec2) = assignBody peerId ebHash slot (acc1, dec1) + let (acc2, dec2) = assignBody peerId ebHash slot offerKind (acc1, dec1) in (acc2, dec2, drops) - (Leios.BodyAcquired jobPool, kind) -> haveBody jobPool kind + (Leios.BodyAcquired _jobPool, TxsClosureNotOffered) -> + -- We hold the body and the peer never offered the closure, so it can + -- no longer help. + pruneThisOffer + (Leios.BodyAcquired jobPool, TxsClosureOffered) + | Jobs.nullLeiosJobPool jobPool -> + -- whole datum in hand: the closure offer is useless now too + pruneThisOffer + | otherwise -> + -- Still need the txs, and the peer offered the closure. If we just + -- now assign all remaining jobs to the peer, prune its offer. + let ((acc2, dec2), MkWhetherPeerEbExhausted exhausted) = + assignClosure env isBig peerId ebHash (acc1, dec1) + in (acc2, dec2, if not exhausted then drops else Set.insert point drops) where ebHash = point.pointEbHash - haveBody _jobPool TxsClosureNotAlsoOffered = - -- We hold the body and the peer never offered the closure, so it can no - -- longer help. - pruneThisOffer - haveBody jobPool TxsClosureAlsoOffered - | Jobs.nullLeiosJobPool jobPool = - -- whole datum in hand: the closure offer is useless now too - pruneThisOffer - | otherwise = - -- Still need the txs, and the peer offered the closure. If we just now - -- assign all remaining jobs to the peer, prune its offer. - let ((acc2, dec2), MkWhetherPeerEbExhausted exhausted) = - assignClosure env isBig peerId ebHash (acc1, dec1) - in (acc2, dec2, if not exhausted then drops else Set.insert point drops) - pruneThisOffer = (acc1, dec1, Set.insert point drops) --- | Request the EB body from this peer +-- | Request the EB body from this peer, if the peer offered the body and +-- offered it at the size we are pursuing. +-- +-- A peer that offered some other size holds a different endorser block than +-- the one we are after --- at most one size for a hash is the truth --- so +-- asking it would only earn us a body that fails 'processLeiosBlock''s size +-- check. Its offer is left in place rather than dropped, since a later focus +-- change could make it the one we want. assignBody :: Ord pid => PeerId pid -> EbHash -> SlotNo -> + Leios.PeerOffer -> (LeiosOutstanding pid, Seq LeiosFetchRequest) -> (LeiosOutstanding pid, Seq LeiosFetchRequest) -assignBody peerId ebHash slot st@(acc, dec) +assignBody peerId ebHash slot offer st@(acc, dec) | peerId `Set.member` Map.findWithDefault Set.empty ebHash (Leios.requestedEbPeers acc) = -- unless we've already requested it from them st @@ -552,15 +561,17 @@ assignBody peerId ebHash slot st@(acc, dec) -- another ephemeral case where 'ebState' has been pruned before the -- offers have st - Just size -> - let acc' = - acc - { Leios.requestedEbPeers = - Map.insertWith Set.union ebHash (Set.singleton peerId) (Leios.requestedEbPeers acc) - , Leios.requestedBytesSizePerPeer = - Map.insertWith (+) peerId size (Leios.requestedBytesSizePerPeer acc) - } - in (acc', dec Seq.|> LeiosBlockRequest (MkLeiosBlockRequest (MkLeiosPoint slot ebHash) size)) + Just size + | Leios.poOfferedBody offer /= SJust size -> st + | otherwise -> + let acc' = + acc + { Leios.requestedEbPeers = + Map.insertWith Set.union ebHash (Set.singleton peerId) (Leios.requestedEbPeers acc) + , Leios.requestedBytesSizePerPeer = + Map.insertWith (+) peerId size (Leios.requestedBytesSizePerPeer acc) + } + in (acc', dec Seq.|> LeiosBlockRequest (MkLeiosBlockRequest (MkLeiosPoint slot ebHash) size)) -- | Flag indicating whether all jobs matching a peer's offers are already -- inflight @@ -1499,65 +1510,62 @@ processLeiosBlockTxs ktracer tracer (outstandingVar, readyVar) txCache writer sy ----- --- | Record an offered EB body: mark it as something to fetch and mark the peer --- as a serving candidate, then wake the fetch logic. Shared by the explicit --- 'MsgLeiosBlockOffer' handler and by the CertRB roll-forward path in --- 'checkMsgRollForwardForLeiosOffers'. +-- | Record this peer's 'MsgLeiosBlockOffer': it can serve this endorser +-- block's body, at this size. -- --- The body is /not/ added to 'missingEbBodies' if it is: too old (older than has already been pruned), already held (per --- 'ebStateHasBody' — the only "do we have it" test now, read in-lock with no --- cache lookup), already listed under this content hash, or zero-sized. Unless it --- is too old or zero-sized, the offer slot is folded into 'ebState' regardless. --- The offered size is not chain-authoritative (there are no EB announcements --- yet), so refusing to overwrite an existing same-hash entry makes the first-seen --- (slot, size) win, and a zero-sized offer — which no honest forger produces — is --- dropped. The per-peer offerings are updated regardless, so the peer stays a --- serving candidate. +-- This does not list the body as one to fetch. The offer is already gated on +-- an announcement from this peer, so it says nothing about what exists that +-- the announcement did not; what we pursue is seeded by announcements and by +-- CertRB roll-forwards ('recordCertRbOffer'). recordEbBodyOffer :: IOLike m => - ( MVar m (LeiosOutstanding pid) - , MVar m () - ) -> + MVar m () -> LeiosPeerVars m -> - AlsoOfferedTxsClosure -> -- | The offered EB: its point and on-the-wire body size. (LeiosPoint, BytesSize) -> m () -recordEbBodyOffer (outstandingVar, readyVar) peerVars offeredClosure (point, ebBytesSize) = do - let MkLeiosPoint ebSlot ebHash = point - MVar.modifyMVar_ outstandingVar $ \outstanding -> - pure $! - let tooOld = ebSlot < Leios.acquiredEbBodiesPrunedSlot outstanding -- too old to fetch - malformed = ebBytesSize == 0 -- malformed offer - -- Offers are currently trusted, so this is evidence that the EB is - -- announced in this slot; fold it into 'ebState' regardless of whether - -- we go on to list the body for fetching. - -- - -- TODO stop that, once offers are no longer trusted - outstanding' - | tooOld || malformed = outstanding - | otherwise = Leios.recordMaxAnnouncementSlot ebHash ebSlot SNothing outstanding - skip = - tooOld - || malformed - || maybe False Leios.ebStateHasBody (Map.lookup ebHash (Leios.ebState outstanding)) -- already have it - || Map.member ebHash (Leios.reverseSlotIndexByEbHash outstanding) -- already listed - in if skip - then outstanding' - else - outstanding' - { Leios.missingEbBodies = - Map.insert point ebBytesSize (Leios.missingEbBodies outstanding') - , Leios.reverseSlotIndexByEbHash = - Map.insertWith - NESet.union - ebHash - (NESet.singleton ebSlot) - (Leios.reverseSlotIndexByEbHash outstanding') - } +recordEbBodyOffer readyVar peerVars (point, ebBytesSize) = + recordOffer readyVar peerVars point $ + Leios.MkPeerOffer (SJust ebBytesSize) TxsClosureNotOffered + +-- | Record this peer's 'MsgLeiosBlockTxsOffer': it can serve this endorser +-- block's tx closure. +-- +-- Independent of the body offer, and carrying no size: closure jobs are per +-- endorser block and only assigned once we hold the body, so a bare point +-- names its closure unambiguously. +recordEbClosureOffer :: + IOLike m => MVar m () -> LeiosPeerVars m -> LeiosPoint -> m () +recordEbClosureOffer readyVar peerVars point = + recordOffer readyVar peerVars point $ + Leios.MkPeerOffer SNothing TxsClosureOffered + +-- | Record a CertRB roll-forward as an offer of both the body and the +-- closure. +-- +-- Its point and size are read out of the announcing block's chain-dep state, +-- so the peer chose which block to roll forward but not what that block's +-- predecessor announced. It still only /offers/: the claim that this endorser +-- block is certified has not been verified yet, and an unverified claim must +-- not be able to make us track an endorser block. What we track comes from the +-- announcement that takes the election's focus, and from the focus moving once +-- the certificate is verified. +recordCertRbOffer :: + IOLike m => + MVar m () -> + LeiosPeerVars m -> + -- | The offered EB: its point and on-the-wire body size. + (LeiosPoint, BytesSize) -> + m () +recordCertRbOffer readyVar peerVars (point, ebBytesSize) = + recordOffer readyVar peerVars point $ + Leios.MkPeerOffer (SJust ebBytesSize) TxsClosureOffered + +recordOffer :: + IOLike m => MVar m () -> LeiosPeerVars m -> LeiosPoint -> Leios.PeerOffer -> m () +recordOffer readyVar peerVars point offer = do MVar.modifyMVar_ (Leios.offerings peerVars) $ \offers -> - -- store the offer as-is; 'mergeOffer' keeps the closure if either offer had it - pure $! Map.insertWith Leios.mergeOffer point offeredClosure offers + pure $! Map.insertWith (<>) point offer offers void $ MVar.tryPutMVar readyVar () ----- @@ -1596,10 +1604,9 @@ checkMsgRollForwardForLeiosOffers kernelVars peerVars hdr cds = peerVars (announcementElection fields) (announcementEbHash fields) - recordEbBodyOffer - kernelVars + recordCertRbOffer + (snd kernelVars) peerVars - TxsClosureAlsoOffered (announcementLeiosPoint fields, announcementEbBodySize fields) -- | Count this peer's claim that an endorser block is certified for an @@ -1735,7 +1742,7 @@ processAnnouncementCentrally ForgedLocally -> markForged ReceivedViaChainSync -> recordAnnounced ReceivedViaLeiosNotify -> recordAnnounced - recordAnnouncementInTxCache txCache ancHdr point + recordAnnouncementInTxCache txCache announcerRbHash point ) cst source @@ -1747,6 +1754,7 @@ processAnnouncementCentrally -- The announced EB's slot is the announcing header's own slot (see -- 'headerLeiosAnnouncement'); its ebHash is kept in 'ancAnnouncementFields'. point = MkLeiosPoint (blockSlot (ancHeader ancHdr)) (announcementEbHash fields) + announcerRbHash = MkRbHash (toRawHash (Proxy @blk) (headerHash (ancHeader ancHdr))) recordAnnounced = recordAnnouncedEb kernelVars onset fields markForged = MVar.modifyMVar_ (fst kernelVars) $ @@ -1766,6 +1774,34 @@ deriving instance Show ExnInvalidLeiosAnnouncement instance Exception ExnInvalidLeiosAnnouncement +-- | Thrown when a peer offers an endorser block over LeiosNotify that it never +-- announced, that it has already offered, or that is too old to check; the +-- ensuing thread death disconnects it. +-- +-- Without this requirement, peers could send bogus offers, and there are +-- infinitely many of those. +data ExnLeiosInvalidOffer + = -- | A body offer of an endorser block this peer never announced, with the + -- size it claimed. + ExnLeiosBlockOfferWithoutAnnouncement !LeiosPoint !BytesSize + | -- | A closure offer for an endorser block this peer never announced. + ExnLeiosClosureOfferWithoutAnnouncement !LeiosPoint + | -- | A second offer of the body, or of the closure, this peer has already + -- offered. The two are independent, so each may be offered once. + ExnLeiosRepeatedOffer !LeiosPoint !OfferedBodyOrClosure + | -- | An offer below the slot we have pruned this peer's announcements to, + -- which is therefore unanswerable on its own terms: the offered point, + -- and that slot. See 'leiosOfferRelayDecision' for why an honest peer + -- does not reach it. + ExnLeiosOfferTooOld !LeiosPoint !SlotNo + deriving Show + +instance Exception ExnLeiosInvalidOffer + +-- | Which of a point's two independent offers a LeiosNotify message makes. +data OfferedBodyOrClosure = OfferedBody | OfferedClosure + deriving (Eq, Show) + -- | Thrown when a peer relays a 'MsgLeiosBlockAnnouncement' whose header carries -- no EB announcement (so 'mkAnnouncingHeader' returns 'Nothing'); the ensuing thread -- death disconnects the peer. @@ -1899,8 +1935,15 @@ recordAnnouncedEb (outstandingVar, readyVar) onset fields = do | otherwise = Leios.focusElectionIfUnfocused elId ebHash $ Leios.recordMaxAnnouncementSlot ebHash ebSlot onset outstanding + -- Only the announcement that takes the election's focus lists a body: + -- one candidate per election, which is what bounds 'missingEbBodies'. + -- A later announcement for an already-focused election is recorded but + -- not pursued, and a certificate that moves the focus lists its own + -- through 'checkMsgRollForwardForLeiosOffers'. + tookFocus = not $ Map.member elId (Leios.elFocus outstanding) skip = tooOld + || not tookFocus || maybe False Leios.ebStateHasBody (Map.lookup ebHash (Leios.ebState outstanding)) -- already have it || Map.member ebHash (Leios.reverseSlotIndexByEbHash outstanding) -- already listed !outstanding'' @@ -1918,17 +1961,131 @@ recordAnnouncedEb (outstandingVar, readyVar) onset fields = do } in (outstanding'', not skip) -prunePeerStateToImmTip :: +-- | What one LeiosNotify client remembers about its upstream peer. +-- +-- The announcements and the offers are pruned together, by the announcement +-- handler, which is the only thing that ever adds an announcement --- and +-- offers are gated on announcements, so neither can grow between prunes. +data LeiosNotifyPeerState blk = MkLeiosNotifyPeerState + { lnpsPruneSlot :: !SlotNo + -- ^ The slot the announcements and the offers have been pruned up to. + , lnpsAnnouncements :: !(PeerState (AnnouncingHeader blk)) + -- ^ What this peer has announced, for dedup and equivocation counting. + , lnpsOffers :: !(Map LeiosPoint Leios.PeerOffer) + -- ^ Whether this peer has offered the body, the closure, or both, for each + -- point, so that repeating either costs it the connection. + -- + -- Kept here rather than read back out of 'offerings', which the fetch logic + -- evicts from as soon as it acts on an offer. + } + +emptyLeiosNotifyPeerState :: LeiosNotifyPeerState blk +emptyLeiosNotifyPeerState = + MkLeiosNotifyPeerState + { lnpsPruneSlot = SlotNo 0 + , lnpsAnnouncements = emptyPeerState + , lnpsOffers = Map.empty + } + +pruneLeiosNotifyPeerStateToImmTip :: LedgerSupportsProtocol blk => ExtLedgerState blk EmptyMK -> - SlotNo -> - PeerState anc -> - (SlotNo, PeerState anc) -prunePeerStateToImmTip immLedger latestPruneSlot peerSt = + LeiosNotifyPeerState blk -> + LeiosNotifyPeerState blk +pruneLeiosNotifyPeerStateToImmTip immLedger peerSt = case getTipSlot (ledgerState immLedger) of NotOrigin immTipSlot - | latestPruneSlot < immTipSlot -> (immTipSlot, prunePeerState immTipSlot peerSt) - _ -> (latestPruneSlot, peerSt) + | lnpsPruneSlot peerSt < immTipSlot -> + MkLeiosNotifyPeerState + { lnpsPruneSlot = immTipSlot + , lnpsAnnouncements = prunePeerState immTipSlot (lnpsAnnouncements peerSt) + , lnpsOffers = + -- 'LeiosPoint' orders slot-first, so the below-tip points are + -- a prefix. + snd $ + Map.spanAntitone + (\(MkLeiosPoint slot _ebHash) -> slot < immTipSlot) + (lnpsOffers peerSt) + } + _ -> peerSt + +-- | Accept a peer's 'MsgLeiosBlockOffer', or say why the peer must go. +-- +-- A peer may offer only an endorser block it has itself announced. That is +-- what stops an offer from being an independent way to make us track an +-- endorser block, outside the two-per-election cap 'extendLive' puts on +-- announcements. +-- +-- Only the point is held to the announcements; the size is free. An offer +-- claims to hold a body, and whoever holds a body knows its size, so a peer may +-- well state a size that no announcement we received claimed --- for one it +-- came by through the Recovery Path, say. Nothing downstream /trusts/ the size: +-- it only filters which offers are relevant to our acquisition of an EB of some +-- specific size (see 'assignBody'). +-- +-- Below the slot we have pruned this peer's announcements to there is nothing +-- left to check the offer against, and the offer is useless to us besides, +-- since the fetch logic prunes to the immutable tip too. See +-- 'leiosOfferRelayDecision' for why an honest peer won't send offers that are +-- older than our imm tip. +checkLeiosBlockOffer :: + LeiosPoint -> + BytesSize -> + LeiosNotifyPeerState blk -> + Either ExnLeiosInvalidOffer (LeiosNotifyPeerState blk) +checkLeiosBlockOffer point claimed peerSt + | ebSlot < lnpsPruneSlot peerSt = + Left $ ExnLeiosOfferTooOld point (lnpsPruneSlot peerSt) + | SJust{} <- Leios.poOfferedBody seen = Left $ ExnLeiosRepeatedOffer point OfferedBody + | not (announcedIt point peerSt) = + Left $ ExnLeiosBlockOfferWithoutAnnouncement point claimed + | otherwise = + Right + peerSt + { lnpsOffers = + Map.insert + point + seen{Leios.poOfferedBody = SJust claimed} + (lnpsOffers peerSt) + } + where + ebSlot = pointSlotNo point + seen = Map.findWithDefault mempty point (lnpsOffers peerSt) + +-- | Whether this peer has announced this endorser block. +announcedIt :: LeiosPoint -> LeiosNotifyPeerState blk -> Bool +announcedIt point peerSt = + any + (\ancHdr -> announcementEbHash (ancAnnouncementFields ancHdr) == pointEbHash point) + (announcementsInSlot (pointSlotNo point) (lnpsAnnouncements peerSt)) + +-- | Accept a peer's 'MsgLeiosBlockTxsOffer', or say why the peer must go. +-- +-- Held to the same announcement as the body offer and otherwise independent of +-- it: either may arrive first, or alone. So a LeiosNotify server never has to +-- track what it has already offered a peer in order to synthesise a body offer +-- ahead of a closure offer. +checkLeiosClosureOffer :: + LeiosPoint -> + LeiosNotifyPeerState blk -> + Either ExnLeiosInvalidOffer (LeiosNotifyPeerState blk) +checkLeiosClosureOffer point peerSt + | pointSlotNo point < lnpsPruneSlot peerSt = + Left $ ExnLeiosOfferTooOld point (lnpsPruneSlot peerSt) + | TxsClosureOffered <- Leios.poClosure seen = + Left $ ExnLeiosRepeatedOffer point OfferedClosure + | not (announcedIt point peerSt) = Left $ ExnLeiosClosureOfferWithoutAnnouncement point + | otherwise = + Right + peerSt + { lnpsOffers = + Map.insert + point + seen{Leios.poClosure = TxsClosureOffered} + (lnpsOffers peerSt) + } + where + seen = Map.findWithDefault mempty point (lnpsOffers peerSt) -- | The just-counted announcement's fields, and whether it equivocates a prior -- header announcing the same election. @@ -1985,6 +2142,60 @@ maxAnnouncementAgeSend = 300 -- 5 minutes maxAnnouncementAgeRecv :: NominalDiffTime maxAnnouncementAgeRecv = 600 -- 10 minutes +-- | Whether an endorser block of this slot is fresh enough to offer to our +-- peers: offer it only while its slot is this many slots younger than our own +-- immutable tip. +-- +-- The LeiosNotify server consults this for each notification it is about to +-- turn into an offer. Reads the immutable tip, which moves, so the same slot +-- can answer differently over time. +-- +-- The receiving peer disconnects us for offering an endorser block below /its/ +-- immutable tip, and each side compares the offered slot against its own +-- immutable tip, so no clock enters into it. That leaves a whole +-- 'leiosMinOfferLead' of room: we only lose a peer once its immutable tip is +-- that far ahead of ours. Keeping back what our own tip has nearly reached is +-- what bounds the wavefront of an endorser block an adversary withheld and then +-- released at just the most dangerous moment that would cost honest relayers +-- the most connections. +-- +-- The Recovery Path is the backstop, which allows a nodes to (eventually) offer +-- these otherwise-unofferable EBs (which were likely withheld by an adversarial +-- issuer, if they're still diffusing when /almost/ as old as the imm tip). +leiosOfferRelayDecision :: + IOLike m => + LeiosMinOfferLead -> + -- | the /immutable/ tip's slot + StrictSTM.STM m (WithOrigin SlotNo) -> + -- | the offered endorser block's slot + SlotNo -> + StrictSTM.STM m ShouldRelay +leiosOfferRelayDecision (MkLeiosMinOfferLead minLead) readImmTipSlot slot = do + immTipSlot <- withOrigin (SlotNo 0) id <$> readImmTipSlot + pure $ if unSlotNo slot < unSlotNo immTipSlot + minLead then DoNotRelay else DoRelay + +-- | The threshold for 'leiosOfferRelayDecision' +newtype LeiosMinOfferLead + = MkLeiosMinOfferLead {unLeiosMinOfferLead :: Word64} + deriving newtype (Enum, Eq, Ord, Show) + +-- | The default 'LeiosMinOfferLead': an hour of one-second slots. +-- +-- Not a protocol parameter --- the two nodes need not agree on it --- so a +-- node may configure its own. Too small and a peer whose immutable tip is +-- merely a little ahead of ours disconnects us, so the risk of choosing one +-- too small falls on the node that chose it. +-- +-- Too large and the node relays nothing at all, and this bound is the one to +-- watch: every endorser block worth relaying sits between the immutable tip +-- and the wall clock, so a lead approaching that distance suppresses the lot. +-- An hour leaves ample room on a network whose immutable tip trails by @k@ +-- blocks of a chain that grows every twenty seconds, and none whatsoever on a +-- short-horizon test network --- which is why the test networks configure +-- their own. +defaultLeiosMinOfferLead :: LeiosMinOfferLead +defaultLeiosMinOfferLead = MkLeiosMinOfferLead 3600 + ----- -- | The forge's counterpart to receiving an EB from an upstream peer: hand our diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic/Announcements.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic/Announcements.hs index afeee86362..c32a74b50a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic/Announcements.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic/Announcements.hs @@ -87,6 +87,26 @@ secondAnnouncement = \case OneAnnouncement _x -> Nothing TwoAnnouncements _x1 x2 -> Just x2 +-- | Both of this election's announcements, first one first. +elStateAnnouncements :: ElState anc -> [anc] +elStateAnnouncements = \case + OneAnnouncement x -> [x] + TwoAnnouncements x1 x2 -> [x1, x2] + +-- | Everything this peer has announced for elections in the given slot. +-- +-- 'ElId' orders slot-first, so those elections are a contiguous range. An +-- endorser block's own slot is its election's slot, so this is what an offer +-- of that endorser block has to be backed by. +announcementsInSlot :: SlotNo -> PeerState anc -> [anc] +announcementsInSlot slot st = + concatMap elStateAnnouncements (Map.elems atSlot) + where + (_below, atOrAbove) = + Map.spanAntitone (\(MkElId elSlot _poolId) -> elSlot < slot) (live st) + (atSlot, _above) = + Map.spanAntitone (\(MkElId elSlot _poolId) -> elSlot <= slot) atOrAbove + -- | Called whenever the ChainDB's immutable tip advances to a new slot -- -- NOTE this pruning should happen ~60 s after the immutable tip @@ -229,6 +249,16 @@ data CentralState m peer anc -- -- We only send equivocation proofs to them. -- + -- TODO collapse this into the per-peer record the LeiosNotify server keeps + -- of what it has enqueued to that peer (@olnAnnounced@), which exists + -- because an offer may not precede its announcement to that same peer. One + -- record instead of two, written by the same pure step that enqueues, and it + -- dies with the connection rather than needing 'deletePeerCentral'; the + -- 'ElBimap' type then has no users left. It needs that record to hold the + -- 'ElId' as well as the point, since neither determines the other, and it + -- needs 'QueueAnnouncementView' to expose a second function so 'send' can + -- ask a peer's queue whether an election has already gone out to it. + -- -- We don't need to track whether or not we've sent them an -- equivocation. } diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic/Announcements/ElBimap.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic/Announcements/ElBimap.hs index 8acdef52ee..51d65577b4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic/Announcements/ElBimap.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic/Announcements/ElBimap.hs @@ -16,9 +16,9 @@ import qualified Data.Map.Strict as Strict (Map) import Data.Set (Set) import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) +import qualified Data.Set.NonEmpty as NESet import GHC.Generics (Generic) import NoThunks.Class (NoThunks) -import qualified Data.Set.NonEmpty as NESet -- | The slot number and pool id of an election data ElId diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoOnlyTestNotify.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoOnlyTestNotify.hs index 5d7907a41f..d37d53c020 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoOnlyTestNotify.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoOnlyTestNotify.hs @@ -163,7 +163,24 @@ instance Protocol (LeiosNotify point announcement vote) where Message (LeiosNotify point announcement vote) StBusy StIdle MsgLeiosBlockOffer :: !point -> - !Word32 -> -- TODO this size should be redundant, determined by the announcement + -- The point alone would not say which announcement's size is being + -- offered: two announcements, even from different elections, can name + -- one endorser block in one slot at different sizes. Suppressing the + -- contrasting announcement is not open to us either, since L_hdr is + -- precisely the window in which an honest peer relays both, before it + -- can know which size is right. + -- + -- There would be two ways to drop it. Name the announcing block's RbHash, + -- instead of or alongside the endorser block's hash: one announcing block + -- is one announcement, hence one size. Or inflate the outstanding-bytes + -- budget conservatively --- charge each request the codec limit rather + -- than a claimed size --- which needs no size at all, at the cost of a + -- budget denominated in the worst case. + -- + -- TODO update the CIP/blueprint, which still has this message carrying + -- the point alone. Both alternatives change the mini-protocol message or + -- its accounting, so the choice belongs in that discussion. + !Word32 -> Message (LeiosNotify point announcement vote) StBusy StIdle MsgLeiosBlockTxsOffer :: !point -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs index bfa4b4778a..efec91fb22 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs @@ -93,9 +93,9 @@ import Data.IntSet.NonEmpty (NEIntSet) import Data.List (sortOn) import Data.Map (Map) import qualified Data.Map.Strict as Map +import Data.Maybe.Strict (StrictMaybe (..)) import Data.MultiSet (MultiSet) import qualified Data.MultiSet as MultiSet -import Data.Maybe.Strict (StrictMaybe (..)) import Data.Ord (Down (..)) import Data.Sequence (Seq) import qualified Data.Sequence as Seq @@ -400,30 +400,69 @@ prettyBitmap (idx, bitmap) = -- patterns of access to the "Ouroboros.Consensus.NodeKernel"'s shared state. -- --- | Whether an EB offer also implies its tx-closure is on offer. A CertRB does --- (it certifies the whole EB); a bare 'MsgLeiosBlockOffer' does not -- the closure --- is offered separately, as a 'MsgLeiosBlockTxsOffer'. This is also the value we --- store per offered point: 'TxsClosureAlsoOffered' means the peer can serve the --- body /and/ the closure (a closure offer implies the body), while --- 'TxsClosureNotAlsoOffered' is body-only. -data AlsoOfferedTxsClosure = TxsClosureAlsoOffered | TxsClosureNotAlsoOffered +-- | Whether a peer has offered an endorser block's tx-closure. +data WhetherTxsClosureOffered = TxsClosureOffered | TxsClosureNotOffered deriving (Eq, Show) --- | Merge two offers for one point: the closure is on offer if either says so. -mergeOffer :: AlsoOfferedTxsClosure -> AlsoOfferedTxsClosure -> AlsoOfferedTxsClosure -mergeOffer TxsClosureAlsoOffered _ = TxsClosureAlsoOffered -mergeOffer _ TxsClosureAlsoOffered = TxsClosureAlsoOffered -mergeOffer _ _ = TxsClosureNotAlsoOffered +-- | Offered if either says so. +instance Semigroup WhetherTxsClosureOffered where + TxsClosureOffered <> _ = TxsClosureOffered + _ <> y = y + +instance Monoid WhetherTxsClosureOffered where + mempty = TxsClosureNotOffered + +-- | What one peer has offered for one endorser block point. +-- +-- The two LeiosNotify offers are independent messages: either can arrive +-- first, or alone. A CertRB roll-forward makes both at once. +-- +-- The body offer carries a size and the closure offer does not, and that +-- asymmetry is not an oversight. A body request is per /candidate/, and a +-- point can have more than one --- two announcements can name one endorser +-- block at different sizes, and only one of them is the truth --- so the size +-- is what says which candidate this peer can serve. Closure jobs are per +-- endorser block: 'assignClosure' only ever runs once we hold the body, by +-- which point the true size is known and the losing candidates are gone. +data PeerOffer = MkPeerOffer + { poOfferedBody :: !(StrictMaybe BytesSize) + -- ^ The size this peer offered the body at, if it has offered the body. + -- + -- Every offer of one endorser block from one peer names the same size, or + -- that peer is lying: an offer says it holds the body, it can only have + -- acquired that body at the size announced --- 'processLeiosBlock' refuses + -- one of any other size --- and so it knows the one true size. Which is why + -- nothing here arbitrates between two of them. + -- + -- TODO disconnect a peer that ever offers one 'EbHash' at two sizes, + -- whichever messages the two arrived on. That is proof it is lying, and + -- today we merely keep one of the two and carry on. + , poClosure :: !WhetherTxsClosureOffered + } + deriving (Eq, Show) + +-- | Each field on its own terms: the leftmost size wins, which for +-- 'Map.insertWith' is the newer offer's, and a peer that makes that choice +-- matter has already lost our trust (see 'poOfferedBody'). +instance Semigroup PeerOffer where + MkPeerOffer sz1 c1 <> MkPeerOffer sz2 c2 = MkPeerOffer (pickSize sz1 sz2) (c1 <> c2) + where + pickSize SNothing y = y + pickSize x _ = x + +instance Monoid PeerOffer where + mempty = MkPeerOffer SNothing mempty data LeiosPeerVars m = MkLeiosPeerVars { whetherBigLedgerPeer :: !IsBigLedgerPeer -- ^ fixed for the connection's lifetime; the fetch logic fetches more -- aggressively from a big-ledger peer (see 'leiosFetchLogicIteration') - , offerings :: !(MVar m (Map LeiosPoint AlsoOfferedTxsClosure)) + , offerings :: !(MVar m (Map LeiosPoint PeerOffer)) -- ^ the peer's current offers, keyed by point -- so the map is already in slot -- order (freshest-first via 'Map.toDescList'), no dedup by EB hash needed -- (honest announcements don't reuse a hash, and an adversary defeats such - -- dedup anyway). Written to only by the LeiosNotify client and eviction. + -- dedup anyway). One entry per point, since a peer may offer each point's + -- body once. Written to only by the LeiosNotify client and eviction. , certificationClaims :: !(MVar m (Map ElId EbHash)) -- ^ For each election, the endorser block this peer has claimed a -- certificate for. @@ -866,6 +905,22 @@ minOnset (SJust a) (SJust b) = SJust (min a b) -- actually depend on them read the LeiosDb directly, never via this -- outstanding state. -- +-- The announcements on the initially selected chain are likewise not replayed +-- here, though those blocks never roll forward and so are never announced to +-- us this run. Only two things list an endorser block to fetch --- the +-- announcement that takes an election's focus, and 'focusCertifiedEb' on a +-- verified certificate --- and between them they reach every endorser block we +-- could come to need. A CertRB on the initial chain has its endorser block +-- already, since it could not have been selected otherwise; one that is not on +-- the initial chain is re-fetched if some chain we would select needs it, and +-- verifying its certificate then sets the focus and lists it. +-- +-- Not replaying them does leave the 'LeiosTxCache' without an entry for those +-- endorser blocks, since only the announcement path calls +-- @recordAnnouncementInTxCache@ and the cache starts empty. That costs nothing +-- but cache misses: their txs read as absent, so a later endorser block that +-- shares one re-fetches it. The LeiosDb still holds it either way. +-- -- The per-peer request-tracking fields must start empty regardless: there are -- no connections yet and nothing is in flight. -- @@ -923,6 +978,60 @@ focusElectionIfUnfocused elId ebHash outstanding -- deliberately do not spend complexity on that case here, since it requires -- catastrophically buggy nodes and/or an amount of adversarial stake the -- protocol itself is not designed to resist. +-- | A verified certificate moves its election's focus onto the endorser block +-- it names, and lists that body as one to fetch. +-- +-- The endorser block this names may never have been listed. The announcement +-- that took the election's focus listed its own; this one's may have lost that +-- race, or may never have reached us --- and nothing lists it in the meantime, +-- because an unverified claim must not be able to make us track an endorser +-- block. +focusCertifiedEb :: AnnouncementFields -> LeiosOutstanding pid -> LeiosOutstanding pid +focusCertifiedEb fields = + focusElection (announcementElection fields) (announcementEbHash fields) + . listEbBodyToFetch (announcementLeiosPoint fields) (announcementEbBodySize fields) + +-- | List an endorser block's body as one to fetch, at the given size, unless +-- it is too old, malformed, already held or already listed. +-- +-- "Already listed" is by endorser block hash, so the first size listed for a +-- hash is the only one ever pursued. Two announcements can name one hash at +-- different sizes, at most one of which is the truth, so a lying announcement +-- that arrives first leaves us unable to fetch that endorser block at all. +-- +-- That is deliberate, and is what @lHdrWait@ is for. Being stuck this way +-- means we saw the equivocation early, and we relay the announcement we saw, +-- so nodes that were not stuck have the proof in hand before their vote window +-- opens and withhold their votes. No certificate forms, and an endorser block +-- that is never certified is one it costs us nothing to have missed. Should +-- that fail, the Recovery Path gets us the endorser block eventually. +listEbBodyToFetch :: + LeiosPoint -> BytesSize -> LeiosOutstanding pid -> LeiosOutstanding pid +listEbBodyToFetch point ebBytesSize outstanding = + let MkLeiosPoint ebSlot ebHash = point + tooOld = ebSlot < acquiredEbBodiesPrunedSlot outstanding + malformed = ebBytesSize == 0 + outstanding' + | tooOld || malformed = outstanding + | otherwise = recordMaxAnnouncementSlot ebHash ebSlot SNothing outstanding + skip = + tooOld + || malformed + || maybe False ebStateHasBody (Map.lookup ebHash (ebState outstanding)) + || Map.member ebHash (reverseSlotIndexByEbHash outstanding) + in if skip + then outstanding' + else + outstanding' + { missingEbBodies = Map.insert point ebBytesSize (missingEbBodies outstanding') + , reverseSlotIndexByEbHash = + Map.insertWith + NESet.union + ebHash + (NESet.singleton ebSlot) + (reverseSlotIndexByEbHash outstanding') + } + focusElection :: ElId -> EbHash -> LeiosOutstanding pid -> LeiosOutstanding pid focusElection elId ebHash outstanding = case Map.lookup elId (elFocus outstanding) of Just oldEbHash | oldEbHash == ebHash -> outstanding @@ -1024,7 +1133,7 @@ pruneOutstandingToImmTip immTipSlot outstanding = -- | Pretty-print the per-peer 'offerings' map: for each peer, its offered points -- freshest-first, each tagged with the strongest kind offered. Hashes truncated. -prettyOfferings :: Show pid => Map (PeerId pid) (Map LeiosPoint AlsoOfferedTxsClosure) -> String +prettyOfferings :: Show pid => Map (PeerId pid) (Map LeiosPoint PeerOffer) -> String prettyOfferings m = unlines $ map (" [leios] " ++) $ @@ -1041,9 +1150,14 @@ prettyOfferings m = | (MkLeiosPoint slot h, k) <- points ] ++ "}" - kindTag = \case - TxsClosureNotAlsoOffered -> "b" - TxsClosureAlsoOffered -> "c" + kindTag (MkPeerOffer mbSize closure) = body ++ txs + where + body = case mbSize of + SNothing -> "" + SJust{} -> "b" + txs = case closure of + TxsClosureNotOffered -> "" + TxsClosureOffered -> "c" prettyLeiosOutstanding :: LeiosOutstanding pid -> String prettyLeiosOutstanding x = @@ -2692,6 +2806,7 @@ leiosExtValidationErrorForHuman = \case <> ")" -- * Protocol parameters + -- -- The node-to-node limits below are constants, but no longer a policy of their -- own: they restate the LeiosFetch codec's message limit, so the buffers sized diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosValidClaims.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosValidClaims.hs index 1035ea2e0d..66f1e4bdc2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosValidClaims.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosValidClaims.hs @@ -77,7 +77,7 @@ data ValidClaims = MkValidClaims { slotOfClaim :: !(Strict.Map RbHash Claim) , claimsBySlot :: !(Strict.Map SlotNo (NESet RbHash)) - , certifiedEbs :: !(Strict.Map ElId EbHash) + , certifiedEbs :: !(Strict.Map ElId AnnouncementFields) -- ^ The endorser block certified for each election: the same shape as the -- fetch logic's own focus, which is what it copies these entries into. -- @@ -111,10 +111,7 @@ insertValidClaim slot mbFields rbHash vc , certifiedEbs = case mbFields of SNothing -> certifiedEbs vc SJust fields -> - Map.insert - (announcementElection fields) - (announcementEbHash fields) - (certifiedEbs vc) + Map.insert (announcementElection fields) fields (certifiedEbs vc) } memberValidClaim :: RbHash -> ValidClaims -> Bool @@ -123,7 +120,8 @@ memberValidClaim rbHash = Map.member rbHash . slotOfClaim -- | Whether some certified claim announced this endorser block, for this -- election. isCertifiedEb :: ElId -> EbHash -> ValidClaims -> Bool -isCertifiedEb elId ebHash = (== Just ebHash) . Map.lookup elId . certifiedEbs +isCertifiedEb elId ebHash = + (== Just ebHash) . fmap announcementEbHash . Map.lookup elId . certifiedEbs -- | Forget every claim announced strictly before the given slot. -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosVoting.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosVoting.hs index 082f274fb6..48700880d8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosVoting.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosVoting.hs @@ -41,8 +41,7 @@ import LeiosDemoDb , withReader ) import LeiosDemoTypes - ( announcementLeiosPoint - , HasLeiosVoting (..) + ( HasLeiosVoting (..) , LeiosClosureError (..) , LeiosNotVotedReason (..) , LeiosPoint (..) @@ -50,6 +49,7 @@ import LeiosDemoTypes , RbHash (..) , SerializedEbBody , TraceLeiosKernel (..) + , announcementLeiosPoint , getLeiosSeatId , prettyLeiosPoint , signLeiosVote diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs index 06e34cce6c..fa1e08a3cf 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs @@ -292,7 +292,8 @@ copyToImmutableDB cdb@CDB{..} = withWriteAccess cdbImmutableDBLock $ \() -> do GenesisHash -> Nothing BlockHash predHash -> Just predHash predInfo <- getBI predHash - LeiosDemoTypes.announcementLeiosPoint <$> strictMaybeToMaybe (VolatileDB.biLeiosAnnouncedEb predInfo) + LeiosDemoTypes.announcementLeiosPoint + <$> strictMaybeToMaybe (VolatileDB.biLeiosAnnouncedEb predInfo) -- \| Remove the header corresponding to the given point from the beginning -- of the current chain fragment. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index 0a05c2e397..7d09933b3e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -51,7 +51,6 @@ import GHC.Stack (HasCallStack) import LeiosDemoTypes ( AcquiredLeiosEbsSet , EbHash - , announcementEbHash , HasLeiosVoting (getLeiosCommitteeFromView) , LeiosExtValidationError (LeiosCertificateForecastRejected) , TraceLeiosChainSel @@ -60,6 +59,7 @@ import LeiosDemoTypes ) , acquiredLeiosEbHashes , acquiredLeiosEbsSetMember + , announcementEbHash ) import LeiosUtils.CallTrace ( CallCtx diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs index b500157815..4a0264ea37 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs @@ -30,7 +30,7 @@ import qualified Data.ByteString.Short as SBS import Data.Foldable (toList) import Data.Function ((&)) import qualified Data.Map.Strict as Map -import Data.Maybe.Strict (StrictMaybe (SNothing)) +import Data.Maybe.Strict (StrictMaybe (SJust, SNothing)) import Data.Sequence.NonEmpty (NESeq) import qualified Data.Set as Set import qualified Data.Set.NonEmpty as NESet @@ -51,8 +51,7 @@ import LeiosDemoLogic ) import LeiosDemoLogic.Announcements.ElBimap (ElId (MkElId)) import LeiosDemoTypes - ( AlsoOfferedTxsClosure (..) - , BytesSize + ( BytesSize , EbHash (..) , LeiosBlockRequest (..) , LeiosEb (..) @@ -62,14 +61,15 @@ import LeiosDemoTypes , LeiosPoint (..) , LeiosTx (..) , PeerId (..) + , PeerOffer (MkPeerOffer) + , WhetherTxsClosureOffered (..) , demoLeiosFetchStaticEnv , emptyLeiosOutstanding + , focusElectionIfUnfocused , hashLeiosEb , hashLeiosTx , markBodyImminent , maxTxsPerEb - , mergeOffer - , focusElectionIfUnfocused , recordMaxAnnouncementSlot ) import System.Random (mkStdGen) @@ -207,7 +207,7 @@ test_forgedEbOfferIgnored = -- | A test fixture: static env, peer offerings, outstanding work. data Scenario pid = Scenario { scEnv :: !LeiosFetchStaticEnv - , scOfferings :: !(Map.Map (PeerId pid) (Map.Map LeiosPoint AlsoOfferedTxsClosure)) + , scOfferings :: !(Map.Map (PeerId pid) (Map.Map LeiosPoint WhetherTxsClosureOffered)) , scOutstanding :: !(LeiosOutstanding pid) } @@ -237,10 +237,10 @@ withMissingBody p@(MkLeiosPoint slot ebHash) size = Map.insertWith NESet.union ebHash (NESet.singleton slot) (reverseSlotIndexByEbHash o) } --- | The one pool these scenarios pretend announced everything, since they have --- no headers to take an issuer from. An endorser block's election is therefore --- just its slot: two announced in one slot would share an election, and only --- the first would be fetched. None of these announce two in a slot. +-- | The one pool a scenario here pretends announced everything, since these +-- have no headers to take an issuer from. An endorser block's election is +-- therefore just its slot, so two announced in one slot share an election and +-- only the first is fetched. fixtureIssuer :: ShortByteString fixtureIssuer = SBS.pack [0] @@ -278,24 +278,27 @@ withRequestedBytesPerPeer pid n = -- | Peer @p@ offers the body (only) of these points. offersBody :: Ord pid => pid -> [LeiosPoint] -> Scenario pid -> Scenario pid offersBody pid points = - insertOffering (MkPeerId pid) (Map.fromList [(p, TxsClosureNotAlsoOffered) | p <- points]) + insertOffering (MkPeerId pid) (Map.fromList [(p, TxsClosureNotOffered) | p <- points]) -- | Peer @p@ offers both the body and the tx-closure of these points. offersBodyAndClosure :: Ord pid => pid -> [LeiosPoint] -> Scenario pid -> Scenario pid offersBodyAndClosure pid points = - insertOffering (MkPeerId pid) (Map.fromList [(p, TxsClosureAlsoOffered) | p <- points]) + insertOffering (MkPeerId pid) (Map.fromList [(p, TxsClosureOffered) | p <- points]) insertOffering :: Ord pid => PeerId pid -> - Map.Map LeiosPoint AlsoOfferedTxsClosure -> + Map.Map LeiosPoint WhetherTxsClosureOffered -> Scenario pid -> Scenario pid insertOffering pid offers sc = sc { scOfferings = - Map.insertWith (Map.unionWith mergeOffer) pid offers (scOfferings sc) + Map.insertWith (Map.unionWith mergeClosure) pid offers (scOfferings sc) } + where + mergeClosure TxsClosureOffered _ = TxsClosureOffered + mergeClosure _ y = y -- | Internal: lift a function on 'LeiosOutstanding' to one on 'Scenario'. onOutstanding :: @@ -318,11 +321,19 @@ runIteration sc = leiosFetchLogicIteration sc.scEnv (Just minBound) - sc.scOfferings + (Map.map (Map.mapWithKey (resolveOfferSize sc.scOutstanding)) sc.scOfferings) Map.empty sc.scOutstanding in reqs +-- | Give a fixture's offer the size the scenario is pursuing for that point, +-- which is what 'assignBody' matches a peer's offer against. A peer offering a +-- point with no listed body offers no size, which is the closure-only case. +resolveOfferSize :: + LeiosOutstanding pid -> LeiosPoint -> WhetherTxsClosureOffered -> PeerOffer +resolveOfferSize o p closure = + MkPeerOffer (maybe SNothing SJust (Map.lookup p (missingEbBodies o))) closure + ------------------------------------------------------------ -- Assertions ------------------------------------------------------------ diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs index 1215eb45ef..bbe606d523 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs @@ -43,6 +43,7 @@ import Control.Monad.Class.MonadTimer (threadDelay) import Control.Monad.IOSim (IOSim, exploreSimTrace, runSimOrThrow, traceResult) import Control.Tracer (nullTracer) import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as SBS import Data.Foldable (toList) import qualified Data.IntMap.Strict as IntMap import qualified Data.IntSet as IntSet @@ -66,9 +67,9 @@ import LeiosDemoLogic , recordEbBodyOffer , removePeerFromOutstanding ) +import LeiosDemoLogic.Announcements.ElBimap (ElId (MkElId)) import LeiosDemoTypes - ( AlsoOfferedTxsClosure (..) - , BytesSize + ( BytesSize , EbHash , LeiosBlockRequest (..) , LeiosEb (..) @@ -78,6 +79,7 @@ import LeiosDemoTypes , LeiosTx (..) , PeerId (..) , TxHash + , WhetherTxsClosureOffered (..) , demoLeiosFetchStaticEnv , emptyLeiosOutstanding , encodeLeiosEbSize @@ -85,8 +87,6 @@ import LeiosDemoTypes , hashLeiosTx , newLeiosPeerVars ) -import qualified Data.ByteString.Short as SBS -import LeiosDemoLogic.Announcements.ElBimap (ElId (MkElId)) import qualified LeiosDemoTypes as Leios import qualified LeiosDemoTypes.LeiosJobs as Jobs import LeiosTxCache (LeiosTxCache, defaultLeiosTxCacheShift, newPureLeiosTxCache, nullLeiosTxCache) @@ -252,7 +252,11 @@ tests = (Leios.maxJobTxCount demoLeiosFetchStaticEnv) misses peerId = MkPeerId (0 :: Int) - offers = Map.singleton peerId (Map.singleton point TxsClosureAlsoOffered) + -- The body is already held in these runs, so the offer names no + -- size; only its closure half is consulted. + offers = + Map.singleton peerId $ + Map.singleton point (Leios.MkPeerOffer SNothing TxsClosureOffered) ordinaryCap = Leios.maxRequestedBytesSizePerPeer demoLeiosFetchStaticEnv bigLedgerCap = Leios.maxRequestedBytesSizePerBigLedgerPeer demoLeiosFetchStaticEnv -- hold the body (so the pool is live), with the peer's in-flight bytes @@ -485,9 +489,8 @@ applyCmd conn txCache kv peerVars peerId = \case pure [] Offer ids slot -> do recordEbBodyOffer - kv + (snd kv) peerVars - TxsClosureNotAlsoOffered (pointOf ids slot, encodeLeiosEbSize (ebOf ids)) pure [] ArriveBody ids slot -> do @@ -584,15 +587,27 @@ applyCmd conn txCache kv peerVars peerId = \case let held = Map.keysSet (Map.filter Leios.ebStateHasBody (Leios.ebState outstanding)) pure (filter (\h -> Set.member h held) (ebBodyRequestHashes decs)) --- | Offer every EB the outstanding state tracks, at its 'ebStateMaxSlot' and as --- 'TxsClosureAlsoOffered' (which implies the body too) -- an all-offering peer, so --- the fetch logic can act on whichever half each EB still needs. -referencedOffers :: LeiosOutstanding Int -> Map.Map Leios.LeiosPoint Leios.AlsoOfferedTxsClosure +-- | Offer every EB the outstanding state tracks, at its 'ebStateMaxSlot', +-- offering both its body and its closure -- an all-offering peer, so the fetch +-- logic can act on whichever of the two each EB still needs. +-- +-- The two are independent offers, so the body offer is stated explicitly, by +-- the size the outstanding state is pursuing. +referencedOffers :: LeiosOutstanding Int -> Map.Map Leios.LeiosPoint Leios.PeerOffer referencedOffers o = Map.fromList - [ (Leios.MkLeiosPoint (Leios.ebStateMaxSlot s) h, Leios.TxsClosureAlsoOffered) + [ ( Leios.MkLeiosPoint (Leios.ebStateMaxSlot s) h + , Leios.MkPeerOffer (sizeOf h) Leios.TxsClosureOffered + ) | (h, s) <- Map.toList (Leios.ebState o) ] + where + -- The size this outstanding state is pursuing for that endorser block, which + -- is what 'assignBody' matches a peer's offer against. + sizeOf h = + case [sz | (Leios.MkLeiosPoint _ h', sz) <- Map.toList (Leios.missingEbBodies o), h' == h] of + [] -> SNothing + sz : _ -> SJust sz -- | Force the requests to a scalar, so any @impossible!@ hidden in a thunk -- surfaces when the caller 'evaluate's it. Touches each tx request's covered @@ -859,7 +874,7 @@ raceSameHashMultiSlot = do announcePoint = pointOf ids 11 arrivalPoint = pointOf ids 12 concurrently_ - (recordEbBodyOffer kv peerVars TxsClosureNotAlsoOffered (offerPoint, ebBytesSize)) + (recordEbBodyOffer (snd kv) peerVars (offerPoint, ebBytesSize)) ( concurrently_ (recordAnnouncedEb kv SNothing (announcementOf announcePoint ebBytesSize)) ( processLeiosBlock From e9d36ae4604e1288ea6d4a0dced785120658f339 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 6 Oct 2026 22:48:42 -0400 Subject: [PATCH 26/60] LeiosFetch: test that a misstated transaction size is never certified Issue https://github.com/input-output-hk/ouroboros-leios/issues/1115 An endorser block whose body states a size other than a transaction's own must never have its closure called complete, or the node would vote for it and offer it onward. The LeiosDb already refuses it at write time: a closure row is pre-allocated as a zeroblob of the size the body declared, and every fill is guarded on that length --- including the cross-EB fill, which is checked against the destination body's own claim rather than the source's. What was missing was coverage. This adds: - a node-versus-environment test in which a liar announces its own endorser block naming a transaction at one byte, plants it with an empty closure, and never offers that closure; the node acquires the transaction via an honest endorser block instead. Both arrival orders are run, and the node must offer the liar's body but never its closure. - 'mkLeiosTestEbClaiming' in unstable-consensus-testlib, which builds an endorser block stating a size other than a transaction's own --- what an adversary would do, and otherwise unrepresentable. - parity coverage in Test.LeiosDemoDb against both backends, since they reach the same answer by different means. Also here, unrelated to the above but caught alongside it: - 'lookupEbClosure' becomes 'lookupTrustedEbClosure', putting its prerequisite in its name: the caller must already have established that the endorser block is trustworthy. - 'maxLeiosEbBytesSize' and 'maxLeiosTxsRequestBytesSize' replace 'maxMsgLeiosBlockBytesSize' and 'msgLeiosBlockFramingSize', so 'maxTxsPerEb' derives from the design ceiling rather than from 'largeByteLimit' and falls from 71,428 to 14,979. - four fixes to the node-versus-environment harness, each of which was quietly making the node under test behave unlike a real node. --- ...0_nick.frisby_leios_fetch_server_bounds.md | 40 ++++ .../Consensus/Shelley/Ledger/Forge.hs | 5 +- .../Consensus/Shelley/Ledger/Leios.hs | 4 +- .../Consensus/Shelley/Ledger/Mempool.hs | 2 +- .../Ouroboros/Consensus/Network/NodeToNode.hs | 1 + .../Ouroboros/Consensus/NodeKernel/Forge.hs | 2 +- .../Test/Consensus/Leios/Environment.hs | 129 ++++++++++-- .../Test/Consensus/Leios/NodeUnderTest.hs | 9 +- .../Test/Consensus/Leios/RecoveryPath.hs | 187 +++++++++++++++++- ouroboros-consensus.cabal | 2 +- .../bench/leios-db-bench/Main.hs | 10 +- .../ouroboros-consensus/LeiosDemoDb/Common.hs | 8 +- .../LeiosDemoDb/InMemory.hs | 6 +- .../ouroboros-consensus/LeiosDemoDb/SQLite.hs | 54 +++-- .../LeiosDemoOnlyTestFetch.hs | 51 ++++- .../src/ouroboros-consensus/LeiosDemoTypes.hs | 41 ++-- .../src/ouroboros-consensus/LeiosVoting.hs | 5 + .../Test/Util/LeiosTestBlock.hs | 24 ++- .../Ouroboros/Consensus/Mock/Ledger/Block.hs | 4 +- .../test/consensus-test/Test/LeiosDemoDb.hs | 81 ++++++-- 20 files changed, 573 insertions(+), 92 deletions(-) create mode 100644 changelog.d/20260925_150000_nick.frisby_leios_fetch_server_bounds.md diff --git a/changelog.d/20260925_150000_nick.frisby_leios_fetch_server_bounds.md b/changelog.d/20260925_150000_nick.frisby_leios_fetch_server_bounds.md new file mode 100644 index 0000000000..3a660a50c5 --- /dev/null +++ b/changelog.d/20260925_150000_nick.frisby_leios_fetch_server_bounds.md @@ -0,0 +1,40 @@ + + +### Breaking + +- `lookupEbClosure` is now `lookupTrustedEbClosure`, to put its prerequisite in its name: the caller must already have established that the endorser block is trustworthy. A certificate does that for ChainSel applying a cert-RB and for the forge, and the LeiosDb having called the closure complete does it for voting. + +- `maxLeiosEbBytesSize` and `maxLeiosTxsRequestBytesSize` replace `maxMsgLeiosBlockBytesSize` and `msgLeiosBlockFramingSize`. They are the design ceilings the logic enforces --- an endorser block's transaction references, and the transactions one `MsgLeiosBlockTxs` carries --- and are unrelated quantities that happen to be close in size. `byteLimitsLeiosFetch` allows `addSafetyMargin` above each, which is what pays for the framing; nothing else may spend that slack as capacity. + + `maxLeiosEbBytesSize` ought to be 500 KiB and is 512 KiB, under protest. `exampleDijkstraGenesis` in cardano-ledger's testlib sets `maxEndorserBlockReferencesSize` to 512 KiB, which is wrong, and `guardLeiosWireLimit` refuses to run with a protocol parameter above our ceiling --- so the Leios ThreadNet, which hard-forks the nodes into that genesis, cannot start until either the ledger is corrected or we accommodate it. Carrying the inflated value keeps this change local; the constant has a TODO. Real deployments are unaffected: the testnet and proto-devnet genesis files both set the parameter to 100,000. + +- Thus, `maxTxsPerEb` falls from 71,428 to 14,979, since it now derives from the design ceiling rather than from `largeByteLimit`. It sizes the two buffers a LeiosFetch server allocates per inbound peer, which go from 1.09 MiB to 234 KiB of pointer array between them; it is also the largest bitmap word index that server will accept, 1,116 before and 234 now, and a factor of `worstCaseCacheTxCount`. + +### Non-Breaking + +- Test coverage for Issue https://github.com/input-output-hk/ouroboros-leios/issues/1115: an endorser block whose body misstates the size of a transaction the node already holds never has its closure called complete, so it is neither voted for nor offered onward. The behaviour itself is the LeiosDb's, which refuses the transaction at write time --- a row is pre-allocated as `zeroblob` of the size the body declared, and every fill is guarded on that length, including a cross-EB fill, which is checked against the destination body's own claim. What is new here is a node-versus-environment test that exercises it end to end, in both arrival orders. + +- There is nobody to disconnect: the issuer is not a peer we are connected to, and the peer that relayed the body may be honest. The sanction is that the endorser block is never certified. Its `missingTxCount` stays positive forever, which is the (buried) signal that something was refused. + +### Patch + +- `unstable-consensus-testlib` gained `mkLeiosTestEbClaiming`, which builds an endorser block stating a size other than a transaction's own --- what an adversary would do, and otherwise unrepresentable. + +- Four fixes to the Leios node-versus-environment harness, each of which was quietly making the node under test behave unlike a real node. + + It ran `nullLeiosTxCache`, whose lookups always miss, so the node re-fetched every transaction it already held. Any test about the node *not* fetching was vacuous. It now runs the reference cache. + + Its downstream LeiosNotify client was the non-pipelined one, so it kept no requests outstanding and the node --- by design --- dropped the offers it had no credit to send. A test could conclude the node never made an offer it had in fact made. It now pipelines to `leiosNotifyPipelineDepth`. + + Its LeiosFetch server ignored the request's bitmaps and replied with the endorser block's whole closure. That is a protocol violation, and for a large closure it also breached the message size limit, killing the connection for a reason unrelated to whatever was under test. It now serves exactly the offsets asked for. A peer planted with an empty closure now stalls on a closure request --- a peer that holds the body and withholds the transactions, which is the one thing no peer can be caught at --- rather than answering with fewer transactions than were asked for. + + The harness also gained the other direction of LeiosFetch, so a test can have a downstream peer request something of the node's own fetch server, including things no honest peer would ask for. + +- `Test.LeiosDemoDb`'s notification tests inserted four-byte transactions under hashes their endorser block claimed were 100-odd bytes. Hash-only matching made that harmless; it is not harmless any more, and one of those tests hung rather than failed. They now insert transactions of the size the endorser block claims. + +- `Test.LeiosDemoDb` also gained parity coverage, run against both the in-memory and the SQLite backends: that a body misstating a size never has its closure announced. The two backends reach that answer by different means --- `zeroblob` pre-allocation plus a `length` guard in SQL, against a declared-size check in the in-memory accept filter --- so nothing but a shared test says they agree. diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs index 79a7d4e434..8528cf3e06 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs @@ -39,8 +39,7 @@ import LeiosDemoTypes , encodeLeiosEbSize , forgeLeiosEb , hashLeiosEb - , maxMsgLeiosBlockBytesSize - , msgLeiosBlockFramingSize + , maxLeiosEbBytesSize ) import Lens.Micro ((&), (.~)) import Ouroboros.Consensus.Block @@ -176,7 +175,7 @@ forgeShelleyBlock hotKey cbl leiosToken ForgeBlockArgs{..} = do -- and the encoder have drifted apart. ebSize = assert - (encodeLeiosEbSize forgedEb.body <= maxMsgLeiosBlockBytesSize - msgLeiosBlockFramingSize) + (encodeLeiosEbSize forgedEb.body <= maxLeiosEbBytesSize) (encodeLeiosEbSize forgedEb.body) ebAnn = EbAnnouncement diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs index f1d2671784..c9b72b436d 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs @@ -40,7 +40,7 @@ import Data.Maybe.Strict (strictMaybeToMaybe) import Data.Proxy (Proxy (..)) import qualified Data.Sequence.Strict as StrictSeq import qualified Data.Text as Text -import LeiosDemoDb (lookupEbClosure) +import LeiosDemoDb (lookupTrustedEbClosure) import LeiosDemoLogic.Announcements.ElBimap (ElId (MkElId)) import LeiosDemoTypes ( AnnouncementFields (..) @@ -132,7 +132,7 @@ instance leiosTxHashOfGenTx (ShelleyTx _ tx) = Just (hashLeiosTx (MkLeiosTx (serialize' tx))) resolveLeiosClosure leiosDb ebHash = do - lookupEbClosure leiosDb ebHash >>= \case + lookupTrustedEbClosure leiosDb ebHash >>= \case Nothing -> pure $ Left $ LeiosClosureMissing ebHash Just closureEntries -> diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs index 2c79aa1061..8c3eb613f4 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs @@ -847,7 +847,7 @@ guardLeiosWireLimit st a <> show wireLimit <> ")" where - wireLimit = Leios.maxMsgLeiosBlockBytesSize - Leios.msgLeiosBlockFramingSize + wireLimit = Leios.maxLeiosEbBytesSize paramLimit = getPParams (tickedShelleyLedgerState st) ^. ppMaxEndorserBlockReferencesSizeL -- | What an endorser block's closure may amount to, in block-measure terms: diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index b9065c3f0f..c28df8b57f 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -42,6 +42,7 @@ module Ouroboros.Consensus.Network.NodeToNode , initiatorAndResponder -- * Leios mini-protocol limits + , leiosNotifyPipelineDepth , leiosNotifyProtocolLimits , leiosFetchProtocolLimits ) where diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs index 4dc932d34c..15280af3af 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs @@ -337,7 +337,7 @@ decideLeiosCertify leiosDbReader voteState tracer ledgerCfg currentSlot extState -- TODO: Why exactly do we guard against this? Also, shouldn't we -- detect it the other way around: if we have a cert, but not -- downloaded it ourselves -> warning! - mClosure <- lookupEbClosure leiosDbReader (Leios.pointEbHash ebPoint) + mClosure <- lookupTrustedEbClosure leiosDbReader (Leios.pointEbHash ebPoint) case mClosure of Nothing -> do traceWith tracer $ diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs index 05fed26604..9fd204df17 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs @@ -27,6 +27,9 @@ module Test.Consensus.Leios.Environment ( PeerEnv (..) , announceEb , connectPeer + , heardBodyOffers + , heardClosureOffers + , requestEbTxs , heardOffers , heardUnannouncedOffers , newPeerEnv @@ -58,9 +61,13 @@ import Data.ByteString.Lazy (ByteString) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.Vector.Strict as V +import Data.Word (Word16, Word64) +import LeiosDemoLogic (bitmapOffsets) import LeiosDemoOnlyTestFetch ( LeiosFetchRequestHandler (..) , Message (..) + , SomeLeiosFetchJob (..) + , leiosFetchClientPeer , leiosFetchServerPeer ) import LeiosDemoOnlyTestNotify (LeiosNotify (StBusy, StIdle)) @@ -85,7 +92,7 @@ import Ouroboros.Network.Channel (createConnectedChannels) import Ouroboros.Network.ConnectionId (ConnectionId (..)) import Ouroboros.Network.Context (ResponderContext (..)) import Ouroboros.Network.ControlMessage (ControlMessage (..)) -import Ouroboros.Network.Driver.Simple (runPeer) +import Ouroboros.Network.Driver.Simple (runPeer, runPipelinedPeer) import Ouroboros.Network.Mock.Chain (Chain) import qualified Ouroboros.Network.Mock.Chain as Chain import Ouroboros.Network.Mock.ProducerState @@ -131,6 +138,11 @@ data PeerEnv m = PeerEnv -- ^ What the node has said to this peer over LeiosNotify, in order. The -- node is the upstream peer on this second LeiosNotify connection, which is -- how a test sees what it relays. + , peFetchRequests :: PlainSTM.StrictTVar m [SomeLeiosFetchJob LeiosPoint LeiosEb LeiosTx m] + -- ^ What this peer has yet to ask the node for over LeiosFetch, in order. + -- The node is the server on that second LeiosFetch connection, so this is + -- how a test says what a downstream peer requests of it --- including things + -- no honest peer would ask for. } -- | One thing a peer says over LeiosNotify. @@ -144,7 +156,16 @@ newPeerEnv = do peEbs <- newTVarIO Map.empty peNotifications <- PlainSTM.newTVarIO [] peHeard <- PlainSTM.newTVarIO [] - pure PeerEnv{peChain, peServeThrough, peEbs, peNotifications, peHeard} + peFetchRequests <- PlainSTM.newTVarIO [] + pure + PeerEnv + { peChain + , peServeThrough + , peEbs + , peNotifications + , peHeard + , peFetchRequests + } -- | The endorser blocks the node offered this peer without having first -- announced them to it. @@ -228,7 +249,68 @@ heardOffers PeerEnv{peHeard} = Notify.MsgLeiosBlockTxsOffer point -> [point] _ -> [] +-- | The endorser blocks whose /body/ the node has told this peer it holds. +heardBodyOffers :: PeerEnv (IOSim s) -> IOSim s [LeiosPoint] +heardBodyOffers PeerEnv{peHeard} = + atomically $ + foldMap offered <$> PlainSTM.readTVar peHeard + where + offered :: LeiosNotification -> [LeiosPoint] + offered = \case + Notify.MsgLeiosBlockOffer point _size -> [point] + _ -> [] + +-- | The endorser blocks whose /closure/ the node has told this peer it holds. +-- +-- Narrower than 'heardOffers' on purpose: offering a body says only that the +-- node has the reference list, which it checked against the announced size, +-- whereas offering the closure says it holds every transaction the block names +-- at the size the block names it at. +heardClosureOffers :: PeerEnv (IOSim s) -> IOSim s [LeiosPoint] +heardClosureOffers PeerEnv{peHeard} = + atomically $ + foldMap offered <$> PlainSTM.readTVar peHeard + where + offered :: LeiosNotification -> [LeiosPoint] + offered = \case + Notify.MsgLeiosBlockTxsOffer point -> [point] + _ -> [] + +-- | Have this peer ask the node for these offsets of this endorser block's +-- closure. +-- +-- The bitmaps are passed through as given, so a test can ask for more than any +-- honest peer would: the node's own fetch logic batches its requests well +-- inside the bound the server enforces, and nothing else would produce one +-- that breaches it. +requestEbTxs :: PeerEnv (IOSim s) -> LeiosPoint -> [(Word16, Word64)] -> IOSim s () +requestEbTxs PeerEnv{peFetchRequests} point bitmaps = + atomically $ + PlainSTM.modifyTVar peFetchRequests (<> [job]) + where + job = + MkSomeLeiosFetchJob + (MsgLeiosBlockTxsRequest point bitmaps) + (pure (\_reply -> pure ())) + +-- | The next thing this peer has to ask for, blocking until it has something. +-- +-- Never finishes: like the LeiosNotify client, this peer simply goes on asking +-- for as long as the test runs. +nextFetchRequest :: + PeerEnv (IOSim s) -> + IOSim s (Either () (SomeLeiosFetchJob LeiosPoint LeiosEb LeiosTx (IOSim s))) +nextFetchRequest PeerEnv{peFetchRequests} = atomically $ do + PlainSTM.readTVar peFetchRequests >>= \case + [] -> retry + job : rest -> do + PlainSTM.writeTVar peFetchRequests rest + pure (Right job) + -- | Make this endorser block, and its closure, available from this peer. +-- +-- An empty closure is a peer that has the body and withholds the transactions: +-- it will answer body requests but stalls on a closure request forever. plantEb :: PeerEnv (IOSim s) -> LeiosEb -> [(TxHash, BS.ByteString)] -> IOSim s () plantEb PeerEnv{peEbs} eb closure = @@ -257,6 +339,7 @@ connectPeer nut registry addr penv = do (lnClient, lnServer) <- createConnectedChannels (lnDownClient, lnDownServer) <- createConnectedChannels (lfClient, lfServer) <- createConnectedChannels + (lfDownClient, lfDownServer) <- createConnectedChannels let codecs = peerCodecs nut apps = peerApps nut @@ -313,11 +396,17 @@ connectPeer nut registry addr penv = do fork ("LeiosNotify server (node) " <> show addr) $ void $ NTN.aLeiosNotifyServer apps version (responderCtx addr) lnDownServer + -- Pipelined, to the same depth the node's own client uses. The node drops a + -- notification it has no credit to send, by design, so a downstream peer + -- that does not keep its requests outstanding silently misses offers --- and + -- a test built on one would conclude the node never made them. fork ("LeiosNotify client (env) " <> show addr) $ void $ - runPeer (sayTracer ("ln-down " <> show addr)) (NTN.cLeiosNotifyCodec codecs) lnDownClient $ - Notify.leiosNotifyClientPeer - (pure (Right record) :: IOSim s (Either () (LeiosNotification -> IOSim s ()))) + runPipelinedPeer (sayTracer ("ln-down " <> show addr)) (NTN.cLeiosNotifyCodec codecs) lnDownClient $ + Notify.toLeiosNotifyClientPeerPipelined $ + Notify.leiosNotifyClientPeerPipelined + (pure (Right NTN.leiosNotifyPipelineDepth) :: IOSim s (Either () Int)) + (pure record) fork ("LeiosFetch client " <> show addr) $ void $ @@ -327,6 +416,16 @@ connectPeer nut registry addr penv = do runPeer (sayTracer ("lf " <> show addr)) (NTN.cLeiosFetchCodec codecs) lfServer $ leiosFetchServerPeer (pure (leiosFetchHandlerOf penv)) + -- The other direction of LeiosFetch: the node is the server, and this + -- environment client asks it for whatever 'requestEbTxs' has queued. + fork ("LeiosFetch server (node) " <> show addr) $ + void $ + NTN.aLeiosFetchServer apps version (responderCtx addr) lfDownServer + fork ("LeiosFetch client (env) " <> show addr) $ + void $ + runPeer (sayTracer ("lf-down " <> show addr)) (NTN.cLeiosFetchCodec codecs) lfDownClient $ + leiosFetchClientPeer (nextFetchRequest penv) + {------------------------------------------------------------------------------- The servers -------------------------------------------------------------------------------} @@ -405,14 +504,22 @@ leiosFetchHandlerOf PeerEnv{peEbs} = MkLeiosFetchRequestHandler $ \case MsgLeiosBlockRequest point -> do (eb, _closure) <- atomically $ awaitEb point pure $ MsgLeiosBlock eb + -- A peer that holds the body but not (all of) the closure simply does not + -- answer, which is the one thing no peer can be caught at. Answering with + -- fewer txs than were asked for would instead be a protocol violation, and + -- the node would rightly kill the connection over it. MsgLeiosBlockTxsRequest point bitmaps -> do - (eb, closure) <- atomically $ awaitEb point - let txs = - V.fromList - [ MkLeiosTx bytes - | (txHash, _size) <- V.toList (leiosEbTxs eb) - , Just bytes <- [Map.lookup txHash closure] + txs <- atomically $ do + (eb, closure) <- awaitEb point + let ebTxs = leiosEbTxs eb + asked = + [ Map.lookup txHash closure + | offset <- bitmapOffsets bitmaps + , Just (txHash, _size) <- [ebTxs V.!? offset] ] + case sequence asked of + Nothing -> retry + Just bytess -> pure $ V.fromList (map MkLeiosTx bytess) pure $ MsgLeiosBlockTxs point bitmaps txs where awaitEb point = do diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/NodeUnderTest.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/NodeUnderTest.hs index e36d09c16c..53e82ca0bd 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/NodeUnderTest.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/NodeUnderTest.hs @@ -34,7 +34,7 @@ import Data.Time.Calendar (fromGregorian) import Data.Time.Clock (UTCTime (..)) import qualified LeiosDemoDb as LeiosDb import qualified LeiosDemoLogic as Leios -import LeiosTxCache (nullLeiosTxCache) +import LeiosTxCache (defaultLeiosTxCacheShift, newPureLeiosTxCache) import Ouroboros.Consensus.BlockchainTime ( BackoffDelay (..) , BlockchainTime @@ -192,6 +192,11 @@ mkNodeKernelArgs :: IOSim s (NodeKernelArgs (IOSim s) PeerAddr () Blk) mkNodeKernelArgs cfg registry chainDB leiosDB btime = do publicPeerSelectionStateVar <- makePublicPeerSelectionStateVar + -- The reference index rather than 'nullLeiosTxCache'. An inert cache misses + -- every transaction, so the node re-fetches ones it already holds --- which + -- no real node does, and which is the sort of difference a test is least + -- likely to notice it is relying on. + leiosTxCache <- newPureLeiosTxCache defaultLeiosTxCacheShift pure NodeKernelArgs { tracers = nullTracers @@ -248,7 +253,7 @@ mkNodeKernelArgs cfg registry chainDB leiosDB btime = do , genesisArgs = GenesisNodeKernelArgs{gnkaLoEAndGDDArgs = LoEAndGDDDisabled} , getDiffusionPipeliningSupport = DiffusionPipeliningOn , leiosDB - , leiosTxCache = nullLeiosTxCache + , leiosTxCache , leiosFetchRng = mkStdGen 4 , leiosMinOfferLead = nutcMinOfferLead cfg } diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs index b8006d5c95..2113b6f8ec 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -11,6 +12,11 @@ -- peer holds and when, and the node does the rest by itself --- syncing -- headers, fetching blocks, verifying the certificate, fetching the endorser -- block, and selecting. +-- +-- TODO The name no longer fits what is here. Only the first test is about the +-- Recovery Path; the rest are about what the node will say to a peer and what +-- it will believe from one. Either rename this module for the harness it +-- actually is, or float those tests out into their own. module Test.Consensus.Leios.RecoveryPath (tests) where import Cardano.Crypto.DSIGN (signDSIGN) @@ -29,13 +35,27 @@ import Control.Monad.IOSim import Control.ResourceRegistry (withRegistry) import qualified Data.ByteString.Char8 as BS8 import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntSet as IntSet import qualified Data.Map.Strict as Map +import Data.Maybe (isJust) import Data.Ratio ((%)) import qualified LeiosDemoDb as LeiosDb import qualified LeiosDemoLogic as Leios import LeiosDemoLogic.Announcements (ShouldRelay (..)) import LeiosDemoLogic.Announcements.ElBimap (ElId) -import LeiosDemoTypes (BytesSize, LeiosCert, LeiosEb, LeiosPoint (..), LeiosSeatId (..), PeerId (..), RbHash (MkRbHash), TxHash, Weight, aggregateLeiosCert, offerings) +import LeiosDemoTypes + ( BytesSize + , LeiosCert + , LeiosEb + , LeiosPoint (..) + , LeiosSeatId (..) + , PeerId (..) + , RbHash (MkRbHash) + , TxHash + , Weight + , aggregateLeiosCert + , offerings + ) import LeiosValidClaims (isCertifiedEb, memberValidClaim, sizeValidClaims) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (slotLengthFromSec) @@ -111,6 +131,12 @@ tests = , testCase "every offer the node makes a peer follows its announcement to that peer" test_offerFollowsAnnouncementPerPeer + , testCase + "an endorser block misstating a size is not offered onward (transaction first)" + (test_lyingSizeIsNotOffered TxBeforeBody) + , testCase + "an endorser block misstating a size is not offered onward (body first)" + (test_lyingSizeIsNotOffered BodyBeforeTx) , testCase "an endorser block too near the immutable tip is not offered onward" (test_offeredOnlyAboveTheLead DoNotRelay) @@ -243,6 +269,52 @@ freshChain = [freshRoot, freshAnnouncer, freshCertRB] (mkCert testCommittee (MkRbHash (toRawHash (Proxy @Blk) (blockHash freshAnnouncer)))) (successorLeiosBlock freshAnnouncer) +-- | A transaction that two endorser blocks name: 'honestEb', which states its +-- size correctly, and 'lyingEb', which does not. +sharedTx :: LeiosTestTx +sharedTx = + LeiosTestTx + { ltxAsserts = IntMap.singleton 4 Nothing + , ltxWrites = IntMap.singleton 4 'd' + } + +-- | Names 'sharedTx' at its true size. The node fetches this one's closure, +-- which is how 'sharedTx' comes to be in its LeiosDb at all. +honestEb :: LeiosEb +honestClosure :: [(TxHash, BS8.ByteString)] +honestSize :: BytesSize +(honestEb, honestClosure, honestSize) = mkLeiosTestEb [sharedTx] + +honestPoint :: LeiosPoint +honestPoint = leiosTestEbPoint 2 honestEb + +-- | The header that announces 'honestEb'. No peer ever serves it as part of a +-- chain: this test is entirely about LeiosNotify and LeiosFetch, so the only +-- thing said about it is the announcement itself. +honestAnnouncer :: Blk +honestAnnouncer = + announcing honestPoint honestSize $ + successorLeiosBlock (firstLeiosBlock 4) + +-- | Names the same transaction as 'honestEb', at one byte. +-- +-- Nothing about this endorser block is detectably wrong on arrival: it is its +-- own block, for its own election, and its body is exactly the size its +-- announcement claims. The lie is inside the body, about a transaction the +-- node is not going to fetch. +lyingEb :: LeiosEb +lyingSize :: BytesSize +(lyingEb, _, lyingSize) = mkLeiosTestEbClaiming [(sharedTx, 1)] + +lyingPoint :: LeiosPoint +lyingPoint = leiosTestEbPoint 4 lyingEb + +-- | Announced in slot 4, so this is a different election from 'honestEb''s. +lyingAnnouncer :: Blk +lyingAnnouncer = + announcing lyingPoint lyingSize $ + iterate successorLeiosBlock (firstLeiosBlock 5) !! 3 + -- | A chain that shares nothing with the announcer and carries no -- certificates, so the node can select it without needing any endorser block. betterChain :: [Blk] @@ -407,6 +479,119 @@ test_forgottenCertRBIsSelectedAgain = do (not (arRivalCertRbHeld after')) assertBool "so the rival is never certified" (not (arRivalCertified after')) +-- | Which of the lying endorser block's body and the transaction it misstates +-- reaches the node first. They complete its closure at different places --- +-- the body's own insert, or the arrival of the last transaction it waited on +-- --- so each has to be checked. +data LieArrival = TxBeforeBody | BodyBeforeTx + deriving Show + +-- | An endorser block may not be offered onward on the strength of a closure +-- the node never checked. +-- +-- The node first acquires 'honestEb', whose body states 'sharedTx''s size +-- correctly, so the transaction lands in its LeiosDb at its true size. Then a +-- second peer announces 'lyingEb', which names that same transaction at one +-- byte. The node fetches that body --- it matches its announced hash and size, +-- so there is nothing to object to --- and the LeiosDb finds every transaction +-- it names already present, because presence is keyed by transaction hash +-- alone. The closure is therefore declared complete without a single byte being +-- fetched for it, and never having been compared against what the body claimed. +-- +-- So the node tells its downstream peers it holds a closure matching a body +-- that lies about its own size. A peer that believes it, and asks for the +-- transactions, is served far more than the body led it to expect: here one +-- byte becomes the whole of 'sharedTx', and in general an endorser block whose +-- body is well under the size ceiling can name a closure of unbounded size. +-- +-- Only the closure offer is at issue. Offering the body is honest --- the node +-- does hold that reference list, at the hash and size announced. +-- +-- Both arrival orders are run, because the closure is completed at a different +-- place in each: by the body's own insert when the transaction is already +-- held, and by the arrival of the last transaction it was waiting on when it +-- is not. Both end in the same offer. +-- +-- The node does own a check that would catch this --- 'checkJobSize' compares +-- arriving transactions against the sizes the body claimed --- but it only +-- runs on what the node fetches. No peer here offers the lying closure, so +-- there is nothing to fetch for it: the transaction arrives on the honest +-- endorser block's fetch, under the size that block states, and completes the +-- lying one as a side-effect. +-- +-- TODO Both cases fail. A bugfix commit is imminent. +test_lyingSizeIsNotOffered :: LieArrival -> Assertion +test_lyingSizeIsNotOffered arrival = do + let simTrace = runSimTrace scenario + case traceResult False simTrace of + Right (bodyOffers, closureOffers) -> do + -- Without this the test could pass for the wrong reason: if the node + -- never offered the listener anything about this endorser block, there + -- was no closure offer to catch. + assertBool + "the node never offered this endorser block's body, so the test proves nothing" + (lyingPoint `elem` bodyOffers) + assertEqual + "the node offered a closure for an endorser block that misstates a size" + [] + (filter (== lyingPoint) closureOffers) + outcome -> + assertFailure $ + unlines $ + ("expected " <> show arrival <> " to be caught, but: " <> show outcome) + : lastN 40 (selectTraceEventsSay' simTrace) + where + scenario :: forall s. IOSim s ([LeiosPoint], [LeiosPoint]) + scenario = do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + holder <- newPeerEnv + listener <- newPeerEnv + liar <- newPeerEnv + + (chainDBTracer, getTraces) <- recordingTracerTVar + + withNodeUnderTest nodeConfig nodeDBs leiosDb chainDBTracer $ \nut -> + withRegistry $ \registry -> do + -- The listener joins first, so the node relays it every announcement + -- and its own send-side gate is never what keeps an offer away. + connectPeer nut registry (PeerAddr 1) listener + connectPeer nut registry (PeerAddr 0) holder + connectPeer nut registry (PeerAddr 2) liar + + -- The liar's body is genuine and genuinely the size it announced; + -- only the size inside it is a lie. It never offers the closure, so + -- the only way the node can come to hold that transaction is the + -- honest endorser block's own fetch. + plantEb liar lyingEb [] + plantEb holder honestEb honestClosure + + -- Both announcing headers sit in slots this simulation starts before, + -- and a header from the future is rejected as such. Nothing here turns + -- on when they arrive, only on the order they arrive in. + threadDelay 6 + + let servesTheTransaction = do + announceEb holder (getHeader honestAnnouncer) + offerEb holder honestPoint honestSize + offerEbTxs holder honestPoint + awaitPollingWith getTraces "the shared transaction is in the LeiosDb" $ + LeiosDb.withReader leiosDb $ \r -> + isJust <$> LeiosDb.lookupTrustedEbClosure r (pointEbHash honestPoint) + servesTheLie = do + announceEb liar (getHeader lyingAnnouncer) + offerEb liar lyingPoint lyingSize + awaitPollingWith getTraces "the lying body is in the LeiosDb" $ + LeiosDb.withReader leiosDb $ \r -> + not . null <$> LeiosDb.lookupEbBody r (pointEbHash lyingPoint) + + case arrival of + TxBeforeBody -> servesTheTransaction >> servesTheLie + BodyBeforeTx -> servesTheLie >> servesTheTransaction + threadDelay 5 + + (,) <$> heardBodyOffers listener <*> heardClosureOffers listener + -- | The node offers an endorser block to its downstream peers only once the -- endorser block's slot is 'nutcMinOfferLead' above the node's own immutable -- tip, so that a peer whose immutable tip is a little ahead of ours does not diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 49a896e6eb..5a94d6fa7e 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -379,7 +379,7 @@ library cardano-binary, cardano-crypto-class >=2.6 && <2.7, cardano-crypto-leios >=0.3, - cardano-diffusion:api, + cardano-diffusion:{api, cardano-diffusion}, cardano-ledger-binary ^>=1.10, cardano-ledger-core ^>=1.22, cardano-ledger-dijkstra ^>=0.4, diff --git a/ouroboros-consensus/bench/leios-db-bench/Main.hs b/ouroboros-consensus/bench/leios-db-bench/Main.hs index e223859d11..726f15b271 100644 --- a/ouroboros-consensus/bench/leios-db-bench/Main.hs +++ b/ouroboros-consensus/bench/leios-db-bench/Main.hs @@ -14,7 +14,7 @@ -- the pre-populated EBs. -- -- * __Chain-sel reader__ (1 thread): mimics the block-apply path via --- 'lookupEbClosure' — the same read that 'resolveLeiosClosure' +-- 'lookupTrustedEbClosure' — the same read that 'resolveLeiosClosure' -- issues per Dijkstra-era CertRB. -- -- * __GC ticker__ (1 thread): periodic 'leiosDbGarbageCollect' calls (a @@ -49,7 +49,7 @@ import LeiosDemoDb , batchRetrieveTxs , leiosDbGarbageCollect , lookupEbBody - , lookupEbClosure + , lookupTrustedEbClosure , newLeiosDBSQLite , withReader , withWriter @@ -81,7 +81,7 @@ main = do , "Concurrent workload per iteration:" , " Fetch clients (×" <> show numFetchClients <> "): 20 insertEbPoint/insertEbBody/insertTxs each" , " Fetch servers (×" <> show numFetchServers <> "): 30 lookupEbBody + 10 batchRetrieveTxs each" - , " Chain-sel reader(×1): " <> show numChainSelReads <> " lookupEbClosure calls" + , " Chain-sel reader(×1): " <> show numChainSelReads <> " lookupTrustedEbClosure calls" , " GC ticker (×1): " <> show numGcTicks <> " garbageCollect calls" , "" , "Runs: 1 warmup + " <> show numRuns <> " timed" @@ -152,12 +152,12 @@ fetchClient db range = forM_ range (insertOneEb w) -- | Mirrors chain-selection's block-apply path: repeated --- 'lookupEbClosure' for the tx closure of each certified EB. +-- 'lookupTrustedEbClosure' for the tx closure of each certified EB. chainSelReader :: LeiosDbHandle IO -> [LeiosPoint] -> IO () chainSelReader db points = withReader db $ \r -> forM_ (take numChainSelReads (cycle points)) $ \p -> - lookupEbClosure r p.pointEbHash + lookupTrustedEbClosure r p.pointEbHash -- | Fires periodic garbage-collect calls. Handle-level operation; touches -- every table when implemented (currently a no-op backend-side, but the diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs index 1e30e521b7..fd7805cf2a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs @@ -80,9 +80,15 @@ data LeiosDbReader m = LeiosDbReader { close :: m () , lookupEbBody :: HasCallStack => EbHash -> m [(TxHash, BytesSize)] -- ^ The EB "body": tx hashes and sizes in order, no tx bytes. - , lookupEbClosure :: HasCallStack => EbHash -> m (Maybe [(TxHash, ByteString)]) + , lookupTrustedEbClosure :: HasCallStack => EbHash -> m (Maybe [(TxHash, ByteString)]) -- ^ The EB "closure": tx hashes /and/ their bytes, or 'Nothing' if the EB is -- not complete. + -- + -- PREREQ: the caller has established that this endorser block is + -- trustworthy. Two things establish it: a certificate, for ChainSel applying + -- a cert-RB and for the forge; and the LeiosDb having called the closure + -- complete, for voting. Calling it on anything else reads an unbounded + -- number of bytes chosen by whoever made the endorser block. , batchRetrieveTxs :: HasCallStack => EbHash -> [Int] -> m [(Int, TxHash, Maybe ByteString)] diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs index df4f4f58dd..ca90248694 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs @@ -143,7 +143,7 @@ openInMemoryReader stateVar = LeiosDbReader { close = pure () , lookupEbBody = imLookupEbBody stateVar - , lookupEbClosure = imLookupEbClosure stateVar + , lookupTrustedEbClosure = imLookupTrustedEbClosure stateVar , batchRetrieveTxs = imBatchRetrieveTxs stateVar , scanEbPoints = imScanEbPoints stateVar , -- ThreadNet persists 'stateVar' across simulated restarts, so on @@ -397,9 +397,9 @@ imBatchRetrieveTxs stateVar ebHash offsets = atomically $ do where bytes = Map.findWithDefault IntMap.empty ebHash (imEbTxBytes state) -imLookupEbClosure :: +imLookupTrustedEbClosure :: IOLike m => StrictTVar m InMemoryLeiosDb -> EbHash -> m (Maybe [(TxHash, ByteString)]) -imLookupEbClosure stateVar ebHash = atomically $ do +imLookupTrustedEbClosure stateVar ebHash = atomically $ do state <- readTVar stateVar case Map.lookup ebHash (imEbBodies state) of Nothing -> pure Nothing diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs index fde6509c4d..a2f6c60ff5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs @@ -257,7 +257,7 @@ newLeiosDBSQLiteWithGcBatchSize tracer volLeiosDbPath immLeiosDbPath gcBatchSize , scanCompleteEbClosuresNotOlderThanSlot = sqlScanCompleteEbPointsSince conn , lookupEbBody = sqlLookupEbBody conn , batchRetrieveTxs = sqlBatchRetrieveTxs conn - , lookupEbClosure = sqlLookupEbClosure conn + , lookupTrustedEbClosure = sqlLookupTrustedEbClosure conn } openWriter writeQueue = @@ -868,7 +868,7 @@ data VolStmts = VolStmts , stDecrMissingCount :: !DB.Statement , stMarkPointNotified :: !DB.Statement , stBatchRetrieveTxs :: !DB.Statement - , stLookupEbClosure :: !DB.Statement + , stLookupTrustedEbClosure :: !DB.Statement , stScanCompleteEbsSince :: !DB.Statement } @@ -894,7 +894,7 @@ data Conn = Conn -- before their connection. data ImmStmts = ImmStmts { immStLookupEbBody :: !DB.Statement - , immStLookupEbClosure :: !DB.Statement + , immStLookupTrustedEbClosure :: !DB.Statement , immStBatchRetrieveTxs :: !DB.Statement , immStFilterPresent :: !DB.Statement } @@ -902,7 +902,7 @@ data ImmStmts = ImmStmts prepareImmStmts :: HasCallStack => DB.Database -> IO ImmStmts prepareImmStmts db = do immStLookupEbBody <- dbPrepare db (fromString sql_lookup_ebBodies) - immStLookupEbClosure <- dbPrepare db (fromString sql_lookup_eb_closure) + immStLookupTrustedEbClosure <- dbPrepare db (fromString sql_lookup_eb_closure) immStBatchRetrieveTxs <- dbPrepare db (fromString sql_retrieve_from_ebTxs_json) immStFilterPresent <- dbPrepare db (fromString sql_imm_filter_present) pure ImmStmts{..} @@ -911,7 +911,7 @@ prepareImmStmts db = do finalizeImmStmts :: ImmStmts -> IO () finalizeImmStmts ImmStmts{..} = do dbFinalize immStLookupEbBody - dbFinalize immStLookupEbClosure + dbFinalize immStLookupTrustedEbClosure dbFinalize immStBatchRetrieveTxs dbFinalize immStFilterPresent @@ -929,7 +929,7 @@ prepareVolStmts db = do stDecrMissingCount <- dbPrepare db (fromString sql_decrement_missing_tx_count) stMarkPointNotified <- dbPrepare db (fromString sql_mark_point_notified) stBatchRetrieveTxs <- dbPrepare db (fromString sql_retrieve_from_ebTxs_json) - stLookupEbClosure <- dbPrepare db (fromString sql_lookup_eb_closure) + stLookupTrustedEbClosure <- dbPrepare db (fromString sql_lookup_eb_closure) stScanCompleteEbsSince <- dbPrepare db (fromString sql_scan_complete_ebs_since) pure VolStmts{..} @@ -948,7 +948,7 @@ finalizeVolStmts VolStmts{..} = do dbFinalize stDecrMissingCount dbFinalize stMarkPointNotified dbFinalize stBatchRetrieveTxs - dbFinalize stLookupEbClosure + dbFinalize stLookupTrustedEbClosure dbFinalize stScanCompleteEbsSince -- | Run an action on a pre-prepared statement and always @sqlite3_reset@ @@ -1514,6 +1514,23 @@ sqlInsertEbPoint conn point ebBytesSize = do -- | Persist an EB body. The point MUST already be present (inserted -- via 'sqlInsertEbPoint' on the announcement path). +-- +-- TODO Nothing here says an endorser block was caught misstating a +-- transaction's size, though this is where it is first detectable: the size +-- predicate in 'sql_insert_missing_txs' leaves such a body waiting on a +-- transaction we already hold, so its @missingTxCount@ stays positive for +-- good. A trace would want to fire once per offending endorser block rather +-- than once per transaction, which needs state neither this function nor +-- 'sqlInsertTxs' keeps, and there is no action to take on it either way --- +-- the issuer is not a peer we are connected to, and the peer that relayed the +-- body may be perfectly honest. Until that is worth building, an old endorser +-- block stuck at a positive @missingTxCount@ is the signal, and this names +-- them: +-- +-- > SELECT e.ebHashBytes, COUNT(*) FROM ebTxs e +-- > JOIN txs t ON e.txHashBytes = t.txHashBytes +-- > WHERE t.txBytesSize <> e.txBytesSize +-- > GROUP BY e.ebHashBytes sqlInsertEbBody :: Tracer IO TraceLeiosDb -> Conn -> @@ -1606,6 +1623,11 @@ readReturningInt64 stmt = DB.Done -> pure n DB.Row -> throwLeiosDbException "readReturningInt64: expected exactly one row from RETURNING" +-- | Persist arriving transactions, completing the closure of every endorser +-- block that was waiting on them. +-- +-- TODO As 'sqlInsertEbBody': an endorser block left waiting here because it +-- misstated this transaction's size goes unremarked, and for the same reasons. sqlInsertTxs :: Tracer IO TraceLeiosDb -> Conn -> @@ -1702,6 +1724,8 @@ immBatchRetrieveTxs conn ebHash offsets = where Conn{connImmStmts = ImmStmts{immStBatchRetrieveTxs = stmt}} = conn +-- | Walk the joined rows, the way 'closureLoop' walks them until a tx is +-- missing. retrieveLoop :: DB.Statement -> [(Int, TxHash, Maybe ByteString)] -> @@ -1812,8 +1836,8 @@ jsonIntArray xs = intersperseB _ [x] = [x] intersperseB s (x : rest) = x : s : intersperseB s rest -sqlLookupEbClosure :: Conn -> EbHash -> IO (Maybe [(TxHash, ByteString)]) -sqlLookupEbClosure conn ebHash = do +sqlLookupTrustedEbClosure :: Conn -> EbHash -> IO (Maybe [(TxHash, ByteString)]) +sqlLookupTrustedEbClosure conn ebHash = do vol <- dbWithTransaction db $ useStmt stmt $ do dbBindBlob stmt 1 (ebHashBytes ebHash) @@ -1824,19 +1848,19 @@ sqlLookupEbClosure conn ebHash = do -- answer for it, or replaying its cert-RB fails. case vol of Just rows -> pure (Just rows) - Nothing -> immLookupEbClosure conn ebHash + Nothing -> immLookupTrustedEbClosure conn ebHash where - Conn{conVolDb = db, connVolStmts = VolStmts{stLookupEbClosure = stmt}} = conn + Conn{conVolDb = db, connVolStmts = VolStmts{stLookupTrustedEbClosure = stmt}} = conn --- | Immutable-partition fallback of 'sqlLookupEbClosure'. Closures land there +-- | Immutable-partition fallback of 'sqlLookupTrustedEbClosure'. Closures land there -- atomically and whole, so any rows are all the rows. -immLookupEbClosure :: Conn -> EbHash -> IO (Maybe [(TxHash, ByteString)]) -immLookupEbClosure conn ebHash = +immLookupTrustedEbClosure :: Conn -> EbHash -> IO (Maybe [(TxHash, ByteString)]) +immLookupTrustedEbClosure conn ebHash = useStmt stmt $ do dbBindBlob stmt 1 (ebHashBytes ebHash) closureLoop stmt [] where - Conn{connImmStmts = ImmStmts{immStLookupEbClosure = stmt}} = conn + Conn{connImmStmts = ImmStmts{immStLookupTrustedEbClosure = stmt}} = conn closureLoop :: DB.Statement -> [(TxHash, ByteString)] -> IO (Maybe [(TxHash, ByteString)]) diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoOnlyTestFetch.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoOnlyTestFetch.hs index 1bf4728e82..e0d3d03cba 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoOnlyTestFetch.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoOnlyTestFetch.hs @@ -18,6 +18,8 @@ module LeiosDemoOnlyTestFetch , SingLeiosFetch (..) , leiosFetchMiniProtocolNum , byteLimitsLeiosFetch + , maxLeiosTxsRequestBytesSize + , maxLeiosEbBytesSize , codecLeiosFetch , codecLeiosFetchId , timeLimitsLeiosFetch @@ -40,6 +42,7 @@ module LeiosDemoOnlyTestFetch , encodeBitmaps ) where +import Cardano.Network.NodeToNode (addSafetyMargin) import qualified Codec.CBOR.Decoding as CBOR import qualified Codec.CBOR.Encoding as CBOR import qualified Codec.CBOR.Read as CBOR @@ -55,7 +58,7 @@ import Data.Primitive.MutVar (MutVar) import qualified Data.Primitive.MutVar as Prim import Data.Proxy (Proxy (..)) import qualified Data.Vector.Strict as V -import Data.Word (Word16, Word64) +import Data.Word (Word16, Word32, Word64) import qualified Network.Mux.Types as Mux import Network.TypedProtocol.Codec.CBOR ( ActiveState @@ -88,7 +91,6 @@ import Network.TypedProtocol.Peer import Ouroboros.Network.Protocol.Limits ( ProtocolSizeLimits (..) , ProtocolTimeLimits (..) - , largeByteLimit , longWait , smallByteLimit , waitForever @@ -207,13 +209,54 @@ deriving instance ----- +-- | The design ceiling on an endorser block +-- +-- This is the bound the logic enforces --- what it will forge, serve and size +-- its buffers for. The codec tolerates slightly more (see +-- 'byteLimitsLeiosFetch'), but that slack pays for framing and nothing may +-- spend it as capacity. +-- +-- TODO Two things wrong with this number. It should be 500 KiB; it is 512 KiB +-- only because @exampleDijkstraGenesis@ in the ledger's testlib sets +-- @maxEndorserBlockReferencesSize@ to that (I think that's simply a typo), and +-- @guardLeiosWireLimit@ refuses to run with a protocol parameter above this +-- ceiling. +-- +-- And it should not be a constant wherever the ledger is in reach: this is the +-- constitution's bound on what @maxEndorserBlockReferencesSize@ may be, not +-- the value in force, which is whatever the current ledger state says. The +-- buffers sized from it are allocated before any ledger state can be read, +-- which is why at least those cannot do better. +maxLeiosEbBytesSize :: Word32 +maxLeiosEbBytesSize = 512 * 1024 + +-- | The design ceiling on the transactions one @MsgLeiosBlockTxs@ carries, so +-- on what a /single request/ may fetch. +-- +-- Not a ceiling on an endorser block's whole closure, which is unbounded by +-- this and ordinarily far larger: a closure is fetched over as many requests +-- as it takes. Nor is it related to 'maxLeiosEbBytesSize', which bounds a list +-- of references rather than the transactions those references name. +-- +-- What ties it to the protocol is that the client batches to exactly this, so +-- the client-side 'maxRequestBytesSize' is defined as it and the server can +-- refuse anything above it without ever refusing an honest peer. +maxLeiosTxsRequestBytesSize :: Word32 +maxLeiosTxsRequestBytesSize = 500 * 1000 + byteLimitsLeiosFetch :: ProtocolSizeLimits (LeiosFetch point eb tx) bytes byteLimitsLeiosFetch = ProtocolSizeLimits $ \case SingIdle -> smallByteLimit - SingBlock -> largeByteLimit - SingBlockTxs -> largeByteLimit + SingBlock -> withMargin maxLeiosEbBytesSize + SingBlockTxs -> withMargin maxLeiosTxsRequestBytesSize st@SingDone -> notActiveState st + where + -- The decoder must not reject a message the logic was right to send, so each + -- state allows for what its message writes around the payload: the reference + -- list's header, and, on @MsgLeiosBlockTxs@, the echoed request. + withMargin :: Word32 -> Word + withMargin = fromIntegral . addSafetyMargin . fromIntegral timeLimitsLeiosFetch :: ProtocolTimeLimits (LeiosFetch point eb tx) diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs index efec91fb22..8a3104dbfc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs @@ -18,6 +18,8 @@ module LeiosDemoTypes ( module LeiosDemoTypes + , maxLeiosTxsRequestBytesSize + , maxLeiosEbBytesSize -- * Re-exports , module Cardano.Crypto.Leios @@ -115,7 +117,12 @@ import GHC.Generics (Generic) import LeiosDemoDb.Trace (LeiosDbStats (..), TraceLeiosDb (..)) import LeiosDemoException (LeiosDbException (..), jsonLeiosDbException) import LeiosDemoLogic.Announcements.ElBimap (ElId (..)) -import LeiosDemoOnlyTestFetch (LeiosFetch, Message (..)) +import LeiosDemoOnlyTestFetch + ( LeiosFetch + , Message (..) + , maxLeiosEbBytesSize + , maxLeiosTxsRequestBytesSize + ) import qualified LeiosDemoOnlyTestFetch as LeiosFetch import LeiosDemoOnlyTestNotify (LeiosNotify, Message (..)) import qualified LeiosDemoOnlyTestNotify as LeiosNotify @@ -148,7 +155,6 @@ import Ouroboros.Consensus.Util.IOLike (IOLike, NoThunks) import Ouroboros.Network.PeerSelection.LedgerPeers.Type ( IsBigLedgerPeer (..) ) -import Ouroboros.Network.Protocol.Limits (largeByteLimit) import System.Random (StdGen) import Text.Pretty.Simple (pShow) @@ -1214,7 +1220,7 @@ demoLeiosFetchStaticEnv :: LeiosFetchStaticEnv demoLeiosFetchStaticEnv = MkLeiosFetchStaticEnv { maxRequestedBytesSizePerPeer = 5 * million - , maxRequestBytesSize = 500 * thousand + , maxRequestBytesSize = maxLeiosTxsRequestBytesSize , maxJobBytesSize = 64 * thousandBase2 , maxJobTxCount = 20000 -- TODO do we want this to be low enough to matter? , fetchPriorityWindowSlots = 10 -- TODO read dynamically from ledger state @@ -1226,8 +1232,6 @@ demoLeiosFetchStaticEnv = million = 10 ^ (6 :: Int) millionBase2 :: Num a => a millionBase2 = 2 ^ (20 :: Int) - thousand :: Num a => a - thousand = 10 ^ (3 :: Int) thousandBase2 :: Num a => a thousandBase2 = 2 ^ (10 :: Int) @@ -2815,31 +2819,18 @@ leiosExtValidationErrorForHuman = \case -- rather than an undiffusable one ('leiosEndorserBlockMeasure') -- silently, -- today; a trace when that cap bites would be worth adding. --- | The largest Leios block message we will send or accept: the LeiosFetch --- codec's own byte limit for its Block state ('byteLimitsLeiosFetch' returns --- 'largeByteLimit' there), so everything sized from this holds anything a peer --- can deliver, by construction. -maxMsgLeiosBlockBytesSize :: BytesSize -maxMsgLeiosBlockBytesSize = fromIntegral largeByteLimit - --- | The bytes @MsgLeiosBlock@ writes around the EB it carries (its list length --- and word tag), which the codec's message limit measures alongside the body. --- An EB body must stay this far under 'maxMsgLeiosBlockBytesSize' to diffuse. -msgLeiosBlockFramingSize :: BytesSize -msgLeiosBlockFramingSize = 2 - --- | The most transactions any EB the codec will accept can name. Sizes the --- fetch buffers and bounds the wire bitmaps. +-- | The most transactions an endorser block may name. Sizes the fetch buffers +-- and bounds the wire bitmaps. -- -- Those buffers are allocated before any ledger state is in reach, which is --- why this derives from the codec limit and not from the protocol parameter; --- the mempool in turn plans EBs within the codec limit, so a forged EB always --- fits the buffers of every honest peer. +-- why this derives from the design ceiling and not from the protocol +-- parameter; the mempool in turn plans EBs within that same ceiling, so a +-- forged EB always fits the buffers of every honest peer. maxTxsPerEb :: Int maxTxsPerEb = - (msgLimit - framing) `div` minItemSize + (ebLimit - framing) `div` minItemSize where - msgLimit = fromIntegral $ maxMsgLeiosBlockBytesSize - msgLeiosBlockFramingSize + ebLimit = fromIntegral maxLeiosEbBytesSize -- The whole reference list less its framing, over the smallest a reference -- can be: both come from the encoder, so the buffers track it exactly. diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosVoting.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosVoting.hs index 48700880d8..8c2d875100 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosVoting.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosVoting.hs @@ -440,6 +440,11 @@ data EbClosureVerdict blk -- Each tx is validated in full, except where the LeiosTxCache reports it -- already validated: then only the state-dependent checks re-run -- ('LedgerSupportsMempool.reapplyTx' rather than 'applyTx'). +-- +-- TODO Issue https://github.com/input-output-hk/ouroboros-leios/issues/1115. +-- Waiting on @AcquiredEbTxs@ is enough today, since that is where an endorser +-- block misstating a transaction's size will be caught. Voting logic that +-- does not wait that long would have to check the sizes itself. validateEbClosure :: forall m blk. ( IOLike m diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs index aa98609131..6a141ce48a 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs @@ -56,6 +56,7 @@ module Test.Util.LeiosTestBlock , leiosTestEbPoint , leiosTestTxBytes , mkLeiosTestEb + , mkLeiosTestEbClaiming , maxLeiosTestChainLength -- * Building chains @@ -119,7 +120,7 @@ import qualified Data.Vector.Strict as V import Data.Void (Void) import Data.Word (Word64) import GHC.Generics (Generic) -import LeiosDemoDb (lookupEbClosure) +import LeiosDemoDb (lookupTrustedEbClosure) import LeiosDemoLogic.Announcements.ElBimap (ElId (MkElId)) import LeiosDemoTypes ( AnnouncementFields (..) @@ -468,7 +469,7 @@ instance ResolveLeiosBlock LeiosTestBlock where -- The closure the LeiosDb holds for this endorser block, decoded back into -- transactions. A CertRB is not selectable until this succeeds. resolveLeiosClosure leiosDb ebHash = - lookupEbClosure leiosDb ebHash >>= \case + lookupTrustedEbClosure leiosDb ebHash >>= \case Nothing -> pure $ Left $ LeiosClosureMissing ebHash Just closure -> pure $ traverse decodeOne closure where @@ -1225,14 +1226,29 @@ leiosTestTxBytes = BL.toStrict . serialise . LeiosTestGenTx -- the body on the wire --- which is what a header announces. mkLeiosTestEb :: [LeiosTestTx] -> (LeiosEb, [(TxHash, BS.ByteString)], BytesSize) mkLeiosTestEb txs = + mkLeiosTestEbClaiming + [ (tx, fromIntegral $ BS.length $ leiosTestTxBytes tx) + | tx <- txs + ] + +-- | As 'mkLeiosTestEb', but each reference claims the given size rather than +-- the transaction's actual size. +-- +-- Only an adversary builds one of these. An endorser block naming a +-- transaction is asserting how big it is, and a node that already holds that +-- transaction --- having fetched it for some other endorser block --- never +-- fetches it again, so it never compares the assertion against the bytes. +mkLeiosTestEbClaiming :: + [(LeiosTestTx, BytesSize)] -> (LeiosEb, [(TxHash, BS.ByteString)], BytesSize) +mkLeiosTestEbClaiming claims = ( eb , [(txHash, bytes) | (txHash, _size, bytes) <- entries] , fromIntegral $ BS.length $ serialize' shelleyProtVer $ encodeLeiosEb eb ) where entries = - [ (hashLeiosTx leiosTx, fromIntegral (BS.length bytes), bytes) - | tx <- txs + [ (hashLeiosTx leiosTx, claimed, bytes) + | (tx, claimed) <- claims , let bytes = leiosTestTxBytes tx , let leiosTx = MkLeiosTx bytes ] diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs index 36a05eb7ab..b4689d7ee1 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -90,7 +90,7 @@ import Data.Proxy import Data.Typeable import Data.Word import GHC.Generics (Generic) -import LeiosDemoDb (lookupEbClosure) +import LeiosDemoDb (lookupTrustedEbClosure) import LeiosDemoTypes (LeiosClosureError (..)) import LeiosVoting (HasLeiosVoting (..)) import NoThunks.Class (NoThunks (..)) @@ -151,7 +151,7 @@ instance ResolveLeiosBlock (SimpleBlock' c ext ext) where resolveLeiosClosure leiosDb ebHash = - lookupEbClosure leiosDb ebHash <&> \case + lookupTrustedEbClosure leiosDb ebHash <&> \case Nothing -> Left $ LeiosClosureMissing ebHash Just txs -> Right $ fmap (fmap (deserialise . Lazy.fromStrict)) txs diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs index b899da9fe9..885c980774 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs @@ -89,7 +89,14 @@ import Test.QuickCheck , (===) ) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=)) +import Test.Tasty.HUnit + ( Assertion + , assertBool + , assertEqual + , assertFailure + , testCase + , (@?=) + ) import Test.Tasty.QuickCheck (testProperty) import Test.Util.LeiosHash (unsafeEbHashFromBytes, unsafeTxHashFromBytes) @@ -152,8 +159,8 @@ rwScanEbPoints = scanEbPoints . rwReader rwLookupEbBody :: RW -> EbHash -> IO [(TxHash, BytesSize)] rwLookupEbBody = lookupEbBody . rwReader -rwLookupEbClosure :: RW -> EbHash -> IO (Maybe [(TxHash, BS.ByteString)]) -rwLookupEbClosure = lookupEbClosure . rwReader +rwLookupTrustedEbClosure :: RW -> EbHash -> IO (Maybe [(TxHash, BS.ByteString)]) +rwLookupTrustedEbClosure = lookupTrustedEbClosure . rwReader rwBatchRetrieveTxs :: RW -> EbHash -> [Int] -> IO [(Int, TxHash, Maybe BS.ByteString)] rwBatchRetrieveTxs = batchRetrieveTxs . rwReader @@ -231,7 +238,12 @@ mkTestGroups impl = withFreshDb impl test_multipleSlotsSameHash ] , testGroup - "lookupEbClosure" + "misstated transaction sizes" + [ testCase "a body claiming the wrong size never completes" $ + withFreshDb impl test_misstatedSizeNeverCompletes + ] + , testGroup + "lookupTrustedEbClosure" [ testProperty "complete EB returns Just with tx data" $ prop_completedEbComplete impl , testProperty "no txs returns Nothing" $ prop_completedEbMissingTxs impl , testProperty "partial txs returns Nothing" $ prop_completedEbPartialTxs impl @@ -239,6 +251,53 @@ mkTestGroups impl = ] ] +-- | An endorser block stating a size that is not its transaction's own never +-- has its closure called complete, so no @AcquiredEbTxs@ is emitted for it. +-- +-- Runs against both backends. The node must not behave differently depending +-- on which one it was built with, and the two implement this by different +-- means: the row pre-allocated at the declared size and a @length@ guard on +-- the fill, against the same check in the in-memory accept filter. +-- +-- Only the body-first order is covered here. The other order --- holding the +-- transaction before the body lands --- cannot be posed to a single endorser +-- block, because the bytes are owned per endorser block and a write before the +-- body has no row to land on. Posing it needs a second, honest endorser block +-- to hold the transaction, which is what +-- 'Test.Consensus.Leios.RecoveryPath' does against a real node. +test_misstatedSizeNeverCompletes :: LeiosDbHandle IO -> IO () +test_misstatedSizeNeverCompletes db = do + chan <- subscribeEbNotifications db + let point = mkTestPoint (SlotNo 1) 1 + eb = mkTestEb 1 + case V.toList (leiosEbTxs eb) of + [(_txHash, claimed)] -> withRW db $ \con -> do + -- One byte longer than the body says. A transaction hash covers its + -- bytes, so this is a claim no honest endorser block makes. + let txs = [(0, BS.replicate (fromIntegral claimed + 1) 0)] + rwInsertEbPoint con point (encodeLeiosEbSize eb) + void $ rwInsertEbBody con point eb + void $ rwInsertTxs con point txs + -- The body's own arrival is still worth announcing; its closure is not. + notifications <- drainChan chan + assertBool + "expected an AcquiredEb for the body" + (not (null [() | AcquiredEb{} <- notifications])) + assertEqual + "the closure of a body that misstates a size must not be announced" + [] + [p | AcquiredEbTxs p <- notifications] + other -> assertFailure $ "expected a one-transaction endorser block: " <> show (length other) + +-- | Everything on the channel right now. +drainChan :: StrictTChan IO LeiosEbNotification -> IO [LeiosEbNotification] +drainChan chan = go [] + where + go acc = + atomically (tryReadTChan chan) >>= \case + Nothing -> pure (reverse acc) + Just x -> go (x : acc) + -- * QuickCheck generators -- | Generate a random EbHash (32 random bytes). @@ -857,7 +916,7 @@ assertOfferBlockTxs expectedPoint = \case AcquiredEb _ _ -> assertFailure "expected AcquiredEbTxs, got AcquiredEb" --- * Property tests for lookupEbClosure +-- * Property tests for lookupTrustedEbClosure -- | Property: complete EB (all txs inserted) returns Just with correct tx data. prop_completedEbComplete :: DbImpl -> Property @@ -900,11 +959,11 @@ prop_completedEbMissingTxs impl = ioProperty $ withFreshDb impl $ \db -> withRW db $ \con -> do rwInsertEbPoint con point (encodeLeiosEbSize eb) void $ rwInsertEbBody con point eb - (result, queryTime) <- timed $ rwLookupEbClosure con (pointEbHash point) + (result, queryTime) <- timed $ rwLookupTrustedEbClosure con (pointEbHash point) pure $ result === Nothing & counterexample "Expected Nothing when no txs are present" - & tabulate "lookupEbClosure (no txs)" [timeBucket queryTime] + & tabulate "lookupTrustedEbClosure (no txs)" [timeBucket queryTime] & tabulate "numTxs" [magnitudeBucket numTxs] -- | Property: EB with partial txs (at least one missing) returns Nothing. @@ -939,11 +998,11 @@ prop_completedEbNoBody impl = forAll genPoint $ \point -> ioProperty $ withFreshDb impl $ \db -> withRW db $ \con -> do rwInsertEbPoint con point 1000 - (result, queryTime) <- timed $ rwLookupEbClosure con (pointEbHash point) + (result, queryTime) <- timed $ rwLookupTrustedEbClosure con (pointEbHash point) pure $ result === Nothing & counterexample "Expected Nothing for EB with no body inserted" - & tabulate "lookupEbClosure (no body)" [timeBucket queryTime] + & tabulate "lookupTrustedEbClosure (no body)" [timeBucket queryTime] -- * truncateLeiosDbAfterSlot @@ -1125,7 +1184,7 @@ test_deleteDanglingTxs volDbPath _immDbPath db = do deleteDanglingTxs volDbPath withRW db $ \con -> do - closure <- rwLookupEbClosure con ebHash + closure <- rwLookupTrustedEbClosure con ebHash fmap (map fst) closure @?= Just (map fst (V.toList (leiosEbTxs eb))) -- A closure resolves only when the db holds every tx the body names. So -- this probe resolves only if the delete missed the dangling tx. @@ -1133,5 +1192,5 @@ test_deleteDanglingTxs volDbPath _immDbPath db = do probePoint = MkLeiosPoint 6 (mkTestEbHash 2) rwInsertEbPoint con probePoint (encodeLeiosEbSize probeEb) void $ rwInsertEbBody con probePoint probeEb - probeClosure <- rwLookupEbClosure con probePoint.pointEbHash + probeClosure <- rwLookupTrustedEbClosure con probePoint.pointEbHash probeClosure @?= Nothing From df3d57c6807f9dc14e4edd61ea51e13d60ad4264 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 25 Sep 2026 13:43:44 -0400 Subject: [PATCH 27/60] LeiosFetch: reject requests for bytes we don't have --- ...0_nick.frisby_leios_fetch_server_bounds.md | 4 + .../Test/Consensus/Leios/Environment.hs | 12 +++ .../Test/Consensus/Leios/RecoveryPath.hs | 91 +++++++++++++++++++ .../src/ouroboros-consensus/LeiosDemoLogic.hs | 74 ++++++++++++++- 4 files changed, 179 insertions(+), 2 deletions(-) diff --git a/changelog.d/20260925_150000_nick.frisby_leios_fetch_server_bounds.md b/changelog.d/20260925_150000_nick.frisby_leios_fetch_server_bounds.md index 3a660a50c5..df953102b0 100644 --- a/changelog.d/20260925_150000_nick.frisby_leios_fetch_server_bounds.md +++ b/changelog.d/20260925_150000_nick.frisby_leios_fetch_server_bounds.md @@ -19,6 +19,10 @@ For top level release notes, leave all the headers commented out. - Test coverage for Issue https://github.com/input-output-hk/ouroboros-leios/issues/1115: an endorser block whose body misstates the size of a transaction the node already holds never has its closure called complete, so it is neither voted for nor offered onward. The behaviour itself is the LeiosDb's, which refuses the transaction at write time --- a row is pre-allocated as `zeroblob` of the size the body declared, and every fill is guarded on that length, including a cross-EB fill, which is checked against the destination body's own claim. What is new here is a node-versus-environment test that exercises it end to end, in both arrival orders. +- The LeiosFetch server refuses a request it cannot answer, rather than replying with whatever it found, and the refusal costs the asking peer its connection (`ExnLeiosInvalidRequest`). Asked for an endorser block whose body it does not hold, it used to build one out of the nothing it found and send that --- a reply the requester cannot tell from a real one until it hashes it. Asked for offsets an endorser block does not have, it used to answer with fewer transactions than were requested, which is itself a protocol violation. + + It does not check that it ever *offered* what was asked for. That would need per-peer state the LeiosFetch server does not keep, and refusing something we can serve buys nothing. One consequence is not yet handled: an honest peer that asks for something pruned between the offer and the request also loses the connection. + - There is nobody to disconnect: the issuer is not a peer we are connected to, and the peer that relayed the body may be honest. The sanction is that the endorser block is never certified. Its `missingTxCount` stays positive forever, which is the (buried) signal that something was refused. ### Patch diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs index 9fd204df17..2257af479e 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs @@ -29,6 +29,7 @@ module Test.Consensus.Leios.Environment , connectPeer , heardBodyOffers , heardClosureOffers + , requestEb , requestEbTxs , heardOffers , heardUnannouncedOffers @@ -276,6 +277,17 @@ heardClosureOffers PeerEnv{peHeard} = Notify.MsgLeiosBlockTxsOffer point -> [point] _ -> [] +-- | Have this peer ask the node for this endorser block's body. +requestEb :: PeerEnv (IOSim s) -> LeiosPoint -> IOSim s () +requestEb PeerEnv{peFetchRequests} point = + atomically $ + PlainSTM.modifyTVar peFetchRequests (<> [job]) + where + job = + MkSomeLeiosFetchJob + (MsgLeiosBlockRequest point) + (pure (\_reply -> pure ())) + -- | Have this peer ask the node for these offsets of this endorser block's -- closure. -- diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs index 2113b6f8ec..a054eb7c62 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs @@ -137,6 +137,19 @@ tests = , testCase "an endorser block misstating a size is not offered onward (body first)" (test_lyingSizeIsNotOffered BodyBeforeTx) + , testCase + "a request for an endorser block we do not have is refused" + (test_requestIsRefused NothingHeld (`requestEb` honestPoint)) + , testCase + "a request for an offset the endorser block does not have is refused" + ( test_requestIsRefused ClosureHeld $ \peer -> + requestEbTxs peer honestPoint (Leios.offsetsToBitmap (IntSet.fromList [0, 1])) + ) + , testCase + "a request for a transaction we do not hold is refused" + ( test_requestIsRefused BodyOnlyHeld $ \peer -> + requestEbTxs peer honestPoint (Leios.offsetsToBitmap (IntSet.singleton 0)) + ) , testCase "an endorser block too near the immutable tip is not offered onward" (test_offeredOnlyAboveTheLead DoNotRelay) @@ -592,6 +605,84 @@ test_lyingSizeIsNotOffered arrival = do (,) <$> heardBodyOffers listener <*> heardClosureOffers listener +-- | How much of 'honestEb' the node has acquired before the request arrives. +data WhatIsHeld + = -- | Nothing at all; no peer ever offers it. + NothingHeld + | -- | The body, from a peer that then withholds the transactions. + BodyOnlyHeld + | -- | The body and the whole closure. + ClosureHeld + +-- | The node refuses a LeiosFetch request it cannot answer, which costs the +-- asking peer its connection. +-- +-- It does not check that it ever /offered/ what was asked for --- that would +-- need state the LeiosFetch server does not keep --- only that it can answer. +-- +-- The empty-body case is the one that used to be silently wrong: the server +-- built an endorser block out of the nothing it found and sent that, a reply +-- the requester cannot tell from a real one until it hashes it. +test_requestIsRefused :: + WhatIsHeld -> (forall s. PeerEnv (IOSim s) -> IOSim s ()) -> Assertion +test_requestIsRefused held asksIt = do + let simTrace = runSimTrace scenario + case traceResult False simTrace of + Left (FailureException e) | isInvalidRequest e -> pure () + outcome -> + assertFailure $ + unlines $ + ("expected the request to be refused, but: " <> show outcome) + : lastN 40 (selectTraceEventsSay' simTrace) + where + isInvalidRequest :: SomeException -> Bool + isInvalidRequest e + | Just (ExceptionInLinkedThread _ inner) <- fromException e = isInvalidRequest inner + | Just (_ :: Leios.ExnLeiosInvalidRequest) <- fromException e = True + | otherwise = False + + scenario :: forall s. IOSim s () + scenario = do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + holder <- newPeerEnv + greedy <- newPeerEnv + + (chainDBTracer, getTraces) <- recordingTracerTVar + + withNodeUnderTest nodeConfig nodeDBs leiosDb chainDBTracer $ \nut -> + withRegistry $ \registry -> do + connectPeer nut registry (PeerAddr 0) holder + connectPeer nut registry (PeerAddr 1) greedy + + -- The announcing header is in slot 2, which this simulation starts + -- before, and a header from the future is rejected as such. + threadDelay 8 + + case held of + NothingHeld -> pure () + BodyOnlyHeld -> do + -- An empty closure is a peer that has the body and never hands + -- the transactions over, so the node is left holding one without + -- the other. + plantEb holder honestEb [] + announceEb holder (getHeader honestAnnouncer) + offerEb holder honestPoint honestSize + awaitPollingWith getTraces "the body is in the LeiosDb" $ + LeiosDb.withReader leiosDb $ \r -> + not . null <$> LeiosDb.lookupEbBody r (pointEbHash honestPoint) + ClosureHeld -> do + plantEb holder honestEb honestClosure + announceEb holder (getHeader honestAnnouncer) + offerEb holder honestPoint honestSize + offerEbTxs holder honestPoint + awaitPollingWith getTraces "the closure is in the LeiosDb" $ + LeiosDb.withReader leiosDb $ \r -> + isJust <$> LeiosDb.lookupTrustedEbClosure r (pointEbHash honestPoint) + + asksIt greedy + threadDelay 30 + -- | The node offers an endorser block to its downstream peers only once the -- endorser block's slot is 'nutcMinOfferLead' above the node's own immutable -- tip, so that a peer whose immutable tip is a little ahead of ours does not diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs index b00145d8ff..32430e7bfa 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs @@ -268,11 +268,12 @@ msgLeiosBlockRequest :: LeiosFetchContext m -> LeiosPoint -> m LeiosEb -msgLeiosBlockRequest tracer leiosContext MkLeiosPoint{pointEbHash} = do +msgLeiosBlockRequest tracer leiosContext point@MkLeiosPoint{pointEbHash} = do let MkLeiosFetchContext{leiosDbReader, leiosEbBuffer = buf} = leiosContext n <- traceException tracer TraceLeiosPeerDbException $ do -- get the EB items using new db items <- lookupEbBody leiosDbReader pointEbHash + when (null items) $ throwIO $ ExnLeiosUnknownBlockRequested point -- A database written by an older build can hold a body with more rows -- than the buffer has room for. let rowCount = length items @@ -317,10 +318,15 @@ msgLeiosBlockTxsRequest _tracer leiosContext point bitmaps = do <> show maxTxsPerEb -- Process results and write to buffer -- REVIEW: why a mutable vector? + -- Every requested offset must come back, or the request named one this + -- endorser block does not have. + when (length results /= length txOffsets) $ + throwIO $ + ExnLeiosUnknownTxsRequested point txOffsets let loop !i [] = pure i loop !i ((offset, _txHash, mbTxBytes) : rest) = do case mbTxBytes of - Nothing -> error $ "Missing txBytes for offset " ++ show offset + Nothing -> throwIO $ ExnLeiosUnknownTxsRequested point [offset] Just txBytes -> do -- NOTE: We do not need to decode the stored bytes into a proper -- 'Tx era' in order to serve them through the mini-protocols. @@ -1798,6 +1804,70 @@ data ExnLeiosInvalidOffer instance Exception ExnLeiosInvalidOffer +-- | Thrown when a peer asks over LeiosFetch for something we do not have, or +-- asks for it in a way no honest peer would; the ensuing thread death +-- disconnects it. +-- +-- An honest peer can still lose the connection here, by asking for something we +-- pruned between sending our offer and receiving their request. Nothing +-- prevents that, but it should be rare between healthy nodes on a healthy +-- connection (and especially so if the nearly-immutable Chain Growth was also +-- healthy). +-- +-- Offered over LeiosNotify, the endorser block is at least 'LeiosMinOfferLead' +-- slots above our immutable tip, and is deleted no sooner than @cdbGcDelay@ +-- after our immutable tip passes it: 60+1 minutes at the mainnet defaults. An +-- immutable tip can lurch --- while syncing, on escaping an eclipse, or over a +-- Chain-Growth gap replayed k blocks later --- which consumes a chunk of that +-- 60 minute buffer arbitrarily fast. @cdbGcDelay@ is wall clock, though, so the +-- peer keeps that last minute regardless. +-- +-- Offered over ChainSync, by rolling a CertRB forward, there is no such lead: +-- only @cdbGcDelay@. However, it also takes two deep fork switches, one to roll +-- forward onto the CertRB near the frontier and another to roll back off it to +-- prevent it from becoming immutable (and hence always requestable). +-- +-- The two do not compound under a ProtocolBurstAttack, where hours of suddenly +-- released endorser blocks queue ahead of ours and freshest-first leaves our +-- offer sitting for well over a minute. Withheld blocks are uncertified --- +-- certification needs a quorum of honest voters to have held the closure +-- /during the voting window/ --- and only a certified EB is offered (by an +-- honest server!) by rolling a CertRB forward. So that attack's EBs only reach +-- the path with the 61-minute margin, never the one with the 60-second +-- margin. That rests on @leiosQuorumStakeThreshold@ staying out of an +-- adversary's reach. +-- +-- However, if a ProtocolBurstAttack consists of EBs /younger/ than one we just +-- offered (either via LeiosNotify or via ChainSync), then that might prevent +-- the honest downstream peer from sending a request in response to our offer +-- until "arbitrarily" later---it depends on how long it takes them to fetch the +-- ProtocolBurstAttack's EBs. If they finish acquiring the ProtocolBurstAttack +-- EBs just before we prune our EB/they prune their offers, then it's possible +-- this race condition will disconnect the two honest nodes. We're accepting +-- this risk for the MVP, since it seems quite difficult for the adversary to +-- arrange it: the ProtocolBurstAttack can't end too soon or too late---its +-- target moment does depend on some /known/ blocks' slots, but the actual +-- state/timings of the two nodes' connection is hard to predict. +-- +-- TODO perhaps an analog of /MsgNoBlocks/ is worthwhile, only sent if the +-- request's slot is old enough for the EB to have been pruned out. +-- +-- TODO check that we /offered/ what was asked for /to the peer that asked for +-- it/. We don't do that already because a) it requires some tedious +-- rearranging\/plumbing\/more complicated state to catch and b) it's /so far/, +-- at least, harmless to serve something we could have offered but didn't. If +-- the egress scheduler begins to rely on un-offered things being +-- un-requestable, then we'd have to fill this gap. +data ExnLeiosInvalidRequest + = -- | An endorser block whose body we do not hold. + ExnLeiosUnknownBlockRequested !LeiosPoint + | -- | Offsets into an endorser block that it does not have, or whose + -- transactions we do not hold. + ExnLeiosUnknownTxsRequested !LeiosPoint ![Int] + deriving Show + +instance Exception ExnLeiosInvalidRequest + -- | Which of a point's two independent offers a LeiosNotify message makes. data OfferedBodyOrClosure = OfferedBody | OfferedClosure deriving (Eq, Show) From de088684a99f2e0325c254db3e6acca5bf35e473 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 25 Sep 2026 14:19:02 -0400 Subject: [PATCH 28/60] LeiosFetch: bound the (honest) pipelining depth - It limits how many requests we _as the client_ will send before we receive replies. - This does not limit how many requests are allowed to arrive before we _as the server_ reply. That's instead inherited from the size bound of the ingress queue (since the LeiosFetch server is not (yet?) LookAhead enabled). --- ...0_nick.frisby_leios_fetch_server_bounds.md | 8 ++++++ .../Ouroboros/Consensus/Network/NodeToNode.hs | 25 ++++++++++++++++++- .../LeiosDemoOnlyTestFetch.hs | 19 ++++++++++---- 3 files changed, 46 insertions(+), 6 deletions(-) diff --git a/changelog.d/20260925_150000_nick.frisby_leios_fetch_server_bounds.md b/changelog.d/20260925_150000_nick.frisby_leios_fetch_server_bounds.md index df953102b0..0e4b740e59 100644 --- a/changelog.d/20260925_150000_nick.frisby_leios_fetch_server_bounds.md +++ b/changelog.d/20260925_150000_nick.frisby_leios_fetch_server_bounds.md @@ -13,6 +13,14 @@ For top level release notes, leave all the headers commented out. `maxLeiosEbBytesSize` ought to be 500 KiB and is 512 KiB, under protest. `exampleDijkstraGenesis` in cardano-ledger's testlib sets `maxEndorserBlockReferencesSize` to 512 KiB, which is wrong, and `guardLeiosWireLimit` refuses to run with a protocol parameter above our ceiling --- so the Leios ThreadNet, which hard-forks the nodes into that genesis, cannot start until either the ledger is corrected or we accommodate it. Carrying the inflated value keeps this change local; the constant has a TODO. Real deployments are unaffected: the testnet and proto-devnet genesis files both set the parameter to 100,000. +- `leiosFetchClientPeerPipelined` takes a pipelining depth. At that depth it waits for a response instead of pipelining another request. It had no depth limit before, and sent as fast as the fetch logic supplied jobs. + + The outstanding-bytes budget was the only brake, and it does not bound the pipelining depth. An endorser block missing one small transaction costs a whole request and almost no bytes, so many such blocks mean many outstanding requests while staying well within budget. + + `Ouroboros.Consensus.Network.NodeToNode` now exports `leiosFetchPipelineDepth`, which is 150. An honest client never needs more than 140. `maxRequestedBytesSizePerBigLedgerPeer` allows five endorser blocks of the largest permitted size; each is 192 jobs of `maxJobBytesSize`; and one request holds 7 of those, because an eighth would exceed `maxRequestBytesSize` and a job may not span two requests. + + This is the depth the node uses as a client. How many requests an incoming peer may leave outstanding is bounded by the ingress queue's size rather than by a depth, which suffices while the LeiosFetch server is not LookAhead-enabled (see PR https://github.com/IntersectMBO/typed-protocols/pull/93). + - Thus, `maxTxsPerEb` falls from 71,428 to 14,979, since it now derives from the design ceiling rather than from `largeByteLimit`. It sizes the two buffers a LeiosFetch server allocates per inbound peer, which go from 1.09 MiB to 234 KiB of pointer array between them; it is also the largest bitmap word index that server will accept, 1,116 before and 234 now, and a factor of `worstCaseCacheTxCount`. ### Non-Breaking diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index c28df8b57f..e6a02e1165 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -42,6 +42,7 @@ module Ouroboros.Consensus.Network.NodeToNode , initiatorAndResponder -- * Leios mini-protocol limits + , leiosFetchPipelineDepth , leiosNotifyPipelineDepth , leiosNotifyProtocolLimits , leiosFetchProtocolLimits @@ -809,7 +810,7 @@ mkHandlers , hLeiosFetchClient = \writer _version controlMessageSTM peer peerVars -> toLeiosFetchClientPeerPipelined $ Effect $ do let reqVar = Leios.requestsToSend peerVars pure $ - ( leiosFetchClientPeerPipelined $ + ( leiosFetchClientPeerPipelined leiosFetchPipelineDepth $ Leios.nextLeiosFetchClientCommand (Node.leiosKernelTracer tracers) (leiosPeerTracer peer) @@ -1803,6 +1804,28 @@ perasUnsupportedInitiatorResponder = leiosNotifyPipelineDepth :: Int leiosNotifyPipelineDepth = 1000 -- TODO magic number +-- | The most LeiosFetch requests to leave outstanding on one connection. +-- +-- Sized from what an honest client needs, which is set by +-- 'maxRequestedBytesSizePerBigLedgerPeer': enough to ask a big-ledger peer for +-- five endorser blocks of the largest size the protocol allows. Each such +-- closure is 12 MiB, which is 192 jobs of 'maxJobBytesSize', and a request +-- carries 7 of those --- the 8th would pass 'maxRequestBytesSize', and a job +-- may not span two requests. So 28 requests per endorser block, 140 for five, +-- rounded up for headroom. +-- +-- Far below what the mini-protocol's ingress queue could hold, so this is a +-- statement about fetch concurrency rather than about buffering. +-- +-- At the limit the client collects one response for each request it sends. A +-- low-water mark would instead let it drain before refilling, so that it is +-- not blocked on a response between one send and the next --- but each send +-- still hands the driver a single message either way, so whether that changes +-- anything on the wire is a question for measurement rather than for this +-- comment. Left out until someone has one. +leiosFetchPipelineDepth :: Int +leiosFetchPipelineDepth = 150 + leiosNotifyProtocolLimits :: MiniProtocolLimits leiosNotifyProtocolLimits = MiniProtocolLimits diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoOnlyTestFetch.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoOnlyTestFetch.hs index e0d3d03cba..8d84d2e489 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoOnlyTestFetch.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoOnlyTestFetch.hs @@ -82,6 +82,7 @@ import Network.TypedProtocol.Core , Protocol (..) , ReflRelativeAgency (..) , StateAgency + , natToInt ) import Network.TypedProtocol.Peer ( Peer (..) @@ -609,6 +610,8 @@ data WhetherDraining = AlreadyDraining | NotYetDraining leiosFetchClientPeerPipelined :: forall m point eb tx a. PrimMonad m => + -- | the most requests to leave outstanding at once + Int -> -- | either the return value or the next job, or a blocking request for those two m ( Either @@ -616,7 +619,7 @@ leiosFetchClientPeerPipelined :: (Either a (SomeLeiosFetchJob point eb tx m)) ) -> Peer (LeiosFetch point eb tx) AsClient (Pipelined Z C) StIdle m a -leiosFetchClientPeerPipelined tryNext = +leiosFetchClientPeerPipelined depth tryNext = Effect $ do stop <- Prim.newMutVar NotYetDraining pure $ go1 stop Zero @@ -648,10 +651,16 @@ leiosFetchClientPeerPipelined tryNext = Right job -> case n of Zero -> send stop n job - Succ m -> - Collect - (Just $ send stop n job) - (\MkC -> send stop m job) + Succ m + -- At the limit, wait for a response rather than adding to the pipe. + -- Sending anyway is what an unbounded client does, and a server that + -- bounds what it will accept outstanding would drop the connection + -- over it. + | natToInt n >= depth -> Collect Nothing (\MkC -> send stop m job) + | otherwise -> + Collect + (Just $ send stop n job) + (\MkC -> send stop m job) send :: MutVar (PrimState m) WhetherDraining -> From 045ba552da91603e8536abd01edde5816a415c95 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 25 Sep 2026 15:56:38 -0400 Subject: [PATCH 29/60] noByteLimits: restore intended semantics --- .../Ouroboros/Consensus/Network/NodeToNode.hs | 29 ++++++++++++++----- .../Consensus/PeerSimulator/BlockFetch.hs | 8 ++--- .../Test/Consensus/PeerSimulator/ChainSync.hs | 8 ++--- 3 files changed, 28 insertions(+), 17 deletions(-) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index e6a02e1165..95f1cbab25 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -1157,17 +1157,32 @@ data ByteLimits bCS bBF bTX bKA bPS bLN bLF = ByteLimits bLF } +-- | Every protocol unlimited, for tests that do not want the production caps. +-- +-- NOTE: 2026 September 25. Once this was 'byteLimitsChainSync' and friends +-- applied to @const 0@, which measured every message as empty. The +-- 'ProtocolSizeLimits' type lost that size function to the 'BearerBytes' class, +-- and the conversion incorrectly left this record equal to 'byteLimits' --- so +-- every caller asking for no limits was instead getting the production +-- limits. That apparently didn't cause intractable problems, because it was +-- months ago. noByteLimits :: ByteLimits bCS bBF bTX bKA bPS bLN bLF noByteLimits = ByteLimits - { blChainSync = byteLimitsChainSync - , blBlockFetch = byteLimitsBlockFetch - , blTxSubmission2 = byteLimitsTxSubmission2 - , blKeepAlive = byteLimitsKeepAlive - , blPeerSharing = byteLimitsPeerSharing - , blLeiosNotify = byteLimitsLeiosNotify - , blLeiosFetch = byteLimitsLeiosFetch + { blChainSync = unlimitedSizeLimits + , blBlockFetch = unlimitedSizeLimits + , blTxSubmission2 = unlimitedSizeLimits + , blKeepAlive = unlimitedSizeLimits + , blPeerSharing = unlimitedSizeLimits + , blLeiosNotify = unlimitedSizeLimits + , blLeiosFetch = unlimitedSizeLimits } + where + -- A limit no message can reach. The decoder only ever tests + -- @consumed > limit@, so nothing underflows and no real message comes near + -- 'maxBound'. + unlimitedSizeLimits :: ProtocolSizeLimits ps bytes + unlimitedSizeLimits = ProtocolSizeLimits{sizeLimitForState = const maxBound} byteLimits :: ByteLimits ByteString ByteString ByteString ByteString ByteString ByteString ByteString diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs index bb8542e425..71b23ae5f6 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs @@ -71,10 +71,7 @@ import Ouroboros.Network.Driver.Limits ( ProtocolLimitFailure (ExceededSizeLimit, ExceededTimeLimit) , runPipelinedPeerWithLimits ) -import Ouroboros.Network.Protocol.BlockFetch.Codec - ( byteLimitsBlockFetch - , codecBlockFetchId - ) +import Ouroboros.Network.Protocol.BlockFetch.Codec (codecBlockFetchId) import Ouroboros.Network.Protocol.BlockFetch.Server ( BlockFetchServer (..) , blockFetchServerPeer @@ -228,8 +225,9 @@ runBlockFetchClient tracer peerId blockFetchTimeouts StateViewTracers{svtPeerSim ntnVersion :: NodeToNodeVersion ntnVersion = maxBound +-- See the NOTE on 'Ouroboros.Consensus.Network.NodeToNode.noByteLimits'. blockFetchNoSizeLimits :: ProtocolSizeLimits (BlockFetch block point) bytes -blockFetchNoSizeLimits = byteLimitsBlockFetch +blockFetchNoSizeLimits = ProtocolSizeLimits{sizeLimitForState = const maxBound} -- | Same as 'timeLimitsChainSync' for BlockFetch. NOTE: There exists a -- @timeLimitsBlockFetch@ in 'Ouroboros.Network.Protocol.BlockFetch.Codec' but diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs index db1493320a..995c757c38 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs @@ -63,10 +63,7 @@ import Ouroboros.Network.Protocol.ChainSync.ClientPipelined ( ChainSyncClientPipelined , chainSyncClientPeerPipelined ) -import Ouroboros.Network.Protocol.ChainSync.Codec - ( byteLimitsChainSync - , codecChainSyncId - ) +import Ouroboros.Network.Protocol.ChainSync.Codec (codecChainSyncId) import Ouroboros.Network.Protocol.ChainSync.PipelineDecision ( pipelineDecisionLowHighMark ) @@ -236,8 +233,9 @@ runChainSyncClient traceWith tracer $ TraceChainSyncClientTerminationEvent peerId TraceTerminatedByLoP _ -> pure () +-- See the NOTE on 'Ouroboros.Consensus.Network.NodeToNode.noByteLimits'. chainSyncNoSizeLimits :: ProtocolSizeLimits (ChainSync header point tip) bytes -chainSyncNoSizeLimits = byteLimitsChainSync +chainSyncNoSizeLimits = ProtocolSizeLimits{sizeLimitForState = const maxBound} chainSyncNoTimeouts :: ChainSyncTimeout chainSyncNoTimeouts = From c905dc326b38aa6721fddbbbc376a15d16c099d6 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 29 Sep 2026 19:43:30 -0400 Subject: [PATCH 30/60] ChainSyncJumping: register Leios offers for Jumpers Without this new CSJ callback, a Jumper is _not_ recorded as having made the Leios offers implied by the CertRBs it jumped over. Thus, if the Dynamo that offered that jump dies and is replaced by a Jumper that accepted the jump, then the node would incorrectly conclude that none of its peers offered the EBs certified by those CertRBs. --- ...925_220000_nick.frisby_leios_csj_offers.md | 26 ++++ .../Ouroboros/Consensus/Network/NodeToNode.hs | 73 ++++++++++- .../Test/Consensus/Leios/Environment.hs | 121 +++++++++++++++++- .../Test/Consensus/Leios/NodeUnderTest.hs | 19 ++- .../Test/Consensus/Leios/RecoveryPath.hs | 81 ++++++++++++ .../Test/Consensus/PeerSimulator/ChainSync.hs | 1 + .../bench/ChainSync-client-bench/Main.hs | 1 + .../src/ouroboros-consensus/LeiosDemoTypes.hs | 21 ++- .../MiniProtocol/ChainSync/Client.hs | 12 ++ .../Consensus/MiniProtocol/ChainSync/CSJ.hs | 1 + .../MiniProtocol/ChainSync/Client.hs | 1 + 11 files changed, 345 insertions(+), 12 deletions(-) create mode 100644 changelog.d/20260925_220000_nick.frisby_leios_csj_offers.md diff --git a/changelog.d/20260925_220000_nick.frisby_leios_csj_offers.md b/changelog.d/20260925_220000_nick.frisby_leios_csj_offers.md new file mode 100644 index 0000000000..1aee6cec81 --- /dev/null +++ b/changelog.d/20260925_220000_nick.frisby_leios_csj_offers.md @@ -0,0 +1,26 @@ + + +### Breaking + +- The ChainSync client's `ConfigEnv` gained `leiosJumpAcceptedCallback`, invoked whenever this peer accepts a jump. For Leios the wiring records, for every header in the dynamo's candidate fragment that the jump carries, the same per-peer offer that header's `MsgRollForward` would have. + + Without it a jumper has no offers at all. It never sends the headers it jumps over, so a node that loses its dynamo is left with nobody to ask for the endorser blocks those headers announced. Agreeing to a jump asserts the peer would have sent the same headers, which is what makes treating them as its offers sound. + + That fragment is anchored where the ChainSync client's view of our own chain is, `k` back, so it sits on our immutable chain: a header it does not reach is one whose block we already hold immutably. + +- `LeiosPeerVars` gained `maxAcceptedJumpSlot`, the newest slot this peer has accepted a jump through. + + Each jump carries the dynamo's whole candidate fragment rather than the part since the previous jump, so the wiring splits both the fragment and the jump's header state history at that slot before walking them. Each split is `O(log n)` in the underlying finger tree, against fragments that successive jumps overlap in everything but their last `csjcJumpSize` headers. Splitting the history at the same slot leaves its anchor holding the first kept header's predecessor state, which is the argument that header's `MsgRollForward` would have been given. + + A split finds nothing at that slot only if this peer accepted a jump on one chain and then a jump on an alternative chain, and the whole fragment is then walked. That needs the dynamo to have changed, since one dynamo may not roll back before the last jump it requested --- CSJ disengages it if it tries --- so the peer is either dishonest, or honest and close enough to the wall clock to have switched chains in between. + +### Patch + +- The Leios node-versus-environment harness serves ChainSync itself rather than through `chainSyncServerExample`, so that a peer can be told whether to announce reaching its tip (`setAwaitAtTip`, `WhetherToAwaitAtTip`). + + CSJ disengages a peer as soon as it says it has no more headers, and every peer in this harness runs out within a simulated instant, so nothing about CSJ could be tested before: no dynamo survived to the fetch logic's next tick. The flag is read in the same transaction that waits for more chain, so telling a peer already parked at its tip to announce it wakes that peer. diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 95f1cbab25..2b1ba4d7a3 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -76,6 +76,7 @@ import Data.Maybe.Strict (StrictMaybe (SJust)) import qualified Data.Primitive.MutVar as Prim import qualified Data.Sequence as Seq import qualified Data.Set as Set +import Data.Typeable (Typeable) import Data.Void (Void) import LeiosDemoDb ( LeiosDbHandle (subscribeEbNotifications) @@ -147,7 +148,14 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types , systemTimeCurrent ) import Ouroboros.Consensus.Config (DiffusionPipeliningSupport (..)) -import Ouroboros.Consensus.HeaderValidation (HeaderWithTime) +import Ouroboros.Consensus.HeaderStateHistory + ( HeaderStateHistory (..) + , HeaderStateWithTime (..) + ) +import Ouroboros.Consensus.HeaderValidation + ( HeaderWithTime (..) + , headerStateChainDep + ) import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Mempool.API (getLeiosTxIndex) @@ -157,6 +165,7 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client ( ChainSyncStateView (..) ) import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CsClient +import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State (JumpInfo (..)) import Ouroboros.Consensus.MiniProtocol.ChainSync.Server import Ouroboros.Consensus.Node.ExitPolicy import Ouroboros.Consensus.Node.NetworkProtocolVersion @@ -164,6 +173,7 @@ import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Serialisation import qualified Ouroboros.Consensus.Node.Tracers as Node import Ouroboros.Consensus.NodeKernel +import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Storage.LedgerDB.Forker ( ResolveLeiosBlock @@ -173,6 +183,8 @@ import Ouroboros.Consensus.Storage.Serialisation (SerialisedHeader) import Ouroboros.Consensus.Util (ShowProxy, whenJust) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () +import qualified Ouroboros.Network.AnchoredFragment as AF +import qualified Ouroboros.Network.AnchoredSeq as AS import Ouroboros.Network.Block ( Serialised (..) , decodePoint @@ -457,6 +469,21 @@ mkHandlers (SJust hdrSlotTime) (Just (diffRelTime now hdrSlotTime)) ancHdr + , CsClient.leiosJumpAcceptedCallback = \jumpInfo -> do + let varMax = Leios.maxAcceptedJumpSlot peerVars + acceptedThrough <- TVar.Unchecked.readTVarIO varMax + forM_ (headersWithPredecessorStates acceptedThrough jumpInfo) $ + \(hdr, cds) -> + Leios.checkMsgRollForwardForLeiosOffers + (getLeiosOutstanding, getLeiosReady) + peerVars + hdr + cds + atomically $ + TVar.Unchecked.modifyTVar varMax $ + max $ + AF.headSlot $ + jTheirFragment jumpInfo } dynEnv , hChainSyncServer = \peer _version -> @@ -1816,6 +1843,50 @@ perasUnsupportedInitiatorResponder = (MiniProtocolCb (\_ _ -> error "Peras diffusion protocol invoked without PerasSupported")) (MiniProtocolCb (\_ _ -> error "Peras diffusion protocol invoked without PerasSupported")) +-- | The part of the dynamo's candidate header fragment past the given slot --- +-- the jump it offered is the whole fragment's tip --- each header paired with +-- the chain-dep state as of its predecessor, the two arguments +-- 'CsClient.leiosMsgRollForwardCallback' would have been given for it. +-- +-- The history holds one state per header plus its anchor, and the state at an +-- index is the one /after/ that header. So splitting the history at the same +-- slot leaves its anchor holding the first kept header's predecessor state, +-- and shifting by one pairs the rest up. +-- +-- Both splits are @O(log n)@ in the underlying finger tree, which is the point +-- of doing them here rather than filtering the list afterwards: successive +-- jumps overlap in everything but their last @csjcJumpSize@ headers. +-- +-- A split yields 'Nothing' if the sequence holds nothing at the given slot, in +-- which case the whole of it is walked. That needs this peer to have accepted +-- a jump on one chain and then a jump on an alternative chain, which in turn +-- needs the dynamo to have changed --- one dynamo may not roll back before the +-- last jump it requested, and CSJ disengages it if it tries. So the peer is +-- either dishonest, or honest and close enough to the wall clock to have +-- switched chains in between. +headersWithPredecessorStates :: + (HasHeader (Header blk), Typeable blk) => + WithOrigin SlotNo -> + JumpInfo blk -> + [(Header blk, ChainDepState (BlockProtocol blk))] +headersWithPredecessorStates acceptedThrough jumpInfo = + zip + (hwtHeader <$> AF.toOldestFirst fragment) + ( headerStateChainDep . hswtHeaderState + <$> (AS.anchor history : AS.toOldestFirst history) + ) + where + past :: + AS.Anchorable (WithOrigin SlotNo) a b => + AS.AnchoredSeq (WithOrigin SlotNo) a b -> + AS.AnchoredSeq (WithOrigin SlotNo) a b + past s = case AS.splitAfterMeasure acceptedThrough (const True) s of + Just (_before, after) -> after + Nothing -> s + + fragment = past $ jTheirFragment jumpInfo + history = past $ unHeaderStateHistory (jTheirHeaderStateHistory jumpInfo) + leiosNotifyPipelineDepth :: Int leiosNotifyPipelineDepth = 1000 -- TODO magic number diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs index 2257af479e..dc8a15a249 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/Environment.hs @@ -25,6 +25,7 @@ -- say --- that it never delivers. module Test.Consensus.Leios.Environment ( PeerEnv (..) + , WhetherToAwaitAtTip (..) , announceEb , connectPeer , heardBodyOffers @@ -34,6 +35,7 @@ module Test.Consensus.Leios.Environment , heardOffers , heardUnannouncedOffers , newPeerEnv + , setAwaitAtTip , offerEb , offerEbTxs , plantEb @@ -89,17 +91,22 @@ import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.Network.NodeToNode as NTN import Ouroboros.Consensus.Node.ExitPolicy (NodeToNodeInitiatorResult) import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Network.Block (Tip) import Ouroboros.Network.Channel (createConnectedChannels) import Ouroboros.Network.ConnectionId (ConnectionId (..)) import Ouroboros.Network.Context (ResponderContext (..)) import Ouroboros.Network.ControlMessage (ControlMessage (..)) import Ouroboros.Network.Driver.Simple (runPeer, runPipelinedPeer) -import Ouroboros.Network.Mock.Chain (Chain) +import Ouroboros.Network.Mock.Chain (Chain, ChainUpdate (..)) import qualified Ouroboros.Network.Mock.Chain as Chain import Ouroboros.Network.Mock.ProducerState ( ChainProducerState (..) + , findFirstPoint + , followerInstruction , initChainProducerState + , initFollower , switchFork + , updateFollower ) import Ouroboros.Network.PeerSelection.PeerMetric (nullMetric) import Ouroboros.Network.Protocol.BlockFetch.Server @@ -109,10 +116,13 @@ import Ouroboros.Network.Protocol.BlockFetch.Server , blockFetchServerPeer ) import Ouroboros.Network.Protocol.BlockFetch.Type (ChainRange (..)) -import Ouroboros.Network.Protocol.ChainSync.Examples - ( chainSyncServerExample +import Ouroboros.Network.Protocol.ChainSync.Server + ( ChainSyncServer (..) + , ServerStIdle (..) + , ServerStIntersect (..) + , ServerStNext (..) + , chainSyncServerPeer ) -import Ouroboros.Network.Protocol.ChainSync.Server (chainSyncServerPeer) import Ouroboros.Network.Protocol.KeepAlive.Server ( KeepAliveServer (..) , keepAliveServerPeer @@ -132,6 +142,9 @@ data PeerEnv m = PeerEnv , peServeThrough :: StrictTVar m (Point Blk) -- ^ The last block of 'peChain' this peer hands over; see -- 'serveChainThrough'. + , peAwaitAtTip :: PlainSTM.StrictTVar m WhetherToAwaitAtTip + -- ^ What this peer does once the node holds every header it has; see + -- 'setAwaitAtTip'. , peEbs :: StrictTVar m (Map EbHash (LeiosEb, Map TxHash BS.ByteString)) , peNotifications :: PlainSTM.StrictTVar m [LeiosNotification] -- ^ What this peer has yet to say over LeiosNotify, in order. @@ -150,10 +163,20 @@ data PeerEnv m = PeerEnv type LeiosNotification = Notify.Message (LeiosNotify LeiosPoint (Header Blk) LeiosVote) StBusy StIdle +-- | See 'setAwaitAtTip'. +data WhetherToAwaitAtTip + = -- | Send @MsgAwaitReply@, as a real peer does. + AwaitAtTip + | -- | Say nothing, leaving the node's request unanswered until this peer's + -- chain grows. + StayQuietAtTip + deriving (Eq, Show) + newPeerEnv :: IOSim s (PeerEnv (IOSim s)) newPeerEnv = do peChain <- PlainSTM.newTVarIO (initChainProducerState Chain.Genesis) peServeThrough <- newTVarIO GenesisPoint + peAwaitAtTip <- PlainSTM.newTVarIO AwaitAtTip peEbs <- newTVarIO Map.empty peNotifications <- PlainSTM.newTVarIO [] peHeard <- PlainSTM.newTVarIO [] @@ -162,6 +185,7 @@ newPeerEnv = do PeerEnv { peChain , peServeThrough + , peAwaitAtTip , peEbs , peNotifications , peHeard @@ -208,6 +232,15 @@ serveChainThrough PeerEnv{peChain, peServeThrough} through chain = PlainSTM.modifyTVar peChain $ switchFork chain writeTVar peServeThrough through +-- | Choose what this peer does once the node holds every header it has. +-- +-- ChainSync jumping disengages a peer that says it has no more headers, and +-- every peer here runs out almost at once, so a test that needs CSJ to +-- still be steering the node when something else happens sets +-- 'StayQuietAtTip'. +setAwaitAtTip :: PeerEnv (IOSim s) -> WhetherToAwaitAtTip -> IOSim s () +setAwaitAtTip PeerEnv{peAwaitAtTip} = atomically . PlainSTM.writeTVar peAwaitAtTip + -- | Have this peer announce, over LeiosNotify, the endorser block this header -- announces. -- @@ -372,7 +405,7 @@ connectPeer nut registry addr penv = do void $ runPeer (sayTracer ("cs " <> show addr)) (NTN.cChainSyncCodec codecs) csServer $ chainSyncServerPeer $ - chainSyncServerExample () (peChain penv) getHeader + chainSyncServerOf penv fork ("BlockFetch client " <> show addr) $ void $ @@ -507,6 +540,82 @@ blockFetchServerOf penv = go holds p = any ((== p) . blockPoint) +-- | Serves this peer's chain, as @chainSyncServerExample@ does, except that +-- reaching the tip need not be announced; see 'setAwaitAtTip'. +chainSyncServerOf :: + PeerEnv (IOSim s) -> + ChainSyncServer (Header Blk) (Point Blk) (Tip Blk) (IOSim s) () +chainSyncServerOf PeerEnv{peChain, peAwaitAtTip} = + ChainSyncServer $ idle <$> newFollower + where + idle r = + ServerStIdle + { recvMsgRequestNext = handleRequestNext r + , recvMsgFindIntersect = handleFindIntersect r + , recvMsgDoneClient = pure () + } + + idle' = ChainSyncServer . pure . idle + + -- The @Right@ is what puts @MsgAwaitReply@ on the wire. Blocking first and + -- answering @Left@ sends the roll-forward alone, whenever it comes. + handleRequestNext r = do + tryReadChainUpdate r >>= \case + Just update -> pure $ Left $ sendNext r update + Nothing -> do + -- This blocks on the flag as well as on the chain, so telling a peer + -- that is already waiting here to announce its tip wakes it. + mbUpdate <- atomically $ do + PlainSTM.readTVar peAwaitAtTip >>= \case + AwaitAtTip -> pure Nothing + StayQuietAtTip -> Just <$> awaitInstruction r + pure $ case mbUpdate of + Just update -> Left $ sendNext r update + Nothing -> Right $ sendNext r <$> readChainUpdate r + + sendNext r (tip, update) = case update of + AddBlock blk -> SendMsgRollForward (getHeader blk) tip (idle' r) + RollBack point -> SendMsgRollBackward point tip (idle' r) + + handleFindIntersect r points = do + (mbPoint, tip) <- atomically $ do + cps <- PlainSTM.readTVar peChain + case findFirstPoint points cps of + Nothing -> pure (Nothing, tipOf cps) + Just point -> do + let cps' = updateFollower r point cps + PlainSTM.writeTVar peChain cps' + pure (Just point, tipOf cps') + pure $ case mbPoint of + Just point -> SendMsgIntersectFound point tip (idle' r) + Nothing -> SendMsgIntersectNotFound tip (idle' r) + + newFollower = atomically $ do + cps <- PlainSTM.readTVar peChain + let (cps', r) = initFollower GenesisPoint cps + PlainSTM.writeTVar peChain cps' + pure r + + tryReadChainUpdate r = atomically $ do + cps <- PlainSTM.readTVar peChain + case followerInstruction r cps of + Nothing -> pure Nothing + Just (update, cps') -> do + PlainSTM.writeTVar peChain cps' + pure $ Just (tipOf cps', update) + + readChainUpdate = atomically . awaitInstruction + + awaitInstruction r = do + cps <- PlainSTM.readTVar peChain + case followerInstruction r cps of + Nothing -> retry + Just (update, cps') -> do + PlainSTM.writeTVar peChain cps' + pure (tipOf cps', update) + + tipOf = Chain.headTip . chainState + -- | Answers a request for an endorser block, or for its closure's -- transactions, blocking until this peer holds it. leiosFetchHandlerOf :: @@ -596,7 +705,7 @@ peerApps nut = NTN.noByteLimits (\_ -> ProtocolTimeLimitsWithRnd $ \_state -> (waitForever,)) CSClient.ChainSyncLoPBucketDisabled - CSClient.CSJDisabled + (nutCsjConfig nut) nullMetric (nutHandlers nut) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/NodeUnderTest.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/NodeUnderTest.hs index 53e82ca0bd..e1a5d621ee 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/NodeUnderTest.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/NodeUnderTest.hs @@ -53,6 +53,7 @@ import Ouroboros.Consensus.Config import qualified Ouroboros.Consensus.HardFork.History as HardFork import Ouroboros.Consensus.Ledger.Extended (ledgerState) import Ouroboros.Consensus.Mempool (MempoolCapacityBytesOverride (..)) +import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck import qualified Ouroboros.Consensus.Network.NodeToNode as NTN @@ -99,6 +100,9 @@ data NodeUnderTestConfig = NodeUnderTestConfig , nutcMinOfferLead :: Leios.LeiosMinOfferLead -- ^ See 'leiosMinOfferLead'. These tests run a handful of slots, so the -- real hour would hold back every offer they make. + , nutcCsjConfig :: CSClient.CSJConfig + -- ^ Off unless a test is about ChainSync jumping: with it on, only one peer + -- is the dynamo and the others are asked to jump rather than send headers. } defaultNodeUnderTestConfig :: @@ -108,6 +112,7 @@ defaultNodeUnderTestConfig nutcLedgerConfig nutcSecurityParam = { nutcLedgerConfig , nutcSecurityParam , nutcMinOfferLead = Leios.MkLeiosMinOfferLead 2 + , nutcCsjConfig = CSClient.CSJDisabled } -- | The peer address these tests use: a peer is just a number. @@ -122,8 +127,7 @@ data NodeUnderTest m = NodeUnderTest , nutKernel :: NodeKernel m PeerAddr () Blk , nutKernelArgs :: NodeKernelArgs m PeerAddr () Blk , nutHandlers :: NTN.Handlers m PeerAddr Blk - -- ^ What the node's mini-protocol clients and servers are made of; the - -- environment turns these into running protocols. + , nutCsjConfig :: CSClient.CSJConfig } -- | Run the node over the given mocked filesystems and LeiosDb, then shut it @@ -156,6 +160,7 @@ withNodeUnderTest cfg nodeDBs leiosDb chainDBTracer body = , nutKernelArgs = kernelArgs , nutHandlers = NTN.mkHandlers kernelArgs kernel TxSubmissionLogicV2 + , nutCsjConfig = nutcCsjConfig cfg } -- | The node's slot clock, derived from the ledger as a real node's is. @@ -237,7 +242,15 @@ mkNodeKernelArgs cfg registry chainDB leiosDB btime = do , gsmArgs = GSM.GsmNodeKernelArgs { gsmAntiThunderingHerd = mkStdGen 2 - , gsmDurationUntilTooOld = Nothing + , gsmDurationUntilTooOld = case nutcCsjConfig cfg of + CSClient.CSJDisabled -> Nothing + -- CSJ only runs while the GSM is not caught up, and a peer + -- that registers while it is caught up is disengaged for good. + -- So a test that turns CSJ on also has to keep the node out + -- of that state, which reporting every selection as already too + -- old does. + CSClient.CSJEnabled{} -> + Just $ GSM.DurationUntilTooOld $ \_selection -> pure GSM.Already , gsmMarkerFileView = GSM.MarkerFileView { touchMarkerFile = pure () diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs index a054eb7c62..f6f6743407 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs @@ -61,6 +61,7 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (slotLengthFromSec) import Ouroboros.Consensus.Config (SecurityParam (..)) import qualified Ouroboros.Consensus.HardFork.History as HardFork +import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import Ouroboros.Consensus.NodeKernel (NodeKernel (..)) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Storage.LedgerDB (headerElId) @@ -137,6 +138,9 @@ tests = , testCase "an endorser block misstating a size is not offered onward (body first)" (test_lyingSizeIsNotOffered BodyBeforeTx) + , testCase + "a jumper offers what it jumped over" + test_aJumperOffersWhatItJumpedOver , testCase "a request for an endorser block we do not have is refused" (test_requestIsRefused NothingHeld (`requestEb` honestPoint)) @@ -614,6 +618,83 @@ data WhatIsHeld | -- | The body and the whole closure. ClosureHeld +-- | As 'nodeConfig', but with ChainSync jumping on. +csjNodeConfig :: NodeUnderTestConfig +csjNodeConfig = + nodeConfig + { nutcCsjConfig = + CSClient.CSJEnabled CSClient.CSJEnabledConfig{CSClient.csjcJumpSize = 1} + } + +-- | 'freshChain' with one more block, so that a jump can reach past the block +-- that certifies 'freshEb'. +-- +-- A jump is offered when the dynamo rolls forward, and covers its fragment up +-- to but not including the header that triggered it. +csjChain :: [Blk] +csjChain = freshChain <> [successorLeiosBlock (last freshChain)] + +-- | A jumper offers the endorser block the dynamo announced, although it never +-- sent that header itself. +-- +-- It agreed to jump over that header, which asserts it would have sent the same +-- one. Unless that counts as offering what those headers announce, a jumper has +-- no offers at all, and so a node that loses its dynamo has nobody left to ask. +-- +-- Neither peer announces its tip, since CSJ disengages a peer that says it +-- has no more headers and this test needs it still steering. The first peer is +-- alone when it connects, so it is made dynamo; extending its chain is then +-- what makes it offer the jump that the second peer accepts. +-- +-- No peer holds the endorser block, so nothing satisfies either offer and +-- neither is pruned. +test_aJumperOffersWhatItJumpedOver :: Assertion +test_aJumperOffersWhatItJumpedOver = do + let simTrace = runSimTrace scenario + case traceResult False simTrace of + Right offeredBy -> + assertEqual + "both peers should be recorded as offering the endorser block" + [True, True] + offeredBy + outcome -> + assertFailure $ + unlines $ + ("expected the run to finish, but: " <> show outcome) + : lastN 40 (selectTraceEventsSay' simTrace) + where + scenario :: forall s. IOSim s [Bool] + scenario = do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + peerA <- newPeerEnv + peerB <- newPeerEnv + + (chainDBTracer, _getTraces) <- recordingTracerTVar + + withNodeUnderTest csjNodeConfig nodeDBs leiosDb chainDBTracer $ \nut -> + withRegistry $ \registry -> do + setAwaitAtTip peerA StayQuietAtTip + setAwaitAtTip peerB StayQuietAtTip + serveChain peerA $ chainOf freshChain + serveChain peerB $ chainOf csjChain + + -- The announcing header is in slot 2, and a header from the future is + -- rejected as such. + threadDelay 8 + + connectPeer nut registry (PeerAddr 0) peerA + threadDelay 5 + connectPeer nut registry (PeerAddr 1) peerB + threadDelay 5 + + -- Rolling forward onto this block is what makes the dynamo offer the + -- jump that the second peer accepts. + serveChain peerA $ chainOf csjChain + threadDelay 25 + + mapM (\addr -> ebOfferedBy nut addr freshPoint) [PeerAddr 0, PeerAddr 1] + -- | The node refuses a LeiosFetch request it cannot answer, which costs the -- asking peer its connection. -- diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs index 995c757c38..52b7208dde 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs @@ -117,6 +117,7 @@ basicChainSyncClient CSClient.historicityCheck = HistoricityCheck.noCheck , CSClient.getDiffusionPipeliningSupport = DiffusionPipeliningOn , CSClient.leiosMsgRollForwardCallback = \_ _ _ -> pure () + , CSClient.leiosJumpAcceptedCallback = \_ -> pure () } CSClient.DynamicEnv { CSClient.version = maxBound diff --git a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs index 8fe0783c23..801e5ec366 100644 --- a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs +++ b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs @@ -152,6 +152,7 @@ oneBenchRun , CSClient.getDiffusionPipeliningSupport = DiffusionPipeliningOn , CSClient.leiosMsgRollForwardCallback = \_ _ _ -> pure () + , CSClient.leiosJumpAcceptedCallback = \_ -> pure () } CSClient.DynamicEnv { CSClient.version = maxBound :: NodeToNodeVersion diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs index 8a3104dbfc..b7c3a420b4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs @@ -70,7 +70,7 @@ import Cardano.Ledger.Dijkstra.PParams , ppLeiosVotePeriodLengthL ) import Cardano.Prelude (NonEmpty, toList, toString, (&)) -import Cardano.Slotting.Slot (SlotNo (SlotNo), WithOrigin, withOrigin) +import Cardano.Slotting.Slot (SlotNo (SlotNo), WithOrigin (Origin), withOrigin) import Cardano.Slotting.Time (RelativeTime, SlotLength, slotLengthToMillisec) import Codec.Serialise (decode, encode) import Control.Concurrent.Class.MonadMVar (MVar) @@ -481,6 +481,15 @@ data LeiosPeerVars m = MkLeiosPeerVars -- A second, different claim for one election is misbehaviour and costs the -- peer its connection; see 'LeiosDemoLogic.noteCertificationClaim'. Pruned -- with the immutable tip, like the rest of the per-election state. + , maxAcceptedJumpSlot :: !(StrictTVar m (WithOrigin SlotNo)) + -- ^ The newest slot this peer has accepted a ChainSync jump through. + -- + -- Each jump carries the dynamo's whole candidate fragment rather than the + -- part since the previous jump, so this is what lets a reader skip the + -- overlap. It only advances while one peer holds the dynamo role, since a + -- dynamo may not roll back before the last jump it requested. + -- + -- Maintaining a jumper's Leios offers is what motivates recording it. , requestsToSend :: !(StrictTVar m (Seq LeiosFetchRequest)) -- ^ written to by the fetch logic and the LeiosFetch client -- @@ -502,8 +511,16 @@ newLeiosPeerVars :: IOLike m => IsBigLedgerPeer -> m (LeiosPeerVars m) newLeiosPeerVars whetherBigLedgerPeer = do offerings <- MVar.newMVar Map.empty certificationClaims <- MVar.newMVar Map.empty + maxAcceptedJumpSlot <- StrictSTM.newTVarIO Origin requestsToSend <- StrictSTM.newTVarIO Seq.empty - pure MkLeiosPeerVars{whetherBigLedgerPeer, offerings, certificationClaims, requestsToSend} + pure + MkLeiosPeerVars + { whetherBigLedgerPeer + , offerings + , certificationClaims + , maxAcceptedJumpSlot + , requestsToSend + } -- | Main data structure used in the Leios fetching logic. -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs index 0d9433dae1..2d7c48165c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs @@ -793,6 +793,17 @@ data ConfigEnv m blk = ConfigEnv -- /certifies/ as an offer from this peer, and feed any EB the header -- /announces/ into the central announcement state — dating that announcement -- from the slot onset. A no-op for non-Leios setups. + , leiosJumpAcceptedCallback :: JumpInfo blk -> m () + -- ^ Invoked when this peer accepts a jump, with the dynamo's candidate + -- fragment that jump carries. For Leios the wiring records, for each header + -- in that fragment, the same per-peer offer that header's 'MsgRollForward' + -- would have. A no-op for non-Leios setups. + -- + -- A jumper never runs 'leiosMsgRollForwardCallback' for the headers it + -- jumped over, so without this it has no offers at all, and a node that + -- loses its dynamo has nobody left to ask for the endorser blocks those + -- headers announced. Agreeing to a jump asserts the peer would have sent + -- those headers, which is what makes treating them as its offers sound. } -- | Arguments determined dynamically @@ -1356,6 +1367,7 @@ knownIntersectionStateTop cfgEnv dynEnv intEnv = if | pt == dynamoTipPt -> do Jumping.jgProcessJumpResult jumping $ Jumping.AcceptedJump jump + leiosJumpAcceptedCallback cfgEnv jumpInfo traceWith tracer $ TraceJumpResult $ Jumping.AcceptedJump jump let kis' = case jump of -- Since the updated kis is needed to validate headers, diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/CSJ.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/CSJ.hs index f61c7009ec..a900dc16cc 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/CSJ.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/CSJ.hs @@ -183,6 +183,7 @@ runTest TestSetup = withRegistry $ \registry -> do , mkPipelineDecision0 = pipelineDecisionLowHighMark 10 20 , getDiffusionPipeliningSupport = diffusionPipelining , leiosMsgRollForwardCallback = \_ _ _ -> pure () + , leiosJumpAcceptedCallback = \_ -> pure () } DynamicEnv { version diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs index 82814dc614..71b377854e 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs @@ -510,6 +510,7 @@ runChainSync , getDiffusionPipeliningSupport = diffusionPipelining , leiosMsgRollForwardCallback = \_ _ _ -> pure () + , leiosJumpAcceptedCallback = \_ -> pure () } DynamicEnv { version = maxBound :: NodeToNodeVersion From d42c2a9db7b7913ff2857a10006c0827c6f8f8f8 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 29 Sep 2026 20:54:29 -0400 Subject: [PATCH 31/60] Config: allow default leiosMinOfferLead to be overriden --- .../Ouroboros/Consensus/Node.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index 3754539e01..35063839ef 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs @@ -408,6 +408,14 @@ data StdRunNodeArgs m blk -- ^ Determine whether to use the system default mempool capacity or explicitly set -- capacity of the mempool. , srnChainSyncIdleTimeout :: ChainSyncIdleTimeout + , srnLeiosMinOfferLead :: Maybe Leios.LeiosMinOfferLead + -- ^ Overrides 'Leios.defaultLeiosMinOfferLead', how much younger than this + -- node's immutable tip an endorser block must be for the node to offer it + -- onward. + -- + -- A network whose immutable tip trails its selection by less than the lead + -- offers nothing at all, so a test network or a devnet has to set its own, + -- smaller value; see 'Leios.defaultLeiosMinOfferLead'. , -- Ad hoc values to replace default ChainDB configurations srnSnapshotPolicyArgs :: SnapshotPolicyArgs , srnQueryBatchSize :: QueryBatchSize @@ -1189,6 +1197,7 @@ stdLowLevelRunNodeArgsIO llrnCustomiseNodeKernelArgs = overBlockFetchConfiguration modifyBlockFetchConfiguration . modifyMempoolCapacityOverride + . modifyLeiosMinOfferLead where modifyBlockFetchConfiguration = maybe @@ -1204,6 +1213,11 @@ stdLowLevelRunNodeArgsIO id (\mc nka -> nka{mempoolCapacityOverride = mc}) srnMaybeMempoolCapacityOverride + modifyLeiosMinOfferLead = + maybe + id + (\lead nka -> nka{leiosMinOfferLead = lead}) + srnLeiosMinOfferLead -- Limit the node version unless srnEnableInDevelopmentVersions is set limitToLatestReleasedVersion :: From 2bd168c80b48a6307d65f9f704446dc5db74acd3 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 2 Oct 2026 11:27:01 -0400 Subject: [PATCH 32/60] DO NOT MERGE EB size bound kludge 1 --- .../Ouroboros/Consensus/Protocol/Praos.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index 938f87e919..e978d6b1e0 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -765,7 +765,15 @@ leiosHeaderChecks PraosConfig{praosEpochInfo} lv b slot cs = SNothing -> pure () SJust ann -> do let announced = ebAnnouncementSize ann - maximum' = Views.llvMaxEbBodySize llv + -- TEMPORARY KLUDGE -- DO NOT MERGE. + -- + -- The deployed testnet has historical announcements above the + -- 'maxEndorserBlockReferencesSize' its own Dijkstra genesis sets + -- (e.g. 102429 against 100000 at slot 709083), so enforcing the + -- ledger's value stalls the sync there. Exception granted here + -- and here only: every other use of the limit, and the genesis + -- file itself, are untouched. + maximum' = max 200000 (Views.llvMaxEbBodySize llv) when (announced > maximum') $ throwError $ LeiosHeaderErr mkHasLeiosProof $ From 2990c49e6056c6a59c94fe0ecebdc7849a421f60 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 2 Oct 2026 11:27:57 -0400 Subject: [PATCH 33/60] LeiosNotify: disconnect if offer's size is too big --- .../src/ouroboros-consensus/LeiosDemoLogic.hs | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs index 32430e7bfa..29d39b1062 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs @@ -1781,8 +1781,9 @@ deriving instance Show ExnInvalidLeiosAnnouncement instance Exception ExnInvalidLeiosAnnouncement -- | Thrown when a peer offers an endorser block over LeiosNotify that it never --- announced, that it has already offered, or that is too old to check; the --- ensuing thread death disconnects it. +-- announced, that it has already offered, that is bigger than any endorser +-- block may be, or that is too old to check; the ensuing thread death +-- disconnects it. -- -- Without this requirement, peers could send bogus offers, and there are -- infinitely many of those. @@ -1790,6 +1791,9 @@ data ExnLeiosInvalidOffer = -- | A body offer of an endorser block this peer never announced, with the -- size it claimed. ExnLeiosBlockOfferWithoutAnnouncement !LeiosPoint !BytesSize + | -- | A body offer claiming more bytes than any endorser block may have: + -- the offered point, the size it claimed, and the bound it exceeded. + ExnLeiosBlockOfferTooBig !LeiosPoint !BytesSize !BytesSize | -- | A closure offer for an endorser block this peer never announced. ExnLeiosClosureOfferWithoutAnnouncement !LeiosPoint | -- | A second offer of the body, or of the closure, this peer has already @@ -2107,6 +2111,16 @@ checkLeiosBlockOffer point claimed peerSt | ebSlot < lnpsPruneSlot peerSt = Left $ ExnLeiosOfferTooOld point (lnpsPruneSlot peerSt) | SJust{} <- Leios.poOfferedBody seen = Left $ ExnLeiosRepeatedOffer point OfferedBody + | claimed > Leios.maxLeiosEbBytesSize = + -- No endorser block may exceed this in any slot: it is the bound the + -- guardrails script imposes, so the ledger parameter that actually + -- applies can only be smaller. + -- + -- TODO enforce that parameter instead of its ceiling. The announcement + -- this offer rides on (see 'announcedIt') was validated against the + -- ledger view of its own slot, so retaining that view's maximum endorser + -- block size alongside the announcement would give the exact value here. + Left $ ExnLeiosBlockOfferTooBig point claimed Leios.maxLeiosEbBytesSize | not (announcedIt point peerSt) = Left $ ExnLeiosBlockOfferWithoutAnnouncement point claimed | otherwise = From 4b18c0892a833a342ed90016835e7b8da0ad1255 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 2 Oct 2026 11:49:53 -0400 Subject: [PATCH 34/60] LeiosFetch: update expected size on cert-based refocus Addresses the most severe failures of the bug described in Issue https://github.com/input-output-hk/ouroboros-leios/issues/1128. Before this, we'd only ever fetch an EB at the size we _first_ saw it announced at---even if it was later certified at a _different_ size. So a adversarial announcement that won the race for some EbHash could prevent the node from ever being about to follow the honest chain (without a manual restart after which the adversary didn't win the race again). --- ...0000_nick.frisby_leios_offer_validation.md | 2 +- .../Test/Consensus/Leios/RecoveryPath.hs | 75 ++++++++++ .../src/ouroboros-consensus/LeiosDemoLogic.hs | 25 +--- .../src/ouroboros-consensus/LeiosDemoTypes.hs | 134 +++++++++++++----- .../Test/LeiosDemoLogic/Invariants.hs | 56 ++++++++ 5 files changed, 230 insertions(+), 62 deletions(-) diff --git a/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md b/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md index 5018cd936a..16eeca1c06 100644 --- a/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md +++ b/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md @@ -11,7 +11,7 @@ For top level release notes, leave all the headers commented out. - `recordEbBodyOffer` no longer lists a body as one to fetch, and takes no `LeiosOutstanding`. It gained two siblings: `recordEbClosureOffer`, and `recordCertRbOffer` for a CertRB roll-forward, which offers both the body and the closure. None of the three lists any EB bodies to fetch (since that's only justified by an announcement, not an offer). -- `ValidClaims`' `certifiedEbs` maps each election to the whole `AnnouncementFields` rather than just its `EbHash`. That is what lets `focusCertifiedEb` --- which moves a verified certificate's election onto the EB it names --- also list that body to fetch, via the new `listEbBodyToFetch`. +- `ValidClaims`' `certifiedEbs` maps each election to the whole `AnnouncementFields` rather than just its `EbHash`. That is what lets `focusCertifiedEb` --- which moves a verified certificate's election onto the EB it names --- also list that body to fetch, via the new `relistCertifiedEbBody`. - `LeiosNotifyPeerState` holds what one LeiosNotify client remembers of its peer --- its latest-pruned slot, its announcements and its offers. `checkLeiosBlockOffer` and `checkLeiosClosureOffer` accept or reject an offer against it, reporting `ExnLeiosInvalidOffer`, and `pruneLeiosNotifyPeerStateToImmTip` prunes it, replacing `prunePeerStateToImmTip`. diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs index f6f6743407..a3e21639d6 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs @@ -91,6 +91,9 @@ tests = , testCase "a certified endorser block is fetched though a rival took the focus first" test_certifiedRivalIsFetched + , testCase + "a certified endorser block is fetched though an announcement lied about its size" + test_mistatedSizeIsCorrected , testCase "a peer claiming two certified endorser blocks for one election is dropped" test_twoCertificationClaimsIsDropped @@ -252,6 +255,22 @@ decoyCertRB = decoyChain :: [Blk] decoyChain = [decoyAnnouncer, decoyCertRB] +-- | Announces 'endorserBlock' at a size it does not have. The peer serving it +-- never holds that endorser block, and nothing ever certifies this. +-- +-- Not an equivocation: this is an election of its own, in a slot of its own, +-- and any election may name any endorser block. So nothing about the header is +-- detectably wrong, and there is no proof for anyone to relay. +mistatingAnnouncer :: Blk +mistatingAnnouncer = + announcing (leiosTestEbPoint 2 endorserBlock) (endorserSize + 1) $ + successorLeiosBlock (firstLeiosBlock 7) + +-- | The chain the mistating announcement is on. It only has to outrank what +-- the node has selected so far, so that the announcement is counted at all. +mistatingChain :: [Blk] +mistatingChain = [firstLeiosBlock 7, mistatingAnnouncer] + -- | An endorser block announced in slot 2 rather than slot 1. Since nothing -- in these tests becomes immutable, that is the difference between being -- inside 'nutcMinOfferLead' of the immutable tip and being clear of it. @@ -882,6 +901,62 @@ test_certifiedRivalIsFetched = do awaitWith getTraces "the certified chain is selected" $ tipIsSTM nut (last afterCertRB) +-- | An endorser block listed at a size it does not have must still end up +-- fetched, once a certificate says what its size really is. +-- +-- 'mistatingAnnouncer' names 'endorserBlock' at the wrong size, and the node +-- hears that before anyone names it at the right one, so that is the size it +-- pursues. The peer that actually holds the endorser block offers it at its +-- true size, and every such offer reads as being for some other endorser block +-- and is passed over. Nothing in the announcements can break the tie --- at +-- most one of the two is honest and nothing says which --- so until the +-- certificate settles the size, the node cannot fetch the endorser block and +-- the CertRB stays parked. +-- +-- Unlike 'test_certifiedRivalIsFetched', the focus is never in doubt here: one +-- endorser block, named by both announcements, at two different sizes. +test_mistatedSizeIsCorrected :: Assertion +test_mistatedSizeIsCorrected = do + assertBool + "the two announcements name one endorser block" + (pointEbHash (leiosTestEbPoint 2 endorserBlock) == pointEbHash endorserPoint) + assertBool + "the mistating announcement is for an election of its own" + (headerElId (getHeader mistatingAnnouncer) /= theElection) + let simTrace = runSimTrace scenario + case traceResult False simTrace of + Right () -> pure () + outcome -> + assertFailure $ + unlines $ + ("expected the certified chain to be selected, but: " <> show outcome) + : lastN 40 (selectTraceEventsSay' simTrace) + where + scenario :: forall s. IOSim s () + scenario = do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + holder <- newPeerEnv + liar <- newPeerEnv + + (chainDBTracer, getTraces) <- recordingTracerTVar + + withNodeUnderTest nodeConfig nodeDBs leiosDb chainDBTracer $ \nut -> + withRegistry $ \registry -> do + connectPeer nut registry (PeerAddr 0) holder + connectPeer nut registry (PeerAddr 1) liar + + -- The wrong size, heard first, is the size the node pursues. + serveChain liar $ chainOf mistatingChain + awaitWith getTraces "the mistating announcement is selected" $ + tipIsSTM nut mistatingAnnouncer + + -- Only then the chain that announces the true size and certifies it. + plantEb holder endorserBlock endorserClosure + serveChain holder $ chainOf ([announcer, certRB] <> afterCertRB) + awaitWith getTraces "the certified chain is selected" $ + tipIsSTM nut (last afterCertRB) + -- | A peer may claim a certificate for at most one endorser block per -- election, and the second claim costs it the connection. -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs index 29d39b1062..f8046c5c9a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs @@ -931,18 +931,7 @@ processLeiosBlock ktracer tracer (outstandingVar, readyVar) txCache writer syste Just peerId -> refundEbRequest peerId ebHash ebBytesSize Nothing -> id ) - $ outstanding - { Leios.missingEbBodies = - case Map.lookup ebHash (Leios.reverseSlotIndexByEbHash outstanding) of - Nothing -> Leios.missingEbBodies outstanding - Just slots -> - foldr - (\slot -> Map.delete (MkLeiosPoint slot ebHash)) - (Leios.missingEbBodies outstanding) - slots - , Leios.reverseSlotIndexByEbHash = - Map.delete ebHash (Leios.reverseSlotIndexByEbHash outstanding) - } + $ Leios.unlistMissingEbBody ebHash outstanding -- Persist and classify only a genuinely novel, still-relevant body. A -- duplicate (already held) or a too-old arrival (its slot is below pruned -- watermark, so 'novel' can't be trusted) is left at the bookkeeping above @@ -2022,17 +2011,7 @@ recordAnnouncedEb (outstandingVar, readyVar) onset fields = do || Map.member ebHash (Leios.reverseSlotIndexByEbHash outstanding) -- already listed !outstanding'' | skip = outstanding' - | otherwise = - outstanding' - { Leios.missingEbBodies = - Map.insert point ebBytesSize (Leios.missingEbBodies outstanding') - , Leios.reverseSlotIndexByEbHash = - Map.insertWith - NESet.union - ebHash - (NESet.singleton ebSlot) - (Leios.reverseSlotIndexByEbHash outstanding') - } + | otherwise = Leios.listMissingEbBody point ebBytesSize outstanding' in (outstanding'', not skip) -- | What one LeiosNotify client remembers about its upstream peer. diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs index b7c3a420b4..0e720e6229 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs @@ -1012,48 +1012,106 @@ focusElectionIfUnfocused elId ebHash outstanding focusCertifiedEb :: AnnouncementFields -> LeiosOutstanding pid -> LeiosOutstanding pid focusCertifiedEb fields = focusElection (announcementElection fields) (announcementEbHash fields) - . listEbBodyToFetch (announcementLeiosPoint fields) (announcementEbBodySize fields) + . relistCertifiedEbBody (announcementLeiosPoint fields) (announcementEbBodySize fields) --- | List an endorser block's body as one to fetch, at the given size, unless --- it is too old, malformed, already held or already listed. +-- | List this endorser block body as one to fetch, at the given size, and +-- correct to that size every other point already listing it. -- --- "Already listed" is by endorser block hash, so the first size listed for a --- hash is the only one ever pursued. Two announcements can name one hash at --- different sizes, at most one of which is the truth, so a lying announcement --- that arrives first leaves us unable to fetch that endorser block at all. +-- One hash is one body is one size, so a size that applies to this point +-- applies to every point listing the same hash --- which is the invariant +-- 'LeiosDemoLogic.bodySize' reads the size back under. The other points are +-- kept, since each is a slot some election needs this body at, and that is what +-- decides when 'pruneOutstandingToImmTip' drops the listing. -- --- That is deliberate, and is what @lHdrWait@ is for. Being stuck this way --- means we saw the equivocation early, and we relay the announcement we saw, --- so nodes that were not stuck have the proof in hand before their vote window --- opens and withhold their votes. No certificate forms, and an endorser block --- that is never certified is one it costs us nothing to have missed. Should --- that fail, the Recovery Path gets us the endorser block eventually. -listEbBodyToFetch :: +-- Keeps 'reverseSlotIndexByEbHash' --- the exact inverse of 'missingEbBodies' +-- --- in step. Says nothing about whether the body is worth listing; that is +-- the caller's to decide. +listMissingEbBody :: LeiosPoint -> BytesSize -> LeiosOutstanding pid -> LeiosOutstanding pid +listMissingEbBody point ebBytesSize outstanding = + case Map.alterF addSlot ebHash (reverseSlotIndexByEbHash outstanding) of + (slots, reverseSlotIndexByEbHash') -> + outstanding + { missingEbBodies = + foldr + (\slot -> Map.insert (MkLeiosPoint slot ebHash) ebBytesSize) + (missingEbBodies outstanding) + slots + , reverseSlotIndexByEbHash = reverseSlotIndexByEbHash' + } + where + MkLeiosPoint ebSlot ebHash = point + addSlot mbListed = (slots, Just slots) + where + slots = maybe (NESet.singleton ebSlot) (NESet.insert ebSlot) mbListed + +-- | Stop fetching this endorser block body: drop every point listing it, at +-- whatever size, keeping 'reverseSlotIndexByEbHash' in step. +-- +-- By hash, not by point, because one body can be listed at several points and +-- the body answers for all of them at once. +unlistMissingEbBody :: EbHash -> LeiosOutstanding pid -> LeiosOutstanding pid +unlistMissingEbBody ebHash outstanding = + case Map.alterF dropSlots ebHash (reverseSlotIndexByEbHash outstanding) of + (mbListed, reverseSlotIndexByEbHash') -> + outstanding + { missingEbBodies = case mbListed of + Nothing -> missingEbBodies outstanding + Just slots -> + foldr + (\slot -> Map.delete (MkLeiosPoint slot ebHash)) + (missingEbBodies outstanding) + slots + , reverseSlotIndexByEbHash = reverseSlotIndexByEbHash' + } + where + dropSlots mbListed = (mbListed, Nothing) + +-- | List a certified endorser block's body as one to fetch at the size its +-- certificate attests, correcting the size any listing of that hash +-- already had --- unless it is too old, malformed or already held. +-- +-- REQUIREMENT: the size must come from an announcement whose certificate this +-- node has verified. 'focusCertifiedEb' is the only caller, and the only thing +-- that calls /it/ is the @leiosFocus@ loop in @NodeKernel@, off +-- @getLeiosValidClaims@. +-- +-- That requirement is the whole of why overriding the size is safe. Two +-- announcements can name one hash at different sizes, at most one of which is +-- the truth, and the first one we saw is the one we are pursuing (see +-- 'recordAnnouncedEb') --- so if that was the lie, no honest peer offers that +-- size and we cannot fetch that endorser block at all. Recovering from that is +-- what the correction is for. Were an unattested size able to displace one we +-- are already pursuing, the lie could simply arrive second instead and nothing +-- would be gained. +-- +-- Two announcements of one hash need not equivocate, though: only a second one +-- within a single election does that, and any two elections may name the same +-- endorser block. So in general there is nothing for us to relay that would +-- warn an unstuck node off voting, and nothing ends the stuck window but a +-- certificate. An endorser block that stays uncertified because we never +-- fetched it stays missed --- which is what an adversary able to anticipate +-- honest EbHashes could aim for. +-- +-- TODO a certificate does not yet actually attest the size. A voter holds the +-- body, so it knows the true size, but it never compares that to the size +-- given by the announcement it votes for (see the @FIXME@ in +-- 'LeiosVoting.runLeiosVoting'), so an announcement naming another election's +-- endorser block at a wrong size can still be certified. Until that check +-- exists, this unsticks an honest race but not an adversary who can get a +-- mis-sized announcement certified. +relistCertifiedEbBody :: LeiosPoint -> BytesSize -> LeiosOutstanding pid -> LeiosOutstanding pid -listEbBodyToFetch point ebBytesSize outstanding = - let MkLeiosPoint ebSlot ebHash = point - tooOld = ebSlot < acquiredEbBodiesPrunedSlot outstanding - malformed = ebBytesSize == 0 - outstanding' - | tooOld || malformed = outstanding - | otherwise = recordMaxAnnouncementSlot ebHash ebSlot SNothing outstanding - skip = - tooOld - || malformed - || maybe False ebStateHasBody (Map.lookup ebHash (ebState outstanding)) - || Map.member ebHash (reverseSlotIndexByEbHash outstanding) - in if skip - then outstanding' - else - outstanding' - { missingEbBodies = Map.insert point ebBytesSize (missingEbBodies outstanding') - , reverseSlotIndexByEbHash = - Map.insertWith - NESet.union - ebHash - (NESet.singleton ebSlot) - (reverseSlotIndexByEbHash outstanding') - } +relistCertifiedEbBody point ebBytesSize outstanding + | tooOld || malformed = outstanding + | alreadyHeld = outstanding1 + | otherwise = outstanding2 + where + MkLeiosPoint ebSlot ebHash = point + tooOld = ebSlot < acquiredEbBodiesPrunedSlot outstanding + malformed = ebBytesSize == 0 + alreadyHeld = maybe False ebStateHasBody (Map.lookup ebHash (ebState outstanding)) + outstanding1 = recordMaxAnnouncementSlot ebHash ebSlot SNothing outstanding + outstanding2 = listMissingEbBody point ebBytesSize outstanding1 focusElection :: ElId -> EbHash -> LeiosOutstanding pid -> LeiosOutstanding pid focusElection elId ebHash outstanding = case Map.lookup elId (elFocus outstanding) of diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs index bbe606d523..1856745e49 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs @@ -59,6 +59,7 @@ import qualified LeiosDemoDb as LeiosDb import LeiosDemoLogic ( LeiosBlockSource (..) , LeiosBlockTxsSource (..) + , bodySize , leiosFetchLogicIteration , noMempoolPull , processLeiosBlock @@ -341,6 +342,61 @@ tests = -- the reverse index stays the exact inverse: hA at slot 10 only, hB gone Map.lookup hA (Leios.reverseSlotIndexByEbHash o) @?= Just (NESet.singleton (SlotNo 10)) Map.lookup hB (Leios.reverseSlotIndexByEbHash o) @?= Nothing + , testCase "a certificate relists the body at its own size" $ do + let eb = ebOf [0, 1] + h = hashLeiosEb eb + trueSize = encodeLeiosEbSize eb + lie = trueSize + 1 + elLie = MkElId (SlotNo 5) (SBS.pack [1]) + elTrue = MkElId (SlotNo 7) (SBS.pack [2]) + -- What 'recordAnnouncedEb' does for the first announcement of an + -- election: take the focus and list the body at the announced size. + announced elId size o = + Leios.focusElectionIfUnfocused elId h $ + (Leios.recordMaxAnnouncementSlot h slot SNothing o) + { Leios.missingEbBodies = + Map.insert (MkLeiosPoint slot h) size (Leios.missingEbBodies o) + , Leios.reverseSlotIndexByEbHash = + Map.insertWith + NESet.union + h + (NESet.singleton slot) + (Leios.reverseSlotIndexByEbHash o) + } + where + MkElId slot _poolId = elId + o0 = + announced elLie lie $ + (emptyLeiosOutstanding (mkStdGen 0) (SlotNo 0) :: LeiosOutstanding Int) + o1 = Leios.focusCertifiedEb (Leios.MkAnnouncementFields elTrue h trueSize) o0 + -- The lying announcement got there first, so it is the size we were + -- pursuing -- and no honest peer ever offers it. + Map.toList (Leios.missingEbBodies o0) @?= [(MkLeiosPoint (SlotNo 5) h, lie)] + bodySize o0 h @?= Just lie + -- The certificate corrects the size at every point listing the hash, + -- the slot-5 one included. That is the point 'bodySize' reads the + -- size back through, and what it returns is what 'assignBody' + -- matches a peer's offer against. + Map.toList (Leios.missingEbBodies o1) + @?= [ (MkLeiosPoint (SlotNo 5) h, trueSize) + , (MkLeiosPoint (SlotNo 7) h, trueSize) + ] + Map.lookup h (Leios.reverseSlotIndexByEbHash o1) + @?= Just (NESet.insert (SlotNo 5) (NESet.singleton (SlotNo 7))) + bodySize o1 h @?= Just trueSize + , testCase "a certificate does not relist a body we already hold" $ do + let eb = ebOf [0, 1] + h = hashLeiosEb eb + elTrue = MkElId (SlotNo 7) (SBS.pack [2]) + o = + Leios.focusCertifiedEb (Leios.MkAnnouncementFields elTrue h (encodeLeiosEbSize eb)) $ + Leios.insertAcquiredEbBody h (Jobs.mkLeiosJobPool 1000 10 mempty) $ + -- the announcement that got us the body in the first place; + -- without it 'insertAcquiredEbBody' has no entry to update + Leios.recordMaxAnnouncementSlot h (SlotNo 7) SNothing $ + (emptyLeiosOutstanding (mkStdGen 0) (SlotNo 0) :: LeiosOutstanding Int) + Leios.missingEbBodies o @?= Map.empty + Leios.reverseSlotIndexByEbHash o @?= Map.empty , testProperty "outstanding-state invariants hold across arbitrary sequences" prop_invariants From 7d98e9cbbac1ff58e8efa6593f0dc87617a7db10 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 2 Oct 2026 14:56:39 -0400 Subject: [PATCH 35/60] LeiosFetch: two bugfixes around multiple announcements of the same EbHash Fixes Issue https://github.com/input-output-hk/ouroboros-leios/issues/1128 The LeiosFetch decision logic can now retrieve a correctly sized EB from a peer who offers&serves it (eg an honest peer) even if we've never received any announcement that claims the correct size for that EbHash. This prevents an easy-recipe for T22; see the Issue for more details. Also: remove an incorrect predicate that was the only thing preventing same EbHash to be fetchable even if it was first announced in a now immutable slot. Also: replace the now vestigial missingEbBodies and its reverse index with just an Int. LeiosFetch: remove now vestigial missingEbBodies --- .../Ouroboros/Consensus/NodeKernel.hs | 2 +- .../Test/Consensus/Leios/RecoveryPath.hs | 233 +++++++++++++++-- .../src/ouroboros-consensus/LeiosDemoLogic.hs | 176 +++++++------ .../src/ouroboros-consensus/LeiosDemoTypes.hs | 238 +++++------------- .../Test/Util/LeiosTestBlock.hs | 15 ++ .../Test/Util/TestBlock.hs | 7 + .../test/consensus-test/Test/LeiosDemoDb.hs | 6 +- .../consensus-test/Test/LeiosDemoLogic.hs | 57 +++-- .../Test/LeiosDemoLogic/Invariants.hs | 195 +++++++------- 9 files changed, 529 insertions(+), 400 deletions(-) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 9e4e4493ca..57a84d1cff 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -819,7 +819,7 @@ initInternalState fetchClientRegistry <- newFetchClientRegistry leiosPeersVars <- LazySTM.newTVarIO Map.empty - -- Seed 'acquiredEbBodiesPrunedSlot' from the immutable tip: everything at or + -- Seed 'outstandingPrunedSlot' from the immutable tip: everything at or -- below it is already final, so an EB that old must read as 'tooOld' from the -- outset -- not only once the first 'pruneOutstandingToImmTip' fires. immTip <- getTipSlot . ledgerState <$> atomically (ChainDB.getImmutableLedger chainDB) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs index a3e21639d6..b467b2800c 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs @@ -20,7 +20,7 @@ module Test.Consensus.Leios.RecoveryPath (tests) where import Cardano.Crypto.DSIGN (signDSIGN) -import Cardano.Ledger.BaseTypes (knownNonZeroBounded) +import Cardano.Ledger.BaseTypes (knownNonZeroBounded, unNonZero) import qualified Control.Concurrent.Class.MonadMVar as MVar import qualified Control.Concurrent.Class.MonadSTM as LazySTM import Control.Monad (unless) @@ -55,11 +55,12 @@ import LeiosDemoTypes , Weight , aggregateLeiosCert , offerings + , outstandingPrunedSlot ) import LeiosValidClaims (isCertifiedEb, memberValidClaim, sizeValidClaims) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (slotLengthFromSec) -import Ouroboros.Consensus.Config (SecurityParam (..)) +import Ouroboros.Consensus.Config (SecurityParam (..), maxRollbacks) import qualified Ouroboros.Consensus.HardFork.History as HardFork import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import Ouroboros.Consensus.NodeKernel (NodeKernel (..)) @@ -92,8 +93,14 @@ tests = "a certified endorser block is fetched though a rival took the focus first" test_certifiedRivalIsFetched , testCase - "a certified endorser block is fetched though an announcement lied about its size" + "one endorser block named by two announcements at two sizes is still fetched" test_mistatedSizeIsCorrected + , testCase + "an endorser block is fetched from a peer offering its true size, though every announcement lied" + test_offeredSizeBeatsAnnouncedSize + , testCase + "an endorser block a later election still needs outlives the earlier point being pruned" + test_laterAnnouncementOutlivesPruning , testCase "a peer claiming two certified endorser blocks for one election is dropped" test_twoCertificationClaimsIsDropped @@ -255,15 +262,25 @@ decoyCertRB = decoyChain :: [Blk] decoyChain = [decoyAnnouncer, decoyCertRB] +-- | The point the mistating announcement names: 'endorserBlock', in that +-- announcement's own election slot. +mistatedPoint :: LeiosPoint +mistatedPoint = leiosTestEbPoint 2 endorserBlock + +-- | The size it claims for that point, which is not the size 'endorserBlock' +-- has. +mistatedSize :: BytesSize +mistatedSize = endorserSize + 1 + -- | Announces 'endorserBlock' at a size it does not have. The peer serving it --- never holds that endorser block, and nothing ever certifies this. +-- need not hold that endorser block, and nothing ever certifies this. -- -- Not an equivocation: this is an election of its own, in a slot of its own, -- and any election may name any endorser block. So nothing about the header is -- detectably wrong, and there is no proof for anyone to relay. mistatingAnnouncer :: Blk mistatingAnnouncer = - announcing (leiosTestEbPoint 2 endorserBlock) (endorserSize + 1) $ + announcing mistatedPoint mistatedSize $ successorLeiosBlock (firstLeiosBlock 7) -- | The chain the mistating announcement is on. It only has to outrank what @@ -271,6 +288,60 @@ mistatingAnnouncer = mistatingChain :: [Blk] mistatingChain = [firstLeiosBlock 7, mistatingAnnouncer] +-- | One endorser block announced by two elections, on a chain long enough that +-- selecting it leaves the earlier announcement below the immutable tip and the +-- later one clear of it. See 'twiceAnnounced'. +data TwiceAnnounced = TwiceAnnounced + { taChain :: ![Blk] + -- ^ Slots 1 through 'taTip''s, one block each. + , taTip :: !Blk + , taEarly :: !Blk + -- ^ Announces 'taEarlyPoint'; pruned out once the chain is selected. + , taEarlyPoint :: !LeiosPoint + , taLate :: !Blk + -- ^ Announces 'taLatePoint', the same endorser block in a later election. + , taLatePoint :: !LeiosPoint + } + +-- | Lay that chain out for a given security parameter. +-- +-- One block per slot from slot 1, so the block in slot @s@ is the @s@th and a +-- selected chain of @n@ blocks puts the immutable tip at slot @n - k@. Pick +-- where that tip should land, and the rest follows: the chain must be @k@ +-- blocks longer, the early announcement goes a margin below it and the late +-- one a margin above, so neither sits on the boundary. +twiceAnnounced :: SecurityParam -> TwiceAnnounced +twiceAnnounced k = + TwiceAnnounced + { taChain = blocks + , taTip = blockAt tipSlot + , taEarly = blockAt earlySlot + , taEarlyPoint = pointAt earlySlot + , taLate = blockAt lateSlot + , taLatePoint = pointAt lateSlot + } + where + -- The first slot the prune keeps: a point in it survives, one in the slot + -- below it does not. The two announcements sit either side of that line, so + -- an off-by-one in the prune shows up here as a failure. + immTipSlot = 2 + earlySlot = immTipSlot - 1 + lateSlot = immTipSlot + tipSlot = immTipSlot + fromIntegral (unNonZero (maxRollbacks k)) + + pointAt slot = leiosTestEbPoint (fromIntegral slot) endorserBlock + + -- Decorating a plain chain after the fact leaves its links intact; see the + -- warning on @LeiosTestBlock@'s 'HeaderHash' instance. + blocks = + [ if slot `elem` [earlySlot, lateSlot] + then announcing (pointAt slot) endorserSize blk + else blk + | (slot, blk) <- zip [1 ..] (take tipSlot (iterate successorLeiosBlock (firstLeiosBlock 8))) + ] + + blockAt slot = blocks !! (slot - 1) + -- | An endorser block announced in slot 2 rather than slot 1. Since nothing -- in these tests becomes immutable, that is the difference between being -- inside 'nutcMinOfferLead' of the immutable tip and being clear of it. @@ -901,20 +972,20 @@ test_certifiedRivalIsFetched = do awaitWith getTraces "the certified chain is selected" $ tipIsSTM nut (last afterCertRB) --- | An endorser block listed at a size it does not have must still end up --- fetched, once a certificate says what its size really is. +-- | One endorser block, named by two announcements at two different sizes, is +-- still fetched and its CertRB still selected. -- --- 'mistatingAnnouncer' names 'endorserBlock' at the wrong size, and the node --- hears that before anyone names it at the right one, so that is the size it --- pursues. The peer that actually holds the endorser block offers it at its --- true size, and every such offer reads as being for some other endorser block --- and is passed over. Nothing in the announcements can break the tie --- at --- most one of the two is honest and nothing says which --- so until the --- certificate settles the size, the node cannot fetch the endorser block and --- the CertRB stays parked. +-- 'mistatingAnnouncer' names 'endorserBlock' at the wrong size and the node +-- hears that first, before the announcement that names it correctly and the +-- certificate for that one. Nothing in the announcements can break the tie: +-- at most one of the two is honest and nothing says which. -- --- Unlike 'test_certifiedRivalIsFetched', the focus is never in doubt here: one --- endorser block, named by both announcements, at two different sizes. +-- Unlike 'test_certifiedRivalIsFetched', the focus is never in doubt here --- +-- one endorser block, two announcements --- and unlike +-- 'test_offeredSizeBeatsAnnouncedSize' a certificate does arrive. It is kept +-- as a regression test: this exact message sequence is one that earlier +-- attempts at the size problem got wrong, and the node must come through it +-- whatever the fetch logic does with sizes. test_mistatedSizeIsCorrected :: Assertion test_mistatedSizeIsCorrected = do assertBool @@ -957,6 +1028,134 @@ test_mistatedSizeIsCorrected = do awaitWith getTraces "the certified chain is selected" $ tipIsSTM nut (last afterCertRB) +-- | A peer offering an endorser block at its true size must be asked for it, +-- even though every announcement the node ever saw named a different size. +-- +-- Gating on the announced size is one way to mount threat T22 --- withholding +-- data from most honest nodes so that an endorser block certifies but does not +-- propagate --- and a cheap one, needing neither network position nor an @L_hdr@ +-- violation nor any honest issuer. An adversary that wins more than one +-- election in a window announces its own endorser block at its true size to +-- just enough committee members to get it certified, and names that same hash +-- at a wrong size in its other, contemporary elections, which is what the rest +-- of the network hears. Those nodes pursue a size nobody will ever offer, so +-- the endorser block does not reach them during @L_diff@ at all --- which is +-- what @L_diff@ exists to prevent, and which sizing @L_diff@ cannot fix. +-- +-- So nothing an announcement says about a size may decide whom we ask. The +-- node here never hears the true size from anyone: the peer that holds the +-- body relays the very same wrong-size announcement --- which is all that +-- entitles it to offer at all --- and then offers the body at the size it +-- really is. +test_offeredSizeBeatsAnnouncedSize :: Assertion +test_offeredSizeBeatsAnnouncedSize = do + let simTrace = runSimTrace scenario + case traceResult False simTrace of + Right () -> pure () + outcome -> + assertFailure $ + unlines $ + ("expected the endorser block to be fetched, but: " <> show outcome) + : lastN 40 (selectTraceEventsSay' simTrace) + where + scenario :: forall s. IOSim s () + scenario = do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + liar <- newPeerEnv + holder <- newPeerEnv + + (chainDBTracer, getTraces) <- recordingTracerTVar + + withNodeUnderTest nodeConfig nodeDBs leiosDb chainDBTracer $ \nut -> + withRegistry $ \registry -> do + connectPeer nut registry (PeerAddr 0) liar + connectPeer nut registry (PeerAddr 1) holder + + plantEb holder endorserBlock endorserClosure + + -- The announcing header sits in a slot this simulation starts before, + -- and a header from the future is rejected as such. + threadDelay 6 + + -- The only thing the node is ever told about this endorser block's + -- size, and it is wrong. + announceEb liar (getHeader mistatingAnnouncer) + announceEb holder (getHeader mistatingAnnouncer) + + -- The one peer that actually has it says how big it is by offering it. + offerEb holder mistatedPoint endorserSize + + awaitPollingWith getTraces "the endorser block body is in the LeiosDb" $ + LeiosDb.withReader leiosDb $ \r -> + not . null <$> LeiosDb.lookupEbBody r (pointEbHash mistatedPoint) + +-- | An endorser block two elections announced is still fetched after the +-- earlier announcement's point has been pruned away. +-- +-- 'twiceAnnounced' lays out a chain naming one endorser block twice, far +-- enough apart that selecting it puts the earlier announcement below the +-- immutable tip and leaves the later one clear of it. Nothing offers the body +-- until that has happened, so the only point left to fetch it under is the +-- later one. +-- +-- The node used to list a body at one point per hash --- whichever election +-- named it first --- so the later announcement added nothing and pruning the +-- earlier point left the fetch logic with no size to match an offer against. +-- The endorser block then became unfetchable despite an election still needing +-- it, and the only way back was a certificate. +test_laterAnnouncementOutlivesPruning :: Assertion +test_laterAnnouncementOutlivesPruning = do + assertBool + "the two announcements are for different elections" + (headerElId (getHeader (taEarly ta)) /= headerElId (getHeader (taLate ta))) + assertBool + "the two announcements name one endorser block" + (pointEbHash (taEarlyPoint ta) == pointEbHash (taLatePoint ta)) + let simTrace = runSimTrace scenario + case traceResult False simTrace of + Right () -> pure () + outcome -> + assertFailure $ + unlines $ + ("expected the endorser block to be fetched, but: " <> show outcome) + : lastN 40 (selectTraceEventsSay' simTrace) + where + ta = twiceAnnounced securityParam + + scenario :: forall s. IOSim s () + scenario = do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + holder <- newPeerEnv + + (chainDBTracer, getTraces) <- recordingTracerTVar + + withNodeUnderTest nodeConfig nodeDBs leiosDb chainDBTracer $ \nut -> + withRegistry $ \registry -> do + connectPeer nut registry (PeerAddr 0) holder + + -- Both announcements, and nothing offering the body behind them. + serveChain holder $ chainOf (taChain ta) + awaitWith getTraces "the whole chain is selected" $ + tipIsSTM nut (taTip ta) + + -- Selecting it put the earlier announcement below the immutable tip. + -- Waiting on how far the node has pruned is the same act as asserting + -- that it pruned. + awaitPollingWith getTraces "the earlier announcement has been pruned out" $ + (> pointSlotNo (taEarlyPoint ta)) . outstandingPrunedSlot + <$> MVar.readMVar (getLeiosOutstanding (nutKernel nut)) + + -- Only now is the body obtainable, and only under the later point. + plantEb holder endorserBlock endorserClosure + announceEb holder (getHeader (taLate ta)) + offerEb holder (taLatePoint ta) endorserSize + + awaitPollingWith getTraces "the endorser block body is in the LeiosDb" $ + LeiosDb.withReader leiosDb $ \r -> + not . null <$> LeiosDb.lookupEbBody r (pointEbHash (taLatePoint ta)) + -- | A peer may claim a certificate for at most one endorser block per -- election, and the second claim costs it the connection. -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs index f8046c5c9a..b6068410c7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs @@ -541,14 +541,15 @@ assignPeer env mbCurrentSlot isBig peerId offers acc = pruneThisOffer = (acc1, dec1, Set.insert point drops) --- | Request the EB body from this peer, if the peer offered the body and --- offered it at the size we are pursuing. +-- | Request the EB body from this peer, at the size the peer offered it at. -- --- A peer that offered some other size holds a different endorser block than --- the one we are after --- at most one size for a hash is the truth --- so --- asking it would only earn us a body that fails 'processLeiosBlock''s size --- check. Its offer is left in place rather than dropped, since a later focus --- change could make it the one we want. +-- The offered size is the only size with any say here; an announcement's has +-- none, since at most one announcement naming a hash is honest and nothing +-- tells us which. So we ask whoever says they have it, for as many bytes as +-- they say. The offer was bounded by 'Leios.maxLeiosEbBytesSize' when it +-- arrived ('checkLeiosBlockOffer'), and what the bytes really are is settled on +-- arrival by hashing them ('processLeiosBlock'): a peer that misrepresented +-- either the block or its length loses the connection then. assignBody :: Ord pid => PeerId pid -> @@ -561,23 +562,18 @@ assignBody peerId ebHash slot offer st@(acc, dec) | peerId `Set.member` Map.findWithDefault Set.empty ebHash (Leios.requestedEbPeers acc) = -- unless we've already requested it from them st - | otherwise = - case bodySize acc ebHash of - Nothing -> - -- another ephemeral case where 'ebState' has been pruned before the - -- offers have - st - Just size - | Leios.poOfferedBody offer /= SJust size -> st - | otherwise -> - let acc' = - acc - { Leios.requestedEbPeers = - Map.insertWith Set.union ebHash (Set.singleton peerId) (Leios.requestedEbPeers acc) - , Leios.requestedBytesSizePerPeer = - Map.insertWith (+) peerId size (Leios.requestedBytesSizePerPeer acc) - } - in (acc', dec Seq.|> LeiosBlockRequest (MkLeiosBlockRequest (MkLeiosPoint slot ebHash) size)) + | otherwise = case Leios.poOfferedBody offer of + -- the peer offered the closure but not the body + SNothing -> st + SJust size -> + let acc' = + acc + { Leios.requestedEbPeers = + Map.insertWith Set.union ebHash (Set.singleton peerId) (Leios.requestedEbPeers acc) + , Leios.requestedBytesSizePerPeer = + Map.insertWith (+) peerId size (Leios.requestedBytesSizePerPeer acc) + } + in (acc', dec Seq.|> LeiosBlockRequest (MkLeiosBlockRequest (MkLeiosPoint slot ebHash) size)) -- | Flag indicating whether all jobs matching a peer's offers are already -- inflight @@ -643,13 +639,6 @@ assignClosure env isBig peerId ebHash st@(acc, dec) = reqs = batchTxsRequests env (MkLeiosPoint slot ebHash) nePicked in (acc', dec <> Seq.fromList reqs) --- | The announced body size of an EB we are still missing. All points of a hash --- share the size, so any one still listed in 'missingEbBodies' serves. -bodySize :: LeiosOutstanding pid -> EbHash -> Maybe BytesSize -bodySize acc ebHash = do - slots <- Map.lookup ebHash (Leios.reverseSlotIndexByEbHash acc) - Map.lookup (MkLeiosPoint (NESet.findMin slots) ebHash) (Leios.missingEbBodies acc) - -- | Take least-requested-available jobs until the budget is spent or -- there are no more jobs that aren't already assigned to this peer. Also -- returns true, in the latter case. Each pick carries the whole 'Jobs.LeiosJob' @@ -883,23 +872,41 @@ processLeiosBlock ktracer tracer (outstandingVar, readyVar) txCache writer syste let MkLeiosPoint _ebSlot ebHash = point let ebBytesSize' = encodeLeiosEbSize eb -- A failed-validation body: attribute the whole body to 'fabInvalid'. + -- + -- TODO throw a proper exception type rather than 'error', which this module + -- otherwise keeps for what cannot happen --- a peer earning a disconnect is + -- routine and should not read as a bug in this node. The mirror of + -- 'ExnLeiosInvalidRequest' is what is missing. 'processLeiosBlockTxs' has the + -- same helper, with the same gap. let invalidReply reason = traceWith ktracer (TraceLeiosFetchBodyArrival (fetchArrivalInvalid ebBytesSize')) >> error reason + -- Whether the peer sent a different number of bytes than its offer promised. + -- + -- That costs it the connection, but only once we have taken the body: the + -- hash is what says these are the right bytes, and if they are, throwing them + -- away would let a peer deny us an endorser block just by lowballing its own + -- offer. So this is settled at the very end of this function. + -- + -- An honest peer cannot be caught by this, because the voting logic checks + -- sizes (TODO it doesn't yet; see the related @FIXME@ in + -- 'LeiosVoting.runLeiosVoting'): only our interpretation of CertRB + -- roll-forward as an EB body offer interprets the issuer's claimed size as + -- the peer's claimed size. When that peer isn't also the issuer, they'd lose + -- their connection to us if the issuer lied about the size. However, an + -- honest peer only sends that CertRB after validating the (or an equivalent) + -- certificate. So, there is actually no such risk, because Leios committee is + -- assumed to be honest. + let wrongLength = case source of + ForgedBlock{} -> False + ReceivedBlockFrom{} -> ebBytesSize' /= ebBytesSize case source of -- A forge's body is self-produced; never validate it (so no 'error' path is -- ever reachable for a locally-forged EB). ForgedBlock{} -> pure () ReceivedBlockFrom{} -> do - -- FIXME: 'ebBytesSize' here is the size we recorded from the peer - -- offer at 'MsgLeiosBlockOffer' time (carried through the request), - -- not the chain-authoritative 'encodeLeiosEbSize' from the parent - -- RB's 'headerLeiosAnnouncement'. EB announcements are not yet - -- implemented; once they are, validate against the announced size - -- so that a peer cannot poison this check by sending a bad-size - -- offer first. - when (ebBytesSize' /= ebBytesSize) $ do - invalidReply $ "MsgLeiosBlock size mismatch: " <> show (ebBytesSize', ebBytesSize) + -- The hash is the whole of it: these bytes either are the endorser block + -- we asked for or they are not, and no announcement gets a say. let ebHash' = hashLeiosEb eb when (ebHash' /= ebHash) $ do invalidReply $ "MsgLeiosBlock hash mismatch: " <> show (ebHash', ebHash) @@ -918,20 +925,19 @@ processLeiosBlock ktracer tracer (outstandingVar, readyVar) txCache writer syste -- body cannot both write it (the second sees 'novel = False'), so we neither -- re-pay the ~16k-row write nor emit a storm of 'LeiosDbInsertCollision's. (shouldPersist, bodyClass, mempoolIngest, missedBoth, fills) <- MVar.modifyMVar outstandingVar $ \outstanding -> do - let tooOld = point.pointSlotNo < Leios.acquiredEbBodiesPrunedSlot outstanding + let tooOld = point.pointSlotNo < Leios.outstandingPrunedSlot outstanding novel = not $ maybe False Leios.ebStateHasBody (Map.lookup ebHash (Leios.ebState outstanding)) -- Always: this request is no longer in flight and we now have the body, -- so drop the body-fetch bookkeeping ('refundEbRequest' reverses the -- per-request accounting -- skipped if a disconnect already cancelled it - -- in bulk -- and we delete every point listing this body from - -- 'missingEbBodies'); and unless the EB is too old to matter, remember we - -- have it so we neither re-fetch nor re-offer it. + -- in bulk); and unless the EB is too old to matter, remember we have it + -- so we neither re-fetch nor re-offer it. !outstandingCleaned = ( case mbPeer of Just peerId -> refundEbRequest peerId ebHash ebBytesSize Nothing -> id ) - $ Leios.unlistMissingEbBody ebHash outstanding + outstanding -- Persist and classify only a genuinely novel, still-relevant body. A -- duplicate (already held) or a too-old arrival (its slot is below pruned -- watermark, so 'novel' can't be trusted) is left at the bookkeeping above @@ -1041,7 +1047,10 @@ processLeiosBlock ktracer tracer (outstandingVar, readyVar) txCache writer syste -- -- A failed write is fatal: the single writer rethrows and is 'link'ed to the -- node, so there is no lost-write case to recover from here. - pointWritten <- writeEbPoint writer point ebBytesSize + -- + -- The size written is the actual size of the received body, regardless of + -- announcements' or offers' claims. + pointWritten <- writeEbPoint writer point ebBytesSize' bodyWritten <- writeEbBody writer point eb fills let settle = do await pointWritten @@ -1089,6 +1098,11 @@ processLeiosBlock ktracer tracer (outstandingVar, readyVar) txCache writer syste writer systemTime (MempoolTxs point mempoolIngest) + -- The body is in hand and ingested; only now does the peer answer for having + -- promised a different number of bytes than it sent. + when wrongLength $ + throwIO $ + ExnLeiosBlockWrongSize point ebBytesSize ebBytesSize' -- | The 'processLeiosBlock' mempool-pull for paths that never pull from the -- mempool (the forge, which already holds the whole closure, and tests): keep @@ -1619,12 +1633,11 @@ checkMsgRollForwardForLeiosOffers kernelVars peerVars hdr cds = -- equivocation proofs can spread, and nothing asks a peer to show us two -- certificates. -- --- Without this, the offer path is a second door into 'ebState' and --- 'missingEbBodies' that the announcement cap does not guard: a pool can --- equivocate its own won slots into arbitrarily many announcing blocks, put a --- cert-claiming header on each --- the certificate is in the body, which we --- need never fetch --- and roll them all forward, arbitrarily increasing the --- node's memory usage. +-- Without this, rolling CertRBs forward is a door into this peer's 'offerings' +-- that the announcement cap does not guard: a pool can equivocate its own won +-- slots into arbitrarily many announcing blocks, put a cert-claiming header on +-- each --- the certificate is in the body, which we need never fetch --- and +-- roll them all forward, arbitrarily increasing the node's memory usage. noteCertificationClaim :: IOLike m => LeiosPeerVars m -> ElId -> EbHash -> m () noteCertificationClaim peerVars elId ebHash = MVar.modifyMVar (Leios.certificationClaims peerVars) $ \claimed -> @@ -1861,6 +1874,20 @@ data ExnLeiosInvalidRequest instance Exception ExnLeiosInvalidRequest +-- | Thrown when a peer's 'MsgLeiosBlock' is not the number of bytes it offered +-- that endorser block at: the point, the size it offered, and the size it sent. +-- The ensuing thread death disconnects it. +-- +-- Unlike the other invalid replies, the body itself is good --- it hashes to +-- the endorser block we asked for --- so it is ingested before this is thrown +-- and its bytes are accounted as the arrival they were. That is why this does +-- not go through @invalidReply@, which writes the whole body off as waste. +data ExnLeiosBlockWrongSize + = ExnLeiosBlockWrongSize !LeiosPoint !BytesSize !BytesSize + deriving Show + +instance Exception ExnLeiosBlockWrongSize + -- | Which of a point's two independent offers a LeiosNotify message makes. data OfferedBodyOrClosure = OfferedBody | OfferedClosure deriving (Eq, Show) @@ -1983,36 +2010,35 @@ recordAnnouncedEb (outstandingVar, readyVar) onset fields = do changed <- MVar.modifyMVar outstandingVar (pure . upd) when changed $ void $ MVar.tryPutMVar readyVar () where - MkAnnouncementFields elId ebHash ebBytesSize = fields + -- The announced size is deliberately unused by fetching; nothing about + -- fetching turns on it (see 'assignBody'). + MkAnnouncementFields elId ebHash _ebBytesSize = fields -- The announced EB's slot is its election's slot (see -- 'headerLeiosAnnouncement'). MkElId ebSlot _poolId = elId - point = MkLeiosPoint ebSlot ebHash - -- The same in-lock guard as 'recordEbBodyOffer' (too old / already held / - -- already listed). No cache lookup: 'ebState' is authoritative here. + -- The same in-lock guard as 'recordEbBodyOffer' (too old / already held). No + -- cache lookup: 'ebState' is authoritative here. upd outstanding = - let tooOld = ebSlot < Leios.acquiredEbBodiesPrunedSlot outstanding -- too old to fetch + let tooOld = ebSlot < Leios.outstandingPrunedSlot outstanding -- too old to fetch + -- One entry per election: the announcement that takes the election's + -- focus. A second announcement for an already-focused election is an + -- equivocation, and tracking its endorser block too would let a pool + -- double what its won slots cost us. If that one turns out to be the + -- certified one, 'trackCertifiedEb' gives it an entry then. + introducedFocus = not $ Map.member elId (Leios.elFocus outstanding) !outstanding' - | tooOld = outstanding + | tooOld || not introducedFocus = outstanding | otherwise = Leios.focusElectionIfUnfocused elId ebHash $ Leios.recordMaxAnnouncementSlot ebHash ebSlot onset outstanding - -- Only the announcement that takes the election's focus lists a body: - -- one candidate per election, which is what bounds 'missingEbBodies'. - -- A later announcement for an already-focused election is recorded but - -- not pursued, and a certificate that moves the focus lists its own - -- through 'checkMsgRollForwardForLeiosOffers'. - tookFocus = not $ Map.member elId (Leios.elFocus outstanding) + -- Whether this gives the fetch logic anything new to do, and so is + -- worth waking it for. skip = tooOld - || not tookFocus + || not introducedFocus || maybe False Leios.ebStateHasBody (Map.lookup ebHash (Leios.ebState outstanding)) -- already have it - || Map.member ebHash (Leios.reverseSlotIndexByEbHash outstanding) -- already listed - !outstanding'' - | skip = outstanding' - | otherwise = Leios.listMissingEbBody point ebBytesSize outstanding' - in (outstanding'', not skip) + in (outstanding', not skip) -- | What one LeiosNotify client remembers about its upstream peer. -- @@ -2090,10 +2116,12 @@ checkLeiosBlockOffer point claimed peerSt | ebSlot < lnpsPruneSlot peerSt = Left $ ExnLeiosOfferTooOld point (lnpsPruneSlot peerSt) | SJust{} <- Leios.poOfferedBody seen = Left $ ExnLeiosRepeatedOffer point OfferedBody - | claimed > Leios.maxLeiosEbBytesSize = - -- No endorser block may exceed this in any slot: it is the bound the - -- guardrails script imposes, so the ledger parameter that actually - -- applies can only be smaller. + | claimed == 0 || claimed > Leios.maxLeiosEbBytesSize = + -- An endorser block has at least one byte, and no endorser block may + -- exceed this in any slot: that is the bound the guardrails script + -- imposes, so the ledger parameter that actually applies can only be + -- smaller. Since the offered size is what we go on to request (see + -- 'assignBody'), this is the only thing bounding it. -- -- TODO enforce that parameter instead of its ceiling. The announcement -- this offer rides on (see 'announcedIt') was validated against the diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs index 0e720e6229..a35130c791 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs @@ -567,21 +567,18 @@ data LeiosOutstanding pid = MkLeiosOutstanding -- this is what filters a peer's offers before either is considered. A body -- we already hold stays held and its job pool stays as it is, so an election -- that focuses it later resumes rather than restarts. - , acquiredEbBodiesPrunedSlot :: !SlotNo - -- ^ The slot 'ebState' has most recently been pruned up to (see - -- 'pruneOutstandingToImmTip'). + , outstandingPrunedSlot :: !SlotNo + -- ^ The slot this whole 'LeiosOutstanding' has most recently been pruned up + -- to: 'pruneOutstandingToImmTip' moves it in the same record it prunes + -- 'ebState' and 'elFocus' in, so it says how far both of them have got. -- -- Used to robustly prevent re-inserting what has already been pruned out. - , missingEbBodies :: !(Map LeiosPoint BytesSize) - -- ^ EB bodies still needed to be fetched (indexed by point and size) - , reverseSlotIndexByEbHash :: !(Map EbHash (NESet SlotNo)) - -- ^ Inverse of 'missingEbBodies' grouped by content hash: for each EbHash - -- listed there, the slots of the 'LeiosPoint's listing it. An EbHash is not - -- 1-to-1 with slots, so one body can be listed at several points; on acquiring - -- the body (keyed by hash) 'processLeiosBlock' must clear every such point, and - -- this index makes that a direct lookup rather than a scan of 'missingEbBodies' - -- (it likewise backs the "already listed?" check on the offer/announcement - -- paths). Kept in step with 'missingEbBodies' at every insert and delete. + , numMissingBodies :: !Int + -- ^ How many 'ebState' entries have no body and are not being forged: the + -- body-fetch backlog, maintained as 'ebState' changes rather than counted, + -- so reading it stays O(1) however often the fetch loop runs. 'wantsBody' is + -- the per-entry contribution; 'Test.LeiosDemoLogic.Invariants.checkInvariant' + -- is what says it has not drifted. , -- Request tracking requestedEbPeers :: !(Map EbHash (Set (PeerId pid))) -- ^ Which peers we've requested each EB from @@ -605,7 +602,7 @@ data LeiosOutstanding pid = MkLeiosOutstanding -- | The empty outstanding state, given the slot it has already been pruned up -- to. The caller supplies the immutable-tip slot at startup so that a body at -- or below it reads as too old from the outset (see --- 'acquiredEbBodiesPrunedSlot' / 'pruneOutstandingToImmTip'), and the seed for +-- 'outstandingPrunedSlot' / 'pruneOutstandingToImmTip'), and the seed for -- the decision loop's PRNG (see 'leiosFetchPrng'). emptyLeiosOutstanding :: StdGen -> SlotNo -> LeiosOutstanding pid emptyLeiosOutstanding prng prunedSlot = @@ -614,9 +611,8 @@ emptyLeiosOutstanding prng prunedSlot = , ebsPerMaxAnnouncementSlot = Map.empty , elFocus = Map.empty , focusedEbs = MultiSet.empty - , acquiredEbBodiesPrunedSlot = prunedSlot - , missingEbBodies = Map.empty - , reverseSlotIndexByEbHash = Map.empty + , outstandingPrunedSlot = prunedSlot + , numMissingBodies = 0 , requestedEbPeers = Map.empty , requestedBytesSizePerPeer = Map.empty , requestedJobsPerPeer = Map.empty @@ -689,8 +685,8 @@ data LeiosOutstandingStats = MkLeiosOutstandingStats -- ^ Total EBs in 'ebState' (should stay bounded by the pruning window; a -- persistent climb signals a pruning leak). , losMissingBodies :: !Int - -- ^ Size of 'missingEbBodies' (EB body points still to fetch) -- the body-fetch - -- backlog. + -- ^ Of those, how many we have no body for and are not forging -- the + -- body-fetch backlog. Read straight off 'numMissingBodies', so O(1). , losPeersInflight :: !Int -- ^ Peers tracked in the outstanding-request byte map. , losInflightBytesDesc :: !(Vector Int) @@ -712,7 +708,7 @@ leiosOutstandingStats :: Int -> [Int] -> LeiosOutstanding pid -> LeiosOutstandin leiosOutstandingStats numOfferingPeers offerSizes o = MkLeiosOutstandingStats { losTracked = Map.size (ebState o) - , losMissingBodies = Map.size (missingEbBodies o) + , losMissingBodies = numMissingBodies o , losPeersInflight = Map.size inflightMap , losInflightBytesDesc = inflightDesc , losOffersDesc = offersDesc @@ -829,40 +825,16 @@ data TxLocation = MkTxLocation !EbHash !TxOffset acquireEbBody :: EbHash -> Jobs.LeiosJobPool -> LeiosOutstanding pid -> LeiosOutstanding pid acquireEbBody ebHash jobPool = - -- De-list the body: we now hold it, so it must not be left in the fetch set. - -- A concurrent offer may have (re-)listed it during the write window, when it - -- read as not-held; without this de-list that listing would survive the claim - -- and the decision loop would keep re-requesting a held body. - delistEbBody ebHash - . alterEbState - ebHash - ( \case - -- Pruned before the write landed (we could not have requested it - -- without an announcement, and that was since evicted): ignore. - Nothing -> Nothing - Just (MkEbState slot onset fetchState) -> case fetchState of - NoBody -> Just $ MkEbState slot onset (BodyAcquired jobPool) - BodyImminent -> Just $ MkEbState slot onset (BodyAcquired jobPool) - -- Already acquired -- e.g. a concurrent redundant delivery landed - -- first; keep the existing pool rather than clobbering it. - BodyAcquired{} -> Nothing - ) - --- | Drop an EB's body points from the fetch set and its reverse-slot index, --- because we now hold the body. Idempotent: a no-op if nothing is listed. -delistEbBody :: EbHash -> LeiosOutstanding pid -> LeiosOutstanding pid -delistEbBody ebHash o = - o - { missingEbBodies = - case Map.lookup ebHash (reverseSlotIndexByEbHash o) of - Nothing -> missingEbBodies o - Just slots -> - foldr - (\slot -> Map.delete (MkLeiosPoint slot ebHash)) - (missingEbBodies o) - slots - , reverseSlotIndexByEbHash = Map.delete ebHash (reverseSlotIndexByEbHash o) - } + alterEbState ebHash $ \case + -- Pruned before the write landed (we could not have requested it + -- without an announcement, and that was since evicted): ignore. + Nothing -> Nothing + Just (MkEbState slot onset fetchState) -> case fetchState of + NoBody -> Just $ MkEbState slot onset (BodyAcquired jobPool) + BodyImminent -> Just $ MkEbState slot onset (BodyAcquired jobPool) + -- Already acquired -- e.g. a concurrent redundant delivery landed + -- first; keep the existing pool rather than clobbering it. + BodyAcquired{} -> Nothing -- | Record that our own forge is producing this EB markBodyImminent :: @@ -1012,106 +984,24 @@ focusElectionIfUnfocused elId ebHash outstanding focusCertifiedEb :: AnnouncementFields -> LeiosOutstanding pid -> LeiosOutstanding pid focusCertifiedEb fields = focusElection (announcementElection fields) (announcementEbHash fields) - . relistCertifiedEbBody (announcementLeiosPoint fields) (announcementEbBodySize fields) - --- | List this endorser block body as one to fetch, at the given size, and --- correct to that size every other point already listing it. --- --- One hash is one body is one size, so a size that applies to this point --- applies to every point listing the same hash --- which is the invariant --- 'LeiosDemoLogic.bodySize' reads the size back under. The other points are --- kept, since each is a slot some election needs this body at, and that is what --- decides when 'pruneOutstandingToImmTip' drops the listing. --- --- Keeps 'reverseSlotIndexByEbHash' --- the exact inverse of 'missingEbBodies' --- --- in step. Says nothing about whether the body is worth listing; that is --- the caller's to decide. -listMissingEbBody :: LeiosPoint -> BytesSize -> LeiosOutstanding pid -> LeiosOutstanding pid -listMissingEbBody point ebBytesSize outstanding = - case Map.alterF addSlot ebHash (reverseSlotIndexByEbHash outstanding) of - (slots, reverseSlotIndexByEbHash') -> - outstanding - { missingEbBodies = - foldr - (\slot -> Map.insert (MkLeiosPoint slot ebHash) ebBytesSize) - (missingEbBodies outstanding) - slots - , reverseSlotIndexByEbHash = reverseSlotIndexByEbHash' - } - where - MkLeiosPoint ebSlot ebHash = point - addSlot mbListed = (slots, Just slots) - where - slots = maybe (NESet.singleton ebSlot) (NESet.insert ebSlot) mbListed - --- | Stop fetching this endorser block body: drop every point listing it, at --- whatever size, keeping 'reverseSlotIndexByEbHash' in step. --- --- By hash, not by point, because one body can be listed at several points and --- the body answers for all of them at once. -unlistMissingEbBody :: EbHash -> LeiosOutstanding pid -> LeiosOutstanding pid -unlistMissingEbBody ebHash outstanding = - case Map.alterF dropSlots ebHash (reverseSlotIndexByEbHash outstanding) of - (mbListed, reverseSlotIndexByEbHash') -> - outstanding - { missingEbBodies = case mbListed of - Nothing -> missingEbBodies outstanding - Just slots -> - foldr - (\slot -> Map.delete (MkLeiosPoint slot ebHash)) - (missingEbBodies outstanding) - slots - , reverseSlotIndexByEbHash = reverseSlotIndexByEbHash' - } - where - dropSlots mbListed = (mbListed, Nothing) + . trackCertifiedEb (announcementLeiosPoint fields) --- | List a certified endorser block's body as one to fetch at the size its --- certificate attests, correcting the size any listing of that hash --- already had --- unless it is too old, malformed or already held. +-- | Start tracking a certified endorser block, unless it is too old. -- --- REQUIREMENT: the size must come from an announcement whose certificate this --- node has verified. 'focusCertifiedEb' is the only caller, and the only thing --- that calls /it/ is the @leiosFocus@ loop in @NodeKernel@, off --- @getLeiosValidClaims@. +-- An 'ebState' entry is what makes a body fetchable at all: the decision logic +-- skips any offer of an endorser block it has no entry for. The announcement +-- that took the election's focus made one, but this endorser block's +-- announcement may have lost that race, or may never have reached us, so this +-- is where a certificate makes one of its own. -- --- That requirement is the whole of why overriding the size is safe. Two --- announcements can name one hash at different sizes, at most one of which is --- the truth, and the first one we saw is the one we are pursuing (see --- 'recordAnnouncedEb') --- so if that was the lie, no honest peer offers that --- size and we cannot fetch that endorser block at all. Recovering from that is --- what the correction is for. Were an unattested size able to displace one we --- are already pursuing, the lie could simply arrive second instead and nothing --- would be gained. --- --- Two announcements of one hash need not equivocate, though: only a second one --- within a single election does that, and any two elections may name the same --- endorser block. So in general there is nothing for us to relay that would --- warn an unstuck node off voting, and nothing ends the stuck window but a --- certificate. An endorser block that stays uncertified because we never --- fetched it stays missed --- which is what an adversary able to anticipate --- honest EbHashes could aim for. --- --- TODO a certificate does not yet actually attest the size. A voter holds the --- body, so it knows the true size, but it never compares that to the size --- given by the announcement it votes for (see the @FIXME@ in --- 'LeiosVoting.runLeiosVoting'), so an announcement naming another election's --- endorser block at a wrong size can still be certified. Until that check --- exists, this unsticks an honest race but not an adversary who can get a --- mis-sized announcement certified. -relistCertifiedEbBody :: - LeiosPoint -> BytesSize -> LeiosOutstanding pid -> LeiosOutstanding pid -relistCertifiedEbBody point ebBytesSize outstanding - | tooOld || malformed = outstanding - | alreadyHeld = outstanding1 - | otherwise = outstanding2 +-- Already holding the body is not a special case: 'recordMaxAnnouncementSlot' +-- leaves the fetch state alone, so nothing is re-fetched. +trackCertifiedEb :: LeiosPoint -> LeiosOutstanding pid -> LeiosOutstanding pid +trackCertifiedEb point outstanding + | ebSlot < outstandingPrunedSlot outstanding = outstanding + | otherwise = recordMaxAnnouncementSlot ebHash ebSlot SNothing outstanding where MkLeiosPoint ebSlot ebHash = point - tooOld = ebSlot < acquiredEbBodiesPrunedSlot outstanding - malformed = ebBytesSize == 0 - alreadyHeld = maybe False ebStateHasBody (Map.lookup ebHash (ebState outstanding)) - outstanding1 = recordMaxAnnouncementSlot ebHash ebSlot SNothing outstanding - outstanding2 = listMissingEbBody point ebBytesSize outstanding1 focusElection :: ElId -> EbHash -> LeiosOutstanding pid -> LeiosOutstanding pid focusElection elId ebHash outstanding = case Map.lookup elId (elFocus outstanding) of @@ -1128,6 +1018,14 @@ focusElection elId ebHash outstanding = case Map.lookup elId (elFocus outstandin isFocusedEb :: EbHash -> LeiosOutstanding pid -> Bool isFocusedEb ebHash = MultiSet.member ebHash . focusedEbs +-- | Whether this EB's body is one we are still trying to fetch: the per-entry +-- contribution to 'numMissingBodies'. +wantsBody :: EbState -> Int +wantsBody (MkEbState _slot _onset fetchState) = case fetchState of + NoBody -> 1 + BodyImminent -> 0 -- our own forge is producing it + BodyAcquired{} -> 0 + -- | Upsert an EB's 'ebState' entry, keeping 'ebsPerMaxAnnouncementSlot' in step -- whenever the entry's max slot moves. The supplied function must be -- slot-monotonic (never lower the greatest slot), which both callers are. @@ -1140,9 +1038,10 @@ alterEbState :: alterEbState ebHash f outstanding = case Map.alterF upsert1 ebHash (ebState outstanding) of (Nothing, _) -> outstanding - (Just (mbOldSlot, newSlot), ebState') -> + (Just (mbOldSlot, newSlot, deltaMissing), ebState') -> outstanding { ebState = ebState' + , numMissingBodies = numMissingBodies outstanding + deltaMissing , ebsPerMaxAnnouncementSlot = if mbOldSlot == Just newSlot then ebsPerMaxAnnouncementSlot outstanding -- max slot unchanged @@ -1159,10 +1058,17 @@ alterEbState ebHash f outstanding = where -- One traversal of 'ebState': the pair functor carries whether the entry -- changed at all and, if so, the prior and new greatest slots for the - -- reverse-index update. + -- reverse-index update and this entry's contribution to 'numMissingBodies'. upsert1 mbOld = case f mbOld of Nothing -> (Nothing, mbOld) - Just new -> (Just (ebStateMaxSlot <$> mbOld, ebStateMaxSlot new), Just new) + Just new -> + ( Just + ( ebStateMaxSlot <$> mbOld + , ebStateMaxSlot new + , wantsBody new - maybe 0 wantsBody mbOld + ) + , Just new + ) -- | Prune 'Outstanding' to the immutable tip, returning the EB hashes it dropped -- (so the caller can drop those same hashes from the peers' offers). @@ -1179,9 +1085,8 @@ pruneOutstandingToImmTip immTipSlot outstanding = , ebsPerMaxAnnouncementSlot = atOrAbove , elFocus = elFocusAtOrAbove , focusedEbs = focusedEbs' - , acquiredEbBodiesPrunedSlot = max (acquiredEbBodiesPrunedSlot outstanding) immTipSlot - , missingEbBodies = missingEbBodiesAtOrAbove - , reverseSlotIndexByEbHash = reverseSlotIndexByEbHash' + , outstandingPrunedSlot = max (outstandingPrunedSlot outstanding) immTipSlot + , numMissingBodies = numMissingBodies outstanding - prunedMissing } ) where @@ -1196,22 +1101,15 @@ pruneOutstandingToImmTip immTipSlot outstanding = Map.spanAntitone (\(MkElId elSlot _poolId) -> elSlot < immTipSlot) (elFocus outstanding) + -- O(pruned), which pruning already is. + prunedMissing = + F.foldl' + (\n h -> n + maybe 0 wantsBody (Map.lookup h (ebState outstanding))) + 0 + prunedHashes focusedEbs' = F.foldl' (flip MultiSet.delete) (focusedEbs outstanding) (Map.elems staleFocus) - -- 'LeiosPoint' orders slot-first, so the below-tip points are a prefix. - (belowBodies, missingEbBodiesAtOrAbove) = - Map.spanAntitone - (\(MkLeiosPoint slot _ebHash) -> slot < immTipSlot) - (missingEbBodies outstanding) - -- Remove each dropped point's slot from its hash's reverse-index entry (which - -- exists, since the index is the exact inverse of 'missingEbBodies'). - reverseSlotIndexByEbHash' = - foldr - (\(MkLeiosPoint slot ebHash) -> Map.update (NESet.nonEmptySet . NESet.delete slot) ebHash) - (reverseSlotIndexByEbHash outstanding) - (Map.keys belowBodies) - -- | Pretty-print the per-peer 'offerings' map: for each peer, its offered points -- freshest-first, each tagged with the strongest kind offered. Hashes truncated. prettyOfferings :: Show pid => Map (PeerId pid) (Map LeiosPoint PeerOffer) -> String @@ -1245,8 +1143,6 @@ prettyLeiosOutstanding x = unlines $ map (" [leios] " ++) $ [ "ebState = " ++ show (Map.size ebState) - , "missingEbBodies = " ++ show (Map.size missingEbBodies) - , "reverseSlotIndexByEbHash = " ++ show (Map.size reverseSlotIndexByEbHash) , "requestedEbPeers = " ++ unwords (map prettyEbHash (Map.keys requestedEbPeers)) , "requestedBytesSizePerPeer = " ++ show (Map.elems requestedBytesSizePerPeer) , "" @@ -1254,8 +1150,6 @@ prettyLeiosOutstanding x = where MkLeiosOutstanding { ebState - , missingEbBodies - , reverseSlotIndexByEbHash , requestedEbPeers , requestedBytesSizePerPeer } = x diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs index 6a141ce48a..d2e7af6505 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs @@ -303,6 +303,21 @@ data instance Header LeiosTestBlock = LeiosTestHeader hashLeiosTestBody :: LeiosTestBody -> Word64 hashLeiosTestBody = djb2 . serialise +-- WARNING: a header's hash is its position in the block tree and nothing else. +-- +-- A real header hash covers the header's contents, so two headers differing in +-- their Leios announcement --- or their issuer, their certificate flag, or +-- their body hash --- necessarily differ in their hash. Here they do not. +-- 'announcing', 'certifying', 'issuedBy' and 'withTxs' each rewrite a header in +-- place and leave 'lthHash' alone, which is what lets a test build a plain +-- chain and decorate its blocks afterwards without breaking the links. +-- +-- That is deliberate, and convenient, but it means this block type cannot +-- exhibit anything that turns on a header's contents being bound to its hash. +-- Two headers a test needs to be genuinely distinct must sit at different +-- positions in the tree ('forkLeiosBlock'); giving them different contents is +-- not enough. In particular, equivocation here is a fact about the tree, not +-- about what the headers say. type instance HeaderHash LeiosTestBlock = TestHash instance StandardHash LeiosTestBlock diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index 85914e53ce..0a7aec7012 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -202,6 +202,13 @@ import Test.Util.Orphans.ToExpr () -- in-memory representation). -- -- The 'BlockNo' of the corresponding block is just the length of the list. +-- +-- WARNING: this is a position in the block tree and nothing else. Unlike a real +-- hash it covers none of the block's contents, so two blocks at the same +-- position have the same hash however much they otherwise differ --- which is +-- what lets a test build a chain and then edit its blocks. Block types built on +-- this inherit it; see the 'HeaderHash' instance for @LeiosTestBlock@ for what +-- that costs. newtype TestHash = UnsafeTestHash { unTestHash :: NonEmpty Word64 } diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs index 885c980774..2084782cb8 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs @@ -716,7 +716,7 @@ test_crossEbFill db = do filled @?= [0, 1] completed @?= [pointB] -- and the closure reads back with A's bytes - closure <- rwLookupEbClosure con (pointEbHash pointB) + closure <- rwLookupTrustedEbClosure con (pointEbHash pointB) fmap (map snd) closure @?= Just [txBytesFor ebA 0, txBytesFor ebA 1] -- C declares a DIFFERENT tx hash of the same size as A's offset 0: a -- stale location resolving to the wrong EB must fill nothing even when @@ -929,7 +929,7 @@ prop_completedEbComplete impl = let ebTxList = V.toList (leiosEbTxs eb) txsToInsert = [(i, txBytesFor eb i) | (i, _) <- zip [0 :: Int ..] ebTxList] _ <- rwInsertTxs con point txsToInsert - (result, queryTime) <- timed $ rwLookupEbClosure con (pointEbHash point) + (result, queryTime) <- timed $ rwLookupTrustedEbClosure con (pointEbHash point) let expectedHashes = map fst ebTxList check = case result of Nothing -> @@ -979,7 +979,7 @@ prop_completedEbPartialTxs impl = partialTxs = take (numTxs `div` 2) ebTxList txsToInsert = [(i, txBytesFor eb i) | (i, _) <- zip [0 :: Int ..] partialTxs] _ <- rwInsertTxs con point txsToInsert - (result, queryTime) <- timed $ rwLookupEbClosure con (pointEbHash point) + (result, queryTime) <- timed $ rwLookupTrustedEbClosure con (pointEbHash point) pure $ result === Nothing & counterexample diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs index 4a0264ea37..6b41f6d087 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs @@ -33,7 +33,6 @@ import qualified Data.Map.Strict as Map import Data.Maybe.Strict (StrictMaybe (SJust, SNothing)) import Data.Sequence.NonEmpty (NESeq) import qualified Data.Set as Set -import qualified Data.Set.NonEmpty as NESet import qualified Data.Vector.Strict as V import LeiosDemoDb ( LeiosDbWriter (..) @@ -208,6 +207,18 @@ test_forgedEbOfferIgnored = data Scenario pid = Scenario { scEnv :: !LeiosFetchStaticEnv , scOfferings :: !(Map.Map (PeerId pid) (Map.Map LeiosPoint WhetherTxsClosureOffered)) + , scOfferedSizes :: !(Map.Map LeiosPoint BytesSize) + -- ^ The size each point is offered at. + -- + -- NOTE a peculiarity of this harness: every peer offering a point offers it + -- at the same size, the one 'withMissingBody' named. The protocol does not + -- work that way --- each offer carries its own size, and 'assignBody' asks + -- for whatever the peer it is asking claimed --- so no scenario here can have + -- two peers disagree about a size. Nothing these tests cover turns on that. + -- + -- It is a field of its own because the size is the offering peer's claim + -- rather than anything the outstanding state holds, so the fixture must + -- supply it. , scOutstanding :: !(LeiosOutstanding pid) } @@ -216,26 +227,25 @@ empty = Scenario { scEnv = demoLeiosFetchStaticEnv , scOfferings = Map.empty + , scOfferedSizes = Map.empty , scOutstanding = emptyLeiosOutstanding (mkStdGen 0) (SlotNo 0) } -- | Outstanding-work combinators ----------------------------------------- + +-- | The body of this point is still to fetch, and every peer that offers it +-- offers it at this size. withMissingBody :: LeiosPoint -> BytesSize -> Scenario pid -> Scenario pid -withMissingBody p@(MkLeiosPoint slot ebHash) size = - onOutstanding $ \o -> - -- Seed everything the announce path would: the missing-body point and its - -- reverse index, (via 'recordMaxAnnouncementSlot') the 'ebState' NoBody - -- entry that the fetch loop now drives bodies off of, and the election that - -- is fetching it, without which the loop asks no one for it. Only a - -- certificate overrules an election that is already fetching something, - -- so this seeds it the way an announcement would. - focusElectionIfUnfocused (MkElId slot fixtureIssuer) ebHash $ - recordMaxAnnouncementSlot ebHash slot SNothing $ - o - { missingEbBodies = Map.insert p size (missingEbBodies o) - , reverseSlotIndexByEbHash = - Map.insertWith NESet.union ebHash (NESet.singleton slot) (reverseSlotIndexByEbHash o) - } +withMissingBody p@(MkLeiosPoint slot ebHash) size sc = + onOutstanding seed sc{scOfferedSizes = Map.insert p size (scOfferedSizes sc)} + where + -- Seed what the announce path would: the 'ebState' NoBody entry the fetch + -- loop drives bodies off of, and the election that is fetching it, without + -- which the loop asks no one for it. Only a certificate overrules an election + -- already fetching something, so this seeds it the way an announcement would. + seed = + focusElectionIfUnfocused (MkElId slot fixtureIssuer) ebHash + . recordMaxAnnouncementSlot ebHash slot SNothing -- | The one pool a scenario here pretends announced everything, since these -- have no headers to take an issuer from. An endorser block's election is @@ -321,18 +331,19 @@ runIteration sc = leiosFetchLogicIteration sc.scEnv (Just minBound) - (Map.map (Map.mapWithKey (resolveOfferSize sc.scOutstanding)) sc.scOfferings) + (Map.map (Map.mapWithKey (resolveOfferSize sc.scOfferedSizes)) sc.scOfferings) Map.empty sc.scOutstanding in reqs --- | Give a fixture's offer the size the scenario is pursuing for that point, --- which is what 'assignBody' matches a peer's offer against. A peer offering a --- point with no listed body offers no size, which is the closure-only case. +-- | Give a fixture's offer the size 'withMissingBody' said peers offer that +-- point at, which is the size 'assignBody' then requests. A point no +-- 'withMissingBody' named is offered with no size, which is the closure-only +-- case. resolveOfferSize :: - LeiosOutstanding pid -> LeiosPoint -> WhetherTxsClosureOffered -> PeerOffer -resolveOfferSize o p closure = - MkPeerOffer (maybe SNothing SJust (Map.lookup p (missingEbBodies o))) closure + Map.Map LeiosPoint BytesSize -> LeiosPoint -> WhetherTxsClosureOffered -> PeerOffer +resolveOfferSize sizes p closure = + MkPeerOffer (maybe SNothing SJust (Map.lookup p sizes)) closure ------------------------------------------------------------ -- Assertions diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs index 1856745e49..a45edb590e 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs @@ -59,7 +59,6 @@ import qualified LeiosDemoDb as LeiosDb import LeiosDemoLogic ( LeiosBlockSource (..) , LeiosBlockTxsSource (..) - , bodySize , leiosFetchLogicIteration , noMempoolPull , processLeiosBlock @@ -215,14 +214,12 @@ tests = -- so every seeded EB reports as held ... all Leios.ebStateHasBody (Map.elems (Leios.ebState o)) @?= True -- ... nothing is listed for fetch (empty pools, no missing bodies) ... - Leios.missingEbBodies o @?= Map.empty - Leios.reverseSlotIndexByEbHash o @?= Map.empty -- ... no requests are outstanding (there are no connections at start-up) ... Leios.requestedBytesSizePerPeer o @?= Map.empty Leios.requestedEbPeers o @?= Map.empty Leios.requestedJobsPerPeer o @?= Map.empty -- ... and the pruning watermark is seeded from the immutable tip - Leios.acquiredEbBodiesPrunedSlot o @?= immTipSlot + Leios.outstandingPrunedSlot o @?= immTipSlot , testCase "start-up seeding: a peer's offer of a seeded EB is not re-fetched" $ do let ebA = [0, 1] :: TestEb ebB = [2, 3] :: TestEb @@ -317,86 +314,57 @@ tests = "least-requested bucket wins: job 0 (multiplicity 1) is not drawn" (not (0 `Set.member` drawnFromPool1)) assertBool "still shuffles among the least-requested jobs" (Set.size drawnFromPool1 > 1) - , testCase "prune drops below-tip missing-body points and keeps the reverse index in sync" $ do - let hA = hashLeiosEb (ebOf [0, 1]) -- to be listed at slots 3 and 10 - hB = hashLeiosEb (ebOf [2, 3]) -- to be listed at slot 3 only - pointAt slot h = MkLeiosPoint (SlotNo slot) h - o0 :: LeiosOutstanding Int - o0 = - (emptyLeiosOutstanding (mkStdGen 0) (SlotNo 0)) - { Leios.missingEbBodies = - Map.fromList [(pointAt 3 hA, 10), (pointAt 10 hA, 10), (pointAt 3 hB, 20)] - , Leios.reverseSlotIndexByEbHash = - Map.fromList - [ (hA, NESet.insert (SlotNo 3) (NESet.singleton (SlotNo 10))) - , (hB, NESet.singleton (SlotNo 3)) - ] - } - o = snd (Leios.pruneOutstandingToImmTip (SlotNo 5) o0) - -- hA's slot-3 point is dropped, its slot-10 point kept - Map.lookup (pointAt 3 hA) (Leios.missingEbBodies o) @?= Nothing - Map.lookup (pointAt 10 hA) (Leios.missingEbBodies o) @?= Just 10 - -- hB was listed only at slot 3, so it drops out entirely - Map.lookup (pointAt 3 hB) (Leios.missingEbBodies o) @?= Nothing - Map.size (Leios.missingEbBodies o) @?= 1 - -- the reverse index stays the exact inverse: hA at slot 10 only, hB gone - Map.lookup hA (Leios.reverseSlotIndexByEbHash o) @?= Just (NESet.singleton (SlotNo 10)) - Map.lookup hB (Leios.reverseSlotIndexByEbHash o) @?= Nothing - , testCase "a certificate relists the body at its own size" $ do + , testCase "only the announcement that takes an election's focus is tracked" $ do + -- The announcement path contributes at most one 'ebState' entry per + -- election: the one that takes the election's focus. A second + -- announcement for an already-focused election is an equivocation, + -- and tracking its endorser block too would let a pool double what + -- its won slots cost us. Should that one turn out to be the certified + -- one, 'trackCertifiedEb' gives it an entry then --- which this says + -- nothing about, and is the other way an election can reach + -- 'ebState'. + let hFocused = hashLeiosEb (ebOf [0, 1]) + hRival = hashLeiosEb (ebOf [2, 3]) + elId = MkElId (SlotNo 5) (SBS.pack [1]) + announcing h = Leios.MkAnnouncementFields elId h 99 + o = runSimOrThrow $ do + outstandingVar <- + newMVar (emptyLeiosOutstanding (mkStdGen 0) (SlotNo 0) :: LeiosOutstanding Int) + readyVar <- newEmptyMVar + recordAnnouncedEb (outstandingVar, readyVar) SNothing (announcing hFocused) + recordAnnouncedEb (outstandingVar, readyVar) SNothing (announcing hRival) + readMVar outstandingVar + Map.member hFocused (Leios.ebState o) @?= True + Map.member hRival (Leios.ebState o) @?= False + Map.lookup elId (Leios.elFocus o) @?= Just hFocused + , testCase "a certificate tracks an endorser block no announcement did" $ do + -- A certificate can reach us for an announcement we never processed: + -- if the announcing block has been on our selection since initial + -- chain selection, ChainSync intersects at or after it, so its header + -- never rolls forward and nothing announces it to us. Then only the + -- certificate gives that endorser block an 'ebState' entry, without + -- which the decision logic skips every offer of it. let eb = ebOf [0, 1] h = hashLeiosEb eb - trueSize = encodeLeiosEbSize eb - lie = trueSize + 1 - elLie = MkElId (SlotNo 5) (SBS.pack [1]) - elTrue = MkElId (SlotNo 7) (SBS.pack [2]) - -- What 'recordAnnouncedEb' does for the first announcement of an - -- election: take the focus and list the body at the announced size. - announced elId size o = - Leios.focusElectionIfUnfocused elId h $ - (Leios.recordMaxAnnouncementSlot h slot SNothing o) - { Leios.missingEbBodies = - Map.insert (MkLeiosPoint slot h) size (Leios.missingEbBodies o) - , Leios.reverseSlotIndexByEbHash = - Map.insertWith - NESet.union - h - (NESet.singleton slot) - (Leios.reverseSlotIndexByEbHash o) - } - where - MkElId slot _poolId = elId - o0 = - announced elLie lie $ + elCertified = MkElId (SlotNo 7) (SBS.pack [2]) + o = + Leios.focusCertifiedEb (Leios.MkAnnouncementFields elCertified h 99) $ (emptyLeiosOutstanding (mkStdGen 0) (SlotNo 0) :: LeiosOutstanding Int) - o1 = Leios.focusCertifiedEb (Leios.MkAnnouncementFields elTrue h trueSize) o0 - -- The lying announcement got there first, so it is the size we were - -- pursuing -- and no honest peer ever offers it. - Map.toList (Leios.missingEbBodies o0) @?= [(MkLeiosPoint (SlotNo 5) h, lie)] - bodySize o0 h @?= Just lie - -- The certificate corrects the size at every point listing the hash, - -- the slot-5 one included. That is the point 'bodySize' reads the - -- size back through, and what it returns is what 'assignBody' - -- matches a peer's offer against. - Map.toList (Leios.missingEbBodies o1) - @?= [ (MkLeiosPoint (SlotNo 5) h, trueSize) - , (MkLeiosPoint (SlotNo 7) h, trueSize) - ] - Map.lookup h (Leios.reverseSlotIndexByEbHash o1) - @?= Just (NESet.insert (SlotNo 5) (NESet.singleton (SlotNo 7))) - bodySize o1 h @?= Just trueSize - , testCase "a certificate does not relist a body we already hold" $ do + Map.lookup h (Leios.ebState o) + @?= Just (Leios.MkEbState (SlotNo 7) SNothing Leios.NoBody) + Map.lookup elCertified (Leios.elFocus o) @?= Just h + , testCase "a certificate leaves a body we already hold held" $ do let eb = ebOf [0, 1] h = hashLeiosEb eb - elTrue = MkElId (SlotNo 7) (SBS.pack [2]) + elCertified = MkElId (SlotNo 7) (SBS.pack [2]) o = - Leios.focusCertifiedEb (Leios.MkAnnouncementFields elTrue h (encodeLeiosEbSize eb)) $ - Leios.insertAcquiredEbBody h (Jobs.mkLeiosJobPool 1000 10 mempty) $ + Leios.focusCertifiedEb (Leios.MkAnnouncementFields elCertified h 99) $ + Leios.acquireEbBody h (Jobs.mkLeiosJobPool 1000 10 mempty) $ -- the announcement that got us the body in the first place; - -- without it 'insertAcquiredEbBody' has no entry to update + -- without it 'acquireEbBody' has no entry to update Leios.recordMaxAnnouncementSlot h (SlotNo 7) SNothing $ (emptyLeiosOutstanding (mkStdGen 0) (SlotNo 0) :: LeiosOutstanding Int) - Leios.missingEbBodies o @?= Map.empty - Leios.reverseSlotIndexByEbHash o @?= Map.empty + maybe False Leios.ebStateHasBody (Map.lookup h (Leios.ebState o)) @?= True , testProperty "outstanding-state invariants hold across arbitrary sequences" prop_invariants @@ -404,7 +372,7 @@ tests = "the fetch logic never requests an already-held EB body" prop_neverRefetchesHeldBody , testProperty - "a concurrent offer and body arrival never leave a held EB body listed (IOSimPOR)" + "a concurrent offer, announcement and body arrival keep the reverse index in sync (IOSimPOR)" prop_neverRefetchesHeldBodyConcurrent ] @@ -647,23 +615,20 @@ applyCmd conn txCache kv peerVars peerId = \case -- offering both its body and its closure -- an all-offering peer, so the fetch -- logic can act on whichever of the two each EB still needs. -- --- The two are independent offers, so the body offer is stated explicitly, by --- the size the outstanding state is pursuing. +-- Offering unconditionally is the point: declining to fetch must be the fetch +-- logic's own doing, not something this fixture arranged by withholding the +-- offer. One byte for the same reason: the size a peer claims is what its +-- request spends against the per-peer byte budget, so the smallest claim is +-- the one least likely to end an iteration before it has assigned everything +-- it would. referencedOffers :: LeiosOutstanding Int -> Map.Map Leios.LeiosPoint Leios.PeerOffer referencedOffers o = Map.fromList [ ( Leios.MkLeiosPoint (Leios.ebStateMaxSlot s) h - , Leios.MkPeerOffer (sizeOf h) Leios.TxsClosureOffered + , Leios.MkPeerOffer (SJust 1) Leios.TxsClosureOffered ) | (h, s) <- Map.toList (Leios.ebState o) ] - where - -- The size this outstanding state is pursuing for that endorser block, which - -- is what 'assignBody' matches a peer's offer against. - sizeOf h = - case [sz | (Leios.MkLeiosPoint _ h', sz) <- Map.toList (Leios.missingEbBodies o), h' == h] of - [] -> SNothing - sz : _ -> SJust sz -- | Force the requests to a scalar, so any @impossible!@ hidden in a thunk -- surfaces when the caller 'evaluate's it. Touches each tx request's covered @@ -704,15 +669,19 @@ requestedOffsets m = -- The invariant ------------------------------------------------------------ --- | Two invariants: +-- | Three invariants: -- -- * 'ebsPerMaxAnnouncementSlot' must be the exact inverse of the greatest-slot -- field of 'ebState' (the reverse index 'pruneOutstandingToImmTip' prunes by). -- +-- * 'numMissingBodies' must be the count 'ebState' would give if we walked it +-- (which nothing does at run time, which is why this checks it). +-- -- * No absorbing 'BodyAcquired': see below. -- -- (The old missing-tx \/ reverse-index invariant is gone with the EbTxs rewrite.) --- | @dbBodies@: the EBs the LeiosDb actually holds a body for. Passed in because +-- +-- @dbBodies@: the EBs the LeiosDb actually holds a body for. Passed in because -- the central invariant is a claim about the database, not about the state alone. checkInvariant :: Set.Set EbHash -> LeiosOutstanding Int -> Either String () checkInvariant dbBodies o @@ -721,6 +690,11 @@ checkInvariant dbBodies o ( "ebsPerMaxAnnouncementSlot desynced from ebState: " <> show (Leios.ebsPerMaxAnnouncementSlot o, inverseOfMax) ) + | Leios.numMissingBodies o /= countedMissing = + Left + ( "numMissingBodies desynced from ebState: " + <> show (Leios.numMissingBodies o, countedMissing) + ) -- 'BodyAcquired' asserts the LeiosDb holds the body, and the fetch logic -- retires a peer's offer for good on the strength of it. So the state may only -- ever be reached through a durable write ('acquireEbBody'): anything else @@ -741,16 +715,15 @@ checkInvariant dbBodies o [ (Leios.ebStateMaxSlot s, NESet.singleton h) | (h, s) <- Map.toList (Leios.ebState o) ] + countedMissing = sum (map Leios.wantsBody (Map.elems (Leios.ebState o))) ------------------------------------------------------------ -- Curated repros ------------------------------------------------------------ -- | A peer offers an EB body; we forge the same EB before the offered body --- arrives. Forging must purge the offered body from 'missingEbBodies' (its --- 'ebState' now reads 'BodyAcquired'), so the fetch logic never re-requests a body --- we already hold. Pre-fix the forge recorded the body as acquired without purging, --- so the 'Decide' re-fetched it. +-- arrives. Forging must leave that endorser block's 'ebState' reading +-- 'BodyAcquired', so the fetch logic never re-requests a body we already hold. reproForgeAfterOffer :: [Cmd] reproForgeAfterOffer = [ Offer [0, 1] 10 @@ -889,17 +862,14 @@ prop_neverRefetchesHeldBody = -- explore every interleaving. -- -- An 'EbHash' is not 1-to-1 with slots, so this is exactly the shape that armed --- the storm: whichever listing wins is recorded at its own slot, and the arrival --- (at yet another slot) must clear it /by hash/, not by point. In every --- interleaving the state invariant "a held EB body is never still listed for --- fetching" must hold, which is what stops a later decision from re-requesting --- it. +-- the storm the fetch bookkeeping used to be vulnerable to: three handlers +-- writing about one endorser block at three slots at once. What they write now +-- is 'ebState', keyed by hash, and 'ebsPerMaxAnnouncementSlot', its reverse +-- index --- so what is left to violate is 'checkInvariant'. -- --- With the shipped fix each handler's "held?"/"listed?" test and its state update --- are one 'outstandingVar' critical section, and acquisition purges every point --- sharing the hash via 'reverseSlotIndexByEbHash', so no interleaving can violate --- this; the test guards against regressing either half (moving a check back out --- of the lock, or reverting to a delete-by-point that misses the other slots). +-- Each handler's read and its state update are one 'outstandingVar' critical +-- section, so no interleaving can desync the two; this guards against moving a +-- check back out of the lock. prop_neverRefetchesHeldBodyConcurrent :: Property prop_neverRefetchesHeldBodyConcurrent = exploreSimTrace id (exploreRaces *> raceSameHashMultiSlot) $ \_ tr -> @@ -946,14 +916,19 @@ raceSameHashMultiSlot = do ) ) outstanding <- readMVar outstandingVar - let held = Map.keysSet (Map.filter Leios.ebStateHasBody (Leios.ebState outstanding)) - listed = - Set.fromList (map (.pointEbHash) (Map.keys (Leios.missingEbBodies outstanding))) - heldAndListed = Set.toList (Set.intersection held listed) - pure $ - counterexample - ("held EB body still listed for fetching: " <> show heldAndListed) - (null heldAndListed) + -- Which bodies the LeiosDb really holds, for the no-absorbing- + -- 'BodyAcquired' half of the invariant. + dbBodies <- + LeiosDb.withReader dbHandle $ \rdr -> + fmap (Set.fromList . map fst . filter (not . null . snd)) $ + mapM (\h -> (,) h <$> LeiosDb.lookupEbBody rdr h) $ + Map.keys (Leios.ebState outstanding) + -- Three handlers wrote about one endorser block at three slots at once; the + -- reverse index must still be the exact inverse of 'ebState', whichever + -- order they ran in. + pure $ case checkInvariant dbBodies outstanding of + Right () -> counterexample "" True + Left why -> counterexample why False -- | An announcement of this endorser block, in an election of its own. -- From ac289664dbdd3152b0821cc3953fe06cff7fd80b Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 2 Oct 2026 17:29:12 -0400 Subject: [PATCH 36/60] LeiosFetch: recent changelog --- ...0000_nick.frisby_leios_offer_validation.md | 2 +- ..._nick.frisby_leios_offered_size_decides.md | 48 +++++++++++++++++++ 2 files changed, 49 insertions(+), 1 deletion(-) create mode 100644 changelog.d/20261002_171233_nick.frisby_leios_offered_size_decides.md diff --git a/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md b/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md index 16eeca1c06..96f6acb025 100644 --- a/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md +++ b/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md @@ -11,7 +11,7 @@ For top level release notes, leave all the headers commented out. - `recordEbBodyOffer` no longer lists a body as one to fetch, and takes no `LeiosOutstanding`. It gained two siblings: `recordEbClosureOffer`, and `recordCertRbOffer` for a CertRB roll-forward, which offers both the body and the closure. None of the three lists any EB bodies to fetch (since that's only justified by an announcement, not an offer). -- `ValidClaims`' `certifiedEbs` maps each election to the whole `AnnouncementFields` rather than just its `EbHash`. That is what lets `focusCertifiedEb` --- which moves a verified certificate's election onto the EB it names --- also list that body to fetch, via the new `relistCertifiedEbBody`. +- `ValidClaims`' `certifiedEbs` maps each election to the whole `AnnouncementFields` rather than just its `EbHash`. That is what lets `focusCertifiedEb` --- which moves a verified certificate's election onto the EB it names --- also start tracking that endorser block, via the new `trackCertifiedEb`. - `LeiosNotifyPeerState` holds what one LeiosNotify client remembers of its peer --- its latest-pruned slot, its announcements and its offers. `checkLeiosBlockOffer` and `checkLeiosClosureOffer` accept or reject an offer against it, reporting `ExnLeiosInvalidOffer`, and `pruneLeiosNotifyPeerStateToImmTip` prunes it, replacing `prunePeerStateToImmTip`. diff --git a/changelog.d/20261002_171233_nick.frisby_leios_offered_size_decides.md b/changelog.d/20261002_171233_nick.frisby_leios_offered_size_decides.md new file mode 100644 index 0000000000..1bc49393c2 --- /dev/null +++ b/changelog.d/20261002_171233_nick.frisby_leios_offered_size_decides.md @@ -0,0 +1,48 @@ + + +### Non-Breaking + +- An EB announcement's stated size no longer decides anything about fetching. + `assignBody` requests a body at the size the offering peer named. Previously, + it passed over any peer whose offer did not match the first size some + announcement gave for that hash. + + That gate was a too-reliable way to mount threat T22, needing no `L_hdr` + violation or any honest issuer; just being upstream of enough committee + members and influential relays. An adversary winning more than one election in + a window can announce its own endorser block at its true size to just the + committee members it needs to certify it, and name that same hash at a wrong + size in its other, contemporary elections. Merely fixing that for the Recovery + Path wouldn't be enough, since then the EB diffusion would still be idle + during `L_diff`. + +- Only the announcement that takes an election's focus now gives its endorser + block an `ebState` entry. A second announcement for an already-focused + election is an equivocation, and tracking its endorser block too let a pool + double what its won slots cost us. If that one turns out to be the certified + one, `trackCertifiedEb` gives it an entry then. + +- On arrival, a body's hash alone decides whether it is accepted. A peer that + sent a different number of bytes than it offered still loses the connection, + now via `ExnLeiosBlockWrongSize` and only after the body has been ingested, so + it cannot deny us an endorser block by misrepresenting its own offer. The + LeiosDb records the size the body actually is rather than the size it was + offered at. + +- A `MsgLeiosBlockOffer` claiming zero bytes, or more than `maxLeiosEbBytesSize` + (the bound the guardrails script imposes), is rejected as + `ExnLeiosBlockOfferTooBig`, which disconnects the peer. The offered size is + now what gets requested, so this is what bounds it. + +- `LeiosOutstanding` lost `missingEbBodies` and its `reverseSlotIndexByEbHash` + reverse index. With no size in it, nothing read that structure to decide + anything: an offer is pursued when some election has the endorser block in + focus and `ebState` says we do not hold it, and an offer is only accepted from + a peer that announced that point. It gained `numMissingBodies`, the + body-fetch backlog maintained as `ebState` changes, which is what the + `missingBodies` trace now reports. From b7107888dd3f8d35a102ade7abcf63fdbc556bf3 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 2 Oct 2026 20:37:15 -0400 Subject: [PATCH 37/60] Leios: move non-dep Leios checks out of updateChainDepState, for LeiosNotify handler --- .../Consensus/Shelley/Ledger/Leios.hs | 4 ++ .../Ouroboros/Consensus/Protocol/Praos.hs | 72 +++++++++++++------ 2 files changed, 55 insertions(+), 21 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs index c9b72b436d..e79d82f535 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs @@ -249,6 +249,10 @@ instance -- rejection. See 'LeiosDemoLogic.Announcements.Validate.validateAnnouncementHeader' -- for why accepting-but-not-propagating a 'StaleOCIN' announcement is safe. validateAnnouncementChainDepState cfg hv _slot tcs = do + -- The Leios checks that do not need the header's predecessor. The gap + -- between a CertRB and the announcement it certifies does need it, so it + -- is left to 'updateChainDepState'; an announcement is not a CertRB. + PP.leiosContextFreeHeaderChecks (tickedPraosStateLedgerView tcs) hv -- validate the claimed election PP.doValidateVRFSignature (praosStateEpochNonce cs) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index e978d6b1e0..28c702cac4 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -35,6 +35,7 @@ module Ouroboros.Consensus.Protocol.Praos , PraosWithLeios , Ticked (..) , forgePraosFields + , leiosContextFreeHeaderChecks , praosCheckCanForge -- * For testing purposes @@ -718,7 +719,53 @@ doValidateVRFSignature eta0 pd f b = do vrfLeaderVal = vrfLeaderValue (Proxy @c) vrfCert slot = Views.hvSlotNo b --- | The Leios-specific checks on a header, called by 'updateChainDepState' +-- | The Leios header checks that read only the header and the ledger view. +-- +-- Sound out of context, which is what lets both header paths run them: +-- 'updateChainDepState', from the header's own predecessor, and +-- 'validateAnnouncementChainDepState', from the immutable tip. The bound they +-- check is forecast for the header's own slot +-- ('Dijkstra.maxEndorserBlockReferencesSizeForecastL'), so both paths read the +-- same value: a forecast either yields the view that slot will have or refuses +-- as 'OutsideHorizon'. The staleness the announcement path does have to live +-- with is in the chain-dep state --- the opcert counters --- and none of these +-- checks reads it. +leiosContextFreeHeaderChecks :: + forall pext c. + KnownPraosExtension pext => + Views.BasePraosLedgerView pext -> + Views.BaseHeaderView pext c -> + Except (BasePraosValidationErr pext c) () +leiosContextFreeHeaderChecks lv b = + case praosExtensionHasLeios (Proxy @pext) of + PextDoesNotHaveLeiosDecided -> pure () + PextHasLeiosDecided -> do + let SJustLeios (_containsCert, mbAnn) = Views.hvLeios b + SJustLeios llv = Views.plvLeios lv + case mbAnn of + SNothing -> pure () + SJust ann -> do + let announced = ebAnnouncementSize ann + -- TEMPORARY KLUDGE -- DO NOT MERGE. + -- + -- The deployed testnet has historical announcements above the + -- 'maxEndorserBlockReferencesSize' its own Dijkstra genesis sets + -- (e.g. 102429 against 100000 at slot 709083), so enforcing the + -- ledger's value stalls the sync there. Exception granted here + -- and here only: every other use of the limit, and the genesis + -- file itself, are untouched. + maximum' = max 200000 (Views.llvMaxEbBodySize llv) + when (announced > maximum') $ + throwError $ + LeiosHeaderErr mkHasLeiosProof $ + Leios.LeiosEbTooBig announced maximum' + +-- | The Leios-specific checks on a header, called by 'updateChainDepState'. +-- +-- 'leiosContextFreeHeaderChecks' plus the one check that needs the header's +-- immediate predecessor: a CertRB may not certify an announcement younger than +-- the certification gap, and only the predecessor's state says which +-- announcement that is. leiosHeaderChecks :: forall pext c. KnownPraosExtension pext => @@ -728,11 +775,12 @@ leiosHeaderChecks :: SlotNo -> BasePraosState pext -> Except (BasePraosValidationErr pext c) () -leiosHeaderChecks PraosConfig{praosEpochInfo} lv b slot cs = +leiosHeaderChecks PraosConfig{praosEpochInfo} lv b slot cs = do + leiosContextFreeHeaderChecks lv b case praosExtensionHasLeios (Proxy @pext) of PextDoesNotHaveLeiosDecided -> pure () PextHasLeiosDecided -> do - let SJustLeios (containsCert, mbAnn) = Views.hvLeios b + let SJustLeios (containsCert, _mbAnn) = Views.hvLeios b SJustLeios llv = Views.plvLeios lv SJustLeios announcedByPredecessor = praosStateLeiosAnnouncement cs @@ -761,24 +809,6 @@ leiosHeaderChecks PraosConfig{praosEpochInfo} lv b slot cs = throwError $ LeiosHeaderErr mkHasLeiosProof Leios.LeiosCertWithoutAnnouncement - case mbAnn of - SNothing -> pure () - SJust ann -> do - let announced = ebAnnouncementSize ann - -- TEMPORARY KLUDGE -- DO NOT MERGE. - -- - -- The deployed testnet has historical announcements above the - -- 'maxEndorserBlockReferencesSize' its own Dijkstra genesis sets - -- (e.g. 102429 against 100000 at slot 709083), so enforcing the - -- ledger's value stalls the sync there. Exception granted here - -- and here only: every other use of the limit, and the genesis - -- file itself, are untouched. - maximum' = max 200000 (Views.llvMaxEbBodySize llv) - when (announced > maximum') $ - throwError $ - LeiosHeaderErr mkHasLeiosProof $ - Leios.LeiosEbTooBig announced maximum' - validateKESSignature :: (KnownPraosExtension pext, PraosCrypto c) => ConsensusConfig (BasePraos pext c) -> From a827d7a1188e39c399f3a2fc2e59b1a85876fdf5 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Mon, 5 Oct 2026 09:10:18 -0400 Subject: [PATCH 38/60] Leios: update some stale comments --- .../src/ouroboros-consensus/LeiosDemoLogic.hs | 8 +- .../src/ouroboros-consensus/LeiosDemoTypes.hs | 79 ++++++++++--------- 2 files changed, 48 insertions(+), 39 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs index b6068410c7..7f50bd6ddc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs @@ -1033,9 +1033,11 @@ processLeiosBlock ktracer tracer (outstandingVar, readyVar) txCache writer syste -- fetch job set above) when shouldPersist $ traceException tracer TraceLeiosPeerDbException $ do - -- FIXME: once EB announcements are wired in the point MUST already - -- be present (announcement handling inserts it); until then insert - -- it idempotently as a stop-gap and trace a warning. + -- FIXME the announcement path does not write the point: 'writeEbPoint' + -- has no caller but this one, so the arriving body is still what first + -- records the point. Were an announcement to record it, this insert + -- would be redundant and the trace below would mean something is wrong; + -- today it fires for every body, so it means nothing. traceWith ktracer $ TraceLeiosBlockPointMissing point -- Enqueue the write first, then claim the body. 'writeEbBody' only parks -- on a free writer-queue slot (bounded backpressure), so a cancellation diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs index a35130c791..0e6784de8c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs @@ -424,25 +424,27 @@ instance Monoid WhetherTxsClosureOffered where -- first, or alone. A CertRB roll-forward makes both at once. -- -- The body offer carries a size and the closure offer does not, and that --- asymmetry is not an oversight. A body request is per /candidate/, and a --- point can have more than one --- two announcements can name one endorser --- block at different sizes, and only one of them is the truth --- so the size --- is what says which candidate this peer can serve. Closure jobs are per --- endorser block: 'assignClosure' only ever runs once we hold the body, by --- which point the true size is known and the losing candidates are gone. +-- asymmetry is not an oversight. We hold nothing to size a body request by, so +-- the peer's claim is both what the request asks for and what it spends +-- against that peer's byte budget. Closure jobs carry their own byte counts, +-- taken from the body we already hold by the time 'assignClosure' runs, so +-- there is nothing there for a peer to claim. data PeerOffer = MkPeerOffer { poOfferedBody :: !(StrictMaybe BytesSize) -- ^ The size this peer offered the body at, if it has offered the body. -- - -- Every offer of one endorser block from one peer names the same size, or - -- that peer is lying: an offer says it holds the body, it can only have - -- acquired that body at the size announced --- 'processLeiosBlock' refuses - -- one of any other size --- and so it knows the one true size. Which is why - -- nothing here arbitrates between two of them. + -- The peer's own claim, and the only size that decides anything: no + -- announcement gets a say (see 'LeiosDemoLogic.assignBody'), and what the + -- endorser block really weighs is settled by hashing the bytes that arrive. + -- + -- Offering one point twice costs the peer its connection + -- ('LeiosDemoLogic.ExnLeiosRepeatedOffer'), but one hash at two /points/ does + -- not: those are separate entries, each needing its own announcement, and + -- nothing here arbitrates between the sizes they name. -- -- TODO disconnect a peer that ever offers one 'EbHash' at two sizes, -- whichever messages the two arrived on. That is proof it is lying, and - -- today we merely keep one of the two and carry on. + -- today we keep both and carry on. , poClosure :: !WhetherTxsClosureOffered } deriving (Eq, Show) @@ -535,18 +537,23 @@ newLeiosPeerVars whetherBigLedgerPeer = do data LeiosOutstanding pid = MkLeiosOutstanding { -- EB-level tracking ebState :: !(Map EbHash EbState) - -- ^ Per-EB state for every EB we have seen announced (or offered) + -- ^ Per-EB state for every EB this node is tracking. Three things add an + -- entry: the announcement that takes an election's focus, a verified + -- certificate ('trackCertifiedEb'), and the start-up seeding + -- ('initializeLeiosOutstanding'), which restores what the LeiosDb already + -- holds. An offer never does, and is only ever acted on for an endorser + -- block already here. -- - -- TODO once offers are only valid if preceded by an announcement, then - -- 'ebState' and the @selfPeer@ field of - -- 'LeiosDemoLogic.Announcements.CentralState' are partially redundant + -- TODO 'ebState' and the @selfPeer@ field of + -- 'LeiosDemoLogic.Announcements.CentralState' is at least partially redundant + -- now that a peer's offers must be preceded by matching announcements , ebsPerMaxAnnouncementSlot :: !(Map SlotNo (NESet EbHash)) -- ^ Slot-keyed reverse index of 'ebStateMaxSlot' on 'ebState' -- -- Used to accelerate pruning. -- - -- TODO will also be redundant with by 'CentralState.selfPeer.live' once - -- offers are no longer trusted. + -- TODO might also be redundant with 'CentralState.selfPeer.live', now that a + -- peer's offers must be preceded by matching announcements , elFocus :: !(Map ElId EbHash) -- ^ The endorser block each election is fetching: the first announcement we -- processed for that election, until a certificate names one, which wins. @@ -621,11 +628,16 @@ emptyLeiosOutstanding prng prunedSlot = -- | Per-EB state tracked in 'ebState' data EbState - = -- | The greatest slot at which the EB has been announced (TODO or, for now, - -- offered); the wall-clock onset of its /oldest/ announcement slot (kept as the - -- minimum, so the body\/closure arrival handlers can report how old the EB was - -- when we first held it; 'SNothing' for an unheralded offer-only or self-forged - -- EB); and the current progress of fetching it. + = -- | The greatest slot at which the EB has been announced, the wall-clock + -- onset of its earliest announcement slot, and the current progress of + -- fetching it. + -- + -- 'LeiosDemoLogic.ebPointAge' subtracts that onset from the arrival time, + -- so the acquisition traces say how long after this EB was first announced + -- we got it. It is 'SNothing' when nothing supplied an onset, as for a + -- verified certificate or the start-up seeding. See + -- 'recordMaxAnnouncementSlot' for why the slot is the greatest of them and + -- the onset the earliest. MkEbState !SlotNo !(StrictMaybe RelativeTime) !EbFetchState deriving (Eq, Show) @@ -849,8 +861,9 @@ markBodyImminent ebHash slot = BodyImminent -> Nothing BodyAcquired{} -> Just $ MkEbState oldSlot onset (BodyAcquired Jobs.emptyLeiosJobPool) --- | Record that the EB with this hash is referenced (announced or offered) at this --- slot, along with that slot's wall-clock onset if known. +-- | Record that the EB with this hash is referenced --- announced, or named by +-- a verified certificate --- at this slot, along with that slot's wall-clock +-- onset if known. -- -- The same EB (hash) can be referenced by several points; we keep the -- /greatest/ such slot, so the EB's state isn't pruned prematurely. The onset, @@ -990,9 +1003,11 @@ focusCertifiedEb fields = -- -- An 'ebState' entry is what makes a body fetchable at all: the decision logic -- skips any offer of an endorser block it has no entry for. The announcement --- that took the election's focus made one, but this endorser block's --- announcement may have lost that race, or may never have reached us, so this --- is where a certificate makes one of its own. +-- this certificate names may have no entry, in two ways. Its announcing block +-- may have been on our selection since start-up, so its header never rolled +-- forward and nothing announced it to us. Or it may have been a second +-- announcement for an election already focused elsewhere, which +-- 'LeiosDemoLogic.recordAnnouncedEb' deliberately does not track. -- -- Already holding the body is not a special case: 'recordMaxAnnouncementSlot' -- leaves the fetch state alone, so nothing is re-fetched. @@ -2780,14 +2795,6 @@ leiosExtValidationErrorForHuman = \case -- * Protocol parameters --- --- The node-to-node limits below are constants, but no longer a policy of their --- own: they restate the LeiosFetch codec's message limit, so the buffers sized --- from them hold anything a peer can deliver. Governance raising --- @maxEndorserBlockReferencesSize@ past the message limit yields a capped EB --- rather than an undiffusable one ('leiosEndorserBlockMeasure') -- silently, --- today; a trace when that cap bites would be worth adding. - -- | The most transactions an endorser block may name. Sizes the fetch buffers -- and bounds the wire bitmaps. -- From 02a3b1f41dec9a2acd7b342a63155a1c6c7f0ba1 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Mon, 5 Oct 2026 09:18:28 -0400 Subject: [PATCH 39/60] Leios: update some stale changelog fragments --- ...0000_nick.frisby_leios_offer_validation.md | 4 +-- ...frisby_leios_announcement_header_checks.md | 26 +++++++++++++++++++ 2 files changed, 28 insertions(+), 2 deletions(-) create mode 100644 changelog.d/20261005_083500_nick.frisby_leios_announcement_header_checks.md diff --git a/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md b/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md index 96f6acb025..e52d56ebe2 100644 --- a/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md +++ b/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md @@ -9,7 +9,7 @@ For top level release notes, leave all the headers commented out. - A peer's offers are now `PeerOffer`, recording the size it offered an EB's body at (if it offered the body) and whether it offered the closure. Now that they're independent offers, `AlsoOfferedTxsClosure` is accordingly `WhetherTxsClosureOffered`, with `TxsClosureOffered` and `TxsClosureNotOffered`. -- `recordEbBodyOffer` no longer lists a body as one to fetch, and takes no `LeiosOutstanding`. It gained two siblings: `recordEbClosureOffer`, and `recordCertRbOffer` for a CertRB roll-forward, which offers both the body and the closure. None of the three lists any EB bodies to fetch (since that's only justified by an announcement, not an offer). +- `recordEbBodyOffer` takes no `LeiosOutstanding`: it writes only to the offering peer's own record. It gained two siblings: `recordEbClosureOffer`, and `recordCertRbOffer` for a CertRB roll-forward, which offers both the body and the closure. None of the three makes the node start tracking an endorser block, since only an announcement justifies that, not an offer. - `ValidClaims`' `certifiedEbs` maps each election to the whole `AnnouncementFields` rather than just its `EbHash`. That is what lets `focusCertifiedEb` --- which moves a verified certificate's election onto the EB it names --- also start tracking that endorser block, via the new `trackCertifiedEb`. @@ -27,7 +27,7 @@ For top level release notes, leave all the headers commented out. - This node likewise offers an EB to a peer only if it sent a matching announcement to that peer, since that is what it demands of its own upstream peers. The LeiosNotify server records what it has enqueued to each peer as it enqueues it, so a peer that joins after an announcement was relayed --- or whose queue had no credits when it was --- is not then offered what it was never given announcements for. -- Neither a LeiosNotify offer nor a CertRB's MsgRollForward lists anything to fetch any more. That is instead seeded when the focus of an election moves onto an EB, which happens for the first-seen announcement (via LeiosNotify, or via ChainSync of the announcing block) or for the verification of a certificate. So nothing lists an EB on the strength of a claim we have not yet verified. Offers only say which peers can serve what, so the candidates we pursue are bounded by elections and certifications rather than by peers. +- Neither a LeiosNotify offer nor a CertRB's MsgRollForward makes the node start tracking an endorser block any more. Only two things do: an election's first-seen announcement (via LeiosNotify, or via ChainSync of the announcing block), and the verification of a certificate. So nothing is tracked on the strength of a claim we have not yet verified, and what we are willing to fetch is bounded by elections and certifications rather than by what peers say. Offers only say which peers can serve what. - The announcements on the chain the node has already selected at startup are deliberately not replayed either, though those blocks never roll forward and so are never announced to it again. Between them those two listing paths still reach every EB it could come to need: a CertRB on that chain has its EB already, since it could not have been selected otherwise, and one that is not on that chain is re-fetched if some chain the node would select needs it, at which point verifying its certificate sets the focus and lists it. The only cost is that the `LeiosTxCache` has no entry for those EBs, so their txs read as absent and a later EB that shares one re-fetches it; acceptable consequence of a restart. diff --git a/changelog.d/20261005_083500_nick.frisby_leios_announcement_header_checks.md b/changelog.d/20261005_083500_nick.frisby_leios_announcement_header_checks.md new file mode 100644 index 0000000000..d3094f4717 --- /dev/null +++ b/changelog.d/20261005_083500_nick.frisby_leios_announcement_header_checks.md @@ -0,0 +1,26 @@ + + +### Non-Breaking + +- An EB announcement arriving over LeiosNotify is now checked against the + maximum endorser block body size its slot allows. It never was: that check + lives in `leiosHeaderChecks`, whose only caller is `updateChainDepState`, and + the announcement path does not go through it --- so an announcement could + claim any size at all, and only the same header arriving over ChainSync would + be rejected for it. + + `Ouroboros.Consensus.Protocol.Praos` now exports + `leiosContextFreeHeaderChecks`, the Leios header checks that read only the + header and the ledger view, and `validateAnnouncementChainDepState` runs + them. The one check left behind needs the header's immediate predecessor --- + a CertRB may not certify an announcement younger than the certification gap, + and only the predecessor's state says which announcement that is. + + Both paths read the same bound: it is forecast for the header's own slot + (`maxEndorserBlockReferencesSizeForecastL`), so a forecast either yields the + view that slot will have or refuses as `OutsideHorizon`. From fd159c5cc2b5621d00743ffa258a2738d3a714e5 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Mon, 5 Oct 2026 20:13:21 -0400 Subject: [PATCH 40/60] LeiosFetch: do not fetch closure of EB whose closure is too big --- .../Ouroboros/Consensus/Cardano/Block.hs | 12 ++ .../Consensus/Shelley/Ledger/Leios.hs | 5 + .../Ouroboros/Consensus/Network/NodeToNode.hs | 18 +- .../Ouroboros/Consensus/NodeKernel.hs | 15 ++ .../Test/Consensus/Leios/RecoveryPath.hs | 152 +++++++++++++++++ .../Test/Consensus/PeerSimulator/ChainSync.hs | 2 +- .../Consensus/Protocol/Praos/Views.hs | 12 +- .../bench/ChainSync-client-bench/Main.hs | 2 +- .../src/ouroboros-consensus/LeiosDemoLogic.hs | 156 +++++++++++++----- .../src/ouroboros-consensus/LeiosDemoTypes.hs | 39 +++-- .../MiniProtocol/ChainSync/Client.hs | 21 ++- .../Consensus/Storage/LedgerDB/Forker.hs | 15 ++ .../Test/Util/LeiosTestBlock.hs | 32 +++- .../Consensus/MiniProtocol/ChainSync/CSJ.hs | 2 +- .../MiniProtocol/ChainSync/Client.hs | 2 +- .../consensus-test/Test/LeiosDemoLogic.hs | 12 +- .../Test/LeiosDemoLogic/Invariants.hs | 105 +++++++++++- .../Test/LeiosValidClaimsChainDB.hs | 4 +- 18 files changed, 513 insertions(+), 93 deletions(-) diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs index aa7f3342bd..e00c55f1ec 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs @@ -1618,6 +1618,18 @@ instance headerElId (HardForkHeader (OneEraHeader ns)) = hcollapse $ hcmap (Proxy @ResolveLeiosBlock) (K . headerElId) ns + -- As above, but dispatching on the per-era ledger /view/ the protocol layer + -- carries rather than on a header. + getLeiosMaxEbTxsSizeFromView _ (HardForkLedgerView _transition hfState) = + hcollapse $ + hcmap + (Proxy @ResolveLeiosBlock) + (\wlv -> K (getLeiosMaxEbTxsSizeFromView (eraProxy wlv) (unwrapLedgerView wlv))) + (State.tip hfState) + where + eraProxy :: WrapLedgerView blk -> Proxy blk + eraProxy _ = Proxy + validateAnnouncementChainDepState = update @(CardanoEras c) headerContainsLeiosCert hdr = case hdr of diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs index e79d82f535..a0c7bf753b 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs @@ -70,6 +70,7 @@ import Ouroboros.Consensus.Protocol.Praos import qualified Ouroboros.Consensus.Protocol.Praos as PP import Ouroboros.Consensus.Protocol.Praos.Common (StrictMaybeLeios (..)) import Ouroboros.Consensus.Protocol.Praos.Views (plvPoolDistr) +import qualified Ouroboros.Consensus.Protocol.Praos.Views as PP import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Eras ( AllegraEra @@ -131,6 +132,10 @@ instance leiosTxBytesOfGenTx (ShelleyTx _ tx) = Just (serialize' tx) leiosTxHashOfGenTx (ShelleyTx _ tx) = Just (hashLeiosTx (MkLeiosTx (serialize' tx))) + getLeiosMaxEbTxsSizeFromView _ lv = + case PP.plvLeios lv of + SJustLeios llv -> PP.llvMaxEbTxsSize llv + resolveLeiosClosure leiosDb ebHash = do lookupTrustedEbClosure leiosDb ebHash >>= \case Nothing -> diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 2b1ba4d7a3..54ecf2bbb0 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Intended for qualified import @@ -173,7 +174,7 @@ import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Serialisation import qualified Ouroboros.Consensus.Node.Tracers as Node import Ouroboros.Consensus.NodeKernel -import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) +import Ouroboros.Consensus.Protocol.Abstract (ChainDepState, LedgerView) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Storage.LedgerDB.Forker ( ResolveLeiosBlock @@ -445,11 +446,12 @@ mkHandlers , CsClient.tracer = contramap (TraceLabelPeer peer) (Node.chainSyncClientTracer tracers) , CsClient.getDiffusionPipeliningSupport = getDiffusionPipeliningSupport - , CsClient.leiosMsgRollForwardCallback = \hdr hdrSlotTime cds -> do + , CsClient.leiosMsgRollForwardCallback = \hdr hdrSlotTime predLedgerView cds -> do Leios.checkMsgRollForwardForLeiosOffers (getLeiosOutstanding, getLeiosReady) peerVars hdr + predLedgerView cds -- Feed any EB this header announces into the central -- announcement state (relay + dedup + txCache), central-only: @@ -473,11 +475,12 @@ mkHandlers let varMax = Leios.maxAcceptedJumpSlot peerVars acceptedThrough <- TVar.Unchecked.readTVarIO varMax forM_ (headersWithPredecessorStates acceptedThrough jumpInfo) $ - \(hdr, cds) -> + \(hdr, predLedgerView, cds) -> Leios.checkMsgRollForwardForLeiosOffers (getLeiosOutstanding, getLeiosReady) peerVars hdr + predLedgerView cds atomically $ TVar.Unchecked.modifyTVar varMax $ @@ -1868,13 +1871,12 @@ headersWithPredecessorStates :: (HasHeader (Header blk), Typeable blk) => WithOrigin SlotNo -> JumpInfo blk -> - [(Header blk, ChainDepState (BlockProtocol blk))] + [(Header blk, LedgerView (BlockProtocol blk), ChainDepState (BlockProtocol blk))] headersWithPredecessorStates acceptedThrough jumpInfo = - zip + zipWith + (\hdr hsWt -> (hdr, hswtLedgerView hsWt, headerStateChainDep (hswtHeaderState hsWt))) (hwtHeader <$> AF.toOldestFirst fragment) - ( headerStateChainDep . hswtHeaderState - <$> (AS.anchor history : AS.toOldestFirst history) - ) + (AS.anchor history : AS.toOldestFirst history) where past :: AS.Anchorable (WithOrigin SlotNo) a b => diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 57a84d1cff..2939bb41b4 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -10,6 +10,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Ouroboros.Consensus.NodeKernel @@ -44,6 +45,7 @@ import qualified Control.Concurrent.Class.MonadSTM.Strict as StrictSTM import Control.DeepSeq (force) import Control.Monad import qualified Control.Monad.Class.MonadTimer.SI as SI +import Control.Monad.Except (runExcept) import Control.ResourceRegistry import Control.Tracer import Data.Bifunctor (second) @@ -86,12 +88,14 @@ import LeiosVoting (HasLeiosVoting (..), runLeiosVoting) import Ouroboros.Consensus.Block hiding (blockMatchesHeader) import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Config +import Ouroboros.Consensus.Forecast (forecastFor) import Ouroboros.Consensus.Genesis.Governor (gddWatcher) import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.SupportsPeerSelection +import Ouroboros.Consensus.Ledger.SupportsProtocol (ledgerViewForecastAt) import Ouroboros.Consensus.Mempool import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface import Ouroboros.Consensus.MiniProtocol.ChainSync.Client @@ -124,6 +128,7 @@ import Ouroboros.Consensus.Storage.ChainDB.API import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.Init as InitChainDB +import Ouroboros.Consensus.Storage.LedgerDB.Forker (getLeiosMaxEbTxsSizeFromView) import Ouroboros.Consensus.Util.AnchoredFragment ( preferAnchoredCandidate ) @@ -523,10 +528,20 @@ initNodeKernel let mbCurrentSlot = case currentSlot of CurrentSlot s -> Just s CurrentSlotUnknown -> Nothing + -- One forecast anchor for the whole pass: the immutable tip, which + -- is also what the announcement validation a LeiosNotify offer rides + -- on forecast from, so it reaches every slot such an offer names. + immLedger <- atomically $ ChainDB.getImmutableLedger chainDB + let forecast = + ledgerViewForecastAt (configLedger cfg) (ledgerState immLedger) + forecastMaxEbTxsSize slot = + getLeiosMaxEbTxsSizeFromView (Proxy @blk) + <$> runExcept (forecastFor forecast slot) let bigLedgerPeers = Map.map Leios.whetherBigLedgerPeer stillLivePeers let (!outstanding', requests, offerDrops) = Leios.leiosFetchLogicIteration Leios.demoLeiosFetchStaticEnv + forecastMaxEbTxsSize mbCurrentSlot (Map.restrictKeys offerings (Map.keysSet stillLivePeers)) bigLedgerPeers diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs index b467b2800c..c60ea64f44 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs @@ -101,6 +101,12 @@ tests = , testCase "an endorser block a later election still needs outlives the earlier point being pruned" test_laterAnnouncementOutlivesPruning + , testCase + "an endorser block referencing more tx bytes than the slot allows costs its server the connection" + test_oversizedClosureIsRejected + , testCase + "an endorser block referencing exactly what the slot allows is fetched" + test_closureAtTheBoundIsFetched , testCase "a peer claiming two certified endorser blocks for one election is dropped" test_twoCertificationClaimsIsDropped @@ -1090,6 +1096,152 @@ test_offeredSizeBeatsAnnouncedSize = do LeiosDb.withReader leiosDb $ \r -> not . null <$> LeiosDb.lookupEbBody r (pointEbHash mistatedPoint) +{------------------------------------------------------------------------------- + The closure bound +-------------------------------------------------------------------------------} + +-- | What 'oversizedNodeConfig' lets an endorser block reference, in total. +-- +-- The two endorser blocks below claim sizes relative to this rather than +-- deriving them from 'endorsedTx', so which side of the bound each falls on +-- does not move if that transaction's encoding changes. The value only has to +-- leave room for an encoded body well under it, which is what makes the +-- contrast between a small body and a huge closure real. +theClosureBound :: BytesSize +theClosureBound = 1000 + +-- | As 'nodeConfig', but with a closure bound small enough to trip. +oversizedNodeConfig :: NodeUnderTestConfig +oversizedNodeConfig = + defaultNodeUnderTestConfig + ((nutcLedgerConfig nodeConfig){ltlcMaxEbTxsSize = theClosureBound}) + securityParam + +-- | An endorser block whose one reference claims one byte more than +-- 'theClosureBound', while the transaction behind it is the same small one +-- every other test uses. +-- +-- That gap is the point: the body is well within 'maxLeiosEbBytesSize' --- a +-- reference costs the CBOR digits of the size it claims, not that size --- so +-- nothing short of summing the references catches it. +oversizedEb :: LeiosEb +oversizedClosure :: [(TxHash, BS8.ByteString)] +oversizedSize :: BytesSize +(oversizedEb, oversizedClosure, oversizedSize) = + mkLeiosTestEbClaiming [(endorsedTx, theClosureBound + 1)] + +oversizedPoint :: LeiosPoint +oversizedPoint = leiosTestEbPoint 1 oversizedEb + +oversizedAnnouncer :: Blk +oversizedAnnouncer = announcing oversizedPoint oversizedSize (firstLeiosBlock 0) + +-- | An endorser block whose one reference claims exactly 'theClosureBound', +-- which is the largest the protocol allows and so must still be fetched. +boundaryEb :: LeiosEb +boundaryClosure :: [(TxHash, BS8.ByteString)] +boundarySize :: BytesSize +(boundaryEb, boundaryClosure, boundarySize) = + mkLeiosTestEbClaiming [(endorsedTx, theClosureBound)] + +boundaryPoint :: LeiosPoint +boundaryPoint = leiosTestEbPoint 1 boundaryEb + +boundaryAnnouncer :: Blk +boundaryAnnouncer = announcing boundaryPoint boundarySize (firstLeiosBlock 0) + +-- | A peer that serves an endorser block referencing more transaction bytes +-- than its slot allows loses the connection. +-- +-- The bytes hash to what we asked for, so nothing before this point objects: +-- the announcement is valid, the offer is backed by it, and the body is the +-- endorser block named. Only summing what it references catches it, and the +-- node must do that before committing to fetch the closure --- which is the +-- whole attack, since a 512 KiB body can name hundreds of megabytes. +test_oversizedClosureIsRejected :: Assertion +test_oversizedClosureIsRejected = do + assertBool + "its body is a fraction of a legal one, so only summing the references catches it" + (oversizedSize < theClosureBound) + let simTrace = runSimTrace scenario + case traceResult False simTrace of + Left (FailureException e) | isClosureTooBig e -> pure () + outcome -> + assertFailure $ + unlines $ + ("expected the serving peer to be dropped, but: " <> show outcome) + : lastN 40 (selectTraceEventsSay' simTrace) + where + isClosureTooBig :: SomeException -> Bool + isClosureTooBig e + | Just (ExceptionInLinkedThread _ inner) <- fromException e = isClosureTooBig inner + | Just Leios.ExnLeiosClosureTooBig{} <- fromException e = True + | otherwise = False + + scenario :: forall s. IOSim s () + scenario = do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + holder <- newPeerEnv + + (chainDBTracer, getTraces) <- recordingTracerTVar + + withNodeUnderTest oversizedNodeConfig nodeDBs leiosDb chainDBTracer $ \nut -> + withRegistry $ \registry -> do + connectPeer nut registry (PeerAddr 0) holder + + plantEb holder oversizedEb oversizedClosure + + threadDelay 6 + + announceEb holder (getHeader oversizedAnnouncer) + offerEb holder oversizedPoint oversizedSize + + -- The peer's thread dies before this ever comes true; the assertion + -- above is on the exception that kills it. + awaitPollingWith getTraces "the endorser block body is in the LeiosDb" $ + LeiosDb.withReader leiosDb $ \r -> + not . null <$> LeiosDb.lookupEbBody r (pointEbHash oversizedPoint) + +-- | An endorser block referencing exactly what its slot allows is fetched. +-- +-- The companion to 'test_oversizedClosureIsRejected': without it, a check +-- written with the comparison the wrong way round would pass that test and +-- silently reject every legal endorser block too. +test_closureAtTheBoundIsFetched :: Assertion +test_closureAtTheBoundIsFetched = do + let simTrace = runSimTrace scenario + case traceResult False simTrace of + Right () -> pure () + outcome -> + assertFailure $ + unlines $ + ("expected the endorser block to be fetched, but: " <> show outcome) + : lastN 40 (selectTraceEventsSay' simTrace) + where + scenario :: forall s. IOSim s () + scenario = do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + holder <- newPeerEnv + + (chainDBTracer, getTraces) <- recordingTracerTVar + + withNodeUnderTest oversizedNodeConfig nodeDBs leiosDb chainDBTracer $ \nut -> + withRegistry $ \registry -> do + connectPeer nut registry (PeerAddr 0) holder + + plantEb holder boundaryEb boundaryClosure + + threadDelay 6 + + announceEb holder (getHeader boundaryAnnouncer) + offerEb holder boundaryPoint boundarySize + + awaitPollingWith getTraces "the endorser block body is in the LeiosDb" $ + LeiosDb.withReader leiosDb $ \r -> + not . null <$> LeiosDb.lookupEbBody r (pointEbHash boundaryPoint) + -- | An endorser block two elections announced is still fetched after the -- earlier announcement's point has been pruned away. -- diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs index 52b7208dde..55102c44e6 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs @@ -116,7 +116,7 @@ basicChainSyncClient -- do not care about this in these tests. CSClient.historicityCheck = HistoricityCheck.noCheck , CSClient.getDiffusionPipeliningSupport = DiffusionPipeliningOn - , CSClient.leiosMsgRollForwardCallback = \_ _ _ -> pure () + , CSClient.leiosMsgRollForwardCallback = \_ _ _ _ -> pure () , CSClient.leiosJumpAcceptedCallback = \_ -> pure () } CSClient.DynamicEnv diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs index 54440b2320..a3d98f5bba 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs @@ -147,9 +147,10 @@ type PraosLedgerView = BasePraosLedgerView PextNone -- | The Leios part of 'BasePraosLedgerView'. -- --- Only what the protocol itself checks. The other Leios parameters bound an --- endorser block's contents, which is validated with a real ledger state in --- hand, so doesn't need to be forecasted. +-- The Leios values that have to be read before the block they bear on is +-- applied: header validation reads the periods and 'llvMaxEbBodySize', +-- ChainSel's certificate check reads the committee and the quorum, and the +-- fetch logic reads 'llvMaxEbTxsSize' when an endorser block's body arrives. data LeiosLedgerView = LeiosLedgerView { llvCommittee :: !LeiosCommittee -- ^ Who may vote this epoch, and with what weight @@ -163,6 +164,9 @@ data LeiosLedgerView = LeiosLedgerView -- count of slots needs the slot length, which only the consensus config has. , llvMaxEbBodySize :: !Word32 -- ^ Maximum total size of an endorser block itself (/not/ the closure) + , llvMaxEbTxsSize :: !Word32 + -- ^ Maximum total size of the transactions an endorser block references (the + -- closure) } deriving (Eq, Show) @@ -182,6 +186,7 @@ initialLeiosLedgerView = , llvVotePeriodLength = Milliseconds32 0 , llvDiffusionPeriodLength = Milliseconds32 1000000000 , llvMaxEbBodySize = 0 + , llvMaxEbTxsSize = 0 } type ForecastsLeios :: PraosExtension -> Type -> Constraint @@ -233,4 +238,5 @@ forecastToLeiosLedgerView f = , llvVotePeriodLength = f ^. Dijkstra.leiosVotePeriodLengthForecastL @era @t , llvDiffusionPeriodLength = f ^. Dijkstra.leiosDiffusionPeriodLengthForecastL @era @t , llvMaxEbBodySize = f ^. Dijkstra.maxEndorserBlockReferencesSizeForecastL @era @t + , llvMaxEbTxsSize = f ^. Dijkstra.maxEndorserBlockTxsSizeForecastL @era @t } diff --git a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs index 801e5ec366..8db2257372 100644 --- a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs +++ b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs @@ -151,7 +151,7 @@ oneBenchRun pipelineDecisionLowHighMark 10 20 , CSClient.getDiffusionPipeliningSupport = DiffusionPipeliningOn - , CSClient.leiosMsgRollForwardCallback = \_ _ _ -> pure () + , CSClient.leiosMsgRollForwardCallback = \_ _ _ _ -> pure () , CSClient.leiosJumpAcceptedCallback = \_ -> pure () } CSClient.DynamicEnv diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs index 7f50bd6ddc..e011c128e4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs @@ -38,6 +38,7 @@ import Data.List (unfoldr) import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) import Data.Map (Map) import qualified Data.Map.Strict as Map +import Data.Maybe (isJust) import Data.Maybe.Strict (StrictMaybe (..), strictMaybeToMaybe) import Data.Proxy (Proxy (..)) import Data.Sequence (Seq) @@ -134,7 +135,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types , systemTimeCurrent ) import Ouroboros.Consensus.Config (TopLevelConfig, configLedger) -import Ouroboros.Consensus.Forecast (forecastFor) +import Ouroboros.Consensus.Forecast (OutsideForecastRange, forecastFor) import Ouroboros.Consensus.Ledger.Abstract (getTipSlot) import Ouroboros.Consensus.Ledger.Basics (EmptyMK) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState, ledgerState) @@ -143,7 +144,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol , ledgerViewForecastAt ) import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck -import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) +import Ouroboros.Consensus.Protocol.Abstract (ChainDepState, LedgerView) import Ouroboros.Consensus.Storage.LedgerDB.Forker ( OCINStaleness (..) , ResolveLeiosBlock (..) @@ -374,6 +375,13 @@ leiosFetchLogicIteration :: forall pid. Ord pid => LeiosFetchStaticEnv -> + -- | The maximum EB closure size forecast from the immutable tip to a slot. + -- + -- Only an offer that brought no bound of its own needs this, and for those it + -- cannot fail: the announcement backing such an offer was accepted by + -- forecasting from the immutable tip to that same slot. See + -- 'Leios.poMaxEbTxsSize'. + (SlotNo -> Either OutsideForecastRange BytesSize) -> -- | The current slot, or 'Nothing' when it is not yet known (i.e. we are -- syncing), in which case we fetch freshest-last instead of freshest-first. Maybe SlotNo -> @@ -387,7 +395,7 @@ leiosFetchLogicIteration :: , Map (PeerId pid) (NESeq LeiosFetchRequest) , Map (PeerId pid) (NESet.NESet LeiosPoint) ) -leiosFetchLogicIteration env mbCurrentSlot offerings bigLedgerPeers = \acc0 -> +leiosFetchLogicIteration env forecastMaxEbTxsSize mbCurrentSlot offerings bigLedgerPeers = \acc0 -> -- One pass per peer. Bodies and tx-closure jobs compete on equal footing, -- ranked by each EB's slot in 'ebState' (its greatest announcement slot), so -- the freshest EBs are fetched first whether it is the body or the closure @@ -398,7 +406,7 @@ leiosFetchLogicIteration env mbCurrentSlot offerings bigLedgerPeers = \acc0 -> ( \(acc, reqs, drops) peerId offers -> let isBig = Map.findWithDefault IsNotBigLedgerPeer peerId bigLedgerPeers (acc', peerReqs, peerDrops) = - assignPeer env mbCurrentSlot isBig peerId offers acc + assignPeer env forecastMaxEbTxsSize mbCurrentSlot isBig peerId offers acc in ( acc' , case NESeq.nonEmptySeq peerReqs of Nothing -> reqs @@ -471,13 +479,14 @@ fetchPriorityTiers mbCurrentSlot l offers = assignPeer :: Ord pid => LeiosFetchStaticEnv -> + (SlotNo -> Either OutsideForecastRange BytesSize) -> Maybe SlotNo -> IsBigLedgerPeer -> PeerId pid -> Map LeiosPoint Leios.PeerOffer -> LeiosOutstanding pid -> (LeiosOutstanding pid, Seq LeiosFetchRequest, Set LeiosPoint) -assignPeer env mbCurrentSlot isBig peerId offers acc = +assignPeer env forecastMaxEbTxsSize mbCurrentSlot isBig peerId offers acc = -- Walk the high-priority tier, then the low, threading the accumulator; the -- second walk immediately short-circuits if the first already saturated the -- peer. @@ -515,12 +524,12 @@ assignPeer env mbCurrentSlot isBig peerId offers acc = (Leios.NoBody, TxsClosureNotOffered) -> -- Body-only offer: request the body. If that's all that was -- offered, prune it. - let (acc2, dec2) = assignBody peerId ebHash slot offerKind (acc1, dec1) + let (acc2, dec2) = assignBody forecastMaxEbTxsSize peerId ebHash slot offerKind (acc1, dec1) in (acc2, dec2, Set.insert point drops) (Leios.NoBody, TxsClosureOffered) -> -- Request the body now, but keep the offer: we will request the -- closure from this peer once we hold the body. - let (acc2, dec2) = assignBody peerId ebHash slot offerKind (acc1, dec1) + let (acc2, dec2) = assignBody forecastMaxEbTxsSize peerId ebHash slot offerKind (acc1, dec1) in (acc2, dec2, drops) (Leios.BodyAcquired _jobPool, TxsClosureNotOffered) -> -- We hold the body and the peer never offered the closure, so it can @@ -528,7 +537,9 @@ assignPeer env mbCurrentSlot isBig peerId offers acc = pruneThisOffer (Leios.BodyAcquired jobPool, TxsClosureOffered) | Jobs.nullLeiosJobPool jobPool -> - -- whole datum in hand: the closure offer is useless now too + -- Nothing left to fetch --- the whole datum is in hand, or we + -- rejected the endorser block on arrival --- so the closure offer + -- is useless now too. pruneThisOffer | otherwise -> -- Still need the txs, and the peer offered the closure. If we just @@ -552,20 +563,27 @@ assignPeer env mbCurrentSlot isBig peerId offers acc = -- either the block or its length loses the connection then. assignBody :: Ord pid => + -- | The maximum EB closure size forecast for a slot. See + -- 'Leios.poMaxEbTxsSize'. + (SlotNo -> Either OutsideForecastRange BytesSize) -> PeerId pid -> EbHash -> SlotNo -> Leios.PeerOffer -> (LeiosOutstanding pid, Seq LeiosFetchRequest) -> (LeiosOutstanding pid, Seq LeiosFetchRequest) -assignBody peerId ebHash slot offer st@(acc, dec) +assignBody forecastMaxEbTxsSize peerId ebHash slot offer st@(acc, dec) | peerId `Set.member` Map.findWithDefault Set.empty ebHash (Leios.requestedEbPeers acc) = -- unless we've already requested it from them st - | otherwise = case Leios.poOfferedBody offer of + | otherwise = case (eMaxEbTxsSize, Leios.poOfferedBody offer) of + -- Beyond our horizon and the offer brought no bound of its own, so we + -- have nothing to hold the body to. Ignoring it this iteration costs + -- nothing: a later one forecasts again, from a tip that has moved. + (Left _outsideRange, _) -> st -- the peer offered the closure but not the body - SNothing -> st - SJust size -> + (_, SNothing) -> st + (Right maxEbTxsSize, SJust size) -> let acc' = acc { Leios.requestedEbPeers = @@ -573,7 +591,20 @@ assignBody peerId ebHash slot offer st@(acc, dec) , Leios.requestedBytesSizePerPeer = Map.insertWith (+) peerId size (Leios.requestedBytesSizePerPeer acc) } - in (acc', dec Seq.|> LeiosBlockRequest (MkLeiosBlockRequest (MkLeiosPoint slot ebHash) size)) + in ( acc' + , dec + Seq.|> LeiosBlockRequest + MkLeiosBlockRequest + { lbrPoint = MkLeiosPoint slot ebHash + , lbrOfferedSize = size + , lbrMaxEbTxsSize = maxEbTxsSize + } + ) + where + -- What the offer brought, else what we can forecast for its slot. + eMaxEbTxsSize = case Leios.poMaxEbTxsSize offer of + SJust x -> Right x + SNothing -> forecastMaxEbTxsSize slot -- | Flag indicating whether all jobs matching a peer's offers are already -- inflight @@ -770,9 +801,9 @@ nextLeiosFetchClientCommand ktracer tracer stopSTM kernelVars txCache writer sys -- everything they touch (the 'LeiosDbWriter' submission point, the locked -- tx cache, the kernel MVars) is thread-safe. g = \case - LeiosBlockRequest req@(MkLeiosBlockRequest p _ebBytesSize) -> + LeiosBlockRequest req -> LF.MkSomeLeiosFetchJob - (LF.MsgLeiosBlockRequest p) + (LF.MsgLeiosBlockRequest (lbrPoint req)) ( pure $ \(LF.MsgLeiosBlock eb) -> processLeiosBlock ktracer @@ -865,12 +896,20 @@ processLeiosBlock :: processLeiosBlock ktracer tracer (outstandingVar, readyVar) txCache writer systemTime pullFromMempool source eb = do now <- systemTimeCurrent systemTime -- validate it - let (mbPeer, point, ebBytesSize) = case source of - ReceivedBlockFrom peerId (MkLeiosBlockRequest p sz) -> (Just peerId, p, sz) - ForgedBlock p -> (Nothing, p, encodeLeiosEbSize eb) + let (mbPeer, point, ebBytesSize, mbMaxEbTxsSize) = case source of + ReceivedBlockFrom peerId req -> + (Just peerId, lbrPoint req, lbrOfferedSize req, Just (lbrMaxEbTxsSize req)) + ForgedBlock p -> (Nothing, p, encodeLeiosEbSize eb, Nothing) traceWith tracer $ MkTraceLeiosPeer $ "[start] MsgLeiosBlock " <> Leios.prettyLeiosPoint point let MkLeiosPoint _ebSlot ebHash = point let ebBytesSize' = encodeLeiosEbSize eb + let closureBytesSize :: Word64 + closureBytesSize = + V.foldl' (\acc (_txh, sz) -> acc + fromIntegral sz) 0 (Leios.leiosEbTxs eb) + mbTooBig = case mbMaxEbTxsSize of + Just maxEbTxsSize + | closureBytesSize > fromIntegral maxEbTxsSize -> Just maxEbTxsSize + _ -> Nothing -- A failed-validation body: attribute the whole body to 'fabInvalid'. -- -- TODO throw a proper exception type rather than 'error', which this module @@ -942,14 +981,30 @@ processLeiosBlock ktracer tracer (outstandingVar, readyVar) txCache writer syste -- duplicate (already held) or a too-old arrival (its slot is below pruned -- watermark, so 'novel' can't be trusted) is left at the bookkeeping above -- -- in particular no second 'writeEbBody', hence no duplicate - -- 'AcquiredEb'/re-offer. - if tooOld || not novel + -- 'AcquiredEb'/re-offer. So is one over its closure bound, which is + -- additionally recorded as held-with-nothing-to-fetch, so that neither its + -- closure nor a re-send of the same bytes costs us anything more. The peer + -- answers for that one below, once the lock is released --- throwing here + -- would roll the record back. + -- + -- TODO the LeiosDb has no way to record that we are done with an endorser + -- block whose closure we never fetched. Writing the body would say the + -- wrong thing --- 'writeEbBody' notifies 'AcquiredEb', and we must never + -- offer this one onward --- so the verdict lives only in 'ebState' and a + -- restart within the pruning window forfeits it, costing one more body + -- fetch from the next peer to serve it. + if tooOld || not novel || isJust mbTooBig then pure - ( outstandingCleaned + ( if isJust mbTooBig + then Leios.acquireEbBody ebHash Jobs.emptyLeiosJobPool outstandingCleaned + else outstandingCleaned , ( False - , (if tooOld then fetchArrivalEvicted else fetchArrivalExtra) $ ebBytesSize' + , case (tooOld, mbTooBig) of + (True, _) -> fetchArrivalEvicted ebBytesSize' + (_, Just{}) -> fetchArrivalInvalid ebBytesSize' + _ -> fetchArrivalExtra ebBytesSize' , IntMap.empty , IntMap.empty , [] @@ -1100,11 +1155,14 @@ processLeiosBlock ktracer tracer (outstandingVar, readyVar) txCache writer syste writer systemTime (MempoolTxs point mempoolIngest) - -- The body is in hand and ingested; only now does the peer answer for having - -- promised a different number of bytes than it sent. + -- The correctly-hashed EB body has been processed by this point. So now we + -- can punish the peer if it the EB isn't what it offered or should not have + -- been offered. when wrongLength $ throwIO $ ExnLeiosBlockWrongSize point ebBytesSize ebBytesSize' + forM_ mbTooBig $ \maxEbTxsSize -> + throwIO $ ExnLeiosClosureTooBig point closureBytesSize maxEbTxsSize -- | The 'processLeiosBlock' mempool-pull for paths that never pull from the -- mempool (the forge, which already holds the whole closure, and tests): keep @@ -1537,7 +1595,7 @@ recordEbBodyOffer :: m () recordEbBodyOffer readyVar peerVars (point, ebBytesSize) = recordOffer readyVar peerVars point $ - Leios.MkPeerOffer (SJust ebBytesSize) TxsClosureNotOffered + Leios.MkPeerOffer SNothing (SJust ebBytesSize) TxsClosureNotOffered -- | Record this peer's 'MsgLeiosBlockTxsOffer': it can serve this endorser -- block's tx closure. @@ -1549,7 +1607,7 @@ recordEbClosureOffer :: IOLike m => MVar m () -> LeiosPeerVars m -> LeiosPoint -> m () recordEbClosureOffer readyVar peerVars point = recordOffer readyVar peerVars point $ - Leios.MkPeerOffer SNothing TxsClosureOffered + Leios.MkPeerOffer SNothing SNothing TxsClosureOffered -- | Record a CertRB roll-forward as an offer of both the body and the -- closure. @@ -1567,10 +1625,13 @@ recordCertRbOffer :: LeiosPeerVars m -> -- | The offered EB: its point and on-the-wire body size. (LeiosPoint, BytesSize) -> + -- | The maximum EB closure size, from the announcment's slot. See + -- 'Leios.poMaxEbTxsSize'. + BytesSize -> m () -recordCertRbOffer readyVar peerVars (point, ebBytesSize) = +recordCertRbOffer readyVar peerVars (point, ebBytesSize) maxEbTxsSize = recordOffer readyVar peerVars point $ - Leios.MkPeerOffer (SJust ebBytesSize) TxsClosureOffered + Leios.MkPeerOffer (SJust maxEbTxsSize) (SJust ebBytesSize) TxsClosureOffered recordOffer :: IOLike m => MVar m () -> LeiosPeerVars m -> LeiosPoint -> Leios.PeerOffer -> m () @@ -1606,9 +1667,11 @@ checkMsgRollForwardForLeiosOffers :: ) -> LeiosPeerVars m -> Header blk -> + -- | The ledger view at this header's predecessor's slot + LedgerView (BlockProtocol blk) -> ChainDepState (BlockProtocol blk) -> m () -checkMsgRollForwardForLeiosOffers kernelVars peerVars hdr cds = +checkMsgRollForwardForLeiosOffers kernelVars peerVars hdr predLedgerView cds = when (headerContainsLeiosCert hdr) $ forM_ (protocolStateLeiosAnnouncement @blk cds) $ \fields -> do noteCertificationClaim @@ -1619,6 +1682,7 @@ checkMsgRollForwardForLeiosOffers kernelVars peerVars hdr cds = (snd kernelVars) peerVars (announcementLeiosPoint fields, announcementEbBodySize fields) + (getLeiosMaxEbTxsSizeFromView (Proxy @blk) predLedgerView) -- | Count this peer's claim that an endorser block is certified for an -- election, disconnecting if it contradicts a prior claim by this peer @@ -1876,19 +1940,33 @@ data ExnLeiosInvalidRequest instance Exception ExnLeiosInvalidRequest --- | Thrown when a peer's 'MsgLeiosBlock' is not the number of bytes it offered --- that endorser block at: the point, the size it offered, and the size it sent. --- The ensuing thread death disconnects it. +-- | Thrown when a peer's 'MsgLeiosBlock' hashes to the endorser block we asked +-- for and is still not one we can accept; the ensuing thread death disconnects +-- it. -- --- Unlike the other invalid replies, the body itself is good --- it hashes to --- the endorser block we asked for --- so it is ingested before this is thrown --- and its bytes are accounted as the arrival they were. That is why this does --- not go through @invalidReply@, which writes the whole body off as waste. -data ExnLeiosBlockWrongSize - = ExnLeiosBlockWrongSize !LeiosPoint !BytesSize !BytesSize +-- Unlike the other invalid replies, the bytes are the endorser block we asked +-- for, so 'processLeiosBlock' settles what it owes the rest of the node before +-- throwing: the arrival is accounted for what it was, and 'ebState' records the +-- verdict so the next peer to serve the same bytes does not cost us the work +-- again. That is why neither of these goes through @invalidReply@, which writes +-- the whole body off as waste, and why both are thrown only once the +-- 'LeiosOutstanding' lock has been let go --- throwing under it would roll the +-- record back. +data ExnLeiosWellHashedBodyRejected + = -- | Not the number of bytes it offered that endorser block at: the point, + -- the size it offered, and the size it sent. + ExnLeiosBlockWrongSize !LeiosPoint !BytesSize !BytesSize + | -- | References more transaction bytes than the protocol allows the closure + -- to amount to: the point, what it referenced, and the bound it broke. + -- + -- No honest peer sends this. Such an endorser block can never be certified + -- --- an honest committee member applies the same bound --- so an honest + -- peer that fetched it rejected it here too and never stored or offered it. + -- Only a peer that skipped the check can serve one. + ExnLeiosClosureTooBig !LeiosPoint !Word64 !BytesSize deriving Show -instance Exception ExnLeiosBlockWrongSize +instance Exception ExnLeiosWellHashedBodyRejected -- | Which of a point's two independent offers a LeiosNotify message makes. data OfferedBodyOrClosure = OfferedBody | OfferedClosure diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs index 0e6784de8c..d35fcefef5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs @@ -361,14 +361,16 @@ data LeiosFetchRequest = LeiosBlockRequest LeiosBlockRequest | LeiosBlockTxsRequest LeiosBlockTxsRequest -data LeiosBlockRequest - = -- | - -- - -- The size isn't sent to the peer, but it's used to validate the reponse - -- when it arrives. - MkLeiosBlockRequest - !LeiosPoint - !BytesSize +-- | A request for an endorser block's body. +data LeiosBlockRequest = MkLeiosBlockRequest + { lbrPoint :: !LeiosPoint + , lbrOfferedSize :: !BytesSize + -- ^ The size the peer offered this endorser block at; not sent, but used by + -- the reply handler. See 'LeiosDemoLogic.ExnLeiosBlockWrongSize'. + , lbrMaxEbTxsSize :: !BytesSize + -- ^ The maximum allowed closure size for this block; not sent, but used by + -- the reply handler. See 'LeiosDemoLogic.ExnLeiosClosureTooBig'. + } data LeiosBlockTxsRequest = -- | A request for some of an EB's txs: its point and the 'Jobs.LeiosJob's it @@ -430,7 +432,14 @@ instance Monoid WhetherTxsClosureOffered where -- taken from the body we already hold by the time 'assignClosure' runs, so -- there is nothing there for a peer to claim. data PeerOffer = MkPeerOffer - { poOfferedBody :: !(StrictMaybe BytesSize) + { poMaxEbTxsSize :: !(StrictMaybe BytesSize) + -- ^ The maximum closure size allowed for this offered EB. It's 'Nothing' if + -- the offer arrived via LeiosNotify, and 'Just' if it arrived via ChainSync. + -- + -- The LeiosFetch decision logic uses forecasting in the 'Nothing' case. We + -- avoid forecasting in the ChainSync case so that the Leios Recovery Path can + -- handle sparse chains. + , poOfferedBody :: !(StrictMaybe BytesSize) -- ^ The size this peer offered the body at, if it has offered the body. -- -- The peer's own claim, and the only size that decides anything: no @@ -452,14 +461,18 @@ data PeerOffer = MkPeerOffer -- | Each field on its own terms: the leftmost size wins, which for -- 'Map.insertWith' is the newer offer's, and a peer that makes that choice -- matter has already lost our trust (see 'poOfferedBody'). +-- +-- The bound is not a claim of the peer's but a value we computed, so the two +-- sides agree whenever both have one and either will do. instance Semigroup PeerOffer where - MkPeerOffer sz1 c1 <> MkPeerOffer sz2 c2 = MkPeerOffer (pickSize sz1 sz2) (c1 <> c2) + MkPeerOffer b1 sz1 c1 <> MkPeerOffer b2 sz2 c2 = + MkPeerOffer (pickSize b1 b2) (pickSize sz1 sz2) (c1 <> c2) where pickSize SNothing y = y pickSize x _ = x instance Monoid PeerOffer where - mempty = MkPeerOffer SNothing mempty + mempty = MkPeerOffer SNothing SNothing mempty data LeiosPeerVars m = MkLeiosPeerVars { whetherBigLedgerPeer :: !IsBigLedgerPeer @@ -802,7 +815,7 @@ summarizeDecisions decs = , ldsRequests = length reqs , ldsBodyRequests = length [() | LeiosBlockRequest{} <- reqs] , ldsJobs = sum [NEIntMap.size jobs | LeiosBlockTxsRequest (MkLeiosBlockTxsRequest _ jobs) <- reqs] - , ldsBodyBytes = sum [fromIntegral sz | LeiosBlockRequest (MkLeiosBlockRequest _ sz) <- reqs] + , ldsBodyBytes = sum [fromIntegral (lbrOfferedSize r) | LeiosBlockRequest r <- reqs] , ldsTxBytes = sum [ fromIntegral b @@ -1144,7 +1157,7 @@ prettyOfferings m = | (MkLeiosPoint slot h, k) <- points ] ++ "}" - kindTag (MkPeerOffer mbSize closure) = body ++ txs + kindTag (MkPeerOffer _bound mbSize closure) = body ++ txs where body = case mbSize of SNothing -> "" diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs index 2d7c48165c..77e7b803b9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs @@ -785,10 +785,18 @@ data ConfigEnv m blk = ConfigEnv , leiosMsgRollForwardCallback :: Header blk -> RelativeTime -> + LedgerView (BlockProtocol blk) -> ChainDepState (BlockProtocol blk) -> m () -- ^ Invoked on each accepted 'MsgRollForward' with the just-arrived header, - -- its slot's wall-clock onset, and the chain-dep state as of its predecessor. + -- its slot's wall-clock onset, and the ledger view and chain-dep state as of + -- its predecessor. + -- + -- For a CertRB the predecessor is the block that announced the endorser block + -- it certifies, so that view is forecast for the announced slot --- and the + -- ChainSync client reaches further than our immutable tip, which is why the + -- fetch logic retains this rather than forecasting it later (see + -- 'LeiosDemoTypes.poMaxEbTxsSize'). -- For Leios the wiring uses this to both register any EB the header -- /certifies/ as an offer from this peer, and feed any EB the header -- /announces/ into the central announcement state — dating that announcement @@ -1565,10 +1573,13 @@ knownIntersectionStateTop cfgEnv dynEnv intEnv = -- Pass the predecessor's chain-dep state (the pre-validation state, -- whose history tip is still the predecessor); see -- 'leiosMsgRollForwardCallback'. - leiosMsgRollForwardCallback cfgEnv hdr hdrSlotTime $ - headerStateChainDep $ - hswtHeaderState $ - HeaderStateHistory.current (theirHeaderStateHistory kis') + let predHeaderState = HeaderStateHistory.current (theirHeaderStateHistory kis') + leiosMsgRollForwardCallback + cfgEnv + hdr + hdrSlotTime + (hswtLedgerView predHeaderState) + (headerStateChainDep (hswtHeaderState predHeaderState)) continueWithState kis''' $ nextStep mkPipelineDecision n theirTip diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs index 6d4b45f7e9..2468e03162 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs @@ -128,6 +128,7 @@ import Ouroboros.Consensus.Protocol.Abstract ( ChainDepState , ConsensusConfig , ConsensusProtocol + , LedgerView , ValidateView , ValidationErr , updateChainDepState @@ -956,6 +957,20 @@ class ResolveLeiosBlock blk where validateAnnouncementChainDepState cfg vv slot tcs = FreshOCIN <$ updateChainDepState cfg vv slot tcs + -- | The maximum closure size in this slot + -- + -- Read from a forecast view rather than an applied ledger state because + -- nothing has applied the endorser block --- or the block that announced it + -- --- by the time this decides whether its closure is worth fetching. + -- + -- An era without the parameter answers 0, which is sentinel but an accurate + -- one. + getLeiosMaxEbTxsSizeFromView :: + proxy blk -> + LedgerView (BlockProtocol blk) -> + BytesSize + getLeiosMaxEbTxsSizeFromView _ _ = 0 + -- | The most recent EB announcement in the 'HeaderState', if any: the -- election that made it, the endorser block's hash, and its body size. -- 'Nothing' for headers in eras that don't carry Leios announcements. diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs index d2e7af6505..aa0088187f 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs @@ -466,6 +466,8 @@ invalidate blk = blk{ltbHeader = (ltbHeader blk){lthValidity = Invalid}} instance ResolveLeiosBlock LeiosTestBlock where blockLeiosCert = ltbCert . ltbBody + getLeiosMaxEbTxsSizeFromView _ = ltvMaxEbTxsSize + announcingRbHash blk = case blockPrevHash blk of GenesisHash -> Nothing BlockHash h -> Just $ MkRbHash $ toRawHash (Proxy @LeiosTestBlock) h @@ -541,18 +543,26 @@ newtype instance Ticked LeiosTestChainDepState data LeiosTestProtocol -- | What Leios needs of the ledger view, and nothing else. -newtype LeiosTestView = LeiosTestView +data LeiosTestView = LeiosTestView { ltvCommittee :: Maybe (LeiosCommittee, Weight) + , ltvMaxEbTxsSize :: !BytesSize + -- ^ What an endorser block announced in this view's slot may reference, in + -- total. 'leiosTestLedgerConfig' fixes it for the whole chain, since no test + -- needs it to change mid-run. } deriving stock Generic deriving anyclass NoThunks instance Show LeiosTestView where - show (LeiosTestView mbCommittee) = case mbCommittee of - Nothing -> "LeiosTestView{no committee}" + show (LeiosTestView mbCommittee maxEbTxsSize) = case mbCommittee of + Nothing -> "LeiosTestView{no committee, maxEbTxsSize = " <> show maxEbTxsSize <> "}" Just (_committee, threshold) -> -- The committee's own 'Show' would dwarf every counterexample it appears in. - "LeiosTestView{committee = , threshold = " <> show threshold <> "}" + "LeiosTestView{committee = , threshold = " + <> show threshold + <> ", maxEbTxsSize = " + <> show maxEbTxsSize + <> "}" data instance ConsensusConfig LeiosTestProtocol = LeiosTestProtocolConfig { ltpcSecurityParam :: !SecurityParam @@ -628,6 +638,7 @@ data LeiosTestLedgerConfig = LeiosTestLedgerConfig { ltlcHardForkParams :: !HardFork.EraParams , ltlcForecastRange :: !SlotNo , ltlcCommittees :: EpochNo -> Maybe (LeiosCommittee, Weight) + , ltlcMaxEbTxsSize :: !BytesSize } deriving NoThunks via OnlyCheckWhnfNamed "LeiosTestLedgerConfig" LeiosTestLedgerConfig @@ -639,12 +650,15 @@ instance Show LeiosTestLedgerConfig where <> show ltlcForecastRange <> " " +-- | The closure bound defaults to 'maxBound', so a test that does not care +-- about it never trips it. 'ltlcMaxEbTxsSize' is how one that does says so. leiosTestLedgerConfig :: HardFork.EraParams -> SlotNo -> (EpochNo -> Maybe (LeiosCommittee, Weight)) -> LeiosTestLedgerConfig -leiosTestLedgerConfig = LeiosTestLedgerConfig +leiosTestLedgerConfig eraParams forecastRange committees = + LeiosTestLedgerConfig eraParams forecastRange committees maxBound type instance LedgerCfg (LedgerState LeiosTestBlock) = LeiosTestLedgerConfig @@ -759,8 +773,10 @@ instance ValidateEnvelope LeiosTestBlock instance LedgerSupportsPeras LeiosTestBlock instance LedgerSupportsProtocol LeiosTestBlock where - protocolLedgerView _cfg = - LeiosTestView . ltlsCommittee . getTickedLeiosTestLedger + protocolLedgerView cfg = + flip LeiosTestView (ltlcMaxEbTxsSize cfg) + . ltlsCommittee + . getTickedLeiosTestLedger ledgerViewForecastAt cfg st = Forecast @@ -782,7 +798,7 @@ instance LedgerSupportsProtocol LeiosTestBlock where -- | The committee the schedule seats for the epoch that contains this slot. viewAt :: LeiosTestLedgerConfig -> SlotNo -> LeiosTestView -viewAt cfg = LeiosTestView . committeeAt cfg +viewAt cfg slot = LeiosTestView (committeeAt cfg slot) (ltlcMaxEbTxsSize cfg) committeeAt :: LeiosTestLedgerConfig -> SlotNo -> Maybe (LeiosCommittee, Weight) committeeAt cfg slot = ltlcCommittees cfg epoch diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/CSJ.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/CSJ.hs index a900dc16cc..e4fd68d9f4 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/CSJ.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/CSJ.hs @@ -182,7 +182,7 @@ runTest TestSetup = withRegistry $ \registry -> do , historicityCheck = HistoricityCheck.noCheck , mkPipelineDecision0 = pipelineDecisionLowHighMark 10 20 , getDiffusionPipeliningSupport = diffusionPipelining - , leiosMsgRollForwardCallback = \_ _ _ -> pure () + , leiosMsgRollForwardCallback = \_ _ _ _ -> pure () , leiosJumpAcceptedCallback = \_ -> pure () } DynamicEnv diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs index 71b377854e..6005ae2b87 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs @@ -509,7 +509,7 @@ runChainSync pipelineDecisionLowHighMark 10 20 , getDiffusionPipeliningSupport = diffusionPipelining - , leiosMsgRollForwardCallback = \_ _ _ -> pure () + , leiosMsgRollForwardCallback = \_ _ _ _ -> pure () , leiosJumpAcceptedCallback = \_ -> pure () } DynamicEnv diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs index 6b41f6d087..bb0a05b58f 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs @@ -71,6 +71,7 @@ import LeiosDemoTypes , maxTxsPerEb , recordMaxAnnouncementSlot ) +import Ouroboros.Consensus.Forecast (OutsideForecastRange) import System.Random (mkStdGen) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) @@ -330,6 +331,7 @@ runIteration sc = -- exercised in "Test.LeiosDemoLogic.Invariants"). leiosFetchLogicIteration sc.scEnv + anyClosureSize (Just minBound) (Map.map (Map.mapWithKey (resolveOfferSize sc.scOfferedSizes)) sc.scOfferings) Map.empty @@ -343,7 +345,7 @@ runIteration sc = resolveOfferSize :: Map.Map LeiosPoint BytesSize -> LeiosPoint -> WhetherTxsClosureOffered -> PeerOffer resolveOfferSize sizes p closure = - MkPeerOffer (maybe SNothing SJust (Map.lookup p sizes)) closure + MkPeerOffer SNothing (maybe SNothing SJust (Map.lookup p sizes)) closure ------------------------------------------------------------ -- Assertions @@ -361,7 +363,7 @@ assertBodyRequest pid p size m = Nothing -> assertFailure $ "no request for peer " <> show pid Just reqs -> [ (pt.pointEbHash, sz) - | LeiosBlockRequest (MkLeiosBlockRequest pt sz) <- toList reqs + | LeiosBlockRequest (MkLeiosBlockRequest pt sz _) <- toList reqs ] @?= [(p.pointEbHash, size)] @@ -420,3 +422,9 @@ serveStoredBody n = do withReader db $ \r -> do ctx <- newLeiosFetchContext r msgLeiosBlockRequest nullTracer ctx bodyPoint + +-- | The closure bound these scenarios forecast: large enough that nothing here +-- trips it. 'Test.Consensus.Leios.RecoveryPath' is where the bound itself is +-- exercised, against a real node. +anyClosureSize :: SlotNo -> Either OutsideForecastRange BytesSize +anyClosureSize _slot = Right maxBound diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs index a45edb590e..10fe880e9e 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs @@ -54,10 +54,12 @@ import qualified Data.Set as Set import qualified Data.Set.NonEmpty as NESet import qualified Data.Vector.Strict as V import Data.Void (Void, absurd) +import Data.Word (Word64) import LeiosDemoDb (withWriter) import qualified LeiosDemoDb as LeiosDb import LeiosDemoLogic - ( LeiosBlockSource (..) + ( ExnLeiosWellHashedBodyRejected (..) + , LeiosBlockSource (..) , LeiosBlockTxsSource (..) , leiosFetchLogicIteration , noMempoolPull @@ -68,6 +70,7 @@ import LeiosDemoLogic , removePeerFromOutstanding ) import LeiosDemoLogic.Announcements.ElBimap (ElId (MkElId)) +import Ouroboros.Consensus.Forecast (OutsideForecastRange) import LeiosDemoTypes ( BytesSize , EbHash @@ -101,7 +104,7 @@ import Ouroboros.Network.PeerSelection.LedgerPeers.Type import System.Random (mkStdGen) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertBool, testCase, (@?=)) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) import Test.Tasty.QuickCheck (testProperty) import Test.Util.Orphans.IOLike () import Test.Util.TestEnv (adjustQuickCheckTests) @@ -231,6 +234,7 @@ tests = (_out', decs, _drops) = leiosFetchLogicIteration demoLeiosFetchStaticEnv + anyClosureSize (Just (SlotNo 10)) offerings Map.empty @@ -254,7 +258,7 @@ tests = -- size; only its closure half is consulted. offers = Map.singleton peerId $ - Map.singleton point (Leios.MkPeerOffer SNothing TxsClosureOffered) + Map.singleton point (Leios.MkPeerOffer SNothing SNothing TxsClosureOffered) ordinaryCap = Leios.maxRequestedBytesSizePerPeer demoLeiosFetchStaticEnv bigLedgerCap = Leios.maxRequestedBytesSizePerBigLedgerPeer demoLeiosFetchStaticEnv -- hold the body (so the pool is live), with the peer's in-flight bytes @@ -272,6 +276,7 @@ tests = (_o, reqs, _d) = leiosFetchLogicIteration demoLeiosFetchStaticEnv + anyClosureSize (Just (SlotNo 11)) offers bigLedgerPeers @@ -353,6 +358,81 @@ tests = Map.lookup h (Leios.ebState o) @?= Just (Leios.MkEbState (SlotNo 7) SNothing Leios.NoBody) Map.lookup elCertified (Leios.elFocus o) @?= Just h + , testCase "an endorser block that references too many tx bytes is dropped, not fetched" $ do + -- The references are what the closure costs, and bounding the encoded + -- body does not bound them: a reference is charged the CBOR digits of + -- the size it claims. So the arriving body is weighed against the + -- bound its request carried, before any closure job exists. + let ids = [0 .. 3] + eb = ebOf ids + point = pointOf ids 5 + h = Leios.pointEbHash point + referenced = sum (map (fromIntegral . txSizeOf) ids) :: Word64 + -- One byte under what this endorser block references. + bound = fromIntegral referenced - 1 + run = runSimOrThrow $ do + dbHandle <- LeiosDb.newLeiosDBInMemory + withWriter dbHandle $ \conn -> do + outstandingVar <- newMVar (emptyLeiosOutstanding (mkStdGen 0) (SlotNo 0)) + readyVar <- newEmptyMVar + let kv = (outstandingVar, readyVar) + recordAnnouncedEb kv SNothing $ + announcementOf point (encodeLeiosEbSize eb) + r <- + try $ + processLeiosBlock + nullTracer + nullTracer + kv + nullLeiosTxCache + conn + dummySystemTime + noMempoolPull + (ReceivedBlockFrom (MkPeerId (0 :: Int)) (MkLeiosBlockRequest point (encodeLeiosEbSize eb) bound)) + eb + outstanding <- readMVar outstandingVar + pure (r :: Either ExnLeiosWellHashedBodyRejected (), outstanding) + (thrown, o) = run + -- The peer answers for it. + case thrown of + Left (ExnLeiosClosureTooBig p referenced' bound') -> + (p, referenced', bound') @?= (point, referenced, bound) + other -> assertFailure ("expected ExnLeiosClosureTooBig, got " <> show other) + -- Recorded with an empty job pool: no closure to fetch, and the next + -- peer to serve the same bytes does not cost us the work again. + Map.lookup h (Leios.ebState o) + @?= Just (Leios.MkEbState (SlotNo 5) SNothing (Leios.BodyAcquired Jobs.emptyLeiosJobPool)) + Leios.numMissingBodies o @?= 0 + , testCase "an endorser block at exactly its bound is fetched" $ do + let ids = [0 .. 3] + eb = ebOf ids + point = pointOf ids 5 + h = Leios.pointEbHash point + bound = sum (map txSizeOf ids) + o = runSimOrThrow $ do + dbHandle <- LeiosDb.newLeiosDBInMemory + withWriter dbHandle $ \conn -> do + outstandingVar <- newMVar (emptyLeiosOutstanding (mkStdGen 0) (SlotNo 0)) + readyVar <- newEmptyMVar + let kv = (outstandingVar, readyVar) + recordAnnouncedEb kv SNothing $ + announcementOf point (encodeLeiosEbSize eb) + processLeiosBlock + nullTracer + nullTracer + kv + nullLeiosTxCache + conn + dummySystemTime + noMempoolPull + (ReceivedBlockFrom (MkPeerId (0 :: Int)) (MkLeiosBlockRequest point (encodeLeiosEbSize eb) bound)) + eb + readMVar outstandingVar + -- Accepted, so its closure became jobs rather than an empty pool. + case Map.lookup h (Leios.ebState o) of + Just (Leios.MkEbState _ _ (Leios.BodyAcquired jobPool)) -> + assertBool "expected a non-empty job pool" (jobPool /= Jobs.emptyLeiosJobPool) + other -> assertFailure ("expected BodyAcquired, got " <> show other) , testCase "a certificate leaves a body we already hold held" $ do let eb = ebOf [0, 1] h = hashLeiosEb eb @@ -519,7 +599,7 @@ applyCmd conn txCache kv peerVars peerId = \case pure [] ArriveBody ids slot -> do let eb = ebOf ids - req = MkLeiosBlockRequest (pointOf ids slot) (encodeLeiosEbSize eb) + req = MkLeiosBlockRequest (pointOf ids slot) (encodeLeiosEbSize eb) maxBound processLeiosBlock nullTracer nullTracer @@ -537,7 +617,7 @@ applyCmd conn txCache kv peerVars peerId = \case pure [] ArriveBodyLostWrite ids slot -> do let eb = ebOf ids - req = MkLeiosBlockRequest (pointOf ids slot) (encodeLeiosEbSize eb) + req = MkLeiosBlockRequest (pointOf ids slot) (encodeLeiosEbSize eb) maxBound -- The body write is never enqueued, so its promise never resolves and -- the acquisition is never confirmed. lostConn = conn{LeiosDb.writeEbBody = \_ _ _ -> pure (LeiosDb.Promise (forever (threadDelay 1000000)))} @@ -596,6 +676,7 @@ applyCmd conn txCache kv peerVars peerId = \case (out', decs, _drops) = leiosFetchLogicIteration demoLeiosFetchStaticEnv + anyClosureSize (Just (fromIntegral slot)) offerings Map.empty @@ -625,7 +706,7 @@ referencedOffers :: LeiosOutstanding Int -> Map.Map Leios.LeiosPoint Leios.PeerO referencedOffers o = Map.fromList [ ( Leios.MkLeiosPoint (Leios.ebStateMaxSlot s) h - , Leios.MkPeerOffer (SJust 1) Leios.TxsClosureOffered + , Leios.MkPeerOffer SNothing (SJust 1) Leios.TxsClosureOffered ) | (h, s) <- Map.toList (Leios.ebState o) ] @@ -638,7 +719,7 @@ forceDecisions m = sum [reqScore req | reqs <- Map.elems m, req <- toList reqs] where reqScore = \case - Leios.LeiosBlockRequest (Leios.MkLeiosBlockRequest _p sz) -> fromIntegral sz + Leios.LeiosBlockRequest r -> fromIntegral (Leios.lbrOfferedSize r) Leios.LeiosBlockTxsRequest (Leios.MkLeiosBlockTxsRequest _p jobs) -> sum [ off @@ -652,7 +733,7 @@ ebBodyRequestHashes :: Map.Map peer (NESeq Leios.LeiosFetchRequest) -> [EbHash] ebBodyRequestHashes m = [ p.pointEbHash | reqs <- Map.elems m - , Leios.LeiosBlockRequest (Leios.MkLeiosBlockRequest p _sz) <- toList reqs + , Leios.LeiosBlockRequest (Leios.MkLeiosBlockRequest p _sz _) <- toList reqs ] -- | The union of every tx offset the requests fetch, across all peers. @@ -669,6 +750,12 @@ requestedOffsets m = -- The invariant ------------------------------------------------------------ +-- | The closure bound these tests forecast: large enough that nothing here +-- trips it. 'Test.Consensus.Leios.RecoveryPath' is where the bound itself is +-- exercised, against a real node. +anyClosureSize :: SlotNo -> Either OutsideForecastRange Leios.BytesSize +anyClosureSize _slot = Right maxBound + -- | Three invariants: -- -- * 'ebsPerMaxAnnouncementSlot' must be the exact inverse of the greatest-slot @@ -911,7 +998,7 @@ raceSameHashMultiSlot = do conn dummySystemTime noMempoolPull - (ReceivedBlockFrom peerId (MkLeiosBlockRequest arrivalPoint ebBytesSize)) + (ReceivedBlockFrom peerId (MkLeiosBlockRequest arrivalPoint ebBytesSize maxBound)) eb ) ) diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosValidClaimsChainDB.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosValidClaimsChainDB.hs index c6cc8cc57c..0c55838021 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosValidClaimsChainDB.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosValidClaimsChainDB.hs @@ -191,7 +191,7 @@ addWithCommittee node predecessor blk = node ( Predecessor (blockSlot predecessor) - (LeiosTestView (Just (testCommittee.committee, wholeCommittee))) + (LeiosTestView (Just (testCommittee.committee, wholeCommittee)) maxBound) ) blk @@ -272,7 +272,7 @@ test_noCommittee = do addAtGenesis node announcer addBlockWith node - (Predecessor (blockSlot announcer) (LeiosTestView Nothing)) + (Predecessor (blockSlot announcer) (LeiosTestView Nothing maxBound)) certRB (,) <$> claimCount node <*> tipPoint node assertEqual "no claim is established" 0 claims From 450c7820281f61502a3fbf7e23327c03bfba5a43 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Mon, 5 Oct 2026 22:37:40 -0400 Subject: [PATCH 41/60] Leios: consolidate Shelley ledger state projections --- .../Consensus/Shelley/Ledger/Ledger.hs | 80 +++++++++++-------- 1 file changed, 45 insertions(+), 35 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index e02e5dbf6a..75dc3eeec2 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -89,7 +89,6 @@ import Cardano.Ledger.Core , ppMaxTxSizeL ) import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Dijkstra.PParams (ppLeiosQuorumStakeThresholdL) import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.Governance as SL import qualified Cardano.Ledger.Shelley.LedgerState as SL @@ -113,7 +112,7 @@ import qualified Data.Text as T import qualified Data.Text as Text import Data.Word import GHC.Generics (Generic) -import LeiosDemoTypes (minCertificationGap) +import LeiosDemoTypes (LeiosCommittee, Weight, minCertificationGap) import LeiosVoting (HasLeiosVoting (..)) import Lens.Micro import Lens.Micro.Extras (view) @@ -134,7 +133,7 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch) -import Ouroboros.Consensus.Protocol.Praos (Praos, PraosWithLeios) +import Ouroboros.Consensus.Protocol.Praos (BasePraos, Praos, PraosWithLeios) import Ouroboros.Consensus.Protocol.Praos.Common (StrictMaybeLeios (SJustLeios)) import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views import Ouroboros.Consensus.Protocol.TPraos (TPraos) @@ -991,6 +990,46 @@ instance LedgerSupportsPeras (ShelleyBlock proto era) where -- REVIEW: Use 'proto' instead of Praos/TPraos? +-- | The ledger view this state projects at its own tip slot. +-- +-- 'SL.currentForecast' applies no TICKF, so this reads the state and nothing +-- more. +untickedLedgerView :: + ( SL.EraForecast era + , Views.ForecastsLeios pext era + ) => + LedgerState (ShelleyBlock (BasePraos pext crypto) era) mk -> + Views.BasePraosLedgerView pext +untickedLedgerView = + Views.forecastToBasePraosLedgerView . SL.currentForecast . shelleyLedgerState + +-- | The committee this state seats and the quorum it demands. +-- +-- The ledger already seats the committee, on the stake snapshot, at the era +-- boundary; take it from there rather than selecting a second time here. +-- +-- Re-deriving it in consensus cannot honour voting-key expiry: the pool +-- distribution carries a bare 'BlsKey' with no registration epoch, whereas +-- the snapshot's seats were filtered by 'selectLeiosCommittee' against +-- @bksRegisteredIn + maxKeyAge@ (CIP-0164). +-- +-- 'ssStakeSet' is the snapshot that governs /this/ epoch: NEWEPOCH sets +-- @nesPd@ -- the distribution leader election runs on -- from the mark +-- snapshot of the previous boundary, which is exactly what 'ssStakeSet' +-- holds after the rotation. Taking the committee from the same snapshot +-- keeps a pool's voting weight and its block-production weight in step. +leiosCommitteeAndQuorum :: + forall pext crypto era mk. + ( SL.EraForecast era + , Views.ForecastsLeios pext era + , HasLeiosVoting (ShelleyBlock (BasePraos pext crypto) era) + ) => + LedgerState (ShelleyBlock (BasePraos pext crypto) era) mk -> + Maybe (LeiosCommittee, Weight) +leiosCommitteeAndQuorum ls = + getLeiosCommitteeFromView (Proxy @(ShelleyBlock (BasePraos pext crypto) era)) $ + untickedLedgerView ls + -- TODO: Ledger-level type class EraCommittee? LedgerState era -> Committee instance HasLeiosVoting (ShelleyBlock (TPraos c) ShelleyEra) where @@ -1024,26 +1063,9 @@ instance HasLeiosVoting (ShelleyBlock (Praos c) ConwayEra) where getMinCertificationGap _ _ = Nothing instance HasLeiosVoting (ShelleyBlock (PraosWithLeios c) DijkstraEra) where - -- The ledger already seats the committee, on the stake snapshot, at the era - -- boundary; take it from there rather than selecting a second time here. - -- - -- Re-deriving it in consensus cannot honour voting-key expiry: the pool - -- distribution carries a bare 'BlsKey' with no registration epoch, whereas - -- the snapshot's seats were filtered by 'selectLeiosCommittee' against - -- @bksRegisteredIn + maxKeyAge@ (CIP-0164). - -- - -- 'ssStakeSet' is the snapshot that governs /this/ epoch: NEWEPOCH sets - -- @nesPd@ -- the distribution leader election runs on -- from the mark - -- snapshot of the previous boundary, which is exactly what 'ssStakeSet' - -- holds after the rotation. Taking the committee from the same snapshot - -- keeps a pool's voting weight and its block-production weight in step. - getLeiosCommittee ls = - Just $ - ls.shelleyLedgerState - ^. SL.nesEsL - . SL.esSnapshotsL - . SL.ssStakeSetL - . SL.ssLeiosCommitteeL + getLeiosCommittee = fmap fst . leiosCommitteeAndQuorum + + getCurrentThreshold = fmap snd . leiosCommitteeAndQuorum getMinCertificationGap cfg = Just @@ -1051,18 +1073,6 @@ instance HasLeiosVoting (ShelleyBlock (PraosWithLeios c) DijkstraEra) where . getPParams . shelleyLedgerState - getCurrentThreshold ls = - Just $ - getPParams ls.shelleyLedgerState - ^. ppLeiosQuorumStakeThresholdL - -- TODO: Use UnitInterval further upstream - & unboundRational - - -- The forecast counterpart of the two accessors above. Reading them from the - -- view rather than the state is what lets ChainSel validate a CertRB's - -- certificate before it has applied the block's predecessor. - -- - -- 'SNothingLeios' is unreachable at this extension, so this is total. getLeiosCommitteeFromView _ lv = case Views.plvLeios lv of SJustLeios llv -> From 75c4e3fdc002bd8d49211b11542f26891420dbc5 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 6 Oct 2026 09:40:13 -0400 Subject: [PATCH 42/60] LeiosFetch: regression test for bug Pascal Grange reported The LeiosFetch state was handling this case well, but its interactions with the LeiosDB/ChainSel state are not yet. --- .../Test/Consensus/Leios/RecoveryPath.hs | 214 +++++++++++++++++- 1 file changed, 213 insertions(+), 1 deletion(-) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs index c60ea64f44..9cee969a63 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs @@ -23,7 +23,7 @@ import Cardano.Crypto.DSIGN (signDSIGN) import Cardano.Ledger.BaseTypes (knownNonZeroBounded, unNonZero) import qualified Control.Concurrent.Class.MonadMVar as MVar import qualified Control.Concurrent.Class.MonadSTM as LazySTM -import Control.Monad (unless) +import Control.Monad (forM_, unless) import Control.Monad.Class.MonadTimer.SI (timeout) import Control.Monad.IOSim ( Failure (FailureException) @@ -32,6 +32,8 @@ import Control.Monad.IOSim , selectTraceEventsSay' , traceResult ) +import Ouroboros.Consensus.Ledger.Abstract (getTipSlot) +import Ouroboros.Consensus.Ledger.Extended (ledgerState) import Control.ResourceRegistry (withRegistry) import qualified Data.ByteString.Char8 as BS8 import qualified Data.IntMap.Strict as IntMap @@ -107,6 +109,15 @@ tests = , testCase "an endorser block referencing exactly what the slot allows is fetched" test_closureAtTheBoundIsFetched + , testCase + "an endorser block announced, acquired and announced again still certifies" + test_reannouncedNothingPruned + , testCase + "an endorser block announced, acquired, pruned and announced again still certifies" + test_reannouncedPruneThenReannounce + , testCase + "an endorser block announced, acquired, announced again and pruned still certifies" + test_reannouncedReannounceThenPrune , testCase "a peer claiming two certified endorser blocks for one election is dropped" test_twoCertificationClaimsIsDropped @@ -1242,6 +1253,207 @@ test_closureAtTheBoundIsFetched = do LeiosDb.withReader leiosDb $ \r -> not . null <$> LeiosDb.lookupEbBody r (pointEbHash boundaryPoint) +-- | One endorser block, announced twice, certified under the second +-- announcement. +-- +-- The whole test vector, in order. 'raWhen' orders the two halves of step 3; +-- every other step is the same in all three parameterizations. +-- +-- 1. The peer holds the endorser block and its closure, and no chain has been +-- served, so the node has selected nothing. +-- +-- 2. The peer announces the endorser block over LeiosNotify at slot 1 and +-- offers both the body and the closure. The node fetches the closure. Two +-- records now hold the endorser block, both aged by slot 1: the ChainDB's +-- acquired-closure set, which gates CertRBs ('isUnacquiredCertRB'), and the +-- fetch logic's 'ebState', which gates fetching. +-- +-- 3. In either order, as 'raWhen' chooses: +-- +-- [3prune]: The peer serves 'raPrefix' as its whole chain. Selecting it +-- carries the immutable tip past slot 1, and both records prune: the +-- acquired-closure set drops the endorser block, and so does 'ebState' --- +-- unless 3announce has already raised its entry to the second +-- announcement's slot. +-- +-- [3announce]: The peer announces the same endorser block again over +-- LeiosNotify, at 'raSecondPoint'. +-- +-- 4. The peer serves all of 'raChain'. Its second-to-last block repeats the +-- second announcement and its last block certifies that announcement. +-- +-- 5. The node is expected to select that CertRB. It can only do so once the +-- acquired-closure set holds the endorser block again, which takes a +-- re-fetch, which takes an 'ebState' entry that still wants the body. +data Reannounced = Reannounced + { raFirstAnnouncer :: !Blk + -- ^ Step 2. The first block of 'raChain' with the announcement added; the + -- hash ignores that field, so step 4 serves the same block without it. + , raFirstPoint :: !LeiosPoint + -- ^ What step 2 announces. + , raChain :: ![Blk] + -- ^ Step 4. One block per slot from 1. + , raSecondAnnouncer :: !Blk + -- ^ What 3announce announces, and the second-to-last block of step 4. + , raSecondPoint :: !LeiosPoint + -- ^ What 'raSecondAnnouncer' announces. + , raWhen :: !WhenReannounced + , raPrefix :: !(Maybe [Blk]) + -- ^ 3prune's chain, or 'Nothing' to skip step 3 entirely. + -- + -- A prefix of 'raChain' stopping short of 'raSecondAnnouncer': a peer serves + -- every header of whatever chain it has, so a chain reaching that block + -- would announce it, whatever blocks are withheld. + } + +-- | How 'Reannounced' orders step 3. +data WhenReannounced + = -- | Neither half runs: the chain is only @k@ blocks, so the immutable tip + -- never leaves Origin, and step 4 alone carries the second announcement. + NothingPruned + | -- | 3prune, then 3announce. + PruneThenReannounce + | -- | 3announce, then 3prune. + ReannounceThenPrune + deriving Show + +-- | Lay the steps out, putting the CertRB far enough along that 3prune can +-- reach past slot 1. +reannounced :: WhenReannounced -> Reannounced +reannounced when_ = + Reannounced + { raFirstAnnouncer = announcing firstPoint endorserSize (firstLeiosBlock 9) + , raFirstPoint = firstPoint + , raChain = chain + , raSecondAnnouncer = chain !! (secondSlot - 1) + , raSecondPoint = secondPoint + , raWhen = when_ + , raPrefix = (`take` chain) <$> mbPrefixSlot + } + where + k = fromIntegral (unNonZero (maxRollbacks securityParam)) + + mbPrefixSlot = case when_ of + NothingPruned -> Nothing + PruneThenReannounce -> Just (4 + k) + ReannounceThenPrune -> Just (4 + k) + + certSlot = maybe k (+ 4) mbPrefixSlot + + firstSlot = 1 :: Int + secondSlot = certSlot - 1 + + firstPoint = leiosTestEbPoint (fromIntegral firstSlot) endorserBlock + secondPoint = leiosTestEbPoint (fromIntegral secondSlot) endorserBlock + + chain = + [ decorate slot blk + | (slot, blk) <- + zip [1 ..] (take certSlot (iterate successorLeiosBlock (firstLeiosBlock 9))) + ] + + decorate slot blk + | slot == secondSlot = announcing secondPoint endorserSize blk + | slot == certSlot = certifying (mkCert testCommittee claim) blk + | otherwise = blk + + claim = MkRbHash $ toRawHash (Proxy @Blk) (blockHash (chain !! (secondSlot - 1))) + +-- | Run the steps of 'Reannounced' in order. +runReannounced :: Reannounced -> Assertion +runReannounced ra = do + assertBool + "the two announcements name one endorser block" + (pointEbHash (raFirstPoint ra) == pointEbHash (raSecondPoint ra)) + assertBool + "the two announcements are for different elections" + ( headerElId (getHeader (raFirstAnnouncer ra)) + /= headerElId (getHeader (raSecondAnnouncer ra)) + ) + let simTrace = runSimTrace scenario + case traceResult False simTrace of + Right () -> pure () + outcome -> + assertFailure $ + unlines $ + ("expected the CertRB's chain to be selected, but: " <> show outcome) + : lastN 40 (selectTraceEventsSay' simTrace) + where + scenario :: forall s. IOSim s () + scenario = do + nodeDBs <- emptyNodeDBs + leiosDb <- LeiosDb.newLeiosDBInMemory + holder <- newPeerEnv + + (chainDBTracer, getTraces) <- recordingTracerTVar + + withNodeUnderTest nodeConfig nodeDBs leiosDb chainDBTracer $ \nut -> + withRegistry $ \registry -> do + connectPeer nut registry (PeerAddr 0) holder + plantEb holder endorserBlock endorserClosure + + -- Every announcing header these relay is in a slot this simulation + -- starts before, and a header from the future is rejected as such, so + -- wait until the clock is past the latest of them. + threadDelay (fromIntegral (unSlotNo (pointSlotNo (raSecondPoint ra))) + 4) + + announceEb holder (getHeader (raFirstAnnouncer ra)) + offerEb holder (raFirstPoint ra) endorserSize + offerEbTxs holder (raFirstPoint ra) + + awaitPollingWith getTraces "the endorser block's closure is complete" $ + LeiosDb.withReader leiosDb $ \r -> + isJust <$> LeiosDb.lookupTrustedEbClosure r (pointEbHash (raFirstPoint ra)) + + -- No offer is needed alongside: the CertRB's own MsgRollForward + -- registers this peer as offering the endorser block its predecessor + -- announced ('recordCertRbOffer'). + let reannounce = announceEb holder (getHeader (raSecondAnnouncer ra)) + prune = forM_ (raPrefix ra) $ \prefix -> do + serveChain holder $ chainOf prefix + -- Two separate pruners watch the immutable tip, and this has to + -- wait for both: the ChainDB's acquired-closure set, which has + -- no observable of its own, and the fetch logic's, which does. + awaitPollingWith getTraces "the immutable tip passed the first announcement" $ + atomically $ do + immLedger <- ChainDB.getImmutableLedger (nutChainDB nut) + pure $ + getTipSlot (ledgerState immLedger) + > NotOrigin (pointSlotNo (raFirstPoint ra)) + awaitPollingWith getTraces "the fetch logic pruned the first announcement" $ + (> pointSlotNo (raFirstPoint ra)) . outstandingPrunedSlot + <$> MVar.readMVar (getLeiosOutstanding (nutKernel nut)) + + case raWhen ra of + NothingPruned -> pure () + PruneThenReannounce -> prune >> reannounce + ReannounceThenPrune -> reannounce >> prune + + serveChain holder $ chainOf (raChain ra) + + awaitWith getTraces "the CertRB's chain is selected" $ + tipIsSTM nut (last (raChain ra)) + +-- | No prune, so both records still hold the endorser block at step 5. +test_reannouncedNothingPruned :: Assertion +test_reannouncedNothingPruned = runReannounced (reannounced NothingPruned) + +-- | Self-healing: 3prune takes the 'ebState' entry too, so 3announce finds +-- nothing and starts the endorser block over, and the re-acquired closure puts +-- it back in the acquired-closure set in time for step 5. +test_reannouncedPruneThenReannounce :: Assertion +test_reannouncedPruneThenReannounce = + runReannounced (reannounced PruneThenReannounce) + +-- | Not self-healing: 3announce raises the 'ebState' entry above the immutable +-- tip, so it survives 3prune as 'BodyAcquired' and nothing re-fetches. The +-- acquired-closure set is still aged by slot 1, so the same prune drops the +-- endorser block from it, and step 5 never happens: the CertRB stays hidden by +-- 'isUnacquiredCertRB' with nothing left that could restore it. +test_reannouncedReannounceThenPrune :: Assertion +test_reannouncedReannounceThenPrune = + runReannounced (reannounced ReannounceThenPrune) + -- | An endorser block two elections announced is still fetched after the -- earlier announcement's point has been pruned away. -- From 5c1ae3b5d1852f8a8a2dc24f2d84077a85b3d397 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 6 Oct 2026 15:03:06 -0400 Subject: [PATCH 43/60] LeiosNotify: write centrally-processed announcements to LeiosDb This fixes the bug where cdbAcquiredEbs wasn't necessary storing the youngest slot for some EB. It also ensures AcquiredEb and AcquiredEbTxs are emitted for a LeiosPoint even if its EB was already in the LeiosDb when this LeiosPoint was first announced. --- ...nick.frisby_leios_reannounce_freshening.md | 64 +++++++++ .../Cardano/Tools/DBSynthesizer/Forging.hs | 2 +- .../Ouroboros/Consensus/Network/NodeToNode.hs | 3 + .../Ouroboros/Consensus/NodeKernel.hs | 7 + .../Test/Consensus/Leios/RecoveryPath.hs | 4 +- .../bench/leios-db-bench/Main.hs | 2 +- .../bench/leios-gc-bench/Main.hs | 4 +- .../ouroboros-consensus/LeiosDemoDb/Common.hs | 23 +++- .../LeiosDemoDb/InMemory.hs | 119 +++++++++++++---- .../ouroboros-consensus/LeiosDemoDb/SQLite.hs | 126 ++++++++++++++++-- .../src/ouroboros-consensus/LeiosDemoLogic.hs | 28 +++- 11 files changed, 329 insertions(+), 53 deletions(-) create mode 100644 changelog.d/20261006_150000_nick.frisby_leios_reannounce_freshening.md diff --git a/changelog.d/20261006_150000_nick.frisby_leios_reannounce_freshening.md b/changelog.d/20261006_150000_nick.frisby_leios_reannounce_freshening.md new file mode 100644 index 0000000000..292b2e18e2 --- /dev/null +++ b/changelog.d/20261006_150000_nick.frisby_leios_reannounce_freshening.md @@ -0,0 +1,64 @@ +### Patch + +- Leios: age an endorser block by the youngest slot that announces it. + + An endorser block announced at slot Y, acquired, and then announced again at + slot Z > Y kept two records disagreeing about its age: the fetch logic's + `ebState` moved to Z, while the ChainDB's `cdbAcquiredLeiosEbs` stayed at Y + and was pruned once the immutable tip passed Y. Nothing then re-fetched the + endorser block, so no closure-completion notification ever restored it, and + `isUnacquiredCertRB` hid its CertRB from chain selection permanently. + + `writeEbPoint` now repeats, at the new point, whichever notifications the + endorser block has already earned: `AcquiredEb` once its body is stored and + `AcquiredEbTxs` once its closure is complete. The announcement path calls it, + so the acquired-closure set is freshened by the same event that feeds it + normally, the new point is persisted for the restart re-seed, and the endorser + block is offered onward under the slot it was just announced at. A point + inserted for an endorser block still being fetched also joins the set whose + closure completion is tracked, so it completes alongside the points already + tracking it. + + `ebs.ebBytesSize` now means: the body's actual size once that point has + acquired it, and the first size the point was announced at before that. The + body is the authority on its own size, so a row written by an announcement is + corrected when the body lands, and an endorser block is never offered at a + size an announcement merely claimed. Only the acquired rows are read, by + `sql_lookup_stored_eb_size`. + + Nothing used to read the column at all, so an existing database may hold a row + whose size is not its endorser block's. This recomputes every acquired row + from the references the body actually carries: + + ```sql + UPDATE ebs + SET ebBytesSize = + ( SELECT ( CASE WHEN COUNT(*) < 24 THEN 1 + WHEN COUNT(*) < 256 THEN 2 + WHEN COUNT(*) < 65536 THEN 3 + ELSE 5 + END ) + + SUM( 34 + CASE WHEN txBytesSize < 24 THEN 1 + WHEN txBytesSize < 256 THEN 2 + WHEN txBytesSize < 65536 THEN 3 + ELSE 5 + END ) + FROM ebTxs + WHERE ebTxs.ebHashBytes = ebs.ebHashBytes + ) + WHERE missingTxCount IS NOT NULL; + ``` + + An existing database also lacks the index that lookup seeks on, since + `sql_schema` runs only when a partition is created: + + ```sql + CREATE INDEX IF NOT EXISTS idx_ebs_acquired + ON ebs(ebHashBytes) WHERE missingTxCount IS NOT NULL; + ``` + + Run both against the volatile and the immutable partition alike. The `34` is the + 32-byte transaction hash plus its two-byte CBOR length prefix; the `CASE` + arms are `cborIntBytesSize`. Rows whose body has not been acquired + (`missingTxCount IS NULL`) keep the size they were announced at, which is what + the new semantics says they should hold. diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs index db1223ab45..0ee4dc8f24 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs @@ -223,7 +223,7 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg votingKey genTxs leio leiosDbWriter forgedEb.point [(off, bs) | (off, (_txh, bs)) <- zip [0 ..] forgedEb.txClosure] - awaitAll [pointWritten, void bodyWritten, void txsWritten] + awaitAll [void pointWritten, void bodyWritten, void txsWritten] traceWith leiosTracer $ TraceLeiosBlockStored{slot = forgedEb.point.pointSlotNo, eb = forgedEb.body} diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 54ecf2bbb0..07587a7876 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -465,6 +465,7 @@ mkHandlers getLeiosCentralState (getLeiosOutstanding, getLeiosReady) getLeiosTxCache + leiosCentralWriter (Just peer) Leios.ReceivedViaChainSync Announcements.DoRelay @@ -620,6 +621,7 @@ mkHandlers getLeiosCentralState (getLeiosOutstanding, getLeiosReady) getLeiosTxCache + leiosCentralWriter (Just peer) Leios.ReceivedViaLeiosNotify shouldRelay @@ -865,6 +867,7 @@ mkHandlers where NodeKernel { getLeiosDB = leiosDB + , getLeiosCentralWriter = leiosCentralWriter , getLeiosVoteState = leiosVoteState , getLeiosOutstanding , getLeiosReady diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 2939bb41b4..42684be974 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -244,6 +244,11 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel , getLeiosDB :: LeiosDbHandle m -- ^ Factory for opening per-thread readers and writers of the Leios demo DB -- and subscribing to EB-notification events. + , getLeiosCentralWriter :: LeiosDb.LeiosDbWriter m + -- ^ The writer the central announcement handling uses, open for the life of + -- the node. A writer is a facade over the shared write queue rather than a + -- connection, and closing one only flushes, so the announcement paths share + -- this one instead of bracketing their own per announcement. , getLeiosVoteState :: LeiosVoteState m -- ^ Aggregated vote state across all peers. Empty in S4; populated -- by the voting thread in S5. @@ -350,6 +355,7 @@ initNodeKernel } = do -- using a lazy 'TVar', 'BlockForging' does not have a 'NoThunks' instance. blockForgingVar :: LazySTM.TMVar m [MkBlockForging m blk] <- LazySTM.newTMVarIO [] + leiosCentralWriter <- LeiosDb.openWriter leiosDB initChainDB (configStorage cfg) (InitChainDB.fromFull chainDB) st <- initInternalState args @@ -701,6 +707,7 @@ initNodeKernel , getTxDecisionPolicy = txDecisionPolicy miniProtocolParameters , getLeiosMinOfferLead = leiosMinOfferLead , getLeiosDB = leiosDB + , getLeiosCentralWriter = leiosCentralWriter , getLeiosVoteState = leiosVoteState , getLeiosPeersVars = getLeiosPeersVars , getLeiosOutstanding = getLeiosOutstanding diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs index 9cee969a63..19e2a2a5bc 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Leios/RecoveryPath.hs @@ -32,8 +32,6 @@ import Control.Monad.IOSim , selectTraceEventsSay' , traceResult ) -import Ouroboros.Consensus.Ledger.Abstract (getTipSlot) -import Ouroboros.Consensus.Ledger.Extended (ledgerState) import Control.ResourceRegistry (withRegistry) import qualified Data.ByteString.Char8 as BS8 import qualified Data.IntMap.Strict as IntMap @@ -64,6 +62,8 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (slotLengthFromSec) import Ouroboros.Consensus.Config (SecurityParam (..), maxRollbacks) import qualified Ouroboros.Consensus.HardFork.History as HardFork +import Ouroboros.Consensus.Ledger.Abstract (getTipSlot) +import Ouroboros.Consensus.Ledger.Extended (ledgerState) import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import Ouroboros.Consensus.NodeKernel (NodeKernel (..)) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB diff --git a/ouroboros-consensus/bench/leios-db-bench/Main.hs b/ouroboros-consensus/bench/leios-db-bench/Main.hs index 726f15b271..872e1cf1ee 100644 --- a/ouroboros-consensus/bench/leios-db-bench/Main.hs +++ b/ouroboros-consensus/bench/leios-db-bench/Main.hs @@ -252,7 +252,7 @@ insertOneEb writer ebIdx = do pointWritten <- writeEbPoint writer point (encodeLeiosEbSize eb) bodyWritten <- writeEbBody writer point eb [] txsWritten <- writeTxs writer point txs - awaitAll [pointWritten, void bodyWritten, void txsWritten] + awaitAll [void pointWritten, void bodyWritten, void txsWritten] -- * Deterministic data generation diff --git a/ouroboros-consensus/bench/leios-gc-bench/Main.hs b/ouroboros-consensus/bench/leios-gc-bench/Main.hs index 58938bfe5c..4f1987be69 100644 --- a/ouroboros-consensus/bench/leios-gc-bench/Main.hs +++ b/ouroboros-consensus/bench/leios-gc-bench/Main.hs @@ -433,7 +433,7 @@ populateDb opts db = pointWritten <- writeEbPoint writer point (encodeLeiosEbSize eb) bodyWritten <- writeEbBody writer point eb [] txsWritten <- writeTxs writer point txs - awaitAll [pointWritten, void bodyWritten, void txsWritten] + awaitAll [void pointWritten, void bodyWritten, void txsWritten] pure (slot, hashBytes) -- | Drop the tx -> referencing-EB index from the volatile partition @@ -542,7 +542,7 @@ runPhases opts db flushEvents latRef sweepBacklog schedule immBefore = bodyWritten <- writeEbBody w point eb [] txsWritten <- writeTxs w point txs -- Awaiting all three times them to durability. - awaitAll [pointWritten, void bodyWritten, void txsWritten] + awaitAll [void pointWritten, void bodyWritten, void txsWritten] pure () ) _ <- flushEvents -- discard events from handle setup diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs index fd7805cf2a..769cdb0f18 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs @@ -111,8 +111,27 @@ data LeiosDbReader m = LeiosDbReader data LeiosDbWriter m = LeiosDbWriter { close :: m () -- ^ Close writer and flush all remaining writes. - , writeEbPoint :: HasCallStack => LeiosPoint -> BytesSize -> m (Promise m ()) - -- ^ Record an announced EB's point and expected size. + , writeEbPoint :: HasCallStack => LeiosPoint -> BytesSize -> m (Promise m CompletedEbs) + -- ^ Record an announced EB's point and the size it was announced at. + -- Idempotent: a second insert at the same point changes nothing. + -- + -- A point novel for a hash whose body is already stored has reached, on + -- arrival, every milestone that body reached when it landed, so it repeats + -- their notifications at this point: 'AcquiredEb' at the stored body's size, + -- and 'AcquiredEbTxs' if the closure is already complete. Returns any EBs + -- whose closure this completed, which is this one in that last case. A + -- closure still being fetched completes at this point too, alongside the + -- points already tracking it. + -- + -- TODO drop the size argument. Nothing here needs the size an endorser block + -- was announced at --- that is a peer's claim, not something the database + -- needs to know --- and the only size it should hold is the one its stored + -- body really is, which 'writeEbBody' supplies. Note that a 'LeiosPoint' + -- could not key an announced size even in principle: multiple elections (so: + -- /no equivocation/) in one slot could announce a different size for the same + -- EB. Dropping it leaves a point with no size until its body lands, so the + -- SQL schema's @ebBytesSize INTEGER NOT NULL@ has to be relaxed at the same + -- time. , writeEbBody :: HasCallStack => LeiosPoint -> LeiosEb -> [LocalFill] -> m (Promise m (CompletedEbs, [TxOffset])) diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs index ca90248694..8d0415995c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs @@ -76,16 +76,30 @@ data InMemoryLeiosDb = InMemoryLeiosDb -- SQLite backend's @ebTxBytes@ table. A tx shared by two EBs is stored -- twice, deliberately. , imEbPoints :: !(Map LeiosPoint BytesSize) - -- ^ Inserted EB points with their expected sizes. The same EB - -- content can be inserted at multiple slots; each - -- @(slot, hash)@ point has its own entry and completes - -- independently. + -- ^ Inserted EB points with their sizes. The same EB content can be + -- inserted at multiple slots; each @(slot, hash)@ point has its own entry + -- and completes independently. + -- + -- As in the SQL backend's @ebs.ebBytesSize@: the body's actual size once + -- this point is in 'imEbBodiesDownloaded', and the first size this point was + -- announced at before that. Nothing reads it --- looking an acquired size up + -- by hash goes to 'imEbBodies' --- but it is kept faithful to the column. + -- + -- If multiple announcements /with different elections/ insert the same + -- 'LeiosPoint' with a different 'BytesSize', then only the first is recorded. + -- (TODO see the TODO on 'writeEbPoint') , imEbBodiesDownloaded :: !(Set LeiosPoint) -- ^ Subset of 'imEbPoints' for which 'writeEbBody' has been -- called. Only these points are considered for completion. - , imEbBodies :: !(Map EbHash (IntMap {- txOffset -} EbTxEntry)) - -- ^ EB tx-hash list, keyed by content hash. Shared across every - -- point that references the same EB. + , imEbBodies :: !(Map EbHash StoredEbBody) + -- ^ Keyed by content hash, so shared across every point that references the + -- same EB. + -- + -- The SQL backend has no per-hash table to put the size in, so there it + -- shares the per-point @ebs.ebBytesSize@ column with the announced sizes, + -- and finding it means a query restricted to the points that have acquired + -- the body --- 'sql_lookup_stored_eb_size', which the partial index + -- @idx_ebs_acquired@ accelerates. Here a hash keys it directly. , imCompletedEbs :: !(Set LeiosPoint) -- ^ Points for which 'AcquiredEbTxs' has already been broadcast. -- The completion predicate stays true once an EB is complete, so @@ -102,6 +116,15 @@ data InMemoryLeiosDb = InMemoryLeiosDb emptyInMemoryLeiosDb :: InMemoryLeiosDb emptyInMemoryLeiosDb = InMemoryLeiosDb mempty mempty mempty mempty mempty +-- | A stored EB body: the references it carries, and the size of the encoding +-- of those references, which is what identifies the body (see 'hashLeiosEb'). +data StoredEbBody = StoredEbBody + { sebBytesSize :: !BytesSize + , sebTxEntries :: !(IntMap {- txOffset -} EbTxEntry) + } + deriving stock Generic + deriving anyclass NoThunks + -- | EB transaction entry (references txs by hash, no bytes stored here) data EbTxEntry = EbTxEntry { eteTxHash :: !TxHash @@ -166,7 +189,9 @@ openInMemoryWriter stateVar notificationChan = LeiosDbWriter { close = pure () , writeEbPoint = \point ebBytesSize -> - resolved ("WriteEbPoint " <> show point) (imInsertEbPoint stateVar point ebBytesSize) + resolved + ("WriteEbPoint " <> show point) + (imInsertEbPoint stateVar notificationChan point ebBytesSize) , writeEbBody = \point eb fills -> resolved ("WriteEbBody " <> show point) @@ -200,22 +225,55 @@ imScanEbPoints stateVar = atomically $ do | p <- Map.keys (imEbPoints state) ] --- | Insert an announced EB point. Idempotent: a second insert at the --- same point keeps the first-seen size. -imInsertEbPoint :: IOLike m => StrictTVar m InMemoryLeiosDb -> LeiosPoint -> BytesSize -> m () -imInsertEbPoint stateVar point ebBytesSize = atomically $ - modifyTVar stateVar $ \s -> - s{imEbPoints = Map.insertWith (\_ old -> old) point ebBytesSize (imEbPoints s)} +-- | Implements 'writeEbPoint'. +-- +-- The new point is added to 'imEbBodiesDownloaded'. 'imInsertTxs' considers +-- only the points in that set, so adding it there is what lets a later +-- transaction arrival complete this point's closure. +imInsertEbPoint :: + IOLike m => + StrictTVar m InMemoryLeiosDb -> + StrictTChan m LeiosEbNotification -> + LeiosPoint -> + BytesSize -> + m CompletedEbs +imInsertEbPoint stateVar notificationChan point ebBytesSize = atomically $ do + state <- readTVar stateVar + if Map.member point (imEbPoints state) + then pure [] + else do + modifyTVar stateVar $ \s -> + s{imEbPoints = Map.insert point ebBytesSize (imEbPoints s)} + case Map.lookup point.pointEbHash (imEbBodies state) of + Nothing -> pure [] + Just storedBody -> do + modifyTVar stateVar $ \s -> + s + { -- This point has acquired the body, so its size is the body's + -- actual size rather than the one just announced. + imEbPoints = + Map.insert point (sebBytesSize storedBody) (imEbPoints s) + , imEbBodiesDownloaded = Set.insert point (imEbBodiesDownloaded s) + } + writeTChan notificationChan $ + AcquiredEb point (sebBytesSize storedBody) + if hashCompleteIn state point.pointEbHash + then do + modifyTVar stateVar $ \s -> + s{imCompletedEbs = Set.insert point (imCompletedEbs s)} + writeTChan notificationChan $ AcquiredEbTxs point + pure [point] + else pure [] imLookupEbBody :: IOLike m => StrictTVar m InMemoryLeiosDb -> EbHash -> m [(TxHash, BytesSize)] imLookupEbBody stateVar ebHash = atomically $ do state <- readTVar stateVar case Map.lookup ebHash (imEbBodies state) of Nothing -> pure [] - Just offsetMap -> + Just storedBody -> pure [ (eteTxHash e, eteTxBytesSize e) - | e <- IntMap.elems offsetMap + | e <- IntMap.elems (sebTxEntries storedBody) ] imInsertEbBody :: @@ -247,7 +305,15 @@ imInsertEbBody stateVar notificationChan point eb fills = do { -- The tx-hash list is fully determined by the EB content -- hash, so a second insertion at the same hash is a no-op. imEbBodies = - Map.insertWith (\_ old -> old) point.pointEbHash entries (imEbBodies s) + Map.insertWith + (\_ old -> old) + point.pointEbHash + (StoredEbBody ebBytesSize entries) + (imEbBodies s) + , -- This point has acquired the body, so its size becomes the body's + -- actual size, whatever size it was announced at. + imEbPoints = + Map.insert point ebBytesSize (imEbPoints s) , -- Mark this point as downloaded. Other points referencing -- the same EB hash are unaffected; each needs its own -- 'writeEbBody' to be considered complete. @@ -261,7 +327,7 @@ imInsertEbBody stateVar notificationChan point eb fills = do -- EB fills nothing), and the size must match the declaration. st0 <- readTVar stateVar let ebHash = point.pointEbHash - declared = Map.findWithDefault IntMap.empty ebHash (imEbBodies st0) + declared = maybe IntMap.empty sebTxEntries (Map.lookup ebHash (imEbBodies st0)) held = Map.findWithDefault IntMap.empty ebHash (imEbTxBytes st0) accepted = IntMap.fromList @@ -270,7 +336,7 @@ imInsertEbBody stateVar notificationChan point eb fills = do , Just e <- [IntMap.lookup dstOff declared] , not (IntMap.member dstOff held) , Just srcE <- - [IntMap.lookup srcOff (Map.findWithDefault IntMap.empty srcEb (imEbBodies st0))] + [IntMap.lookup srcOff (maybe IntMap.empty sebTxEntries (Map.lookup srcEb (imEbBodies st0)))] , eteTxHash srcE == eteTxHash e , Just bytes <- [IntMap.lookup srcOff (Map.findWithDefault IntMap.empty srcEb (imEbTxBytes st0))] @@ -302,9 +368,9 @@ imInsertEbBody stateVar notificationChan point eb fills = do hashCompleteIn :: InMemoryLeiosDb -> EbHash -> Bool hashCompleteIn state h = case Map.lookup h (imEbBodies state) of Nothing -> False - Just entries -> + Just storedBody -> let bytes = Map.findWithDefault IntMap.empty h (imEbTxBytes state) - in IntMap.keysSet entries `IntSet.isSubsetOf` IntMap.keysSet bytes + in IntMap.keysSet (sebTxEntries storedBody) `IntSet.isSubsetOf` IntMap.keysSet bytes imInsertTxs :: IOLike m => @@ -321,7 +387,7 @@ imInsertTxs stateVar notificationChan point offBytes = atomically $ do -- before the body are dropped (production cannot produce them: the writer -- queue is FIFO and tx writes follow their body write). modifyTVar stateVar $ \s -> - let declared = Map.findWithDefault IntMap.empty ebHash (imEbBodies s) + let declared = maybe IntMap.empty sebTxEntries (Map.lookup ebHash (imEbBodies s)) held = Map.findWithDefault IntMap.empty ebHash (imEbTxBytes s) accepted = IntMap.fromList @@ -388,11 +454,11 @@ imBatchRetrieveTxs stateVar ebHash offsets = atomically $ do state <- readTVar stateVar case Map.lookup ebHash (imEbBodies state) of Nothing -> pure [] - Just offsetMap -> + Just storedBody -> pure [ (offset, eteTxHash entry, IntMap.lookup offset bytes) | offset <- offsets - , Just entry <- [IntMap.lookup offset offsetMap] + , Just entry <- [IntMap.lookup offset (sebTxEntries storedBody)] ] where bytes = Map.findWithDefault IntMap.empty ebHash (imEbTxBytes state) @@ -403,8 +469,9 @@ imLookupTrustedEbClosure stateVar ebHash = atomically $ do state <- readTVar stateVar case Map.lookup ebHash (imEbBodies state) of Nothing -> pure Nothing - Just entries -> - let bytes = Map.findWithDefault IntMap.empty ebHash (imEbTxBytes state) + Just storedBody -> + let entries = sebTxEntries storedBody + bytes = Map.findWithDefault IntMap.empty ebHash (imEbTxBytes state) txClosure = [ (eteTxHash e, tx) | (off, e) <- IntMap.toAscList entries diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs index a2f6c60ff5..cf1617b289 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs @@ -859,6 +859,8 @@ sweepEbBatch conn batchSize = do data VolStmts = VolStmts { stScanEbPoints :: !DB.Statement , stInsertEbPoint :: !DB.Statement + , stLookupStoredEbSize :: !DB.Statement + , stSetEbPointSize :: !DB.Statement , stLookupEbBody :: !DB.Statement , stInsertEbTxsRow :: !DB.Statement , stInitMissingCount :: !DB.Statement @@ -920,6 +922,8 @@ prepareVolStmts :: DB.Database -> IO VolStmts prepareVolStmts db = do stScanEbPoints <- dbPrepare db (fromString sql_scan_ebs) stInsertEbPoint <- dbPrepare db (fromString sql_insert_eb) + stLookupStoredEbSize <- dbPrepare db (fromString sql_lookup_stored_eb_size) + stSetEbPointSize <- dbPrepare db (fromString sql_set_eb_point_size) stLookupEbBody <- dbPrepare db (fromString sql_lookup_ebBodies) stInsertEbTxsRow <- dbPrepare db (fromString sql_insert_ebBody) stInitMissingCount <- dbPrepare db (fromString sql_init_missing_tx_count) @@ -939,6 +943,8 @@ finalizeVolStmts :: VolStmts -> IO () finalizeVolStmts VolStmts{..} = do dbFinalize stScanEbPoints dbFinalize stInsertEbPoint + dbFinalize stLookupStoredEbSize + dbFinalize stSetEbPointSize dbFinalize stLookupEbBody dbFinalize stInsertEbTxsRow dbFinalize stInitMissingCount @@ -1010,7 +1016,7 @@ closeChecked db = -- for a write lock on the volatile partition. Sweeping is not a job at all -- -- the worker does it between jobs; see 'startWriter'. data WriteJob - = WriteEbPoint !LeiosPoint !BytesSize !(WriteResult ()) + = WriteEbPoint !LeiosPoint !BytesSize !(WriteResult CompletedEbs) | WriteEbBody !LeiosPoint !LeiosEb ![LocalFill] !(WriteResult (CompletedEbs, [TxOffset])) | WriteTxs !LeiosPoint ![(TxOffset, ByteString)] !(WriteResult CompletedEbs) | -- | Does nothing; awaiting it after the queue's FIFO order means every @@ -1216,7 +1222,7 @@ startWriter tracer statsVar notificationChan sweepDoorbell gcBatchSize volPath i atomically $ putTMVar resultVar result pure True WriteEbPoint point size resultVar -> - publish resultVar (sqlInsertEbPoint conn point size) >> pure False + publish resultVar (sqlInsertEbPoint conn notify point size) >> pure False WriteEbBody point eb fills resultVar -> publish resultVar (sqlInsertEbBody tracer conn notify point eb fills) >> pure False WriteTxs point offBytes resultVar -> @@ -1500,17 +1506,74 @@ bodyLoop stmt acc = size <- fromIntegral <$> DB.columnInt64 stmt 1 bodyLoop stmt ((txHash, size) : acc) -sqlInsertEbPoint :: Conn -> LeiosPoint -> BytesSize -> IO () -sqlInsertEbPoint conn point ebBytesSize = do - inserted <- dbWithWriteTransaction conn $ useStmt stmt $ do - dbBindInt64 stmt 1 (fromIntegral $ unSlotNo point.pointSlotNo) - dbBindBlob stmt 2 (ebHashBytes point.pointEbHash) - dbBindInt64 stmt 3 (fromIntegral ebBytesSize) - dbStep1 stmt - DB.changes db +sqlInsertEbPoint :: + Conn -> + (LeiosEbNotification -> IO ()) -> + LeiosPoint -> + BytesSize -> + IO CompletedEbs +sqlInsertEbPoint conn notify point ebBytesSize = do + (inserted, mbAcquired) <- dbWithWriteTransaction conn $ do + inserted <- useStmt stInsertEbPoint $ do + dbBindInt64 stInsertEbPoint 1 (fromIntegral $ unSlotNo point.pointSlotNo) + dbBindBlob stInsertEbPoint 2 (ebHashBytes point.pointEbHash) + dbBindInt64 stInsertEbPoint 3 (fromIntegral ebBytesSize) + dbStep1 stInsertEbPoint + DB.changes db + if inserted == 0 + then pure (inserted, Nothing) + else do + -- Cannot match the row just inserted, whose @missingTxCount@ is NULL. + mbStoredSize <- useStmt stLookupStoredEbSize $ do + dbBindBlob stLookupStoredEbSize 1 (ebHashBytes point.pointEbHash) + dbStep stLookupStoredEbSize >>= \case + DB.Done -> pure Nothing + DB.Row -> + Just . fromIntegral <$> DB.columnInt64 stLookupStoredEbSize 0 + case mbStoredSize of + Nothing -> pure (inserted, Nothing) + Just storedSize -> do + -- The @ebs.ebHashBytes@ field might have been incorrect, since + -- announcements aren't necessarily + -- correct. 'sql_lookup_stored_eb_size' needs it to be correct, so + -- overwrite it now. + useStmt stSetEbPointSize $ do + dbBindInt64 stSetEbPointSize 1 (fromIntegral storedSize) + dbBindInt64 stSetEbPointSize 2 (fromIntegral $ unSlotNo point.pointSlotNo) + dbBindBlob stSetEbPointSize 3 (ebHashBytes point.pointEbHash) + dbStep1 stSetEbPointSize + missingCount <- useStmt stInitMissingCount $ do + dbBindBlob stInitMissingCount 1 (ebHashBytes point.pointEbHash) + dbBindBlob stInitMissingCount 2 (ebHashBytes point.pointEbHash) + dbBindInt64 stInitMissingCount 3 (fromIntegral $ unSlotNo point.pointSlotNo) + readReturningInt64 stInitMissingCount + completed <- + if missingCount /= 0 + then pure [] + else do + useStmt stMarkPointNotified $ do + dbBindInt64 stMarkPointNotified 1 (fromIntegral $ unSlotNo point.pointSlotNo) + dbBindBlob stMarkPointNotified 2 (ebHashBytes point.pointEbHash) + dbStep1 stMarkPointNotified + pure [point] + pure (inserted, Just (storedSize, completed)) bumpVolatileStats conn inserted + forM_ mbAcquired $ \(storedSize, completed) -> do + notify (AcquiredEb point storedSize) + forM_ completed $ notify . AcquiredEbTxs + pure $ maybe [] snd mbAcquired where - Conn{conVolDb = db, connVolStmts = VolStmts{stInsertEbPoint = stmt}} = conn + Conn + { conVolDb = db + , connVolStmts = + VolStmts + { stInsertEbPoint + , stLookupStoredEbSize + , stSetEbPointSize + , stInitMissingCount + , stMarkPointNotified + } + } = conn -- | Persist an EB body. The point MUST already be present (inserted -- via 'sqlInsertEbPoint' on the announcement path). @@ -1553,6 +1616,13 @@ sqlInsertEbBody tracer conn notify point eb fills = do "ebTxs" (show point.pointEbHash <> "@" <> show txOffset) stInsertEbTxsRow + -- The body is the authority on its own size, whatever size the + -- announcement's point was inserted at; see 'sql_lookup_stored_eb_size'. + useStmt stSetEbPointSize $ do + dbBindInt64 stSetEbPointSize 1 (fromIntegral ebBytesSize) + dbBindInt64 stSetEbPointSize 2 (fromIntegral $ unSlotNo point.pointSlotNo) + dbBindBlob stSetEbPointSize 3 ebHashRaw + dbStep1 stSetEbPointSize -- Allocate the closure's rows in one offset-ordered pass; see -- 'sql_prealloc_ebTxBytes'. useStmt stPreallocEbTxBytes $ do @@ -1607,6 +1677,7 @@ sqlInsertEbBody tracer conn notify point eb fills = do , stFillFromLocal , stInitMissingCount , stMarkPointNotified + , stSetEbPointSize } = connVolStmts -- | Read a single-column @Int64@ from a statement that uses a @@ -1890,7 +1961,10 @@ sql_schema = [ "CREATE TABLE ebs (" , " ebSlot INTEGER NOT NULL," , " ebHashBytes BLOB NOT NULL," - , " ebBytesSize INTEGER NOT NULL," + , -- the body's actual size once this point has acquired it (see + -- 'sql_lookup_stored_eb_size'), and the first size it was announced at + -- before that + " ebBytesSize INTEGER NOT NULL," , -- NULL = body not downloaded, >0 = txs missing, 0 = just completed, <0 = notified " missingTxCount INTEGER," , -- 0 = volatile, 1 = certified/pinned awaiting copy, @@ -1900,6 +1974,12 @@ sql_schema = , " PRIMARY KEY (ebSlot, ebHashBytes)" , ");" , "CREATE INDEX idx_ebs_ebHashBytes ON ebs(ebHashBytes);" + , -- What 'sql_lookup_stored_eb_size' seeks on. Partial, so the rows that + -- name a hash without having fetched its body are never visited: an + -- attacker announcing one hash in every slot it wins makes them as + -- numerous as its elections in the live window, and every later + -- announcement of that hash would otherwise visit them all again. + "CREATE INDEX idx_ebs_acquired ON ebs(ebHashBytes) WHERE missingTxCount IS NOT NULL;" , -- The body: one row per referenced tx, written in one pass when the body -- arrives. 'txHashBytes' is a payload here, not a key -- nothing indexes -- by tx hash, so the insert is sequential within the EB. Optimized for @@ -1986,6 +2066,28 @@ sql_insert_eb :: String sql_insert_eb = "INSERT OR IGNORE INTO ebs (ebSlot, ebHashBytes, ebBytesSize) VALUES (?, ?, ?)" +-- | The size the stored body of this EB really is, read off whichever of its +-- points has already acquired it (@missingTxCount IS NOT NULL@) --- the rows +-- whose @ebBytesSize@ is an actual size rather than an announcement's claim. +-- +-- @idx_ebs_acquired@ indexes exactly those rows, so this is a seek among them +-- rather than a walk over every point naming the hash. +-- +-- Parameters: 1 = ebHashBytes +sql_lookup_stored_eb_size :: String +sql_lookup_stored_eb_size = + "SELECT ebBytesSize FROM ebs\n\ + \WHERE ebHashBytes = ? AND missingTxCount IS NOT NULL\n\ + \LIMIT 1\n\ + \" + +-- | Overwrite one point's recorded size; see 'sql_lookup_stored_eb_size'. +-- +-- Parameters: 1 = ebBytesSize, 2 = ebSlot, 3 = ebHashBytes +sql_set_eb_point_size :: String +sql_set_eb_point_size = + "UPDATE ebs SET ebBytesSize = ? WHERE ebSlot = ? AND ebHashBytes = ?" + sql_lookup_ebBodies :: String sql_lookup_ebBodies = "SELECT txHashBytes, txBytesSize FROM ebTxs\n\ diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs index e011c128e4..dd16959268 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs @@ -1088,11 +1088,16 @@ processLeiosBlock ktracer tracer (outstandingVar, readyVar) txCache writer syste -- fetch job set above) when shouldPersist $ traceException tracer TraceLeiosPeerDbException $ do - -- FIXME the announcement path does not write the point: 'writeEbPoint' - -- has no caller but this one, so the arriving body is still what first - -- records the point. Were an announcement to record it, this insert - -- would be redundant and the trace below would mean something is wrong; - -- today it fires for every body, so it means nothing. + -- TODO remove the 'writeEbPoint' call below once no important node's + -- VolatileDB still holds an announcing RB that it fetched without this + -- patch. 'processAnnouncementCentrally' records the point now, and that + -- write is persistent, so the only endorser blocks still reaching here + -- without one are those announced by an RB this node selected before it + -- ran this code. + -- + -- The trace below is unconditional, so it fires for every body and means + -- nothing. Conditioning it on the point being absent would make it + -- report exactly the endorser blocks described above. traceWith ktracer $ TraceLeiosBlockPointMissing point -- Enqueue the write first, then claim the body. 'writeEbBody' only parks -- on a free writer-queue slot (bounded backpressure), so a cancellation @@ -1110,7 +1115,7 @@ processLeiosBlock ktracer tracer (outstandingVar, readyVar) txCache writer syste pointWritten <- writeEbPoint writer point ebBytesSize' bodyWritten <- writeEbBody writer point eb fills let settle = do - await pointWritten + completedByPoint <- await pointWritten (completedByBody, filledOffs) <- await bodyWritten -- The fetch set is what the settled write still misses: the fills -- that landed are durable rows, everything else -- fills whose source @@ -1134,7 +1139,7 @@ processLeiosBlock ktracer tracer (outstandingVar, readyVar) txCache writer syste void $ MVar.tryPutMVar readyVar () st <- Leios.ebState <$> MVar.readMVar outstandingVar traceWith ktracer $ TraceLeiosBlockAcquired point (ebPointAge now st point) - forM_ completedByBody $ \p -> + forM_ (completedByPoint <> completedByBody) $ \p -> traceWith ktracer $ TraceLeiosBlockTxsAcquired p (ebPointAge now st p) case source of -- The forge must not advertise what it has not stored, so it waits. @@ -1779,6 +1784,7 @@ processAnnouncementCentrally :: MVar m (Announcements.CentralState m peer (AnnouncingHeader blk)) -> (MVar m (LeiosOutstanding pid), MVar m ()) -> LeiosTxCache m () () SerializedEbBody -> + LeiosDbWriter m -> Maybe peer -> AnnouncementSource -> ShouldRelay -> @@ -1796,6 +1802,7 @@ processAnnouncementCentrally centralVar kernelVars txCache + writer source provenance shouldRelay @@ -1817,6 +1824,12 @@ processAnnouncementCentrally ReceivedViaChainSync -> recordAnnounced ReceivedViaLeiosNotify -> recordAnnounced recordAnnouncementInTxCache txCache announcerRbHash point + -- If this new point's EB body and/or closure is already in the + -- LeiosDb, it should also emit the corresponding events for this + -- point. One crucial consequence is 'cdbAcquiredLeiosEbs' being + -- informed that the EB won't be pruned until the new (often + -- /younger/) point becomes immutable. + void $ writeEbPoint writer point (announcementEbBodySize fields) ) cst source @@ -2405,6 +2418,7 @@ onForgedLeiosEb kernelTracer centralVar kv txCache writer systemTime anc forgedE centralVar kv txCache + writer Nothing ForgedLocally Announcements.DoRelay From 17d2280809b88ae28914cb65eb2f1a92edf2141e Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 6 Oct 2026 15:09:13 -0400 Subject: [PATCH 44/60] Add accidentally untracked changelog fragments --- ....frisby_leios_forget_certrbs_at_startup.md | 23 ++++++++++++++++ ...00_nick.frisby_leios_closure_size_bound.md | 26 +++++++++++++++++++ ...00_nick.frisby_leios_committee_via_view.md | 14 ++++++++++ 3 files changed, 63 insertions(+) create mode 100644 changelog.d/20260921_100250_nick.frisby_leios_forget_certrbs_at_startup.md create mode 100644 changelog.d/20261005_143000_nick.frisby_leios_closure_size_bound.md create mode 100644 changelog.d/20261006_004500_nick.frisby_leios_committee_via_view.md diff --git a/changelog.d/20260921_100250_nick.frisby_leios_forget_certrbs_at_startup.md b/changelog.d/20260921_100250_nick.frisby_leios_forget_certrbs_at_startup.md new file mode 100644 index 0000000000..ed57d4007c --- /dev/null +++ b/changelog.d/20260921_100250_nick.frisby_leios_forget_certrbs_at_startup.md @@ -0,0 +1,23 @@ + + +### Breaking + +- The `VolatileDB` gained `forgetLeiosCertsAtStartUpExcept`. It forgets every block carrying a Leios certificate but the given ones: a forgotten block is stored but unknown, so `getBlockInfo`, `filterByPredecessor` and `getBlockComponent` all answer as though the DB does not hold it, while `putBlock` still recognises its hash and so writes nothing if the block is added again, which also re-admits it. + +- The `VolatileDB`'s `TraceEvent` gained `ForgotLeiosCertBlocks` and `ReadmittedForgottenBlock`. + +### Non-Breaking + +- After initial chain selection, the ChainDB now forgets the cert-carrying blocks that are not on that selection, so they are re-fetched and re-added if some chain it would select turns out to need them. That is what lets their certificates be verified at all: such a block would otherwise never pass through `chainSelAddBlock` again, so nothing would hand it the ledger view its certificate must be checked against, and its claim would stay unverified for the rest of the run — closing the Recovery Path for the endorser block it certifies. See `docs/website/contents/explanations/valid_claims_startup.md`. + + diff --git a/changelog.d/20261005_143000_nick.frisby_leios_closure_size_bound.md b/changelog.d/20261005_143000_nick.frisby_leios_closure_size_bound.md new file mode 100644 index 0000000000..71bd1b522f --- /dev/null +++ b/changelog.d/20261005_143000_nick.frisby_leios_closure_size_bound.md @@ -0,0 +1,26 @@ + + +### Breaking + +- `LeiosLedgerView` gained `llvMaxEbTxsSize`, the total size an endorser block's transactions may amount to, forecast via the ledger's `maxEndorserBlockTxsSizeForecastL`. `ResolveLeiosBlock` gained `getLeiosMaxEbTxsSizeFromView` to read it, defaulting to 0 for an era without the parameter --- which is the truth rather than a placeholder, since such an era has no endorser blocks and one offered anyway may reference nothing. + +- `leiosFetchLogicIteration` takes a `SlotNo -> Either OutsideForecastRange BytesSize`, the bound forecast from the immutable tip to a slot. `assignBody` consults it for the offered point's slot, so one `EbHash` announced in two slots is requested under each slot's own bound. The bound is a protocol parameter --- a function of the slot and nothing else --- so there is nothing per endorser block to retain and nothing to keep coherent. + +- `PeerOffer` gained `poMaxEbTxsSize`, `SJust` only for an offer synthesised from a CertRB roll-forward. That header was validated against the view at its predecessor's slot, which is the announced endorser block's own slot, and `CsClient.leiosMsgRollForwardCallback` now receives that view (so `recordCertRbOffer` and `checkMsgRollForwardForLeiosOffers` take it). Retaining it there is what keeps the Recovery Path alive on a sparse chain: the ChainSync client can validate a header our immutable tip cannot forecast to, and a CertRB cannot be selected until we hold its endorser block, so a fetch blocked on a failed forecast would keep the immutable tip from advancing and the forecast from ever succeeding. A LeiosNotify offer needs no such retention --- the announcement backing it was accepted by forecasting from the immutable tip to that same slot. + +- `LeiosBlockRequest` is a record: `lbrPoint`, `lbrOfferedSize` and the new `lbrMaxEbTxsSize`, which names the two sizes rather than leaving them adjacent positional `BytesSize`es. Only the point goes to the peer; both sizes are what the response is validated against, so `processLeiosBlock` reads the bound off its `LeiosBlockSource` rather than looking anything up, and the check sits outside the `LeiosOutstanding` lock: it is decided by the body and the request alone. + +- `ExnLeiosBlockWrongSize` is now a constructor of `ExnLeiosWellHashedBodyRejected`, alongside the new `ExnLeiosClosureTooBig`. Both are thrown by `processLeiosBlock` for a body that hashes to the endorser block we asked for and is still unacceptable, and both only once the lock is released, since throwing under it would roll back the record they rely on. + +- `LeiosTestView` gained `ltvMaxEbTxsSize`, fixed for a whole test run by `ltlcMaxEbTxsSize` and defaulting to `maxBound`, so a test that does not care about the bound never trips it. + +### Non-Breaking + +- An arriving endorser block's references are weighed against the bound before any closure job is built, and the peer that served it is disconnected. Bounding the encoded body does not bound its closure: a reference is charged the CBOR digits of the size it claims, so a body within `maxLeiosEbBytesSize` (512 KiB) could name hundreds of megabytes of transactions, against a protocol intent of twelve. The per-job caps `mkLeiosJobPool` takes partition that work, they do not cap it. + +- A rejected endorser block is recorded as acquired with an empty job pool and never written to the LeiosDb, so its closure is never fetched, it is never offered on, and the next peer to serve the same bytes does not cost us the work again. No honest peer sends one: such an endorser block can never be certified, because an honest committee member applies the same bound, so an honest peer that fetched it rejected it too and never stored or offered it. diff --git a/changelog.d/20261006_004500_nick.frisby_leios_committee_via_view.md b/changelog.d/20261006_004500_nick.frisby_leios_committee_via_view.md new file mode 100644 index 0000000000..611f383b59 --- /dev/null +++ b/changelog.d/20261006_004500_nick.frisby_leios_committee_via_view.md @@ -0,0 +1,14 @@ + + +### Patch + +- `getLeiosCommittee` and `getCurrentThreshold` now read through `getLeiosCommitteeFromView`, applied to the ledger view the state projects at its own tip slot, rather than each reaching into the state itself. Previously three definitions knew that the committee lives at `ssStakeSet . ssLeiosCommittee` and the quorum at `ppLeiosQuorumStakeThreshold`; now one does, so the view-derived accessor and the state-derived ones agree by construction instead of by copies staying in step. That the two agreed was already asserted in a comment; it is now structural. + +- The projection is `SL.currentForecast`, which is `SL.mkForecast` --- no TICKF --- so the state-derived accessors cost what they did before. `protocolLedgerView` and the anchor-slot branch of `ledgerViewForecastAt` are defined by the same projection for the same reason, which is what this extends to the Leios accessors. + +- No signature changed: `HasLeiosVoting` keeps all three methods, the two new helpers are module-private, and nothing downstream moved. From 7e778cba51cec49ab90b24ba80bf3a87176693a4 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 6 Oct 2026 15:30:15 -0400 Subject: [PATCH 45/60] LeiosNotify: add Pascal Grange's test vectors --- .../Test/LeiosDemoLogic/Invariants.hs | 134 ++++++++++++++++-- 1 file changed, 125 insertions(+), 9 deletions(-) diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs index 10fe880e9e..d1c0619323 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs @@ -35,6 +35,7 @@ import Control.Concurrent.Class.MonadMVar , newMVar , readMVar ) +import Control.Concurrent.Class.MonadSTM.Strict (atomically, tryReadTChan) import Control.Monad (forever) import Control.Monad.Class.MonadAsync (concurrently_) import Control.Monad.Class.MonadTest (exploreRaces) @@ -45,6 +46,7 @@ import Control.Tracer (nullTracer) import qualified Data.ByteString as BS import qualified Data.ByteString.Short as SBS import Data.Foldable (toList) +import Data.List (sort) import qualified Data.IntMap.Strict as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map.Strict as Map @@ -58,21 +60,33 @@ import Data.Word (Word64) import LeiosDemoDb (withWriter) import qualified LeiosDemoDb as LeiosDb import LeiosDemoLogic - ( ExnLeiosWellHashedBodyRejected (..) + ( AnnouncingHeader + , ExnLeiosWellHashedBodyRejected (..) , LeiosBlockSource (..) , LeiosBlockTxsSource (..) , leiosFetchLogicIteration + , mkAnnouncingHeader , noMempoolPull + , processAnnouncementCentrally , processLeiosBlock , processLeiosBlockTxs , recordAnnouncedEb , recordEbBodyOffer , removePeerFromOutstanding ) +import qualified LeiosDemoLogic.Announcements as Announcements import LeiosDemoLogic.Announcements.ElBimap (ElId (MkElId)) +import Test.Util.LeiosTestBlock + ( LeiosTestBlock + , announcing + , firstLeiosBlock + , issuedBy + , successorLeiosBlock + ) import Ouroboros.Consensus.Forecast (OutsideForecastRange) import LeiosDemoTypes - ( BytesSize + ( AnnouncementSource (..) + , BytesSize , EbHash , LeiosBlockRequest (..) , LeiosEb (..) @@ -93,6 +107,7 @@ import LeiosDemoTypes import qualified LeiosDemoTypes as Leios import qualified LeiosDemoTypes.LeiosJobs as Jobs import LeiosTxCache (LeiosTxCache, defaultLeiosTxCacheShift, newPureLeiosTxCache, nullLeiosTxCache) +import Ouroboros.Consensus.Block (getHeader) import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( RelativeTime (..) , SystemTime (..) @@ -331,17 +346,43 @@ tests = let hFocused = hashLeiosEb (ebOf [0, 1]) hRival = hashLeiosEb (ebOf [2, 3]) elId = MkElId (SlotNo 5) (SBS.pack [1]) - announcing h = Leios.MkAnnouncementFields elId h 99 + fieldsFor h = Leios.MkAnnouncementFields elId h 99 o = runSimOrThrow $ do outstandingVar <- newMVar (emptyLeiosOutstanding (mkStdGen 0) (SlotNo 0) :: LeiosOutstanding Int) readyVar <- newEmptyMVar - recordAnnouncedEb (outstandingVar, readyVar) SNothing (announcing hFocused) - recordAnnouncedEb (outstandingVar, readyVar) SNothing (announcing hRival) + recordAnnouncedEb (outstandingVar, readyVar) SNothing (fieldsFor hFocused) + recordAnnouncedEb (outstandingVar, readyVar) SNothing (fieldsFor hRival) readMVar outstandingVar Map.member hFocused (Leios.ebState o) @?= True Map.member hRival (Leios.ebState o) @?= False Map.lookup elId (Leios.elFocus o) @?= Just hFocused + , testGroup + "EB-hash collision (ported from #2309)" + -- 'announcementOf' derives the election from (slot, hash), so the same + -- EB at two slots is two elections. Only 'Forge' completes a closure + -- here (no tx-delivery command, no mempool pull), so notifications are + -- only asserted in the 'Forge' scenarios. + [ testCase "forged, then the same EB announced at a new slot: both points registered and notified" $ do + let (points, notified) = runCmdsCollision [Forge collisionEb 5, Announce collisionEb 8] + points @?= [(SlotNo 5, collisionHash), (SlotNo 8, collisionHash)] + notified @?= [pointOf collisionEb 5, pointOf collisionEb 8] + , testCase "body held, then the same EB announced at a new slot: both points registered" $ do + let (points, _) = + runCmdsCollision + [Announce collisionEb 5, Decide 5, ArriveBody collisionEb 5, Announce collisionEb 8] + points @?= [(SlotNo 5, collisionHash), (SlotNo 8, collisionHash)] + , testCase "both announced before the fetch: both points registered" $ do + let (points, _) = + runCmdsCollision + [Announce collisionEb 5, Announce collisionEb 8, Decide 8, ArriveBody collisionEb 8] + points @?= [(SlotNo 5, collisionHash), (SlotNo 8, collisionHash)] + , testCase "forged, then the same EB merely offered at a new slot: the offer registers nothing" $ do + -- An offer is an unverified claim (#2309's 9c8e5d9aa). + let (points, notified) = runCmdsCollision [Forge collisionEb 5, Offer collisionEb 8] + points @?= [(SlotNo 5, collisionHash)] + notified @?= [pointOf collisionEb 5] + ] , testCase "a certificate tracks an endorser block no announcement did" $ do -- A certificate can reach us for an announcement we never processed: -- if the announcing block has been on our selection since initial @@ -524,6 +565,25 @@ ebOf ids = MkLeiosEb (V.fromList [(txHashOf i, txSizeOf i) | i <- ids]) pointOf :: TestEb -> Word -> LeiosPoint pointOf ids slot = MkLeiosPoint (fromIntegral slot) (hashLeiosEb (ebOf ids)) +-- | The announcing header a 'Announce' stands for: a block in that slot, by +-- 'issuerOf', announcing that EB. +announcingHeaderOf :: TestEb -> Word -> AnnouncingHeader LeiosTestBlock +announcingHeaderOf ids slot = + case mkAnnouncingHeader (getHeader blk) of + Nothing -> error "announcingHeaderOf: header announces nothing" + Just anc -> anc + where + blk = + announcing (pointOf ids slot) (encodeLeiosEbSize (ebOf ids)) $ + issuedBy (issuerOf ids) $ + iterate successorLeiosBlock (firstLeiosBlock 9) !! (fromIntegral slot - 1) + +-- | A distinct issuer per 'TestEb', so that two endorser blocks announced in +-- one slot are two elections rather than one pool equivocating. 'headerElId' +-- keeps only the low byte, and the four 'worldEbs' map to 9, 17, 1 and 180. +issuerOf :: TestEb -> Word64 +issuerOf = fromIntegral . foldl' (\acc i -> (acc * 7 + i + 1) `mod` 256) 0 + ------------------------------------------------------------ -- Harness ------------------------------------------------------------ @@ -533,6 +593,43 @@ pointOf ids slot = MkLeiosPoint (fromIntegral slot) (hashLeiosEb (ebOf ids)) runCmds :: [Cmd] -> Either String () runCmds = (() <$) . runCmdsReFetchViolations +collisionEb :: TestEb +collisionEb = [0, 1] + +collisionHash :: EbHash +collisionHash = hashLeiosEb (ebOf collisionEb) + +-- | Run a command sequence against a fresh in-memory LeiosDb, then report the +-- EB points it has registered (sorted) and every 'AcquiredEbTxs' it emitted, in +-- order (duplicates kept, so "exactly once" is checkable). +-- +-- The in-memory writer performs each write at submission, so everything the +-- commands wrote has landed by the time 'withWriter' returns. +runCmdsCollision :: [Cmd] -> ([(SlotNo, EbHash)], [LeiosPoint]) +runCmdsCollision cmds = runSimOrThrow go + where + go :: forall s. IOSim s ([(SlotNo, EbHash)], [LeiosPoint]) + go = do + dbHandle <- LeiosDb.newLeiosDBInMemory + chan <- LeiosDb.subscribeEbNotifications dbHandle + withWriter dbHandle $ \conn -> do + outstandingVar <- newMVar (emptyLeiosOutstanding (mkStdGen 0) (SlotNo 0)) + readyVar <- newEmptyMVar + peerVars <- newLeiosPeerVars IsNotBigLedgerPeer + let kv = (outstandingVar, readyVar) + centralVar <- newMVar Announcements.emptyCentralState + mapM_ + (applyCmd centralVar conn nullLeiosTxCache kv peerVars (MkPeerId (0 :: Int))) + cmds + -- The plain selector: record dot cannot select a 'HasCallStack =>' field. + points <- LeiosDb.withReader dbHandle LeiosDb.scanEbPoints + let drain acc = + atomically (tryReadTChan chan) >>= \case + Nothing -> pure (reverse acc) + Just n -> drain (n : acc) + notifs <- drain [] + pure (sort points, [p | LeiosDb.AcquiredEbTxs p <- notifs]) + -- | Like 'runCmds', but on success also return the EB bodies that the fetch -- logic requested despite already holding them (i.e. despite 'ebStateHasBody'), -- gathered across all 'Decide's. That list is the @@ -548,13 +645,14 @@ runCmdsReFetchViolations cmds = runSimOrThrow (go cmds) outstandingVar <- newMVar (emptyLeiosOutstanding (mkStdGen 0) (SlotNo 0)) readyVar <- newEmptyMVar peerVars <- newLeiosPeerVars IsNotBigLedgerPeer + centralVar <- newMVar Announcements.emptyCentralState let kv = (outstandingVar, readyVar) txCache = nullLeiosTxCache peerId = MkPeerId (0 :: Int) loop acc [] = pure (Right acc) loop acc (c : cs) = do r <- - try (applyCmd conn txCache kv peerVars peerId c) :: + try (applyCmd centralVar conn txCache kv peerVars peerId c) :: IOSim s (Either SomeException [EbHash]) case r of Left e -> pure (Left ("exception on " <> show c <> ": " <> show e)) @@ -577,6 +675,9 @@ runCmdsReFetchViolations cmds = runSimOrThrow (go cmds) -- but a misbehaving 'Decide'. applyCmd :: forall s. + MVar + (IOSim s) + (Announcements.CentralState (IOSim s) (PeerId Int) (AnnouncingHeader LeiosTestBlock)) -> LeiosDb.LeiosDbWriter (IOSim s) -> LeiosTxCache (IOSim s) () () Leios.SerializedEbBody -> (MVar (IOSim s) (LeiosOutstanding Int), MVar (IOSim s) ()) -> @@ -584,12 +685,27 @@ applyCmd :: PeerId Int -> Cmd -> IOSim s [EbHash] -applyCmd conn txCache kv peerVars peerId = \case +applyCmd centralVar conn txCache kv peerVars peerId = \case Announce ids slot -> do + -- Through the same entry point the node uses, so that whatever a validated + -- announcement is defined to do --- today that includes registering the + -- point with the LeiosDb --- these commands do too, without this harness + -- having to know what that is. + -- -- These invariants are about the fetch bookkeeping, which never reads the -- onset; only the voting path needs it. - recordAnnouncedEb kv SNothing $ - announcementOf (pointOf ids slot) (encodeLeiosEbSize (ebOf ids)) + processAnnouncementCentrally + nullTracer + centralVar + kv + txCache + conn + (Just peerId) + ReceivedViaLeiosNotify + Announcements.DoRelay + SNothing + Nothing + (announcingHeaderOf ids slot) pure [] Offer ids slot -> do recordEbBodyOffer From e372a6db107672bc06b4834a84b081741af3c303 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 6 Oct 2026 23:11:53 -0400 Subject: [PATCH 46/60] Fix up pre-existing foldl' import warning, for all GHC versions --- .../src/ouroboros-consensus/LeiosTxCache/Reference.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs index e8a78a6b23..554dcf3901 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs @@ -59,7 +59,8 @@ module LeiosTxCache.Reference ) where import Cardano.Slotting.Slot (SlotNo (..)) -import Data.List (find, foldl') +import Data.List (find) +import qualified Data.List as List import Data.Map.NonEmpty (NEMap) import qualified Data.Map.NonEmpty as NEMap import Data.Map.Strict (Map) @@ -471,7 +472,7 @@ setTxLocations ebh offTxs idx = idx { locRing = Map.insert slot ebh (locRing idx) , locNext = locNext' - , txLocState = foldl' upd (txLocState idx) offTxs + , txLocState = List.foldl' upd (txLocState idx) offTxs } where (slot, locNext') = case ringSlotOf ebh idx of From 8cfd3e4c01d05be2f48bb0cd7f6e1d779eb3a7e5 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Wed, 7 Oct 2026 10:52:56 -0400 Subject: [PATCH 47/60] Disable partiality warning in test module --- ouroboros-consensus/test/consensus-test/Test/LeiosVoteState.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosVoteState.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosVoteState.hs index 7513fc4d23..f58764fcd7 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosVoteState.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosVoteState.hs @@ -1,6 +1,8 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} +{-# OPTIONS_GHC -Wno-x-partial #-} + module Test.LeiosVoteState (tests) where import Cardano.Crypto.DSIGN From bdbf3b3f1c6c37e2c22b2cf514aee3b436a31ad2 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Wed, 7 Oct 2026 10:52:41 -0400 Subject: [PATCH 48/60] Trim comments about types chosen for the sake of GHCs older than 9.12 --- .../Consensus/Shelley/Protocol/Praos.hs | 19 ++++--------------- .../Ouroboros/Consensus/Protocol/Praos.hs | 15 +++------------ 2 files changed, 7 insertions(+), 27 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs index 63a49d2c70..53ff2c0f2a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs @@ -231,9 +231,8 @@ instance where hv = headerToView @pext hdr - -- Each branch refines @pext@, so the body type reduces to one 'PraosCrypto' - -- covers; it cannot be discharged for an abstract @pext@. - withSignableDict :: (KES.Signable (KES c) (BaseHeaderBody pext c) => r) -> r + withSignableDict :: + (KES.Signable (KES c) (BaseHeaderBody pext c) => r) -> r withSignableDict k = case singPraosExtension (Proxy @pext) of SingPextNone -> k SingPextLeios -> k @@ -259,12 +258,7 @@ instance case singPraosExtension (Proxy @pext) of SingPextNone -> do PraosFields{praosSignature, praosToSign} <- forgePraosFields hk cbl il praosBody - -- The annotations here and below are load-bearing: 'PraosCodec.Header' - -- and 'LeiosCodec.Header' are pattern synonyms carrying a @Crypto - -- crypto@ constraint, so without one GHC has to solve that @crypto@ - -- inside two implications --- the synonym's and this branch's @pext@ - -- refinement --- where it is untouchable. 9.12 copes; 9.6 and 9.10 do - -- not. + -- A type annotation for sake of GHCs older than 9.12. pure (PraosCodec.Header praosToSign praosSignature :: PraosCodec.Header c) SingPextLeios -> case leios of SJustLeios (containsCert, mbAnn) -> do @@ -276,12 +270,7 @@ instance (toCodecEbAnnouncement <$> mbAnn) pure (LeiosCodec.Header praosToSign praosSignature :: LeiosCodec.Header c) where - -- The signature is load-bearing. Without it 'MonoLocalBinds' still gives - -- this a @crypto@ metavariable, but one born out here, which each branch - -- below then has to solve inside its @pext@ refinement, where it is - -- untouchable. 9.12 copes; 9.6 and 9.10 do not. The annotations on the two - -- header constructions are for the same reason: both 'Header's are pattern - -- synonyms carrying a @Crypto crypto@ constraint. + -- A signature for the sake of GHCs older than 9.12. praosBody :: PraosToSign c -> PraosCodec.HeaderBody c praosBody PraosToSign diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index 28c702cac4..f9e179e145 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -874,10 +874,8 @@ doValidateKESSignatureWorker whetherToUpperBound praosMaxKESEvo praosSlotsPerKES DSIGN.verifySignedDSIGN () vkcold (OCert.ocertToSignable oc) tau ?!: InvalidSignatureOCERT n c0 - withSignableDict $ - KES.verifySignedKES () vk_hot t (Views.hvSigned b) (Views.hvSignature b) - ?!: InvalidKesSignatureOCERT kp_ c0_ t praosMaxKESEvo - + withSignableDict (KES.verifySignedKES () vk_hot t (Views.hvSigned b) (Views.hvSignature b)) + ?!: InvalidKesSignatureOCERT kp_ c0_ t praosMaxKESEvo case currentIssueNo of Nothing -> do throwError $ NoCounterForKeyHashOCERT hk @@ -905,15 +903,8 @@ doValidateKESSignatureWorker whetherToUpperBound praosMaxKESEvo praosSlotsPerKES | otherwise = Nothing - -- The result type is fixed rather than polymorphic in @r@: inside the - -- implication this constraint introduces, an @r@ would be untouchable, so - -- GHC could not solve it against the caller's type (it manages on 9.12 but - -- not on 9.6 or 9.10). withSignableDict :: - ( KES.Signable (KES c) (Views.BaseHeaderBody pext c) => - Except (BasePraosValidationErr pext c) () - ) -> - Except (BasePraosValidationErr pext c) () + (KES.Signable (KES c) (Views.BaseHeaderBody pext c) => r) -> r withSignableDict k = case singPraosExtension (Proxy @pext) of SingPextNone -> k SingPextLeios -> k From 9cb6a560c7487a95186be7e3171aff6e09ccc90c Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Wed, 7 Oct 2026 13:26:10 -0400 Subject: [PATCH 49/60] consensus: naming TODO on topLevelConfigProtocol and ConsensusConfig --- .../ouroboros-consensus/Ouroboros/Consensus/Config.hs | 9 +++++++++ .../Ouroboros/Consensus/Protocol/Abstract.hs | 3 +++ 2 files changed, 12 insertions(+) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config.hs index 505f5c23d4..c933278ac7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config.hs @@ -49,6 +49,15 @@ import Ouroboros.Consensus.Protocol.Abstract -- | The top-level node configuration data TopLevelConfig blk = TopLevelConfig { topLevelConfigProtocol :: !(ConsensusConfig (BlockProtocol blk)) + -- ^ TODO both @topLevelConfigProtocol@ and @ConsensusConfig@ are misnomers, + -- which isn't too surprising considering they couldn't even agree :/ + -- + -- I think "header" be the best non-exotic classifier for this. It's still + -- somewhat confusing, since "chains of blocks" /inherit/ semantics of the + -- "chains of headers" that this config /directly/ affects. So any effect + -- some value within @topLevelConfigHeader/HeaderConfig@ might have on the + -- treatment of blocks could cause confusion. But that's seems preferable to + -- the current, extremely nebulous classifers "protocol" and "consensus". , topLevelConfigLedger :: !(LedgerConfig blk) , topLevelConfigBlock :: !(BlockConfig blk) , topLevelConfigCodec :: !(CodecConfig blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs index 6f6d75067f..9e7e83cad7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs @@ -57,6 +57,9 @@ import Ouroboros.Consensus.Ticked -- Defined out of the class so that protocols can define this type without -- having to define the entire protocol at the same time (or indeed in the same -- module). +-- +-- TODO See the TODO about this misnomer at +-- 'Ouroboros.Consensus.Config.topLevelConfigProtocol'. data family ConsensusConfig p :: Type -- | The (open) universe of Ouroboros protocols From c50335ea87951a5b5ab06acf4dbe1717f195ad03 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Wed, 7 Oct 2026 15:40:36 -0400 Subject: [PATCH 50/60] Separate Praos and Leios as `proto` types (broken past o-c-protocols) (This commit message is written as if comparing/contrasting with origin/main instead of the preceding commits on this feature branch.) This incurs some duplication, but it's worth it. - The duplication is not overly burdensome to compensate for by factoring the Praos impl somewhat so its types and functions can be reused as much as possible. For Leios, at least, that's easy since Leios only adds a few independent fields to the header semantics. - The risk of the two accidentally drifting apart is low: Praos has been running on mainnet for years, so any incompatible changes to it need a great deal of scrutiny. (And any changes to it at all need to be worth the trouble.) - Duplicating instances between Praos and PraosWithLeios instead of having them share some instances (ala a `BasePraos leiosFlag` protocol type) has a couple benefits. First, code is either monomorphic or reuses the existing parameterizations over `proto`, which is already ubiquitous. Second, it avoids _implicit_ reuse of today's Praos's rules for Leios, which makes _accidental_ reuse less likely---compare to type class method defaults. We do _not_ duplicate more than we need to, though. In particular, many of Praos's data types and some of its classes gain a `proto` parameter, which is used so that the single data type definition can be reused for Praos with and without Leios. The benefit is that there is just one constructor/field per Praos concept, regardless of whether Leios is enabled. This is not a fully modular design: subsequent additional extensions will also need to add to these same definitions (eg adding fields for Ouroboros Phalanx). That is intentional. This code does not need to be classically extensible, since there is, unfortunately, no such thing as an extensible security proof. Our protocol changes are well studied before implemented, and have never happened concurrently. In other words: it's a very important benefit that there is _one definition_ to look at in order to see everything all of the Praos extensions _cumulatively_ do. The type-level DSL used to isolate extension components is simple and legible; see the `EitherLeiosF` data family. --- .../Ouroboros/Consensus/Protocol/Leios.hs | 276 +++++++ .../Ouroboros/Consensus/Protocol/Praos.hs | 685 +++++++++--------- .../Consensus/Protocol/Praos/Common.hs | 157 +--- .../Consensus/Protocol/Praos/Orphans.hs | 17 + .../Consensus/Protocol/Praos/Views.hs | 163 +---- ouroboros-consensus.cabal | 2 + 6 files changed, 681 insertions(+), 619 deletions(-) create mode 100644 ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Leios.hs create mode 100644 ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Orphans.hs diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Leios.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Leios.hs new file mode 100644 index 0000000000..49ffa1e897 --- /dev/null +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Leios.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- | Praos with the Leios overlay. +module Ouroboros.Consensus.Protocol.Leios + ( LeiosCrypto + , PraosWithLeios + , ConsensusConfig (..) + ) where + +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) +import Cardano.Ledger.Chain (ChainChecksPParams (..)) +import Cardano.Ledger.Keys (hashKey) +import Cardano.Protocol.Crypto (Crypto, StandardCrypto) +import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec +import Cardano.Slotting.EpochInfo (epochInfoSlotLength) +import Cardano.Slotting.Slot (SlotNo) +import Ouroboros.Consensus.Block (WithOrigin (NotOrigin)) +import Control.DeepSeq (NFData) +import Control.Monad (when) +import Control.Monad.Except (Except, throwError) +import Data.Functor.Identity (runIdentity) +import Data.Kind (Type) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import LeiosDemoTypes (ebAnnouncementSize, minCertificationSlot) +import NoThunks.Class (NoThunks) +import qualified Cardano.Ledger.Dijkstra.Forecast as Dijkstra +import qualified Cardano.Ledger.Shelley.API as SL +import Lens.Micro ((^.)) +import qualified Ouroboros.Consensus.HardFork.History as History +import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Protocol.Praos +import Ouroboros.Consensus.Protocol.Praos.Common + ( EitherLeiosF + , PraosCanBeLeader + , PraosTiebreakerView + , ShelleyProtocolHeader + , fromCodecEbAnnouncement + ) +import Ouroboros.Consensus.Protocol.Praos.Orphans () +import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views + +{------------------------------------------------------------------------------- + The protocol +-------------------------------------------------------------------------------} + +type PraosWithLeios :: Type -> Type +data PraosWithLeios c + +type instance ShelleyProtocolHeader (PraosWithLeios c) = LeiosCodec.Header c + +instance BasePraosCrypto (PraosWithLeios StandardCrypto) StandardCrypto + +type LeiosCrypto c = BasePraosCrypto (PraosWithLeios c) c + +{------------------------------------------------------------------------------- + The fields only this protocol has +-------------------------------------------------------------------------------} + +-- | This protocol is Leios, so it holds the right alternative. +newtype instance EitherLeiosF (PraosWithLeios c) a b = LeiosLeiosRight b + deriving (Eq, Generic, Show) + deriving newtype NFData + +deriving anyclass instance + NoThunks b => NoThunks (EitherLeiosF (PraosWithLeios c) a b) + +instance Functor (EitherLeiosF (PraosWithLeios c) a) where + fmap f (LeiosLeiosRight b) = LeiosLeiosRight (f b) + +instance Applicative (EitherLeiosF (PraosWithLeios c) a) where + pure = LeiosLeiosRight + LeiosLeiosRight f <*> LeiosLeiosRight b = LeiosLeiosRight (f b) + +instance Foldable (EitherLeiosF (PraosWithLeios c) a) where + foldMap f (LeiosLeiosRight b) = f b + +instance Traversable (EitherLeiosF (PraosWithLeios c) a) where + traverse f (LeiosLeiosRight b) = LeiosLeiosRight <$> f b + +{------------------------------------------------------------------------------- + Configuration +-------------------------------------------------------------------------------} + +-- | Praos's configuration, wrapped only because 'ConsensusConfig' is a data +-- family. +-- +-- Leios adds nothing to it: the periods, the committee, the quorum and the size +-- bounds all reach the protocol through the ledger view instead. +newtype instance ConsensusConfig (PraosWithLeios c) = LeiosConfig + { leiosPraosConfig :: ConsensusConfig (Praos c) + } + deriving Generic + +deriving newtype instance Crypto c => NoThunks (ConsensusConfig (PraosWithLeios c)) + +{------------------------------------------------------------------------------- + Chain-dep state +-------------------------------------------------------------------------------} + +-- | Its own format, which merely also starts counting; this is the version the +-- Leios prototype has been writing, so snapshots already on disk still decode. +instance Typeable c => SerialisePraosState (PraosWithLeios c) where + versionOfPraosState _ = 1 + countOfFieldsInPraosState _ = 9 + +{------------------------------------------------------------------------------- + The header checks this protocol adds +-------------------------------------------------------------------------------} + +-- | The Leios header checks that read only the header and the ledger view. +-- +-- Sound out of context, which is what lets both header paths run them: +-- 'updateChainDepState', from the header's own predecessor, and +-- 'validateAnnouncementChainDepState', from the immutable tip. The bound they +-- check is forecast for the header's own slot, so both paths read the same +-- value: a forecast either yields the view that slot will have or refuses as +-- 'OutsideHorizon'. The staleness the announcement path does have to live with +-- is in the chain-dep state --- the opcert counters --- and none of these +-- checks reads it. +leiosContextFreeHeaderChecks :: + Views.BasePraosLedgerView (PraosWithLeios c) -> + Views.BasePraosValidateView (PraosWithLeios c) c -> + Except (BasePraosValidationErr (PraosWithLeios c) c) () +leiosContextFreeHeaderChecks lv b = do + let LeiosLeiosRight (_containsCert, mbAnn) = Views.hvLeios b + LeiosLeiosRight maxEbBodySize = Views.plvMaxEbBodySize lv + case mbAnn of + SNothing -> pure () + SJust ann -> do + let announced = ebAnnouncementSize ann + -- TEMPORARY KLUDGE -- DO NOT MERGE into main. + -- + -- The deployed testnet has historical announcements above the + -- 'maxEndorserBlockReferencesSize' its own Dijkstra genesis sets + -- (e.g. 102429 against 100000 at slot 709083), so enforcing the + -- ledger's value stalls the sync there. Exception granted here and + -- here only: every other use of the limit, and the genesis file + -- itself, are untouched. + maximum' = max 200000 maxEbBodySize + when (announced > maximum') $ + throwError $ + LeiosEbTooBig (LeiosLeiosRight ()) announced maximum' + +-- | The Leios-specific checks on a header, called by 'updateChainDepState'. +-- +-- 'leiosContextFreeHeaderChecks' plus the one check that needs the header's +-- immediate predecessor: a CertRB may not certify an announcement younger than +-- the certification gap, and only the predecessor's state says which +-- announcement that is. +leiosHeaderChecks :: + ConsensusConfig (PraosWithLeios c) -> + Views.BasePraosLedgerView (PraosWithLeios c) -> + Views.BasePraosValidateView (PraosWithLeios c) c -> + SlotNo -> + BasePraosState (PraosWithLeios c) -> + Except (BasePraosValidationErr (PraosWithLeios c) c) () +leiosHeaderChecks cfg lv b slot cs = do + leiosContextFreeHeaderChecks lv b + let LeiosLeiosRight (containsCert, _mbAnn) = Views.hvLeios b + LeiosLeiosRight announcementPeriod = Views.plvAnnouncementPeriodLength lv + LeiosLeiosRight votePeriod = Views.plvVotePeriodLength lv + LeiosLeiosRight diffusionPeriod = Views.plvDiffusionPeriodLength lv + LeiosLeiosRight announcedByPredecessor = praosStateLeiosAnnouncement cs + PraosConfig{praosEpochInfo} = leiosPraosConfig cfg + + -- Note that the genesis state doesn't announce an EB. + when containsCert $ + case (announcedByPredecessor, praosStateLastSlot cs) of + (SJust{}, NotOrigin announcingSlot) -> do + let earliestAllowed = + minCertificationSlot + ( runIdentity $ + epochInfoSlotLength + (History.toPureEpochInfo praosEpochInfo) + slot + ) + announcementPeriod + votePeriod + diffusionPeriod + announcingSlot + when (slot < earliestAllowed) $ + throwError $ + LeiosCertTooYoung (LeiosLeiosRight ()) announcingSlot slot earliestAllowed + -- A state that announced an EB has necessarily applied a header, so + -- 'Origin' is the same situation as announcing nothing. + _ -> throwError $ LeiosCertWithoutAnnouncement (LeiosLeiosRight ()) + +{------------------------------------------------------------------------------- + ConsensusProtocol +-------------------------------------------------------------------------------} + +instance LeiosCrypto c => ConsensusProtocol (PraosWithLeios c) where + type ChainDepState (PraosWithLeios c) = BasePraosState (PraosWithLeios c) + type IsLeader (PraosWithLeios c) = PraosIsLeader c + type CanBeLeader (PraosWithLeios c) = PraosCanBeLeader c + type TiebreakerView (PraosWithLeios c) = PraosTiebreakerView c + type LedgerView (PraosWithLeios c) = Views.BasePraosLedgerView (PraosWithLeios c) + type ValidationErr (PraosWithLeios c) = BasePraosValidationErr (PraosWithLeios c) c + type ValidateView (PraosWithLeios c) = Views.BasePraosValidateView (PraosWithLeios c) c + + protocolSecurityParam = praosSecurityParam . praosParams . leiosPraosConfig + + checkIsLeader cfg = checkIsLeaderPraos (praosParams (leiosPraosConfig cfg)) + + tickChainDepState cfg = tickPraosState (praosEpochInfo (leiosPraosConfig cfg)) + + updateChainDepState cfg b slot tcs = do + -- The Leios header checks. Cheap, so they run before the signature checks. + -- + -- NB cert/txs exclusivity is not among these: it is a property of the body, + -- and 'blockMatchesHeader' already enforces it where the body is in hand. + -- Nor is the EB closure's size: the announcement carries only one size, and + -- it is the body's. + leiosHeaderChecks cfg lv b slot cs + -- Everything below this line exactly matches the 'Praos' instance, _except_ + -- the 'reupdateChainDepState' continuation is also at type 'Leios'. + validateKESSignature prms lv (praosStateOCertCounters cs) b + validateVRFSignature (praosStateEpochNonce cs) lv (praosLeaderF prms) b + pure $ reupdateChainDepState cfg b slot tcs + where + PraosConfig{praosParams = prms} = leiosPraosConfig cfg + lv = tickedPraosStateLedgerView tcs + cs = tickedPraosStateChainDepState tcs + + reupdateChainDepState cfg b slot tcs = + reupdatePraosState prms ei upd b slot (tickedPraosStateChainDepState tcs) + where + PraosConfig prms ei = leiosPraosConfig cfg + + -- A header with no announcement clears the field. + upd _old = + LeiosLeiosRight $ + MkAnnouncedBy (hashKey (Views.hvVK b)) . fromCodecEbAnnouncement + <$> LeiosCodec.hbEbAnnouncement (Views.hvSigned b) + +instance Dijkstra.DijkstraEraForecast era => Views.ForecastsLeios (PraosWithLeios c) era where + forecastToBasePraosLedgerView (f :: SL.Forecast t era) = + Views.PraosLedgerView + { Views.plvPoolDistr = f ^. SL.poolDistrForecastL @era @t + , Views.plvMaxHeaderSize = ccMaxBHSize cc + , Views.plvMaxBodySize = ccMaxBBSize cc + , Views.plvProtocolVersion = ccProtocolVersion cc + , Views.plvCommittee = + LeiosLeiosRight $ f ^. Dijkstra.leiosCommitteeForecastL @era @t + , Views.plvQuorumStakeThreshold = + LeiosLeiosRight $ f ^. Dijkstra.leiosQuorumStakeThresholdForecastL @era @t + , Views.plvAnnouncementPeriodLength = + LeiosLeiosRight $ f ^. Dijkstra.leiosAnnouncementPeriodLengthForecastL @era @t + , Views.plvVotePeriodLength = + LeiosLeiosRight $ f ^. Dijkstra.leiosVotePeriodLengthForecastL @era @t + , Views.plvDiffusionPeriodLength = + LeiosLeiosRight $ f ^. Dijkstra.leiosDiffusionPeriodLengthForecastL @era @t + , Views.plvMaxEbBodySize = + LeiosLeiosRight $ f ^. Dijkstra.maxEndorserBlockReferencesSizeForecastL @era @t + , Views.plvMaxEbTxsSize = + LeiosLeiosRight $ f ^. Dijkstra.maxEndorserBlockTxsSizeForecastL @era @t + } + where + cc = SL.forecastChainChecks @t @era f diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index f9e179e145..40266d3be6 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -11,6 +15,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} @@ -18,25 +23,30 @@ module Ouroboros.Consensus.Protocol.Praos ( AnnouncedBy (..) - , BasePraos - , BasePraosState (..) , BasePraosValidationErr (..) , ConsensusConfig (..) , Praos - , PraosExtension (..) , PraosCannotForge (..) + , BasePraosCrypto , PraosCrypto , PraosFields (..) , PraosIsLeader (..) , PraosParams (..) + , BasePraosState (..) + , PraosLedgerView , PraosState + , PraosValidateView , PraosToSign (..) , PraosValidationErr - , PraosWithLeios + , SerialisePraosState (..) , Ticked (..) , forgePraosFields - , leiosContextFreeHeaderChecks , praosCheckCanForge + , checkIsLeaderPraos + , reupdatePraosState + , tickPraosState + , validateKESSignature + , validateVRFSignature -- * For testing purposes , doValidateKESSignature @@ -70,9 +80,9 @@ import Cardano.Ledger.Keys import qualified Cardano.Ledger.Keys as SL import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Slot (Duration (Duration), (+*)) +import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.State as SL import Cardano.Protocol.Crypto (Crypto, KES, StandardCrypto, VRF) -import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec import qualified Cardano.Protocol.Praos.BlockHeader as PraosCodec import Cardano.Protocol.Praos.VRF ( InputVRF @@ -98,7 +108,6 @@ import Cardano.Slotting.EpochInfo ( EpochInfo , epochInfoEpoch , epochInfoFirst - , epochInfoSlotLength , hoistEpochInfo ) import Cardano.Slotting.Slot @@ -110,24 +119,25 @@ import Cardano.Slotting.Slot import qualified Codec.CBOR.Encoding as CBOR import Codec.Serialise (Serialise (decode, encode)) import Control.Exception (throw) -import Control.Monad (unless, when) +import Control.DeepSeq (NFData) +import Control.Monad (unless) import Control.Monad.Except (Except, runExcept, throwError) import Data.Coerce (coerce) import Data.Functor.Identity (runIdentity) import Data.Kind (Type) import Data.Map.Strict (Map) +import Data.Typeable (Typeable) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (Proxy)) -import Data.Word (Word64) +import Data.Void (Void) +import Data.Word (Word32, Word64) import GHC.Generics (Generic) +import Lens.Micro ((^.)) import LeiosDemoTypes ( EbAnnouncement , decodeEbAnnouncement - , ebAnnouncementSize , encodeEbAnnouncement - , minCertificationSlot ) -import qualified LeiosDemoTypes as Leios import NoThunks.Class (NoThunks) import Numeric.Natural (Natural) import Ouroboros.Consensus.Block (WithOrigin (NotOrigin)) @@ -137,6 +147,8 @@ import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch) import Ouroboros.Consensus.Protocol.Praos.Common +import Ouroboros.Consensus.Protocol.Praos.Orphans () +import Ouroboros.Consensus.Protocol.Signed (Signed) import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views import Ouroboros.Consensus.Protocol.TPraos ( ConsensusConfig (TPraosConfig, tpraosEpochInfo, tpraosParams) @@ -155,23 +167,45 @@ import Ouroboros.Consensus.Util.Versioned , encodeVersion ) -type BasePraos :: PraosExtension -> Type -> Type -data BasePraos pext c +-- | Praos with no extensions. +type Praos :: Type -> Type +data Praos c + +type instance ShelleyProtocolHeader (Praos c) = PraosCodec.Header c + +-- | Praos is not Leios, so it holds the left alternative. +newtype instance EitherLeiosF (Praos c) a b = PraosLeiosLeft a + deriving (Eq, Generic, Show) + deriving newtype NFData + +deriving anyclass instance NoThunks a => NoThunks (EitherLeiosF (Praos c) a b) -type Praos = BasePraos PextNone +instance Functor (EitherLeiosF (Praos c) a) where + fmap _ (PraosLeiosLeft a) = PraosLeiosLeft a -type PraosWithLeios = BasePraos PextLeios +instance (() ~ a) => Applicative (EitherLeiosF (Praos c) a) where + pure _ = PraosLeiosLeft () + PraosLeiosLeft () <*> PraosLeiosLeft () = PraosLeiosLeft () +instance Foldable (EitherLeiosF (Praos c) a) where + foldMap _ (PraosLeiosLeft _) = mempty + +instance Traversable (EitherLeiosF (Praos c) a) where + traverse _ (PraosLeiosLeft a) = pure (PraosLeiosLeft a) + +-- | What a protocol needs of its crypto: the Praos essentials, plus signing +-- whichever header body it is the protocol for. class ( Crypto c , DSIGN.Signable DSIGN (OCertSignable c) - , KES.Signable (KES c) (LeiosCodec.HeaderBody c) - , KES.Signable (KES c) (PraosCodec.HeaderBody c) , VRF.Signable (VRF c) InputVRF + , KES.Signable (KES c) (Signed (ShelleyProtocolHeader proto)) ) => - PraosCrypto c + BasePraosCrypto proto c -instance PraosCrypto StandardCrypto +instance BasePraosCrypto (Praos StandardCrypto) StandardCrypto + +type PraosCrypto c = BasePraosCrypto (Praos c) c {------------------------------------------------------------------------------- Fields required by Praos in the header @@ -206,9 +240,9 @@ data PraosToSign c = PraosToSign } deriving Generic -instance PraosCrypto c => NoThunks (PraosToSign c) +instance Crypto c => NoThunks (PraosToSign c) -deriving instance PraosCrypto c => Show (PraosToSign c) +deriving instance Crypto c => Show (PraosToSign c) forgePraosFields :: ( PraosCrypto c @@ -280,10 +314,10 @@ newtype PraosIsLeader c = PraosIsLeader } deriving Generic -instance PraosCrypto c => NoThunks (PraosIsLeader c) +instance Crypto c => NoThunks (PraosIsLeader c) -- | Static configuration -data instance ConsensusConfig (BasePraos ext c) = PraosConfig +data instance ConsensusConfig (Praos c) = PraosConfig { praosParams :: !PraosParams , praosEpochInfo :: !(EpochInfo (Except History.PastHorizonException)) -- it's useful for this record to be EpochInfo and one other thing, @@ -292,9 +326,9 @@ data instance ConsensusConfig (BasePraos ext c) = PraosConfig } deriving Generic -instance PraosCrypto c => NoThunks (ConsensusConfig (BasePraos ext c)) +instance Crypto c => NoThunks (ConsensusConfig (Praos c)) -instance HasMaxMajorProtVer (BasePraos c ext) where +instance HasMaxMajorProtVer (Praos c) where protoMaxMajorPV = praosMaxMajorPV . praosParams {------------------------------------------------------------------------------- @@ -306,7 +340,7 @@ instance HasMaxMajorProtVer (BasePraos c ext) where -- We track the last slot and the counters for operational certificates, as well -- as a series of nonces which get updated in different ways over the course of -- an epoch. -data BasePraosState pext = PraosState +data BasePraosState proto = PraosState { praosStateLastSlot :: !(WithOrigin SlotNo) , praosStateOCertCounters :: !(Map (KeyHash SL.BlockIssuer) Word64) -- ^ Operation Certificate counters @@ -324,7 +358,7 @@ data BasePraosState pext = PraosState -- ^ Nonce corresponding to the LAB nonce of the last block of the previous -- epoch , praosStateLeiosAnnouncement :: - !(StrictMaybeLeios (PraosExtensionHasLeios pext) (StrictMaybe AnnouncedBy)) + !(EitherLeiosF proto () (StrictMaybe AnnouncedBy)) -- ^ The Leios 'EbAnnouncement' from the most recently applied header on -- this chain — overwritten on every header tick (so a header with no -- announcement clears the field). The 'ResolveLeiosBlock' instance for @@ -332,7 +366,19 @@ data BasePraosState pext = PraosState -- that a certifying block's 'LeiosCert' refers to; only the -- immediately-previous announcement is ever certified. } - deriving (Generic, Show, Eq) + deriving Generic + +type PraosState c = BasePraosState (Praos c) + +type PraosLedgerView c = Views.BasePraosLedgerView (Praos c) + +type PraosValidateView c = Views.BasePraosValidateView (Praos c) c + +deriving instance + Show (EitherLeiosF proto () (StrictMaybe AnnouncedBy)) => Show (BasePraosState proto) + +deriving instance + Eq (EitherLeiosF proto () (StrictMaybe AnnouncedBy)) => Eq (BasePraosState proto) -- | An EB announcement, and the issuer of the header that carried it. -- @@ -357,41 +403,42 @@ decodeAnnouncedBy = do enforceSize "AnnouncedBy" 2 MkAnnouncedBy <$> fromCBOR <*> decodeEbAnnouncement -type PraosState = BasePraosState PextNone -instance KnownPraosExtension pext => NoThunks (BasePraosState pext) +deriving anyclass instance + ( Typeable proto + , NoThunks (EitherLeiosF proto () (StrictMaybe AnnouncedBy)) + ) => + NoThunks (BasePraosState proto) -instance KnownPraosExtension pext => ToCBOR (BasePraosState pext) where +instance SerialisePraosState proto => ToCBOR (BasePraosState proto) where toCBOR = encode -instance KnownPraosExtension pext => FromCBOR (BasePraosState pext) where +instance SerialisePraosState proto => FromCBOR (BasePraosState proto) where fromCBOR = decode -countOfFieldsInPraosState :: - forall pext proxy a. (KnownPraosExtension pext, Num a) => proxy pext -> a -countOfFieldsInPraosState _ = - praos + leios - where - praos = 8 - leios = case praosExtensionHasLeios (Proxy @pext) of - PextDoesNotHaveLeiosDecided -> 0 - PextHasLeiosDecided -> 1 - --- | @pext@ selects the codec, so each extension's version numbers are their own --- namespace: these two are unrelated formats that merely both start counting. +-- | How a protocol encodes 'PraosState'. -- --- 'PextNone' is mainnet's, and so keeps the version mainnet writes. 'PextLeios' --- starts at 1, which is what the code before 'BasePraos' wrote for Dijkstra -- --- back when Dijkstra was paired with 'Praos' -- with the same fields in the --- same order. A node already running the Leios prototype can therefore still --- decode the chain-dep state in the snapshots it has on disk. -versionOfPraosState :: - forall pext proxy. KnownPraosExtension pext => proxy pext -> VersionNumber -versionOfPraosState _ = case praosExtensionHasLeios (Proxy @pext) of - PextDoesNotHaveLeiosDecided -> 0 - PextHasLeiosDecided -> 1 - -instance KnownPraosExtension pext => Serialise (BasePraosState pext) where +-- Only the field count and the version number vary; which fields those are is +-- what 'EitherLeiosF' already decides. +class + ( Typeable proto + , Applicative (EitherLeiosF proto ()) + , Traversable (EitherLeiosF proto ()) + ) => + SerialisePraosState proto + where + -- | Separate namespaces: the HFC's era index precedes this, so the codec is + -- already chosen when the version is read. + versionOfPraosState :: proxy proto -> VersionNumber + + -- | How many fields this protocol writes. + countOfFieldsInPraosState :: Num a => proxy proto -> a + +instance Typeable c => SerialisePraosState (Praos c) where + versionOfPraosState _ = 0 + countOfFieldsInPraosState _ = 8 + +instance SerialisePraosState proto => Serialise (BasePraosState proto) where encode PraosState { praosStateLastSlot @@ -404,9 +451,9 @@ instance KnownPraosExtension pext => Serialise (BasePraosState pext) where , praosStateLastEpochBlockNonce , praosStateLeiosAnnouncement } = - encodeVersion (versionOfPraosState (Proxy @pext)) $ + encodeVersion (versionOfPraosState (Proxy @proto)) $ mconcat - [ CBOR.encodeListLen (countOfFieldsInPraosState (Proxy @pext)) + [ CBOR.encodeListLen (countOfFieldsInPraosState (Proxy @proto)) , toCBOR praosStateLastSlot , toCBOR praosStateOCertCounters , toEraCBOR @ShelleyEra praosStateEvolvingNonce @@ -420,12 +467,12 @@ instance KnownPraosExtension pext => Serialise (BasePraosState pext) where decode = decodeVersion - [ (versionOfPraosState (Proxy @pext), Decode decodePraosState) + [ (versionOfPraosState (Proxy @proto), Decode decodePraosState) ] where - decodePraosState :: forall s. Decoder s (BasePraosState pext) + decodePraosState :: forall s. Decoder s (BasePraosState proto) decodePraosState = do - enforceSize "PraosState" (countOfFieldsInPraosState (Proxy @pext)) + enforceSize "PraosState" (countOfFieldsInPraosState (Proxy @proto)) PraosState <$> fromCBOR <*> fromCBOR @@ -437,20 +484,20 @@ instance KnownPraosExtension pext => Serialise (BasePraosState pext) where <*> fromEraCBOR @ShelleyEra <*> traverse (\() -> decodeNullStrictMaybe decodeAnnouncedBy) - ( case praosExtensionHasLeios (Proxy @pext) of - PextDoesNotHaveLeiosDecided -> SNothingLeios - PextHasLeiosDecided -> SJustLeios () - ) - -data instance Ticked (BasePraosState pext) = TickedPraosState - { tickedPraosStateChainDepState :: BasePraosState pext - , tickedPraosStateLedgerView :: Views.BasePraosLedgerView pext + (pure () :: EitherLeiosF proto () ()) + +data instance Ticked (BasePraosState proto) = TickedPraosState + { tickedPraosStateChainDepState :: BasePraosState proto + , tickedPraosStateLedgerView :: Views.BasePraosLedgerView proto } ----- -- | Errors which we might encounter -data BasePraosValidationErr pext c +-- +-- Includes the errors of every extension, but only if they're enabled, via +-- token constructor arguments like 'VoidUnlessLeios'. +data BasePraosValidationErr proto c = VRFKeyUnknown !(KeyHash SL.StakePool) -- unknown VRF keyhash (not registered) | VRFKeyWrongVRFKey @@ -488,56 +535,45 @@ data BasePraosValidationErr pext c !String -- error message given by Consensus Layer | NoCounterForKeyHashOCERT !(KeyHash SL.BlockIssuer) -- stake pool key hash - | LeiosHeaderErr !(HasLeiosProof (PraosExtensionHasLeios pext)) Leios.LeiosHeaderErr + | LeiosEbTooBig + !(EitherLeiosF proto Void ()) + !Word32 -- the announced size + !Word32 -- the bound + | LeiosCertTooYoung + !(EitherLeiosF proto Void ()) + !SlotNo -- the announcing slot + !SlotNo -- the certifying slot + !SlotNo -- the earliest the certificate was allowed + | LeiosCertWithoutAnnouncement + !(EitherLeiosF proto Void ()) deriving Generic --- | The one Leios constructor (the embedder) of 'BasePraosValidationErr' --- carries a 'HasLeiosProof', so at 'PextNone' --- which is mainnet's /before/ --- Leios\/Dijkstra --- none of them can be constructed and the inhabited set is --- exactly what it was before Leios. -type PraosValidationErr c = BasePraosValidationErr PextNone c - -deriving instance (PraosCrypto c, KnownPraosExtension pext) => Eq (BasePraosValidationErr pext c) +type PraosValidationErr c = BasePraosValidationErr (Praos c) c deriving instance - (PraosCrypto c, KnownPraosExtension pext) => NoThunks (BasePraosValidationErr pext c) + (BasePraosCrypto proto c, Eq (EitherLeiosF proto Void ())) => + Eq (BasePraosValidationErr proto c) -deriving instance (PraosCrypto c, KnownPraosExtension pext) => Show (BasePraosValidationErr pext c) +deriving instance + (BasePraosCrypto proto c, Typeable proto, NoThunks (EitherLeiosF proto Void ())) => + NoThunks (BasePraosValidationErr proto c) -instance (PraosCrypto c, KnownPraosExtension pext) => ConsensusProtocol (BasePraos pext c) where - type ChainDepState (BasePraos pext c) = BasePraosState pext - type IsLeader (BasePraos pext c) = PraosIsLeader c - type CanBeLeader (BasePraos pext c) = PraosCanBeLeader c - type TiebreakerView (BasePraos pext c) = PraosTiebreakerView c - type LedgerView (BasePraos pext c) = Views.BasePraosLedgerView pext - type ValidationErr (BasePraos pext c) = BasePraosValidationErr pext c - type ValidateView (BasePraos pext c) = Views.BaseHeaderView pext c +deriving instance + (BasePraosCrypto proto c, Show (EitherLeiosF proto Void ())) => + Show (BasePraosValidationErr proto c) + +instance PraosCrypto c => ConsensusProtocol (Praos c) where + type ChainDepState (Praos c) = BasePraosState (Praos c) + type IsLeader (Praos c) = PraosIsLeader c + type CanBeLeader (Praos c) = PraosCanBeLeader c + type TiebreakerView (Praos c) = PraosTiebreakerView c + type LedgerView (Praos c) = Views.BasePraosLedgerView (Praos c) + type ValidationErr (Praos c) = BasePraosValidationErr (Praos c) c + type ValidateView (Praos c) = Views.BasePraosValidateView (Praos c) c protocolSecurityParam = praosSecurityParam . praosParams - checkIsLeader - cfg - PraosCanBeLeader - { praosCanBeLeaderSignKeyVRF - , praosCanBeLeaderColdVerKey - } - slot - cs = - if meetsLeaderThreshold cfg lv (SL.coerceKeyRole vkhCold) rho - then - Just - PraosIsLeader - { praosIsLeaderVrfRes = coerce rho - } - else Nothing - where - chainState = tickedPraosStateChainDepState cs - lv = tickedPraosStateLedgerView cs - eta0 = praosStateEpochNonce chainState - vkhCold = SL.hashKey praosCanBeLeaderColdVerKey - rho' = mkInputVRF slot eta0 - - rho = VRF.evalCertified () rho' praosCanBeLeaderSignKeyVRF + checkIsLeader cfg = checkIsLeaderPraos (praosParams cfg) -- Updating the chain dependent state for Praos. -- @@ -549,118 +585,92 @@ instance (PraosCrypto c, KnownPraosExtension pext) => ConsensusProtocol (BasePra -- nonce derived from the last block of the previous epoch. -- - Update the "last block of previous epoch" nonce to the nonce derived -- from the last applied block. - tickChainDepState - PraosConfig{praosEpochInfo} - lv - slot - st = - TickedPraosState - { tickedPraosStateChainDepState = st' - , tickedPraosStateLedgerView = lv - } - where - newEpoch = - isNewEpoch - (History.toPureEpochInfo praosEpochInfo) - (praosStateLastSlot st) - slot - st' = - if newEpoch - then - st - { praosStateEpochNonce = - praosStateCandidateNonce st - ⭒ praosStateLastEpochBlockNonce st - , praosStatePreviousEpochNonce = - praosStateEpochNonce st - , praosStateLastEpochBlockNonce = - praosStateLabNonce st - } - else st + tickChainDepState cfg = tickPraosState (praosEpochInfo cfg) -- Validate and update the chain dependent state as a result of processing a -- new header. updateChainDepState - cfg@( PraosConfig - PraosParams{praosLeaderF} - _ - ) + (PraosConfig prms@PraosParams{praosLeaderF} ei) b slot tcs = do - -- The Leios header checks. Cheap, so they run before the signature - -- checks. - -- - -- NB cert/txs exclusivity is not among these: it is a property of the - -- body, and 'blockMatchesHeader' already enforces it where the body is - -- in hand. Nor is the EB closure's size: the announcement carries only - -- one size, and it is the body's. - leiosHeaderChecks cfg lv b slot cs - -- First, we check the KES signature, which validates that the issuer is -- in fact who they say they are. - validateKESSignature cfg lv (praosStateOCertCounters cs) b + validateKESSignature prms lv (praosStateOCertCounters cs) b -- Then we examing the VRF proof, which confirms that they have the -- right to issue in this slot. validateVRFSignature (praosStateEpochNonce cs) lv praosLeaderF b -- Finally, we apply the changes from this header to the chain state. - pure $ reupdateChainDepState cfg b slot tcs + pure $ reupdatePraosState prms ei id b slot cs where lv = tickedPraosStateLedgerView tcs cs = tickedPraosStateChainDepState tcs -- Re-update the chain dependent state as a result of processing a header. - reupdateChainDepState - _cfg@( PraosConfig - PraosParams{praosRandomnessStabilisationWindow} - ei - ) - b - slot - tcs = - cs - { praosStateLastSlot = NotOrigin slot - , praosStateLabNonce = prevHashToNonce (Views.hvPrevHash b) - , praosStateEvolvingNonce = newEvolvingNonce - , praosStateCandidateNonce = - if slot +* Duration praosRandomnessStabilisationWindow < firstSlotNextEpoch - then newEvolvingNonce - else praosStateCandidateNonce cs - , praosStateOCertCounters = - Map.insert hk n $ praosStateOCertCounters cs - , praosStateLeiosAnnouncement = - case singPraosExtension (Proxy @pext) of - SingPextNone -> SNothingLeios - SingPextLeios -> - SJustLeios $ - MkAnnouncedBy hk . fromCodecEbAnnouncement - <$> LeiosCodec.hbEbAnnouncement (Views.hvSigned b) - } - where - epochInfoWithErr = - hoistEpochInfo - (either throw pure . runExcept) - ei - firstSlotNextEpoch = runIdentity $ do - EpochNo currentEpochNo <- epochInfoEpoch epochInfoWithErr slot - let nextEpoch = EpochNo $ currentEpochNo + 1 - epochInfoFirst epochInfoWithErr nextEpoch - cs = tickedPraosStateChainDepState tcs - eta = vrfNonceValue (Proxy @c) $ Views.hvVrfRes b - newEvolvingNonce = praosStateEvolvingNonce cs ⭒ eta - OCert _ n _ _ = Views.hvOCert b - hk = hashKey $ Views.hvVK b + reupdateChainDepState (PraosConfig prms ei) b slot tcs = + reupdatePraosState prms ei id b slot (tickedPraosStateChainDepState tcs) + +-- | The chain-dep state update every protocol performs. +-- +-- The one field that differs is 'praosStateLeiosAnnouncement', so the caller +-- says how to update it; 'Praos' passes 'id'. +reupdatePraosState :: + forall proto c. + PraosParams -> + EpochInfo (Except History.PastHorizonException) -> + ( EitherLeiosF proto () (StrictMaybe AnnouncedBy) -> + EitherLeiosF proto () (StrictMaybe AnnouncedBy) + ) -> + Views.BasePraosValidateView proto c -> + SlotNo -> + BasePraosState proto -> + BasePraosState proto +reupdatePraosState + PraosParams{praosRandomnessStabilisationWindow} + ei + updAnnouncement + b + slot + cs = + cs + { praosStateLastSlot = NotOrigin slot + , praosStateLabNonce = prevHashToNonce (Views.hvPrevHash b) + , praosStateEvolvingNonce = newEvolvingNonce + , praosStateCandidateNonce = + if slot +* Duration praosRandomnessStabilisationWindow < firstSlotNextEpoch + then newEvolvingNonce + else praosStateCandidateNonce cs + , praosStateOCertCounters = + Map.insert hk n $ praosStateOCertCounters cs + , praosStateLeiosAnnouncement = + updAnnouncement (praosStateLeiosAnnouncement cs) + } + where + epochInfoWithErr = + hoistEpochInfo + (either throw pure . runExcept) + ei + firstSlotNextEpoch = runIdentity $ do + EpochNo currentEpochNo <- epochInfoEpoch epochInfoWithErr slot + let nextEpoch = EpochNo $ currentEpochNo + 1 + epochInfoFirst epochInfoWithErr nextEpoch + eta = vrfNonceValue (Proxy @c) $ Views.hvVrfRes b + newEvolvingNonce = praosStateEvolvingNonce cs ⭒ eta + OCert _ n _ _ = Views.hvOCert b + hk = hashKey $ Views.hvVK b -- | Check whether this node meets the leader threshold to issue a block. meetsLeaderThreshold :: - forall pext c. - ConsensusConfig (BasePraos pext c) -> - LedgerView (BasePraos pext c) -> + forall proxy proto c. + proxy c -> + PraosParams -> + Views.BasePraosLedgerView proto -> SL.KeyHash SL.StakePool -> VRF.CertifiedVRF (VRF c) InputVRF -> Bool meetsLeaderThreshold - PraosConfig{praosParams} + _prx + praosParams Views.PraosLedgerView{Views.plvPoolDistr} keyHash rho = @@ -675,26 +685,26 @@ meetsLeaderThreshold Map.lookup keyHash poolDistr validateVRFSignature :: - forall pext c. - PraosCrypto c => + forall proto c. + BasePraosCrypto proto c => Nonce -> - Views.BasePraosLedgerView pext -> + Views.BasePraosLedgerView proto -> ActiveSlotCoeff -> - Views.BaseHeaderView pext c -> - Except (BasePraosValidationErr pext c) () + Views.BasePraosValidateView proto c -> + Except (BasePraosValidationErr proto c) () validateVRFSignature eta0 (Views.plvPoolDistr -> SL.PoolDistr pd _) = doValidateVRFSignature eta0 pd -- NOTE: this function is much easier to test than 'validateVRFSignature' because we don't need -- to construct a 'PraosConfig' nor 'LedgerView' to test it. doValidateVRFSignature :: - forall pext c. - PraosCrypto c => + forall proto c. + BasePraosCrypto proto c => Nonce -> Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> ActiveSlotCoeff -> - Views.BaseHeaderView pext c -> - Except (BasePraosValidationErr pext c) () + Views.BasePraosValidateView proto c -> + Except (BasePraosValidationErr proto c) () doValidateVRFSignature eta0 pd f b = do case Map.lookup hk pd of Nothing -> throwError $ VRFKeyUnknown hk @@ -719,108 +729,15 @@ doValidateVRFSignature eta0 pd f b = do vrfLeaderVal = vrfLeaderValue (Proxy @c) vrfCert slot = Views.hvSlotNo b --- | The Leios header checks that read only the header and the ledger view. --- --- Sound out of context, which is what lets both header paths run them: --- 'updateChainDepState', from the header's own predecessor, and --- 'validateAnnouncementChainDepState', from the immutable tip. The bound they --- check is forecast for the header's own slot --- ('Dijkstra.maxEndorserBlockReferencesSizeForecastL'), so both paths read the --- same value: a forecast either yields the view that slot will have or refuses --- as 'OutsideHorizon'. The staleness the announcement path does have to live --- with is in the chain-dep state --- the opcert counters --- and none of these --- checks reads it. -leiosContextFreeHeaderChecks :: - forall pext c. - KnownPraosExtension pext => - Views.BasePraosLedgerView pext -> - Views.BaseHeaderView pext c -> - Except (BasePraosValidationErr pext c) () -leiosContextFreeHeaderChecks lv b = - case praosExtensionHasLeios (Proxy @pext) of - PextDoesNotHaveLeiosDecided -> pure () - PextHasLeiosDecided -> do - let SJustLeios (_containsCert, mbAnn) = Views.hvLeios b - SJustLeios llv = Views.plvLeios lv - case mbAnn of - SNothing -> pure () - SJust ann -> do - let announced = ebAnnouncementSize ann - -- TEMPORARY KLUDGE -- DO NOT MERGE. - -- - -- The deployed testnet has historical announcements above the - -- 'maxEndorserBlockReferencesSize' its own Dijkstra genesis sets - -- (e.g. 102429 against 100000 at slot 709083), so enforcing the - -- ledger's value stalls the sync there. Exception granted here - -- and here only: every other use of the limit, and the genesis - -- file itself, are untouched. - maximum' = max 200000 (Views.llvMaxEbBodySize llv) - when (announced > maximum') $ - throwError $ - LeiosHeaderErr mkHasLeiosProof $ - Leios.LeiosEbTooBig announced maximum' - --- | The Leios-specific checks on a header, called by 'updateChainDepState'. --- --- 'leiosContextFreeHeaderChecks' plus the one check that needs the header's --- immediate predecessor: a CertRB may not certify an announcement younger than --- the certification gap, and only the predecessor's state says which --- announcement that is. -leiosHeaderChecks :: - forall pext c. - KnownPraosExtension pext => - ConsensusConfig (BasePraos pext c) -> - Views.BasePraosLedgerView pext -> - Views.BaseHeaderView pext c -> - SlotNo -> - BasePraosState pext -> - Except (BasePraosValidationErr pext c) () -leiosHeaderChecks PraosConfig{praosEpochInfo} lv b slot cs = do - leiosContextFreeHeaderChecks lv b - case praosExtensionHasLeios (Proxy @pext) of - PextDoesNotHaveLeiosDecided -> pure () - PextHasLeiosDecided -> do - let SJustLeios (containsCert, _mbAnn) = Views.hvLeios b - SJustLeios llv = Views.plvLeios lv - SJustLeios announcedByPredecessor = praosStateLeiosAnnouncement cs - - -- Note that the genesis state doesn't announce an EB. - when containsCert $ - case (announcedByPredecessor, praosStateLastSlot cs) of - (SJust{}, NotOrigin announcingSlot) -> do - let earliestAllowed = - minCertificationSlot - ( runIdentity $ - epochInfoSlotLength - (History.toPureEpochInfo praosEpochInfo) - slot - ) - (Views.llvAnnouncementPeriodLength llv) - (Views.llvVotePeriodLength llv) - (Views.llvDiffusionPeriodLength llv) - announcingSlot - when (slot < earliestAllowed) $ - throwError $ - LeiosHeaderErr mkHasLeiosProof $ - Leios.LeiosCertTooYoung announcingSlot slot earliestAllowed - -- A state that announced an EB has necessarily applied a header, so - -- 'Origin' is the same situation as announcing nothing. - _ -> - throwError $ - LeiosHeaderErr mkHasLeiosProof Leios.LeiosCertWithoutAnnouncement - validateKESSignature :: - (KnownPraosExtension pext, PraosCrypto c) => - ConsensusConfig (BasePraos pext c) -> - LedgerView (BasePraos pext c) -> + BasePraosCrypto proto c => + PraosParams -> + Views.BasePraosLedgerView proto -> Map (KeyHash SL.BlockIssuer) Word64 -> - Views.BaseHeaderView pext c -> - Except (BasePraosValidationErr pext c) () + Views.BasePraosValidateView proto c -> + Except (BasePraosValidationErr proto c) () validateKESSignature - _cfg@( PraosConfig - PraosParams{praosMaxKESEvo, praosSlotsPerKESPeriod} - _ei - ) + PraosParams{praosMaxKESEvo, praosSlotsPerKESPeriod} Views.PraosLedgerView{Views.plvPoolDistr = SL.PoolDistr lvPoolDistr _totalActiveStake} ocertCounters = doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod lvPoolDistr ocertCounters @@ -842,27 +759,27 @@ data WhetherToUpperBoundOCERT -- NOTE: This function is much easier to test than 'validateKESSignature' because we don't need to -- construct a 'PraosConfig' nor 'LedgerView' to test it. doValidateKESSignature :: - (PraosCrypto c, KnownPraosExtension pext) => + BasePraosCrypto proto c => Word64 -> Word64 -> Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> Map (KeyHash SL.BlockIssuer) Word64 -> - Views.BaseHeaderView pext c -> - Except (BasePraosValidationErr pext c) () + Views.BasePraosValidateView proto c -> + Except (BasePraosValidationErr proto c) () doValidateKESSignature = doValidateKESSignatureWorker UpperBoundOCERT -- | The worker underlying 'doValidateKESSignature', parameterized by whether to -- enforce the OCERT counter's upper bound (see 'WhetherToUpperBoundOCERT'). doValidateKESSignatureWorker :: - forall pext c. - (KnownPraosExtension pext, PraosCrypto c) => + forall proto c. + BasePraosCrypto proto c => WhetherToUpperBoundOCERT -> Word64 -> Word64 -> Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> Map (KeyHash SL.BlockIssuer) Word64 -> - Views.BaseHeaderView pext c -> - Except (BasePraosValidationErr pext c) () + Views.BasePraosValidateView proto c -> + Except (BasePraosValidationErr proto c) () doValidateKESSignatureWorker whetherToUpperBound praosMaxKESEvo praosSlotsPerKESPeriod stakeDistribution ocertCounters b = do c0 <= kp ?! KESBeforeStartOCERT c0 kp @@ -874,7 +791,7 @@ doValidateKESSignatureWorker whetherToUpperBound praosMaxKESEvo praosSlotsPerKES DSIGN.verifySignedDSIGN () vkcold (OCert.ocertToSignable oc) tau ?!: InvalidSignatureOCERT n c0 - withSignableDict (KES.verifySignedKES () vk_hot t (Views.hvSigned b) (Views.hvSignature b)) + KES.verifySignedKES () vk_hot t (Views.hvSigned b) (Views.hvSignature b) ?!: InvalidKesSignatureOCERT kp_ c0_ t praosMaxKESEvo case currentIssueNo of Nothing -> do @@ -903,12 +820,6 @@ doValidateKESSignatureWorker whetherToUpperBound praosMaxKESEvo praosSlotsPerKES | otherwise = Nothing - withSignableDict :: - (KES.Signable (KES c) (Views.BaseHeaderBody pext c) => r) -> r - withSignableDict k = case singPraosExtension (Proxy @pext) of - SingPextNone -> k - SingPextLeios -> k - {------------------------------------------------------------------------------- CannotForge -------------------------------------------------------------------------------} @@ -931,10 +842,10 @@ data PraosCannotForge c !OCert.KESPeriod deriving Generic -deriving instance PraosCrypto c => Show (PraosCannotForge c) +deriving instance Crypto c => Show (PraosCannotForge c) praosCheckCanForge :: - ConsensusConfig (BasePraos pext c) -> + ConsensusConfig (Praos c) -> SlotNo -> HotKey.KESInfo -> Either (PraosCannotForge c) () @@ -960,10 +871,10 @@ praosCheckCanForge -------------------------------------------------------------------------------} instance - (PraosCrypto c, KnownPraosExtension pext) => - PraosProtocolSupportsNode (BasePraos pext c) + PraosCrypto c => + PraosProtocolSupportsNode (Praos c) where - type PraosProtocolSupportsNodeCrypto (BasePraos pext c) = c + type PraosProtocolSupportsNodeCrypto (Praos c) = c getPraosNonces _prx cdst = PraosNonces @@ -999,16 +910,20 @@ instance -- - They share the same ADDRHASH algorithm -- - They share the same DSIGN verification keys -- - They share the same VRF verification keys -instance KnownPraosExtension pext => TranslateProto (TPraos c) (BasePraos pext c) where +instance TranslateProto (TPraos c) (Praos c) where translateLedgerView _ SL.TPraosLedgerView{SL.tplvPoolDistr, SL.tplvChainChecks} = Views.PraosLedgerView { Views.plvPoolDistr = tplvPoolDistr , Views.plvMaxHeaderSize = SL.ccMaxBHSize tplvChainChecks , Views.plvMaxBodySize = SL.ccMaxBBSize tplvChainChecks , Views.plvProtocolVersion = SL.ccProtocolVersion tplvChainChecks - , Views.plvLeios = case praosExtensionHasLeios (Proxy @pext) of - PextDoesNotHaveLeiosDecided -> SNothingLeios - PextHasLeiosDecided -> SJustLeios Views.initialLeiosLedgerView + , Views.plvCommittee = PraosLeiosLeft () + , Views.plvQuorumStakeThreshold = PraosLeiosLeft () + , Views.plvAnnouncementPeriodLength = PraosLeiosLeft () + , Views.plvVotePeriodLength = PraosLeiosLeft () + , Views.plvDiffusionPeriodLength = PraosLeiosLeft () + , Views.plvMaxEbBodySize = PraosLeiosLeft () + , Views.plvMaxEbTxsSize = PraosLeiosLeft () } translateChainDepState _ tpState = @@ -1021,9 +936,7 @@ instance KnownPraosExtension pext => TranslateProto (TPraos c) (BasePraos pext c , praosStatePreviousEpochNonce = epochNonce -- same as current epoch nonce , praosStateLabNonce = csLabNonce , praosStateLastEpochBlockNonce = SL.ticknStatePrevHashNonce csTickn - , praosStateLeiosAnnouncement = case praosExtensionHasLeios (Proxy @pext) of - PextDoesNotHaveLeiosDecided -> SNothingLeios - PextHasLeiosDecided -> SJustLeios SNothing + , praosStateLeiosAnnouncement = PraosLeiosLeft () } where SL.ChainDepState{SL.csProtocol, SL.csTickn, SL.csLabNonce} = @@ -1046,34 +959,88 @@ infix 1 ?! (Right _) ?!: _ = pure () (Left e1) ?!: f = throwError $ f e1 + infix 1 ?!: --- | Crossing from the base protocol into the Leios extension. +-- | 'checkIsLeader', for any protocol whose state is a 'PraosState'. +checkIsLeaderPraos :: + forall proto c. + BasePraosCrypto proto c => + PraosParams -> + PraosCanBeLeader c -> + SlotNo -> + Ticked (BasePraosState proto) -> + Maybe (PraosIsLeader c) +checkIsLeaderPraos + prms + PraosCanBeLeader + { praosCanBeLeaderSignKeyVRF + , praosCanBeLeaderColdVerKey + } + slot + cs = + if meetsLeaderThreshold (Proxy @c) prms lv (SL.coerceKeyRole vkhCold) rho + then Just PraosIsLeader{praosIsLeaderVrfRes = coerce rho} + else Nothing + where + chainState = tickedPraosStateChainDepState cs + lv = tickedPraosStateLedgerView cs + eta0 = praosStateEpochNonce chainState + vkhCold = SL.hashKey praosCanBeLeaderColdVerKey + rho' = mkInputVRF slot eta0 + + rho = VRF.evalCertified () rho' praosCanBeLeaderSignKeyVRF + +-- | 'tickChainDepState', for any protocol whose state is a 'PraosState'. -- --- Everything carries over unchanged; only the Leios announcement has to be --- introduced, and it starts empty, since no header of the extension we are --- leaving could have carried one. -instance TranslateProto (BasePraos PextNone c) (BasePraos PextLeios c) where - -- The Leios data has to be conjured from a state that has none; see - -- 'Views.initialLeiosLedgerView'. - translateLedgerView _ lv = +-- If we are not in a new epoch, nothing happens. If we are, we do three things: +-- store the existing current epoch nonce as the "previous epoch" nonce; update +-- the epoch nonce to the combination of the candidate nonce and the nonce +-- derived from the last block of the previous epoch; and update the "last block +-- of previous epoch" nonce to the one derived from the last applied block. +tickPraosState :: + EpochInfo (Except History.PastHorizonException) -> + Views.BasePraosLedgerView proto -> + SlotNo -> + BasePraosState proto -> + Ticked (BasePraosState proto) +tickPraosState ei lv slot st = + TickedPraosState + { tickedPraosStateChainDepState = st' + , tickedPraosStateLedgerView = lv + } + where + newEpoch = + isNewEpoch + (History.toPureEpochInfo ei) + (praosStateLastSlot st) + slot + st' = + if newEpoch + then + st + { praosStateEpochNonce = + praosStateCandidateNonce st + ⭒ praosStateLastEpochBlockNonce st + , praosStatePreviousEpochNonce = praosStateEpochNonce st + , praosStateLastEpochBlockNonce = praosStateLabNonce st + } + else st + +instance Views.ForecastsLeios (Praos c) era where + forecastToBasePraosLedgerView (f :: SL.Forecast t era) = Views.PraosLedgerView - { Views.plvPoolDistr = Views.plvPoolDistr lv - , Views.plvMaxHeaderSize = Views.plvMaxHeaderSize lv - , Views.plvMaxBodySize = Views.plvMaxBodySize lv - , Views.plvProtocolVersion = Views.plvProtocolVersion lv - , Views.plvLeios = SJustLeios Views.initialLeiosLedgerView - } - - translateChainDepState _ st = - PraosState - { praosStateLastSlot = praosStateLastSlot st - , praosStateOCertCounters = praosStateOCertCounters st - , praosStateEvolvingNonce = praosStateEvolvingNonce st - , praosStateCandidateNonce = praosStateCandidateNonce st - , praosStateEpochNonce = praosStateEpochNonce st - , praosStatePreviousEpochNonce = praosStatePreviousEpochNonce st - , praosStateLabNonce = praosStateLabNonce st - , praosStateLastEpochBlockNonce = praosStateLastEpochBlockNonce st - , praosStateLeiosAnnouncement = SJustLeios SNothing + { Views.plvPoolDistr = f ^. SL.poolDistrForecastL @era @t + , Views.plvMaxHeaderSize = SL.ccMaxBHSize cc + , Views.plvMaxBodySize = SL.ccMaxBBSize cc + , Views.plvProtocolVersion = SL.ccProtocolVersion cc + , Views.plvCommittee = PraosLeiosLeft () + , Views.plvQuorumStakeThreshold = PraosLeiosLeft () + , Views.plvAnnouncementPeriodLength = PraosLeiosLeft () + , Views.plvVotePeriodLength = PraosLeiosLeft () + , Views.plvDiffusionPeriodLength = PraosLeiosLeft () + , Views.plvMaxEbBodySize = PraosLeiosLeft () + , Views.plvMaxEbTxsSize = PraosLeiosLeft () } + where + cc = SL.forecastChainChecks @t @era f diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs index 65d205aec5..a996dd878c 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs @@ -12,13 +12,15 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Various things common to iterations of the Praos protocol. module Ouroboros.Consensus.Protocol.Praos.Common - ( MaxMajorProtVer (..) + ( ShelleyProtocolHeader + , MaxMajorProtVer (..) , HasMaxMajorProtVer (..) , PraosCanBeLeader (..) , PraosTiebreakerView (..) @@ -32,14 +34,7 @@ module Ouroboros.Consensus.Protocol.Praos.Common , instantiatePraosCredentials -- * Leios - , PraosExtension (..) - , HasLeiosProof - , WhetherHasLeios (..) - , WhetherHasLeiosDecided (..) - , KnownPraosExtension (..) - , SingPraosExtension (..) - , StrictMaybeLeios (..) - , mkHasLeiosProof + , EitherLeiosF , fromCodecEbAnnouncement , toCodecEbAnnouncement ) where @@ -64,18 +59,13 @@ import Cardano.Protocol.Crypto (Crypto, KES, VRF) import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec import qualified Cardano.Protocol.TPraos.OCert as OCert import Cardano.Slotting.Slot (SlotNo) -import Control.DeepSeq (NFData (..)) import qualified Control.Tracer as Tracer import Data.Function (on) -import Data.Kind (Constraint, Type) +import Data.Kind (Type) import Data.Map.Strict (Map) import Data.Ord (Down (..)) -import Data.Proxy (Proxy (Proxy)) -import Data.Type.Equality ((:~:) (Refl)) -import Data.Typeable (Typeable, typeRep) import Data.Word (Word64) import GHC.Generics (Generic) -import GHC.Show (showSpace) import LeiosDemoTypes (EbAnnouncement (..), EbHash (MkEbHash)) import NoThunks.Class import Ouroboros.Consensus.Protocol.Abstract @@ -394,131 +384,34 @@ class ConsensusProtocol p => PraosProtocolSupportsNode p where ----- --- | Which optional extensions to the base Praos protocol are enabled. +-- | The header a protocol validates, determined by the protocol. -- --- We define them here, as part of Praos, because we want exactly one single --- source of truth (this subtree of the module hierarchy) to explicitly --- determine how the base protocol and whichever of its extensions are enabled --- simultaneously to interact /as a @ConsensusProtocol@/. --- --- We define one constructor per each subset extensions that are known to be --- simultaneously compatible and worthwhile. (For now it's just Leios, but more --- extensions are planned, such as Phalanx.) -data PraosExtension = PextNone | PextLeios - --- | When possible, use 'WhetherHasLeiosDecided' instead -type SingPraosExtension :: PraosExtension -> Type -data SingPraosExtension pext where - SingPextNone :: SingPraosExtension PextNone - SingPextLeios :: SingPraosExtension PextLeios - --- | A 'Bool' isomorph for better type errors -data WhetherHasLeios = PextHasLeios | PextDoesNotHaveLeios - -data WhetherHasLeiosDecided pext - = PraosExtensionHasLeios pext ~ PextHasLeios => PextHasLeiosDecided - | PraosExtensionHasLeios pext ~ PextDoesNotHaveLeios => PextDoesNotHaveLeiosDecided +-- TODO two things to fix here, both deferred because each touches every use in +-- ouroboros-consensus-cardano. The name is not Shelley's --- this is whichever +-- header the protocol signs, which is why 'HeaderView' and the instances for +-- 'Praos', 'PraosWithLeios' and 'TPraos' all need it from the protocol package. +-- And 'Shelley.Protocol.Abstract' currently re-exports this, which the importers +-- there should stop relying on: they should name this module. +type family ShelleyProtocolHeader proto = (sh :: Type) | sh -> proto -type KnownPraosExtension :: PraosExtension -> Constraint -class (Typeable pext, Typeable (PraosExtensionHasLeios pext)) => KnownPraosExtension pext where - type PraosExtensionHasLeios pext :: WhetherHasLeios - praosExtensionHasLeios :: proxy pext -> WhetherHasLeiosDecided pext - - -- | When possible, use 'praosExtensionHasLeios' instead, since it's less - -- informative - singPraosExtension :: proxy pext -> SingPraosExtension pext - -instance KnownPraosExtension PextNone where - type PraosExtensionHasLeios _ = PextDoesNotHaveLeios - praosExtensionHasLeios = const PextDoesNotHaveLeiosDecided - singPraosExtension = const SingPextNone +----- -instance KnownPraosExtension PextLeios where - type PraosExtensionHasLeios _ = PextHasLeios - praosExtensionHasLeios = const PextHasLeiosDecided - singPraosExtension = const SingPextLeios ----- --- | Newtype wrapper to avoid 'NoThunks' orphan +-- | @a@ for the protocols without Leios, and @b@ for the ones with it. -- --- We're using ':~:' at all merely so we can still use @deriving@ for exception --- sum types. -type HasLeiosProof :: WhetherHasLeios -> Type -newtype HasLeiosProof whether - = MkHasLeiosProof (whether :~: PextHasLeios) - deriving (Eq, Show) - -deriving via - OnlyCheckWhnf (HasLeiosProof whether) - instance - Typeable whether => NoThunks (HasLeiosProof whether) - -mkHasLeiosProof :: HasLeiosProof PextHasLeios -mkHasLeiosProof = MkHasLeiosProof Refl - ------ +-- One such family per extension, which is what keeps every type that mentions +-- one indexed by @proto@ alone. The two uses so far: +-- +-- * @EitherLeiosF proto Void ()@ gates a constructor, since the protocols +-- without Leios cannot build it. +-- +-- * @EitherLeiosF proto () a@ gates a field, which those protocols have but +-- cannot put anything in. +type EitherLeiosF :: Type -> Type -> Type -> Type +data family EitherLeiosF proto a :: Type -> Type -type StrictMaybeLeios :: WhetherHasLeios -> Type -> Type - --- | Like 'StrictMaybe', but it's @SJust@ if and only if 'PraosExtensionHasLeios' -data StrictMaybeLeios whether a where - -- | Encoding and decoding this is a complete noop. - SNothingLeios :: StrictMaybeLeios PextDoesNotHaveLeios a - -- | Encoding and decoding this has no extra wrapper. - SJustLeios :: !a -> StrictMaybeLeios PextHasLeios a - -instance Functor (StrictMaybeLeios whether) where - fmap f = \case - SNothingLeios -> SNothingLeios - SJustLeios x -> SJustLeios $ f x - -instance Applicative (StrictMaybeLeios PextDoesNotHaveLeios) where - pure = const SNothingLeios - SNothingLeios <*> SNothingLeios = SNothingLeios - -instance Applicative (StrictMaybeLeios PextHasLeios) where - pure = SJustLeios - SJustLeios f <*> SJustLeios x = SJustLeios $ f x - -instance Foldable (StrictMaybeLeios whether) where - foldMap f = \case - SNothingLeios -> mempty - SJustLeios x -> f x - -instance Traversable (StrictMaybeLeios whether) where - traverse f = \case - SNothingLeios -> pure SNothingLeios - SJustLeios x -> SJustLeios <$> f x - -instance Eq a => Eq (StrictMaybeLeios whether a) where - SNothingLeios == SNothingLeios = True - SJustLeios x == SJustLeios y = x == y - -instance Ord a => Ord (StrictMaybeLeios whether a) where - compare SNothingLeios SNothingLeios = EQ - compare (SJustLeios x) (SJustLeios y) = compare x y - -instance Show a => Show (StrictMaybeLeios whether a) where - showsPrec p = \case - SNothingLeios -> showString "SNothingLeios" - SJustLeios x -> showParen (p >= 11) $ showString "SJustLeios" <> showSpace <> shows x - -instance NFData a => NFData (StrictMaybeLeios whether a) where - rnf = \case - SNothingLeios -> () - SJustLeios x -> rnf x - -instance (Typeable whether, NoThunks a) => NoThunks (StrictMaybeLeios whether a) where - showTypeOf _ = - unwords - [ "StrictMaybeLeios" - , "(" ++ show (typeRep (Proxy @whether)) ++ ")" - , "(" ++ showTypeOf (Proxy @a) ++ ")" - ] - wNoThunks ctxt = \case - SNothingLeios -> wNoThunks ctxt () - SJustLeios x -> wNoThunks ctxt x ----- diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Orphans.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Orphans.hs new file mode 100644 index 0000000000..9b86a77901 --- /dev/null +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Orphans.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Which part of each Praos header is the signed one. +-- +-- Orphans by necessity: 'Signed' is declared in @ouroboros-consensus@ and the +-- header types in @cardano-protocol@, so no module owning either can host +-- these. They are alone here so that the pragma covers nothing else. +module Ouroboros.Consensus.Protocol.Praos.Orphans () where + +import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec +import qualified Cardano.Protocol.Praos.BlockHeader as PraosCodec +import Ouroboros.Consensus.Protocol.Signed (Signed) + +type instance Signed (PraosCodec.Header c) = PraosCodec.HeaderBody c + +type instance Signed (LeiosCodec.Header c) = LeiosCodec.HeaderBody c diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs index a3d98f5bba..6ab0d625e4 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs @@ -7,16 +7,12 @@ {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Protocol.Praos.Views - ( BaseHeaderBody - , BaseHeaderView (..) + ( BasePraosValidateView (..) , BasePraosLedgerView (..) , ForecastsLeios (..) - , LeiosLedgerView (..) - , PraosLedgerView - , initialLeiosLedgerView - , forecastToBasePraosLedgerView , extendHeaderBodyWithLeios ) where @@ -28,11 +24,9 @@ import Cardano.Ledger.BaseTypes , StrictMaybe , UnitInterval ) -import Cardano.Ledger.Chain (ChainChecksPParams (..)) -import qualified Cardano.Ledger.Dijkstra.Forecast as Dijkstra import Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey) import qualified Cardano.Ledger.Shelley.API as SL -import Cardano.Ledger.State (LeiosCommittee, emptyLeiosCommittee) +import Cardano.Ledger.State (LeiosCommittee) import Cardano.Protocol.Crypto (KES, VRF) import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec import qualified Cardano.Protocol.Praos.BlockHeader as PraosCodec @@ -41,27 +35,15 @@ import Cardano.Protocol.TPraos.BlockHeader (PrevHash) import Cardano.Protocol.TPraos.OCert (OCert) import Cardano.Slotting.Slot (SlotNo) import Data.Kind (Constraint, Type) -import Data.Proxy (Proxy (Proxy)) import Data.Word (Word16, Word32) import LeiosDemoTypes (EbAnnouncement) -import Lens.Micro ((^.)) import Ouroboros.Consensus.Protocol.Praos.Common +import Ouroboros.Consensus.Protocol.Signed (Signed) {------------------------------------------------------------------------------- - The upstream header types, per extension + The upstream header types, per protocol -------------------------------------------------------------------------------} --- | The upstream @cardano-protocol@ header body this extension uses. --- --- Its owners define one per protocol, wholly separately, and future extensions --- of Praos (eg Ouroboros Phalanx) will presumably each bring another. This is --- the KES-signed object, which is why it appears in 'BaseHeaderView' as-is --- rather than being projected field by field. -type BaseHeaderBody :: PraosExtension -> Type -> Type -type family BaseHeaderBody pext :: Type -> Type where - BaseHeaderBody PextNone = PraosCodec.HeaderBody - BaseHeaderBody PextLeios = LeiosCodec.HeaderBody - -- | The Leios header body is the Praos one plus the two Leios fields, so -- whoever builds one builds the Praos body first and hands it here. extendHeaderBodyWithLeios :: @@ -90,10 +72,10 @@ extendHeaderBodyWithLeios pb containsCert ann = Header view -------------------------------------------------------------------------------} -type BaseHeaderView :: PraosExtension -> Type -> Type +type BasePraosValidateView :: Type -> Type -> Type -- | View of the block header required by the Praos protocol. -data BaseHeaderView pext crypto = HeaderView +data BasePraosValidateView proto crypto = HeaderView { hvPrevHash :: !PrevHash -- ^ Hash of the previous block , hvVK :: !(VKey BlockIssuer) @@ -106,19 +88,12 @@ data BaseHeaderView pext crypto = HeaderView -- ^ operational certificate , hvSlotNo :: !SlotNo -- ^ Slot - , hvLeios :: - !( StrictMaybeLeios - (PraosExtensionHasLeios pext) - (Bool, StrictMaybe EbAnnouncement) - ) + , hvLeios :: !(EitherLeiosF proto () (Bool, StrictMaybe EbAnnouncement)) -- ^ The Leios payload: whether this block's body carries a certificate (ie -- whether it is a CertRB), and the endorser block this header announces. - -- - -- Statically absent unless the extension has Leios, since the header checks - -- that read it only exist there. - , hvSigned :: !(BaseHeaderBody pext crypto) + , hvSigned :: !(Signed (ShelleyProtocolHeader proto)) -- ^ Header which must be signed - , hvSignature :: !(SignedKES (KES crypto) (BaseHeaderBody pext crypto)) + , hvSignature :: !(SignedKES (KES crypto) (Signed (ShelleyProtocolHeader proto))) -- ^ KES Signature of the header } @@ -126,10 +101,10 @@ data BaseHeaderView pext crypto = HeaderView Ledger view -------------------------------------------------------------------------------} -type BasePraosLedgerView :: PraosExtension -> Type +type BasePraosLedgerView :: Type -> Type -- | View of the ledger required by the Praos protocol. -data BasePraosLedgerView pext = PraosLedgerView +data BasePraosLedgerView proto = PraosLedgerView { plvPoolDistr :: SL.PoolDistr -- ^ Stake distribution , plvMaxHeaderSize :: !Word16 @@ -138,105 +113,37 @@ data BasePraosLedgerView pext = PraosLedgerView -- ^ Maximum block body size , plvProtocolVersion :: !ProtVer -- ^ Current protocol version - , plvLeios :: !(StrictMaybeLeios (PraosExtensionHasLeios pext) LeiosLedgerView) - } - -deriving instance Show (BasePraosLedgerView pext) - -type PraosLedgerView = BasePraosLedgerView PextNone - --- | The Leios part of 'BasePraosLedgerView'. --- --- The Leios values that have to be read before the block they bear on is --- applied: header validation reads the periods and 'llvMaxEbBodySize', --- ChainSel's certificate check reads the committee and the quorum, and the --- fetch logic reads 'llvMaxEbTxsSize' when an endorser block's body arrives. -data LeiosLedgerView = LeiosLedgerView - { llvCommittee :: !LeiosCommittee + , plvCommittee :: !(EitherLeiosF proto () LeiosCommittee) -- ^ Who may vote this epoch, and with what weight - , llvQuorumStakeThreshold :: !UnitInterval + , plvQuorumStakeThreshold :: !(EitherLeiosF proto () UnitInterval) -- ^ Weight a certificate must accumulate - , llvAnnouncementPeriodLength :: !Milliseconds32 - , llvVotePeriodLength :: !Milliseconds32 - , llvDiffusionPeriodLength :: !Milliseconds32 + , plvAnnouncementPeriodLength :: !(EitherLeiosF proto () Milliseconds32) + , plvVotePeriodLength :: !(EitherLeiosF proto () Milliseconds32) + , plvDiffusionPeriodLength :: !(EitherLeiosF proto () Milliseconds32) -- ^ The three periods that determine how long after its announcement an -- endorser block may be certified. Kept as durations, since converting to a -- count of slots needs the slot length, which only the consensus config has. - , llvMaxEbBodySize :: !Word32 + , plvMaxEbBodySize :: !(EitherLeiosF proto () Word32) -- ^ Maximum total size of an endorser block itself (/not/ the closure) - , llvMaxEbTxsSize :: !Word32 - -- ^ Maximum total size of the transactions an endorser block references (the - -- closure) + , plvMaxEbTxsSize :: !(EitherLeiosF proto () Word32) + -- ^ Maximum total size of the transactions an endorser block references } - deriving (Eq, Show) --- | The Leios view of a ledger state that seats no committee. --- --- Nothing can be certified against it: the committee is empty and the quorum is --- the entire weight. This is the truth rather than a placeholder, both before --- the Leios era and during its first epochs, until a snapshot seated by the new --- era's rules rotates in. And so the other parameter values don't actually --- matter. -initialLeiosLedgerView :: LeiosLedgerView -initialLeiosLedgerView = - LeiosLedgerView - { llvCommittee = emptyLeiosCommittee - , llvQuorumStakeThreshold = maxBound - , llvAnnouncementPeriodLength = Milliseconds32 0 - , llvVotePeriodLength = Milliseconds32 0 - , llvDiffusionPeriodLength = Milliseconds32 1000000000 - , llvMaxEbBodySize = 0 - , llvMaxEbTxsSize = 0 - } +deriving instance + ( Show (EitherLeiosF proto () LeiosCommittee) + , Show (EitherLeiosF proto () UnitInterval) + , Show (EitherLeiosF proto () Milliseconds32) + , Show (EitherLeiosF proto () Word32) + ) => + Show (BasePraosLedgerView proto) -type ForecastsLeios :: PraosExtension -> Type -> Constraint +type ForecastsLeios :: Type -> Type -> Constraint --- | The Leios part of an era's forecast, as this extension sees it. +-- | How a protocol reads an era's forecast. -- --- Reading that part needs 'Dijkstra.DijkstraEraForecast', which the extensions --- without Leios must not demand of their eras. 'KnownPraosExtension' cannot --- serve here: refining @pext@ says nothing about @era@, and it is an @era@ --- dictionary that is missing. -class ForecastsLeios pext era where - forecastToLeiosPart :: - proxy pext -> - SL.Forecast t era -> - StrictMaybeLeios (PraosExtensionHasLeios pext) LeiosLedgerView - -instance ForecastsLeios PextNone era where - forecastToLeiosPart _ _ = SNothingLeios - -instance Dijkstra.DijkstraEraForecast era => ForecastsLeios PextLeios era where - forecastToLeiosPart _ = SJustLeios . forecastToLeiosLedgerView - -forecastToBasePraosLedgerView :: - forall pext t era. - (ForecastsLeios pext era, SL.EraForecast era) => - SL.Forecast t era -> - BasePraosLedgerView pext -forecastToBasePraosLedgerView f = - PraosLedgerView - { plvPoolDistr = f ^. SL.poolDistrForecastL @era @t - , plvMaxHeaderSize = ccMaxBHSize cc - , plvMaxBodySize = ccMaxBBSize cc - , plvProtocolVersion = ccProtocolVersion cc - , plvLeios = forecastToLeiosPart (Proxy @pext) f - } - where - cc = SL.forecastChainChecks @t @era f - -forecastToLeiosLedgerView :: - forall t era. - Dijkstra.DijkstraEraForecast era => - SL.Forecast t era -> - LeiosLedgerView -forecastToLeiosLedgerView f = - LeiosLedgerView - { llvCommittee = f ^. Dijkstra.leiosCommitteeForecastL @era @t - , llvQuorumStakeThreshold = f ^. Dijkstra.leiosQuorumStakeThresholdForecastL @era @t - , llvAnnouncementPeriodLength = f ^. Dijkstra.leiosAnnouncementPeriodLengthForecastL @era @t - , llvVotePeriodLength = f ^. Dijkstra.leiosVotePeriodLengthForecastL @era @t - , llvDiffusionPeriodLength = f ^. Dijkstra.leiosDiffusionPeriodLengthForecastL @era @t - , llvMaxEbBodySize = f ^. Dijkstra.maxEndorserBlockReferencesSizeForecastL @era @t - , llvMaxEbTxsSize = f ^. Dijkstra.maxEndorserBlockTxsSizeForecastL @era @t - } +-- A method rather than one shared function because only the protocols with +-- Leios may demand 'Dijkstra.DijkstraEraForecast' of their era, and knowing +-- @proto@ alone cannot supply that @era@ dictionary. +class ForecastsLeios proto era where + forecastToBasePraosLedgerView :: + SL.EraForecast era => SL.Forecast t era -> BasePraosLedgerView proto diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 5a94d6fa7e..9d0f6ff14a 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -1153,9 +1153,11 @@ library protocol exposed-modules: Ouroboros.Consensus.Protocol.Ledger.HotKey Ouroboros.Consensus.Protocol.Ledger.Util + Ouroboros.Consensus.Protocol.Leios Ouroboros.Consensus.Protocol.Praos Ouroboros.Consensus.Protocol.Praos.AgentClient Ouroboros.Consensus.Protocol.Praos.Common + Ouroboros.Consensus.Protocol.Praos.Orphans Ouroboros.Consensus.Protocol.Praos.Views Ouroboros.Consensus.Protocol.TPraos From b5417366fe219a307db848724c28a0be5a7189ad Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Wed, 7 Oct 2026 21:39:20 -0400 Subject: [PATCH 51/60] Fixup build of rest of code --- .../Ouroboros/Consensus/Cardano/Block.hs | 5 +- .../Consensus/Cardano/CanHardFork.hs | 3 +- .../Ouroboros/Consensus/Cardano/Ledger.hs | 3 +- .../Ouroboros/Consensus/Cardano/Node.hs | 3 +- .../Ouroboros/Consensus/Shelley/HFEras.hs | 5 +- .../Consensus/Shelley/Ledger/Forge.hs | 30 +- .../Consensus/Shelley/Ledger/Ledger.hs | 31 +- .../Consensus/Shelley/Ledger/Leios.hs | 26 +- .../Consensus/Shelley/Ledger/Protocol.hs | 3 +- .../Shelley/Ledger/SupportsProtocol.hs | 111 ++-- .../Ouroboros/Consensus/Shelley/Node/Praos.hs | 30 +- .../Consensus/Shelley/Node/Serialisation.hs | 11 +- .../Consensus/Shelley/Node/TPraos.hs | 2 +- .../Consensus/Shelley/Protocol/Abstract.hs | 16 +- .../Consensus/Shelley/Protocol/Praos.hs | 504 +++++++++--------- .../Consensus/Shelley/Protocol/TPraos.hs | 2 - .../Ouroboros/Consensus/Shelley/ShelleyHFC.hs | 25 +- .../Test/Consensus/Cardano/MockCrypto.hs | 6 + .../Test/Consensus/Shelley/Examples.hs | 31 +- .../Test/Consensus/Shelley/Generators.hs | 114 ++-- .../Test/Consensus/Shelley/MockCrypto.hs | 2 + .../Test/Consensus/Cardano/Translation.hs | 1 + .../Test/Consensus/Shelley/Dijkstra.hs | 2 +- .../Ouroboros/Consensus/Protocol/Leios.hs | 98 +++- .../Ouroboros/Consensus/Protocol/Praos.hs | 114 ++-- .../Ouroboros/Consensus/Protocol/TPraos.hs | 22 + .../Protocol/Serialisation/Generators.hs | 47 +- 27 files changed, 722 insertions(+), 525 deletions(-) diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs index e00c55f1ec..b7fca9d794 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs @@ -242,7 +242,8 @@ import Ouroboros.Consensus.Ledger.SupportsMempool ) import Ouroboros.Consensus.Ledger.Tables.Utils (emptyLedgerTables) import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) -import Ouroboros.Consensus.Protocol.Praos (Praos, PraosCrypto, PraosWithLeios) +import Ouroboros.Consensus.Protocol.Leios (LeiosCrypto, PraosWithLeios) +import Ouroboros.Consensus.Protocol.Praos (Praos) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) @@ -1539,7 +1540,7 @@ pattern ChainDepStateDijkstra st <- -- a single case; era mismatches fall through to the no-op default. instance forall c. - ( PraosCrypto c + ( LeiosCrypto c , ShelleyCompatible (PraosWithLeios c) DijkstraEra , HasCanonicalTxIn (CardanoEras c) , HasHardForkTxOut (CardanoEras c) diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs index 0ad07c2f62..2a8bf66f9b 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -91,7 +91,8 @@ import Ouroboros.Consensus.Protocol.Abstract hiding ) import Ouroboros.Consensus.Protocol.PBFT.State (PBftState) import qualified Ouroboros.Consensus.Protocol.PBFT.State as PBftState -import Ouroboros.Consensus.Protocol.Praos (Praos, PraosWithLeios) +import Ouroboros.Consensus.Protocol.Leios (PraosWithLeios) +import Ouroboros.Consensus.Protocol.Praos (Praos) import qualified Ouroboros.Consensus.Protocol.Praos as Praos import Ouroboros.Consensus.Protocol.Praos.Common (PraosTiebreakerView) import Ouroboros.Consensus.Protocol.TPraos diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs index fe41f24a14..b794998937 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs @@ -53,7 +53,8 @@ import Ouroboros.Consensus.Cardano.CanHardFork import Ouroboros.Consensus.HardFork.Combinator import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.Ledger.Tables -import Ouroboros.Consensus.Protocol.Praos (Praos, PraosWithLeios) +import Ouroboros.Consensus.Protocol.Leios (PraosWithLeios) +import Ouroboros.Consensus.Protocol.Praos (Praos) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Ledger ( BigEndianTxIn diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index c324fae1d3..9b0b51fa3b 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs @@ -92,7 +92,8 @@ import Ouroboros.Consensus.Ledger.Tables import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run -import Ouroboros.Consensus.Protocol.Praos (Praos, PraosParams (..), PraosWithLeios) +import Ouroboros.Consensus.Protocol.Leios (PraosWithLeios) +import Ouroboros.Consensus.Protocol.Praos (Praos, PraosParams (..)) import Ouroboros.Consensus.Protocol.Praos.AgentClient import Ouroboros.Consensus.Protocol.Praos.Common ( PraosCanBeLeader (..) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs index 532d9bcc4a..6d74cb57b5 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs @@ -20,7 +20,8 @@ module Ouroboros.Consensus.Shelley.HFEras import Cardano.Ledger.Dijkstra.Era (DijkstraEraBlockHeader (..)) import Cardano.Protocol.Crypto import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec -import Ouroboros.Consensus.Protocol.Praos (Praos, PraosWithLeios) +import Ouroboros.Consensus.Protocol.Leios (LeiosCrypto, PraosWithLeios) +import Ouroboros.Consensus.Protocol.Praos (Praos) import qualified Ouroboros.Consensus.Protocol.Praos as Praos import Ouroboros.Consensus.Protocol.TPraos (TPraos) import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos @@ -86,7 +87,7 @@ instance Praos.PraosCrypto c => ShelleyCompatible (Praos c) BabbageEra instance Praos.PraosCrypto c => ShelleyCompatible (Praos c) ConwayEra -instance Praos.PraosCrypto c => ShelleyCompatible (PraosWithLeios c) DijkstraEra where +instance LeiosCrypto c => ShelleyCompatible (PraosWithLeios c) DijkstraEra where workaroundLedgerIssue5937 = encodeShelleyBlockWorkaroundLedgerIssue5937 instance Crypto c => DijkstraEraBlockHeader (LeiosCodec.Header c) DijkstraEra where diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs index 8528cf3e06..f98a6cfc2a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs @@ -47,8 +47,8 @@ import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Protocol.Abstract (CanBeLeader) +import Ouroboros.Consensus.Protocol.Praos.Common (EitherLeiosF) import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) -import Ouroboros.Consensus.Protocol.Praos.Common (StrictMaybeLeios (..)) import Ouroboros.Consensus.Shelley.Eras (DijkstraEra) import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Config @@ -58,7 +58,7 @@ import Ouroboros.Consensus.Shelley.Ledger.Integrity import Ouroboros.Consensus.Shelley.Ledger.Mempool import Ouroboros.Consensus.Shelley.Protocol.Abstract ( ProtoCrypto - , ProtocolHeaderSupportsKES (ProtoHasLeios, configSlotsPerKESPeriod) + , ProtocolHeaderSupportsKES (configSlotsPerKESPeriod) , mkHeader ) @@ -68,10 +68,13 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract forgeShelleyBlock :: forall m era proto. - (ShelleyCompatible proto era, Monad m) => + ( ShelleyCompatible proto era + , Traversable (EitherLeiosF proto ()) + , Monad m + ) => HotKey (ProtoCrypto proto) m -> CanBeLeader proto -> - StrictMaybeLeios (ProtoHasLeios proto) () -> + EitherLeiosF proto () () -> ForgeBlockArgs m (ShelleyBlock proto era) -> m (ShelleyBlock proto era, Maybe ForgedLeiosEb) forgeShelleyBlock hotKey cbl leiosToken ForgeBlockArgs{..} = do @@ -83,17 +86,14 @@ forgeShelleyBlock hotKey cbl leiosToken ForgeBlockArgs{..} = do -- * Announce: forge and store a new EB from 'fbEbTxs' and announce it on this RB's header. -- When we are also certifying, 'fbEbTxs' contains transactions from the mempool that has already -- been rebased onto the post-certificate ledger state. - -- Matching the token refines 'ProtoHasLeios', which is what lets the Leios - -- branch build the header fields below. - (mayEbAnn :: Maybe (ForgedLeiosEb, EbAnnouncement), leiosFields) <- - case leiosToken of - SNothingLeios -> pure (Nothing, SNothingLeios) - SJustLeios () -> do - ann <- mkEb - pure - ( ann - , SJustLeios (isJust fbMayLeiosCert, maybeToStrictMaybe (snd <$> ann)) - ) + -- Runs 'mkEb' exactly where the protocol has the field. + leiosResult <- traverse (\() -> mkEb) leiosToken + let mayEbAnn :: Maybe (ForgedLeiosEb, EbAnnouncement) + mayEbAnn = foldr (\x _ -> x) Nothing leiosResult + + leiosFields = + (\ann -> (isJust fbMayLeiosCert, maybeToStrictMaybe (snd <$> ann))) + <$> leiosResult let rbBody = mkBody fbMayLeiosCert actualRbBodySize = SL.blockBodySize protocolVersion rbBody hdr <- diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index 75dc3eeec2..103392abb9 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -133,8 +133,9 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch) -import Ouroboros.Consensus.Protocol.Praos (BasePraos, Praos, PraosWithLeios) -import Ouroboros.Consensus.Protocol.Praos.Common (StrictMaybeLeios (SJustLeios)) +import Ouroboros.Consensus.Protocol.Abstract (LedgerView) +import Ouroboros.Consensus.Protocol.Leios (EitherLeiosF (..), PraosWithLeios) +import Ouroboros.Consensus.Protocol.Praos (Praos) import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Eras @@ -996,10 +997,10 @@ instance LedgerSupportsPeras (ShelleyBlock proto era) where -- more. untickedLedgerView :: ( SL.EraForecast era - , Views.ForecastsLeios pext era + , Views.ForecastsLeios proto era ) => - LedgerState (ShelleyBlock (BasePraos pext crypto) era) mk -> - Views.BasePraosLedgerView pext + LedgerState (ShelleyBlock proto era) mk -> + Views.BasePraosLedgerView proto untickedLedgerView = Views.forecastToBasePraosLedgerView . SL.currentForecast . shelleyLedgerState @@ -1019,15 +1020,16 @@ untickedLedgerView = -- holds after the rotation. Taking the committee from the same snapshot -- keeps a pool's voting weight and its block-production weight in step. leiosCommitteeAndQuorum :: - forall pext crypto era mk. + forall proto era mk. ( SL.EraForecast era - , Views.ForecastsLeios pext era - , HasLeiosVoting (ShelleyBlock (BasePraos pext crypto) era) + , Views.ForecastsLeios proto era + , HasLeiosVoting (ShelleyBlock proto era) + , LedgerView proto ~ Views.BasePraosLedgerView proto ) => - LedgerState (ShelleyBlock (BasePraos pext crypto) era) mk -> + LedgerState (ShelleyBlock proto era) mk -> Maybe (LeiosCommittee, Weight) leiosCommitteeAndQuorum ls = - getLeiosCommitteeFromView (Proxy @(ShelleyBlock (BasePraos pext crypto) era)) $ + getLeiosCommitteeFromView (Proxy @(ShelleyBlock proto era)) $ untickedLedgerView ls -- TODO: Ledger-level type class EraCommittee? LedgerState era -> Committee @@ -1074,9 +1076,6 @@ instance HasLeiosVoting (ShelleyBlock (PraosWithLeios c) DijkstraEra) where . shelleyLedgerState getLeiosCommitteeFromView _ lv = - case Views.plvLeios lv of - SJustLeios llv -> - Just - ( Views.llvCommittee llv - , unboundRational (Views.llvQuorumStakeThreshold llv) - ) + case (Views.plvCommittee lv, Views.plvQuorumStakeThreshold lv) of + (LeiosLeiosRight cmt, LeiosLeiosRight q) -> + Just (cmt, unboundRational q) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs index a0c7bf753b..417803b99a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -56,19 +57,23 @@ import Ouroboros.Consensus.Block (ChainHash (..), blockPrevHash, toRawHash) import Ouroboros.Consensus.Ledger.Abstract (getTipSlot) import Ouroboros.Consensus.Ledger.SupportsMempool (getTransactionKeySets) import Ouroboros.Consensus.Ledger.Tables (stowLedgerTables, unstowLedgerTables) +import Ouroboros.Consensus.Protocol.Leios + ( ConsensusConfig (..) + , EitherLeiosF (..) + , LeiosCrypto + , PraosWithLeios + , leiosContextFreeHeaderChecks + ) import Ouroboros.Consensus.Protocol.Praos ( AnnouncedBy (..) , BasePraosState (..) - , ConsensusConfig (..) , Praos - , PraosCrypto , PraosParams (..) - , PraosWithLeios , Ticked (..) , WhetherToUpperBoundOCERT (..) ) import qualified Ouroboros.Consensus.Protocol.Praos as PP -import Ouroboros.Consensus.Protocol.Praos.Common (StrictMaybeLeios (..)) + import Ouroboros.Consensus.Protocol.Praos.Views (plvPoolDistr) import qualified Ouroboros.Consensus.Protocol.Praos.Views as PP import Ouroboros.Consensus.Protocol.TPraos (TPraos) @@ -122,7 +127,7 @@ instance ResolveLeiosBlock (ShelleyBlock (Praos c) ConwayEra) instance forall c. - (PraosCrypto c, ShelleyCompatible (PraosWithLeios c) DijkstraEra) => + (LeiosCrypto c, ShelleyCompatible (PraosWithLeios c) DijkstraEra) => ResolveLeiosBlock (ShelleyBlock (PraosWithLeios c) DijkstraEra) where -- The on-wire bytes and 'TxHash' a forged EB records for each tx (see @@ -133,8 +138,8 @@ instance leiosTxHashOfGenTx (ShelleyTx _ tx) = Just (hashLeiosTx (MkLeiosTx (serialize' tx))) getLeiosMaxEbTxsSizeFromView _ lv = - case PP.plvLeios lv of - SJustLeios llv -> PP.llvMaxEbTxsSize llv + case PP.plvMaxEbTxsSize lv of + LeiosLeiosRight sz -> sz resolveLeiosClosure leiosDb ebHash = do lookupTrustedEbClosure leiosDb ebHash >>= \case @@ -257,7 +262,7 @@ instance -- The Leios checks that do not need the header's predecessor. The gap -- between a CertRB and the announcement it certifies does need it, so it -- is left to 'updateChainDepState'; an announcement is not a CertRB. - PP.leiosContextFreeHeaderChecks (tickedPraosStateLedgerView tcs) hv + leiosContextFreeHeaderChecks (tickedPraosStateLedgerView tcs) hv -- validate the claimed election PP.doValidateVRFSignature (praosStateEpochNonce cs) @@ -271,7 +276,7 @@ instance PP.NoCounterForKeyHashOCERT{} -> pure StaleOCIN _ -> throwError err where - prms = praosParams cfg + prms = praosParams (leiosPraosConfig cfg) cs = tickedPraosStateChainDepState tcs SL.PoolDistr pd _ = plvPoolDistr (tickedPraosStateLedgerView tcs) authenticate = @@ -284,9 +289,8 @@ instance hv protocolStateLeiosAnnouncement st = do - -- 'SNothingLeios' is unreachable at this extension, so this is total. MkAnnouncedBy issuer ann <- case praosStateLeiosAnnouncement st of - SJustLeios mbAnn -> strictMaybeToMaybe mbAnn + LeiosLeiosRight mbAnn -> strictMaybeToMaybe mbAnn pure MkAnnouncementFields { announcementElection = diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Protocol.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Protocol.hs index 76c2be9a76..2c4c8f0518 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Protocol.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Protocol.hs @@ -16,8 +16,7 @@ import Ouroboros.Consensus.Protocol.Signed import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Config (BlockConfig (..)) import Ouroboros.Consensus.Shelley.Protocol.Abstract - ( ShelleyProtocolHeader - , pHeaderIssueNo + ( pHeaderIssueNo , pHeaderIssuer , pTieBreakVRFValue , protocolHeaderView diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs index 900c74fed0..6d5109c3ab 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -14,6 +15,7 @@ -- instance for 'ShelleyBlock'. module Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () where +import qualified Cardano.Ledger.Dijkstra.Forecast as Dijkstra import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Protocol.TPraos.API as SL import Control.Monad.Except (MonadError (throwError)) @@ -24,16 +26,14 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol (..) ) -import Ouroboros.Consensus.Protocol.Praos (BasePraos) -import qualified Ouroboros.Consensus.Protocol.Praos as Praos (PraosCrypto) -import Ouroboros.Consensus.Protocol.Praos.Common (KnownPraosExtension) +import Ouroboros.Consensus.Protocol.Leios (PraosWithLeios) +import Ouroboros.Consensus.Protocol.Praos (Praos) import qualified Ouroboros.Consensus.Protocol.Praos.Views as Praos import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Ledger import Ouroboros.Consensus.Shelley.Ledger.Protocol () import Ouroboros.Consensus.Shelley.Protocol.Abstract () -import Ouroboros.Consensus.Shelley.Protocol.Praos (HasPraosExtensionHeader) import Ouroboros.Consensus.Shelley.Protocol.TPraos () instance @@ -77,47 +77,74 @@ instance maxFor = addSlots swindow $ succWithOrigin at instance - ( ShelleyCompatible (BasePraos pext crypto) era - , KnownPraosExtension pext - , HasPraosExtensionHeader pext - , Praos.ForecastsLeios pext era + ( ShelleyCompatible (Praos c) era , SL.EraForecast era - , Praos.PraosCrypto crypto ) => - LedgerSupportsProtocol (ShelleyBlock (BasePraos pext crypto) era) + LedgerSupportsProtocol (ShelleyBlock (Praos c) era) where - -- 'SL.currentForecast' is 'SL.mkForecast': a projection of the state, with no - -- TICKF. 'SL.futureForecast' is TICKF and then that same projection. Reusing - -- it here is what makes this method and 'ledgerViewForecastAt' agree by - -- construction, instead of by two copies of the projection staying in step. - protocolLedgerView _cfg = - Praos.forecastToBasePraosLedgerView . SL.currentForecast . tickedShelleyLedgerState + protocolLedgerView = protocolLedgerView_BasePraos + ledgerViewForecastAt = ledgerViewForecastAt_BasePraos - ledgerViewForecastAt cfg ledgerState = Forecast at $ \for -> - if - | NotOrigin for == at -> - return $ - Praos.forecastToBasePraosLedgerView (SL.currentForecast shelleyLedgerState) - | for < maxFor -> - return $ futureLedgerView for - | otherwise -> - throwError $ - OutsideForecastRange - { outsideForecastAt = at - , outsideForecastMaxFor = maxFor - , outsideForecastFor = for - } - where - ShelleyLedgerState{shelleyLedgerState} = ledgerState - globals = shelleyLedgerGlobals cfg - swindow = SL.stabilityWindow globals - at = ledgerTipSlot ledgerState +instance + ( ShelleyCompatible (PraosWithLeios c) era + , Dijkstra.DijkstraEraForecast era + , SL.EraForecast era + ) => + LedgerSupportsProtocol (ShelleyBlock (PraosWithLeios c) era) + where + protocolLedgerView = protocolLedgerView_BasePraos + ledgerViewForecastAt = ledgerViewForecastAt_BasePraos - futureLedgerView :: SlotNo -> Praos.BasePraosLedgerView pext - futureLedgerView for = - Praos.forecastToBasePraosLedgerView $ - SL.futureForecast globals for shelleyLedgerState +-- | 'protocolLedgerView' for any Praos. +-- +-- 'SL.currentForecast' is 'SL.mkForecast': a projection of the state, with no +-- TICKF. 'SL.futureForecast' is TICKF and then that same projection. Reusing it +-- here is what makes this function and 'ledgerViewForecastAt_BasePraos' agree by +-- construction, instead of by two copies of the projection staying in step. +protocolLedgerView_BasePraos :: + ( Praos.ForecastsLeios proto era + , SL.EraForecast era + ) => + LedgerConfig (ShelleyBlock proto era) -> + Ticked (LedgerState (ShelleyBlock proto era)) mk -> + Praos.BasePraosLedgerView proto +protocolLedgerView_BasePraos _cfg = + Praos.forecastToBasePraosLedgerView . SL.currentForecast . tickedShelleyLedgerState - -- Exclusive upper bound - maxFor :: SlotNo - maxFor = addSlots swindow $ succWithOrigin at +-- | 'ledgerViewForecastAt' for any Praos. +ledgerViewForecastAt_BasePraos :: + forall proto era mk. + ( ShelleyCompatible proto era + , Praos.ForecastsLeios proto era + ) => + LedgerConfig (ShelleyBlock proto era) -> + LedgerState (ShelleyBlock proto era) mk -> + Forecast (Praos.BasePraosLedgerView proto) +ledgerViewForecastAt_BasePraos cfg ledgerState = Forecast at $ \for -> + if + | NotOrigin for == at -> + return $ + Praos.forecastToBasePraosLedgerView (SL.currentForecast shelleyLedgerState) + | for < maxFor -> + return $ futureLedgerView for + | otherwise -> + throwError $ + OutsideForecastRange + { outsideForecastAt = at + , outsideForecastMaxFor = maxFor + , outsideForecastFor = for + } + where + ShelleyLedgerState{shelleyLedgerState} = ledgerState + globals = shelleyLedgerGlobals cfg + swindow = SL.stabilityWindow globals + at = ledgerTipSlot ledgerState + + futureLedgerView :: SlotNo -> Praos.BasePraosLedgerView proto + futureLedgerView for = + Praos.forecastToBasePraosLedgerView $ + SL.futureForecast globals for shelleyLedgerState + + -- Exclusive upper bound + maxFor :: SlotNo + maxFor = addSlots swindow $ succWithOrigin at diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs index 75bfbaa41d..5656271a06 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -19,14 +20,15 @@ import qualified Data.Text as T import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config (configConsensus) import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey +import Ouroboros.Consensus.Protocol.Abstract (CanBeLeader, ConsensusConfig) +import Ouroboros.Consensus.Protocol.Leios (ConsensusConfig (..), EitherLeiosF (..), PraosWithLeios) +import Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader) import Ouroboros.Consensus.Protocol.Praos - ( BasePraos + ( PraosCannotForge , Praos , PraosParams (..) - , PraosWithLeios , praosCheckCanForge ) -import Ouroboros.Consensus.Protocol.Praos.Common (StrictMaybeLeios (..)) import Ouroboros.Consensus.Shelley.Ledger ( ShelleyBlock , ShelleyCompatible @@ -35,7 +37,7 @@ import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Node.Common ( ShelleyLeaderCredentials (..) ) -import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoHasLeios) +import Ouroboros.Consensus.Shelley.Protocol.Abstract (CannotForgeError, ProtoCrypto) import Ouroboros.Consensus.Shelley.Protocol.Praos () import Ouroboros.Consensus.Util.IOLike (IOLike) @@ -69,17 +71,23 @@ praosBlockForging praosParams hotKey credentials = -- | Shared by every Praos extension; the caller supplies the Leios token, -- since it knows which extension it is. basePraosSharedBlockForging :: - forall m pext c era. - ( ShelleyCompatible (BasePraos pext c) era + forall m proto c era. + ( ShelleyCompatible proto era + , Traversable (EitherLeiosF proto ()) + , ProtoCrypto proto ~ c + , CanBeLeader proto ~ PraosCanBeLeader c + , CannotForgeError proto ~ PraosCannotForge c , IOLike m ) => - StrictMaybeLeios (ProtoHasLeios (BasePraos pext c)) () -> + EitherLeiosF proto () () -> + (ConsensusConfig proto -> PraosParams) -> HotKey.HotKey c m -> (SlotNo -> Absolute.KESPeriod) -> ShelleyLeaderCredentials c -> - BlockForging m (ShelleyBlock (BasePraos pext c) era) + BlockForging m (ShelleyBlock proto era) basePraosSharedBlockForging leiosToken + getPraosParams hotKey slotToPeriod ShelleyLeaderCredentials @@ -94,7 +102,7 @@ basePraosSharedBlockForging <$> HotKey.evolve hotKey (slotToPeriod curSlot) , checkCanForge = \cfg curSlot _tickedChainDepState _isLeader -> praosCheckCanForge - (configConsensus cfg) + (getPraosParams (configConsensus cfg)) curSlot , forgeBlock = \cfg -> forgeShelleyBlock @@ -114,7 +122,7 @@ praosSharedBlockForging :: (SlotNo -> Absolute.KESPeriod) -> ShelleyLeaderCredentials c -> BlockForging m (ShelleyBlock (Praos c) era) -praosSharedBlockForging = basePraosSharedBlockForging SNothingLeios +praosSharedBlockForging = basePraosSharedBlockForging (PraosLeiosLeft ()) praosParams praosWithLeiosSharedBlockForging :: forall m c era. @@ -125,4 +133,4 @@ praosWithLeiosSharedBlockForging :: (SlotNo -> Absolute.KESPeriod) -> ShelleyLeaderCredentials c -> BlockForging m (ShelleyBlock (PraosWithLeios c) era) -praosWithLeiosSharedBlockForging = basePraosSharedBlockForging (SJustLeios ()) +praosWithLeiosSharedBlockForging = basePraosSharedBlockForging (LeiosLeiosRight ()) (praosParams . leiosPraosConfig) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs index d6346afeb7..65cf9a40f2 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs @@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -43,7 +44,7 @@ import Ouroboros.Consensus.Ledger.Tables (EmptyMK) import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Serialisation import Ouroboros.Consensus.Protocol.Praos (BasePraosState) -import Ouroboros.Consensus.Protocol.Praos.Common (KnownPraosExtension) +import Ouroboros.Consensus.Protocol.Praos (SerialisePraosState) import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger @@ -108,15 +109,15 @@ instance ShelleyCompatible proto era => DecodeDisk (ShelleyBlock proto era) TPra decodeDisk _ = decode instance - (ShelleyCompatible proto era, KnownPraosExtension pext) => - EncodeDisk (ShelleyBlock proto era) (BasePraosState pext) + (ShelleyCompatible proto era, SerialisePraosState proto2, proto ~ proto2) => + EncodeDisk (ShelleyBlock proto era) (BasePraosState proto2) where encodeDisk _ = encode -- | @'ChainDepState' ('BlockProtocol' ('ShelleyBlock' era))@ instance - (ShelleyCompatible proto era, KnownPraosExtension pext) => - DecodeDisk (ShelleyBlock proto era) (BasePraosState pext) + (ShelleyCompatible proto era, SerialisePraosState proto2, proto ~ proto2) => + DecodeDisk (ShelleyBlock proto era) (BasePraosState proto2) where decodeDisk _ = decode diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs index 94ee664e7b..03dc2010ae 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs @@ -124,7 +124,7 @@ shelleySharedBlockForging hotKey slotToPeriod credentials = forgeShelleyBlock hotKey canBeLeader - SNothingLeios + (TPraosLeiosLeft ()) cfg , finalize = HotKey.finalize hotKey } diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs index 94240b3ce1..ed1817bc5e 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs @@ -65,8 +65,8 @@ import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) import Ouroboros.Consensus.Protocol.Praos.Common ( HasMaxMajorProtVer - , StrictMaybeLeios - , WhetherHasLeios + , ShelleyProtocolHeader + , EitherLeiosF ) import Ouroboros.Consensus.Protocol.Signed (SignedHeader) import Ouroboros.Consensus.Util.Condense (Condense (..)) @@ -103,9 +103,6 @@ instance Condense ShelleyHash where Header -------------------------------------------------------------------------------} --- | Shelley header, determined by the associated protocol. -type family ShelleyProtocolHeader proto = (sh :: Type) | sh -> proto - -- | Indicates that the header (determined by the protocol) supports " Envelope -- " functionality. Envelope functionality refers to the minimal functionality -- required to construct a chain. @@ -165,13 +162,6 @@ default_pHeaderLeiosEbAnnouncement = const SNothing -- header (made specific to KES-using protocols through the need to handle -- the hot key). class ProtocolHeaderSupportsKES proto where - -- | Whether this protocol's header carries the Leios fields. - -- - -- Unlike 'ShelleyProtocolHeader' this is not injective — several protocols - -- have no Leios — but it only ever indexes a 'StrictMaybeLeios', so nothing - -- needs to invert it. - type ProtoHasLeios proto :: WhetherHasLeios - -- | Extract the "slots per KES period" value from the protocol config. -- -- Note that we do not require `ConsensusConfig` in 'verifyHeaderIntegrity' @@ -205,7 +195,7 @@ class ProtocolHeaderSupportsKES proto where ProtVer -> -- | Optional fields for Leios: whether the body carries a certificate, and -- this header's announcement, if any - StrictMaybeLeios (ProtoHasLeios proto) (Bool, StrictMaybe EbAnnouncement) -> + EitherLeiosF proto () (Bool, StrictMaybe EbAnnouncement) -> m (ShelleyProtocolHeader proto) -- | Extract the most recently announced (and not yet certified) Leios EB diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs index 53ff2c0f2a..16c7d4ede3 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs @@ -9,10 +9,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Ouroboros.Consensus.Shelley.Protocol.Praos - ( ShelleyHeaderView (..) - , HasPraosExtensionHeader (..) - ) where +module Ouroboros.Consensus.Shelley.Protocol.Praos () where import qualified Cardano.Crypto.Hash as Hash import qualified Cardano.Crypto.KES as KES @@ -21,9 +18,10 @@ import Cardano.Ledger.BaseTypes (ProtVer (ProtVer)) import Cardano.Ledger.Chain (ChainChecksPParams (..)) import Cardano.Ledger.Hashes (EraIndependentBlockBody, HASH) import Cardano.Ledger.Slot (SlotNo (unSlotNo)) -import Cardano.Protocol.Crypto (Crypto, KES) +import Cardano.Protocol.Crypto (Crypto) import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec import qualified Cardano.Protocol.Praos.BlockHeader as PraosCodec +import Cardano.Protocol.TPraos.BlockHeader (PrevHash) import Cardano.Protocol.TPraos.OCert ( OCert (ocertKESPeriod, ocertVkHot) ) @@ -31,16 +29,12 @@ import qualified Cardano.Protocol.TPraos.OCert as SL import Cardano.Slotting.Block (BlockNo) import Data.Either (isRight) import Data.Maybe.Strict (StrictMaybe (..)) -import Data.Proxy (Proxy (Proxy)) -import Data.Word (Word32) -import LeiosDemoTypes (EbAnnouncement) +import Control.Monad.Except (Except) +import Data.Word (Word32, Word64) import Ouroboros.Consensus.Protocol.Praos +import Ouroboros.Consensus.Protocol.Leios (ConsensusConfig (..), EitherLeiosF (..), LeiosCrypto, PraosWithLeios) import Ouroboros.Consensus.Protocol.Praos.Common - ( KnownPraosExtension (singPraosExtension) - , MaxMajorProtVer (MaxMajorProtVer) - , PraosExtensionHasLeios - , SingPraosExtension (..) - , StrictMaybeLeios (..) + ( MaxMajorProtVer (MaxMajorProtVer) , fromCodecEbAnnouncement , toCodecEbAnnouncement ) @@ -49,11 +43,12 @@ import Ouroboros.Consensus.Protocol.Signed import Ouroboros.Consensus.Shelley.Protocol.Abstract ( ProtoCrypto , ProtocolHeaderSupportsEnvelope (..) + , default_pHeaderLeiosContainsCert + , default_pHeaderLeiosEbAnnouncement , ProtocolHeaderSupportsKES (..) , ProtocolHeaderSupportsProtocol (..) , ShelleyHash (ShelleyHash) , ShelleyProtocol - , ShelleyProtocolHeader ) import Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks ( EnvelopeError @@ -62,275 +57,276 @@ import Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks ) {------------------------------------------------------------------------------- - The header as the Shelley block layer needs it + The header as the protocol reads it -------------------------------------------------------------------------------} --- | View of the block header required by the Shelley block layer. --- --- The counterpart to 'BaseHeaderView', which is what the 'ConsensusProtocol' --- instance requires: this is what the @ProtocolHeaderSupports*@ classes require, --- ie the header's identity and the body it claims. Keeping the two separate --- keeps each narrow, and lets the extension-dependence of the upstream header --- types be discharged in one place per view. --- --- Unindexed by @pext@, unlike 'BaseHeaderView': every field here is uniform --- across the extensions, an extension without Leios simply reporting 'False' --- and 'SNothing' for the last two. -data ShelleyHeaderView = ShelleyHeaderView - { shvHash :: !ShelleyHash - , shvSize :: !Int - -- ^ Over the bytes the header was decoded from; see 'headerSize'. - , shvBlockNo :: !BlockNo - , shvBodyHash :: !(Hash.Hash HASH EraIndependentBlockBody) - , shvBodySize :: !Word32 - , shvProtVer :: !ProtVer - , shvLeiosContainsCert :: !Bool - -- ^ Whether the block's body carries a Leios certificate, ie whether it is a - -- CertRB. - , shvLeiosEbAnnouncement :: !(StrictMaybe EbAnnouncement) - -- ^ The endorser block this header announces. - } - --- | Project an extension's header into the two views that read it. --- --- Two projections rather than one because the views want different things: --- 'BaseHeaderView' carries the signed body itself, and 'ShelleyHeaderView' the --- block number, body hash and body size, which that one does not. -class HasPraosExtensionHeader pext where - headerToView :: - Crypto c => ShelleyProtocolHeader (BasePraos pext c) -> BaseHeaderView pext c - headerToShelleyView :: - Crypto c => ShelleyProtocolHeader (BasePraos pext c) -> ShelleyHeaderView - -instance HasPraosExtensionHeader PextNone where - headerToView hdr = - HeaderView - { hvPrevHash = PraosCodec.hbPrev body - , hvVK = PraosCodec.hbVk body - , hvVrfVK = PraosCodec.hbVrfVk body - , hvVrfRes = PraosCodec.hbVrfRes body - , hvOCert = PraosCodec.hbOCert body - , hvSlotNo = PraosCodec.hbSlotNo body - , hvLeios = SNothingLeios - , hvSigned = body - , hvSignature = PraosCodec.headerSig hdr - } - where - body = PraosCodec.headerBody hdr - - headerToShelleyView hdr = - ShelleyHeaderView - { shvHash = ShelleyHash $ PraosCodec.headerHash hdr - , shvSize = PraosCodec.headerSize hdr - , shvBlockNo = PraosCodec.hbBlockNo body - , shvBodyHash = PraosCodec.hbBodyHash body - , shvBodySize = PraosCodec.hbBodySize body - , shvProtVer = PraosCodec.hbProtVer body - , shvLeiosContainsCert = False - , shvLeiosEbAnnouncement = SNothing - } - where - body = PraosCodec.headerBody hdr - -instance HasPraosExtensionHeader PextLeios where - headerToView hdr = - HeaderView - { hvPrevHash = LeiosCodec.hbPrev body - , hvVK = LeiosCodec.hbVk body - , hvVrfVK = LeiosCodec.hbVrfVk body - , hvVrfRes = LeiosCodec.hbVrfRes body - , hvOCert = LeiosCodec.hbOCert body - , hvSlotNo = LeiosCodec.hbSlotNo body - , hvLeios = - SJustLeios - ( LeiosCodec.hbBlockBodyContainsLeiosCert body - , fromCodecEbAnnouncement <$> LeiosCodec.hbEbAnnouncement body - ) - , hvSigned = body - , hvSignature = LeiosCodec.headerSig hdr - } - where - body = LeiosCodec.headerBody hdr - - headerToShelleyView hdr = - ShelleyHeaderView - { shvHash = ShelleyHash $ LeiosCodec.headerHash hdr - , shvSize = LeiosCodec.headerSize hdr - , shvBlockNo = LeiosCodec.hbBlockNo body - , shvBodyHash = LeiosCodec.hbBodyHash body - , shvBodySize = LeiosCodec.hbBodySize body - , shvProtVer = LeiosCodec.hbProtVer body - , shvLeiosContainsCert = LeiosCodec.hbBlockBodyContainsLeiosCert body - , shvLeiosEbAnnouncement = - fromCodecEbAnnouncement <$> LeiosCodec.hbEbAnnouncement body - } - where - body = LeiosCodec.headerBody hdr +protocolHeaderView_Praos :: + Crypto c => + PraosCodec.Header c -> BasePraosValidateView (Praos c) c +protocolHeaderView_Praos hdr = + HeaderView + { hvPrevHash = PraosCodec.hbPrev body + , hvVK = PraosCodec.hbVk body + , hvVrfVK = PraosCodec.hbVrfVk body + , hvVrfRes = PraosCodec.hbVrfRes body + , hvOCert = PraosCodec.hbOCert body + , hvSlotNo = PraosCodec.hbSlotNo body + , hvLeios = PraosLeiosLeft () + , hvSigned = body + , hvSignature = PraosCodec.headerSig hdr + } + where + body = PraosCodec.headerBody hdr + +protocolHeaderView_PraosWithLeios :: + Crypto c => + LeiosCodec.Header c -> BasePraosValidateView (PraosWithLeios c) c +protocolHeaderView_PraosWithLeios hdr = + HeaderView + { hvPrevHash = LeiosCodec.hbPrev body + , hvVK = LeiosCodec.hbVk body + , hvVrfVK = LeiosCodec.hbVrfVk body + , hvVrfRes = LeiosCodec.hbVrfRes body + , hvOCert = LeiosCodec.hbOCert body + , hvSlotNo = LeiosCodec.hbSlotNo body + , hvLeios = + LeiosLeiosRight + ( LeiosCodec.hbBlockBodyContainsLeiosCert body + , fromCodecEbAnnouncement <$> LeiosCodec.hbEbAnnouncement body + ) + , hvSigned = body + , hvSignature = LeiosCodec.headerSig hdr + } + where + body = LeiosCodec.headerBody hdr + {------------------------------------------------------------------------------- Instances -------------------------------------------------------------------------------} +type instance ProtoCrypto (Praos c) = c + +type instance ProtoCrypto (PraosWithLeios c) = c + +-- | 'envelopeChecks' for any Praos; the config and the header type are what differ. +envelopeChecks_BasePraos :: + MaxMajorProtVer -> + BasePraosLedgerView proto -> + -- | Size of the header, over the bytes it was decoded from + Int -> + -- | Size of the block body + Word32 -> + Except EnvelopeError () +envelopeChecks_BasePraos (MaxMajorProtVer maxpv) lv headerSize bodySize = + envelopeCheck maxpv ccd $ + EnvelopeHeaderView + { ehvProtVer = m + , ehvHeaderSize = headerSize + , ehvBodySize = bodySize + } + where + ProtVer m _ = plvProtocolVersion lv + ccd = + ChainChecksPParams + { ccMaxBHSize = plvMaxHeaderSize lv + , ccMaxBBSize = plvMaxBodySize lv + , ccProtocolVersion = plvProtocolVersion lv + } -type instance ProtoCrypto (BasePraos pext c) = c - -type instance ShelleyProtocolHeader (BasePraos PextNone c) = PraosCodec.Header c +-- | 'verifyHeaderIntegrity' for any Praos. +verifyHeaderIntegrity_BasePraos :: + BasePraosCrypto proto c => + Word64 -> + BasePraosValidateView proto c -> + Bool +verifyHeaderIntegrity_BasePraos slotsPerKESPeriod hv = + isRight $ + KES.verifySignedKES () ocertVkHot t (hvSigned hv) (hvSignature hv) + where + SL.OCert + { ocertVkHot + , ocertKESPeriod = SL.KESPeriod startOfKesPeriod + } = hvOCert hv + + currentKesPeriod = + fromIntegral $ + unSlotNo (hvSlotNo hv) `div` slotsPerKESPeriod + + t + | currentKesPeriod >= startOfKesPeriod = + currentKesPeriod - startOfKesPeriod + | otherwise = + 0 + +-- | The header body to sign, given the fields only forging supplies. +-- +-- The fields the protocols share are filled in here; the caller says how its own +-- body extends that, since only it knows the extra fields. +mkHeader_BasePraos :: + SlotNo -> + BlockNo -> + PrevHash -> + Hash.Hash HASH EraIndependentBlockBody -> + Int -> + ProtVer -> + -- | How this protocol's header body extends the shared one + (PraosCodec.HeaderBody c -> body) -> + PraosToSign c -> + body +mkHeader_BasePraos + slotNo + blockNo + prevHash + bbHash + sz + protVer + extend + PraosToSign + { praosToSignIssuerVK + , praosToSignVrfVK + , praosToSignVrfRes + , praosToSignOCert + } = + extend $ + PraosCodec.HeaderBody + { PraosCodec.hbBlockNo = blockNo + , PraosCodec.hbSlotNo = slotNo + , PraosCodec.hbPrev = prevHash + , PraosCodec.hbVk = praosToSignIssuerVK + , PraosCodec.hbVrfVk = praosToSignVrfVK + , PraosCodec.hbVrfRes = praosToSignVrfRes + , PraosCodec.hbBodySize = fromIntegral sz + , PraosCodec.hbBodyHash = bbHash + , PraosCodec.hbOCert = praosToSignOCert + , PraosCodec.hbProtVer = protVer + } -type instance ShelleyProtocolHeader (BasePraos PextLeios c) = LeiosCodec.Header c +{------------------------------------------------------------------------------- + Praos +-------------------------------------------------------------------------------} -instance - ( PraosCrypto c - , HasPraosExtensionHeader pext - ) => - ProtocolHeaderSupportsEnvelope (BasePraos pext c) - where - pHeaderHash = shvHash . headerToShelleyView @pext - pHeaderPrevHash = hvPrevHash . headerToView @pext - pHeaderBodyHash = shvBodyHash . headerToShelleyView @pext - pHeaderSlot = hvSlotNo . headerToView @pext - pHeaderBlock = shvBlockNo . headerToShelleyView @pext - pHeaderSize = fromIntegral . shvSize . headerToShelleyView @pext - pHeaderBlockSize = fromIntegral . shvBodySize . headerToShelleyView @pext - pHeaderLeiosContainsCert = shvLeiosContainsCert . headerToShelleyView @pext - pHeaderLeiosEbAnnouncement = shvLeiosEbAnnouncement . headerToShelleyView @pext +instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (Praos c) where + pHeaderHash hdr = ShelleyHash $ PraosCodec.headerHash hdr + pHeaderPrevHash (PraosCodec.Header body _) = PraosCodec.hbPrev body + pHeaderBodyHash (PraosCodec.Header body _) = PraosCodec.hbBodyHash body + pHeaderSlot (PraosCodec.Header body _) = PraosCodec.hbSlotNo body + pHeaderBlock (PraosCodec.Header body _) = PraosCodec.hbBlockNo body + pHeaderSize hdr = fromIntegral $ PraosCodec.headerSize hdr + pHeaderBlockSize (PraosCodec.Header body _) = fromIntegral $ PraosCodec.hbBodySize body + pHeaderLeiosContainsCert = default_pHeaderLeiosContainsCert + pHeaderLeiosEbAnnouncement = default_pHeaderLeiosEbAnnouncement type EnvelopeCheckError _ = EnvelopeError - envelopeChecks cfg lv hdr = - envelopeCheck maxpv ccd $ - EnvelopeHeaderView - { ehvProtVer = m - , ehvHeaderSize = shvSize shv - , ehvBodySize = shvBodySize shv - } - where - shv = headerToShelleyView @pext hdr - MaxMajorProtVer maxpv = praosMaxMajorPV (praosParams cfg) - ProtVer m _ = plvProtocolVersion lv - ccd = - ChainChecksPParams - { ccMaxBHSize = plvMaxHeaderSize lv - , ccMaxBBSize = plvMaxBodySize lv - , ccProtocolVersion = plvProtocolVersion lv - } - -instance - ( PraosCrypto c - , KnownPraosExtension pext - , HasPraosExtensionHeader pext - ) => - ProtocolHeaderSupportsKES (BasePraos pext c) - where - type ProtoHasLeios (BasePraos pext c) = PraosExtensionHasLeios pext + envelopeChecks cfg lv hdr@(PraosCodec.Header body _) = + envelopeChecks_BasePraos + (praosMaxMajorPV (praosParams cfg)) + lv + (PraosCodec.headerSize hdr) + (PraosCodec.hbBodySize body) +instance PraosCrypto c => ProtocolHeaderSupportsKES (Praos c) where configSlotsPerKESPeriod cfg = praosSlotsPerKESPeriod $ praosParams cfg - verifyHeaderIntegrity slotsPerKESPeriod hdr = - withSignableDict $ - isRight $ - KES.verifySignedKES () ocertVkHot t (hvSigned hv) (hvSignature hv) - where - hv = headerToView @pext hdr - - withSignableDict :: - (KES.Signable (KES c) (BaseHeaderBody pext c) => r) -> r - withSignableDict k = case singPraosExtension (Proxy @pext) of - SingPextNone -> k - SingPextLeios -> k - - SL.OCert - { ocertVkHot - , ocertKESPeriod = SL.KESPeriod startOfKesPeriod - } = hvOCert hv - - currentKesPeriod = - fromIntegral $ - unSlotNo (hvSlotNo hv) `div` slotsPerKESPeriod - - t - | currentKesPeriod >= startOfKesPeriod = - currentKesPeriod - startOfKesPeriod - | otherwise = - 0 - - mkHeader hk cbl il slotNo blockNo prevHash bbHash sz protVer leios = - -- Each branch refines @pext@, so the body type is concrete: both the KES - -- 'Signable' dictionary and the header constructor are then available. - case singPraosExtension (Proxy @pext) of - SingPextNone -> do - PraosFields{praosSignature, praosToSign} <- forgePraosFields hk cbl il praosBody - -- A type annotation for sake of GHCs older than 9.12. - pure (PraosCodec.Header praosToSign praosSignature :: PraosCodec.Header c) - SingPextLeios -> case leios of - SJustLeios (containsCert, mbAnn) -> do - PraosFields{praosSignature, praosToSign} <- - forgePraosFields hk cbl il $ \ts -> - extendHeaderBodyWithLeios - (praosBody ts) - containsCert - (toCodecEbAnnouncement <$> mbAnn) - pure (LeiosCodec.Header praosToSign praosSignature :: LeiosCodec.Header c) - where - -- A signature for the sake of GHCs older than 9.12. - praosBody :: PraosToSign c -> PraosCodec.HeaderBody c - praosBody - PraosToSign - { praosToSignIssuerVK - , praosToSignVrfVK - , praosToSignVrfRes - , praosToSignOCert - } = - PraosCodec.HeaderBody - { PraosCodec.hbBlockNo = blockNo - , PraosCodec.hbSlotNo = slotNo - , PraosCodec.hbPrev = prevHash - , PraosCodec.hbVk = praosToSignIssuerVK - , PraosCodec.hbVrfVk = praosToSignVrfVK - , PraosCodec.hbVrfRes = praosToSignVrfRes - , PraosCodec.hbBodySize = fromIntegral sz - , PraosCodec.hbBodyHash = bbHash - , PraosCodec.hbOCert = praosToSignOCert - , PraosCodec.hbProtVer = protVer - } + verifyHeaderIntegrity slotsPerKESPeriod = + verifyHeaderIntegrity_BasePraos slotsPerKESPeriod . protocolHeaderView_Praos - protocolStateLeiosInfo _ cs = - case praosStateLeiosAnnouncement cs of - SNothingLeios -> Nothing - SJustLeios SNothing -> Nothing - SJustLeios (SJust announced) -> - Just (announcedEb announced, praosStateLastSlot cs) + mkHeader hk cbl il slotNo blockNo prevHash bbHash sz protVer PraosLeiosLeft{} = do + PraosFields{praosSignature, praosToSign} <- + forgePraosFields hk cbl il (mkHeader_BasePraos slotNo blockNo prevHash bbHash sz protVer id) + pure $ PraosCodec.Header praosToSign praosSignature + + -- Praos announces no endorser blocks. + protocolStateLeiosInfo _ _ = Nothing -instance - ( PraosCrypto c - , HasPraosExtensionHeader pext - ) => - ProtocolHeaderSupportsProtocol (BasePraos pext c) - where - type CannotForgeError (BasePraos pext c) = PraosCannotForge c +instance PraosCrypto c => ProtocolHeaderSupportsProtocol (Praos c) where + type CannotForgeError (Praos c) = PraosCannotForge c - protocolHeaderView = headerToView @pext - pHeaderIssuer = hvVK . headerToView @pext - pHeaderIssueNo = SL.ocertN . hvOCert . headerToView @pext + protocolHeaderView = protocolHeaderView_Praos + pHeaderIssuer = hvVK . protocolHeaderView_Praos + pHeaderIssueNo = SL.ocertN . hvOCert . protocolHeaderView_Praos -- This is the "unified" VRF value, prior to range extension which yields e.g. -- the leader VRF value used for slot election. -- -- In the future, we might want to use a dedicated range-extended VRF value -- here instead. - pTieBreakVRFValue = certifiedOutput . hvVrfRes . headerToView @pext + pTieBreakVRFValue = certifiedOutput . hvVrfRes . protocolHeaderView_Praos + +{------------------------------------------------------------------------------- + PraosWithLeios +-------------------------------------------------------------------------------} -type instance Signed (PraosCodec.Header c) = PraosCodec.HeaderBody c +instance LeiosCrypto c => ProtocolHeaderSupportsEnvelope (PraosWithLeios c) where + pHeaderHash hdr = ShelleyHash $ LeiosCodec.headerHash hdr + pHeaderPrevHash (LeiosCodec.Header body _) = LeiosCodec.hbPrev body + pHeaderBodyHash (LeiosCodec.Header body _) = LeiosCodec.hbBodyHash body + pHeaderSlot (LeiosCodec.Header body _) = LeiosCodec.hbSlotNo body + pHeaderBlock (LeiosCodec.Header body _) = LeiosCodec.hbBlockNo body + pHeaderSize hdr = fromIntegral $ LeiosCodec.headerSize hdr + pHeaderBlockSize (LeiosCodec.Header body _) = fromIntegral $ LeiosCodec.hbBodySize body + pHeaderLeiosContainsCert (LeiosCodec.Header body _) = + LeiosCodec.hbBlockBodyContainsLeiosCert body + pHeaderLeiosEbAnnouncement (LeiosCodec.Header body _) = + fromCodecEbAnnouncement <$> LeiosCodec.hbEbAnnouncement body + + type EnvelopeCheckError _ = EnvelopeError + + envelopeChecks cfg lv hdr@(LeiosCodec.Header body _) = + envelopeChecks_BasePraos + (praosMaxMajorPV (praosParams (leiosPraosConfig cfg))) + lv + (LeiosCodec.headerSize hdr) + (LeiosCodec.hbBodySize body) + +instance LeiosCrypto c => ProtocolHeaderSupportsKES (PraosWithLeios c) where + configSlotsPerKESPeriod cfg = + praosSlotsPerKESPeriod $ praosParams $ leiosPraosConfig cfg + + verifyHeaderIntegrity slotsPerKESPeriod = + verifyHeaderIntegrity_BasePraos slotsPerKESPeriod . protocolHeaderView_PraosWithLeios + + mkHeader + hk + cbl + il + slotNo + blockNo + prevHash + bbHash + sz + protVer + (LeiosLeiosRight (containsCert, mbAnn)) = do + PraosFields{praosSignature, praosToSign} <- + forgePraosFields hk cbl il $ + mkHeader_BasePraos slotNo blockNo prevHash bbHash sz protVer $ \pb -> + extendHeaderBodyWithLeios pb containsCert (toCodecEbAnnouncement <$> mbAnn) + pure $ LeiosCodec.Header praosToSign praosSignature + + protocolStateLeiosInfo _ cs = + case praosStateLeiosAnnouncement cs of + LeiosLeiosRight SNothing -> Nothing + LeiosLeiosRight (SJust announced) -> + Just (announcedEb announced, praosStateLastSlot cs) + +instance LeiosCrypto c => ProtocolHeaderSupportsProtocol (PraosWithLeios c) where + type CannotForgeError (PraosWithLeios c) = PraosCannotForge c + + protocolHeaderView = protocolHeaderView_PraosWithLeios + pHeaderIssuer = hvVK . protocolHeaderView_PraosWithLeios + pHeaderIssueNo = SL.ocertN . hvOCert . protocolHeaderView_PraosWithLeios + pTieBreakVRFValue = certifiedOutput . hvVrfRes . protocolHeaderView_PraosWithLeios + +{------------------------------------------------------------------------------- + Instances +-------------------------------------------------------------------------------} instance PraosCrypto c => SignedHeader (PraosCodec.Header c) where headerSigned = PraosCodec.headerBody -type instance Signed (LeiosCodec.Header c) = LeiosCodec.HeaderBody c - -instance PraosCrypto c => SignedHeader (LeiosCodec.Header c) where +instance LeiosCrypto c => SignedHeader (LeiosCodec.Header c) where headerSigned = LeiosCodec.headerBody --- Concrete per extension, rather than one instance over @pext@: the --- superclasses need 'Typeable' and 'SignedHeader' of the header type, which --- only reduce once the extension is known. -instance PraosCrypto c => ShelleyProtocol (BasePraos PextNone c) +instance PraosCrypto c => ShelleyProtocol (Praos c) -instance PraosCrypto c => ShelleyProtocol (BasePraos PextLeios c) +instance LeiosCrypto c => ShelleyProtocol (PraosWithLeios c) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs index 009bd0b0a9..c07d959a33 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs @@ -19,7 +19,6 @@ import Cardano.Slotting.Slot (unSlotNo) import Data.Either (isRight) import Data.Word (Word32) import Numeric.Natural (Natural) -import Ouroboros.Consensus.Protocol.Praos.Common (WhetherHasLeios (..)) import Ouroboros.Consensus.Protocol.Signed ( Signed , SignedHeader (headerSigned) @@ -83,7 +82,6 @@ instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (TPraos c) where MaxMajorProtVer maxPV = tpraosMaxMajorPV (tpraosParams cfg) instance PraosCrypto c => ProtocolHeaderSupportsKES (TPraos c) where - type ProtoHasLeios (TPraos c) = PextDoesNotHaveLeios configSlotsPerKESPeriod cfg = tpraosSlotsPerKESPeriod $ tpraosParams cfg verifyHeaderIntegrity slotsPerKESPeriod hdr = diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs index 3778b00b55..906b3394ef 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -87,8 +87,12 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol ) import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Protocol.Leios + ( ConsensusConfig (..) + , LeiosCrypto + , PraosWithLeios + ) import Ouroboros.Consensus.Protocol.Praos -import Ouroboros.Consensus.Protocol.Praos.Common (KnownPraosExtension) import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger @@ -273,17 +277,26 @@ instance } instance - ( Ouroboros.Consensus.Protocol.Praos.PraosCrypto c - , KnownPraosExtension pext - ) => - HasPartialConsensusConfig (BasePraos pext c) + Ouroboros.Consensus.Protocol.Praos.PraosCrypto c => + HasPartialConsensusConfig (Praos c) where - type PartialConsensusConfig (BasePraos pext c) = PraosParams + type PartialConsensusConfig (Praos c) = PraosParams completeConsensusConfig _ praosEpochInfo praosParams = PraosConfig{..} toPartialConsensusConfig _ = praosParams +instance + LeiosCrypto c => + HasPartialConsensusConfig (PraosWithLeios c) + where + type PartialConsensusConfig (PraosWithLeios c) = PraosParams + + completeConsensusConfig _ praosEpochInfo praosParams = + LeiosConfig PraosConfig{..} + + toPartialConsensusConfig _ = praosParams . leiosPraosConfig + instance SL.PraosCrypto c => HasPartialConsensusConfig (TPraos c) where type PartialConsensusConfig (TPraos c) = TPraosParams diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/MockCrypto.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/MockCrypto.hs index c4052d3bec..0fa5b218ac 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/MockCrypto.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/MockCrypto.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -8,6 +9,7 @@ module Test.Consensus.Cardano.MockCrypto (MockCryptoCompatByron) where import Cardano.Crypto.KES (MockKES) import Cardano.Crypto.VRF (MockVRF) import Cardano.Protocol.Crypto (Crypto (..)) +import qualified Ouroboros.Consensus.Protocol.Leios as Leios import qualified Ouroboros.Consensus.Protocol.Praos as Praos import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos @@ -37,4 +39,8 @@ instance Crypto MockCryptoCompatByron where instance TPraos.PraosCrypto MockCryptoCompatByron +instance Praos.BasePraosCrypto (Praos.Praos MockCryptoCompatByron) MockCryptoCompatByron instance Praos.PraosCrypto MockCryptoCompatByron + +instance Praos.BasePraosCrypto (Leios.PraosWithLeios MockCryptoCompatByron) MockCryptoCompatByron +instance Leios.LeiosCrypto MockCryptoCompatByron diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs index b2d4ad8b8d..894eec610c 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs @@ -48,8 +48,12 @@ import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.Tables hiding (TxIn) import Ouroboros.Consensus.Ledger.Tables.Utils -import Ouroboros.Consensus.Protocol.Abstract (translateChainDepState) -import Ouroboros.Consensus.Protocol.Praos (BasePraos, Praos, PraosWithLeios) +import Ouroboros.Consensus.Protocol.Abstract + ( TranslateProto + , translateChainDepState + ) +import Ouroboros.Consensus.Protocol.Leios (PraosWithLeios) +import Ouroboros.Consensus.Protocol.Praos (Praos) import Ouroboros.Consensus.Protocol.Praos.Common import Ouroboros.Consensus.Protocol.Praos.Views (extendHeaderBodyWithLeios) import Ouroboros.Consensus.Protocol.TPraos @@ -59,7 +63,6 @@ import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.HFEras import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Ledger.Query.Types -import Ouroboros.Consensus.Shelley.Protocol.Abstract (ShelleyProtocolHeader) import Ouroboros.Consensus.Shelley.Protocol.TPraos () import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.Time (secondsToNominalDiffTime) @@ -237,16 +240,16 @@ fromShelleyLedgerExamples ledgerConfig = exampleShelleyLedgerConfig leTranslationContext -- | TODO Factor this out into something nicer. -fromShelleyLedgerExamplesBasePraos :: - forall pext era. - ( ShelleyCompatible (BasePraos pext StandardCrypto) era - , KnownPraosExtension pext +fromShelleyLedgerExamplesAnyPraos :: + forall proto era. + ( ShelleyCompatible proto era + , TranslateProto (TPraos StandardCrypto) proto ) => - -- | Rebuild the example's TPraos header as this extension's header - (SL.BHeader StandardCrypto -> ShelleyProtocolHeader (BasePraos pext StandardCrypto)) -> + -- | Rebuild the example's TPraos header as this protocol's header + (SL.BHeader StandardCrypto -> ShelleyProtocolHeader proto) -> ProtocolLedgerExamples (SL.BHeader StandardCrypto) era -> - Examples (ShelleyBlock (BasePraos pext StandardCrypto) era) -fromShelleyLedgerExamplesBasePraos + Examples (ShelleyBlock proto era) +fromShelleyLedgerExamplesAnyPraos translateHeader ProtocolLedgerExamples { pleLedgerExamples = Shelley.LedgerExamples{..} @@ -355,7 +358,7 @@ fromShelleyLedgerExamplesBasePraos } chainDepState = translateChainDepState - (Proxy @(TPraos StandardCrypto, BasePraos pext StandardCrypto)) + (Proxy @(TPraos StandardCrypto, proto)) $ TPraosState (NotOrigin 1) pleChainDepState extLedgerState = ExtLedgerState @@ -368,14 +371,14 @@ fromShelleyLedgerExamplesPraos :: ShelleyCompatible (Praos StandardCrypto) era => ProtocolLedgerExamples (SL.BHeader StandardCrypto) era -> Examples (ShelleyBlock (Praos StandardCrypto) era) -fromShelleyLedgerExamplesPraos = fromShelleyLedgerExamplesBasePraos translatePraosHeader +fromShelleyLedgerExamplesPraos = fromShelleyLedgerExamplesAnyPraos translatePraosHeader fromShelleyLedgerExamplesPraosWithLeios :: ShelleyCompatible (PraosWithLeios StandardCrypto) era => ProtocolLedgerExamples (SL.BHeader StandardCrypto) era -> Examples (ShelleyBlock (PraosWithLeios StandardCrypto) era) fromShelleyLedgerExamplesPraosWithLeios = - fromShelleyLedgerExamplesBasePraos translateLeiosHeader + fromShelleyLedgerExamplesAnyPraos translateLeiosHeader -- | Rebuild a TPraos example header as a Praos one. translatePraosHeader :: SL.BHeader StandardCrypto -> Praos.Header StandardCrypto diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs index 51a9363ee3..fcbf626505 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs @@ -14,7 +14,8 @@ module Test.Consensus.Shelley.Generators ( SomeResult (..) , praosHeaderBodyFromTPraos - , translateTPraosHeader + , translateTPraosHeader_Praos + , translateTPraosHeader_PraosWithLeios ) where import Cardano.Ledger.Core (TranslationContext) @@ -33,19 +34,17 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool -import Ouroboros.Consensus.Protocol.Praos (BasePraos) +import Ouroboros.Consensus.Protocol.Leios (PraosWithLeios) +import Ouroboros.Consensus.Protocol.Praos (Praos) import qualified Ouroboros.Consensus.Protocol.Praos as Praos -import Ouroboros.Consensus.Protocol.Praos.Common - ( KnownPraosExtension (singPraosExtension) - , SingPraosExtension (SingPextLeios, SingPextNone) - ) import Ouroboros.Consensus.Protocol.Praos.Views (extendHeaderBodyWithLeios) import Ouroboros.Consensus.Protocol.TPraos (TPraos, TPraosState (..)) import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Node.Common () import Ouroboros.Consensus.Shelley.Protocol.Abstract - ( ShelleyProtocolHeader + ( ProtoCrypto + , ShelleyProtocolHeader , pHeaderHash ) import Ouroboros.Consensus.Shelley.Protocol.Praos () @@ -97,10 +96,21 @@ instance instance ( Praos.PraosCrypto crypto - , CanMock (BasePraos pext crypto) era - , Arbitrary (ShelleyProtocolHeader (BasePraos pext crypto)) + , CanMock (Praos crypto) era + , Arbitrary (ShelleyProtocolHeader (Praos crypto)) + ) => + Arbitrary (ShelleyBlock (Praos crypto) era) + where + arbitrary = mkShelleyBlock <$> blk + where + blk = SL.Block <$> arbitrary <*> arbitrary + +instance + ( Praos.PraosCrypto crypto + , CanMock (PraosWithLeios crypto) era + , Arbitrary (ShelleyProtocolHeader (PraosWithLeios crypto)) ) => - Arbitrary (ShelleyBlock (BasePraos pext crypto) era) + Arbitrary (ShelleyBlock (PraosWithLeios crypto) era) where arbitrary = mkShelleyBlock <$> blk where @@ -134,42 +144,54 @@ praosHeaderBodyFromTPraos bhBody = , Praos.hbProtVer = SL.bprotver bhBody } --- | Rebuild a TPraos header as this extension's header. +-- | Rebuild a TPraos header as Praos's header. +translateTPraosHeader_Praos :: + Crypto c => SL.BHeader c -> Gen (Praos.Header c) +translateTPraosHeader_Praos (SL.BHeader bhBody bhSig) = + pure $ Praos.Header (praosHeaderBodyFromTPraos bhBody) (coerce bhSig) + +-- | Rebuild a TPraos header as this protocol's header. -- --- In 'Gen' because an extension may add fields the TPraos header has no --- counterpart for. Only the generators that borrow upstream's coherent-block --- generator need this; see the 'Coherent' instance below. -translateTPraosHeader :: - forall pext c. - (KnownPraosExtension pext, Crypto c) => - SL.BHeader c -> - Gen (ShelleyProtocolHeader (BasePraos pext c)) -translateTPraosHeader (SL.BHeader bhBody bhSig) = - case singPraosExtension (Proxy @pext) of - SingPextNone -> pure $ Praos.Header hBody (coerce bhSig) - SingPextLeios -> - flip Leios.Header (coerce bhSig) - <$> (extendHeaderBodyWithLeios hBody <$> arbitrary <*> arbitrary) - where - hBody = praosHeaderBodyFromTPraos bhBody +-- In 'Gen' because this header has fields the TPraos header has no counterpart +-- for. Only the generators that borrow upstream's coherent-block generator need +-- this. +translateTPraosHeader_PraosWithLeios :: + Crypto c => SL.BHeader c -> Gen (Leios.Header c) +translateTPraosHeader_PraosWithLeios (SL.BHeader bhBody bhSig) = + flip Leios.Header (coerce bhSig) + <$> ( extendHeaderBodyWithLeios (praosHeaderBodyFromTPraos bhBody) + <$> arbitrary + <*> arbitrary + ) + +-- | The body of the 'Coherent' instances below. +genCoherentShelleyBlock :: + CanMock proto era => + (SL.BHeader (ProtoCrypto proto) -> Gen (ShelleyProtocolHeader proto)) -> + Gen (Coherent (ShelleyBlock proto era)) +genCoherentShelleyBlock translateHeader = do + allPoolKeys <- + replicateM (fromIntegral $ numCoreNodes defaultConstants) $ + genIssuerKeys defaultConstants + SL.Block hdr1 bdy <- genCoherentBlock allPoolKeys + hdr <- translateHeader hdr1 + pure $ Coherent $ mkShelleyBlock $ SL.Block hdr bdy -- | Create a coherent Praos block -- -- TODO Establish a coherent block without doing this translation from a -- TPraos header. instance - ( CanMock (BasePraos pext crypto) era - , KnownPraosExtension pext - ) => - Arbitrary (Coherent (ShelleyBlock (BasePraos pext crypto) era)) + CanMock (Praos crypto) era => + Arbitrary (Coherent (ShelleyBlock (Praos crypto) era)) where - arbitrary = do - allPoolKeys <- - replicateM (fromIntegral $ numCoreNodes defaultConstants) $ - genIssuerKeys defaultConstants - SL.Block hdr1 bdy <- genCoherentBlock allPoolKeys - hdr <- translateTPraosHeader hdr1 - pure $ Coherent $ mkShelleyBlock $ SL.Block hdr bdy + arbitrary = genCoherentShelleyBlock translateTPraosHeader_Praos + +instance + CanMock (PraosWithLeios crypto) era => + Arbitrary (Coherent (ShelleyBlock (PraosWithLeios crypto) era)) + where + arbitrary = genCoherentShelleyBlock translateTPraosHeader_PraosWithLeios instance CanMock (TPraos crypto) era => @@ -178,10 +200,20 @@ instance arbitrary = getHeader <$> arbitrary instance - ( CanMock (BasePraos pext crypto) era - , Arbitrary (ShelleyProtocolHeader (BasePraos pext crypto)) + ( CanMock (Praos crypto) era + , Arbitrary (ShelleyProtocolHeader (Praos crypto)) + ) => + Arbitrary (Header (ShelleyBlock (Praos crypto) era)) + where + arbitrary = do + hdr <- arbitrary + pure $ ShelleyHeader hdr (pHeaderHash hdr) + +instance + ( CanMock (PraosWithLeios crypto) era + , Arbitrary (ShelleyProtocolHeader (PraosWithLeios crypto)) ) => - Arbitrary (Header (ShelleyBlock (BasePraos pext crypto) era)) + Arbitrary (Header (ShelleyBlock (PraosWithLeios crypto) era)) where arbitrary = do hdr <- arbitrary diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs index 5125648908..c3a62f03d0 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -59,6 +60,7 @@ instance Crypto MockCrypto where type VRF MockCrypto = MockVRF instance SL.PraosCrypto MockCrypto +instance Praos.BasePraosCrypto (Praos.Praos MockCrypto) MockCrypto instance Praos.PraosCrypto MockCrypto type Block = ShelleyBlock (TPraos MockCrypto) ShelleyEra diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs index 7b73ba2d32..ab2d904e6b 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs @@ -65,6 +65,7 @@ import Ouroboros.Consensus.Ledger.Basics import Ouroboros.Consensus.Ledger.Tables hiding (TxIn) import Ouroboros.Consensus.Ledger.Tables.Diff (Diff) import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff +import Ouroboros.Consensus.Protocol.Leios (PraosWithLeios) import Ouroboros.Consensus.Protocol.Praos import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Eras diff --git a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Dijkstra.hs b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Dijkstra.hs index 85bc5860f0..35d3e83926 100644 --- a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Dijkstra.hs +++ b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Dijkstra.hs @@ -17,7 +17,7 @@ import Cardano.Protocol.Leios.BlockHeader ) import qualified Data.ByteString as BS import Lens.Micro ((&), (.~), (^.)) -import Ouroboros.Consensus.Protocol.Praos (PraosWithLeios) +import Ouroboros.Consensus.Protocol.Leios (PraosWithLeios) import Ouroboros.Consensus.Shelley.Eras (DijkstraEra) import Ouroboros.Consensus.Shelley.HFEras () import Ouroboros.Consensus.Shelley.Ledger diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Leios.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Leios.hs index 49ffa1e897..75433a3059 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Leios.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Leios.hs @@ -18,14 +18,17 @@ -- | Praos with the Leios overlay. module Ouroboros.Consensus.Protocol.Leios - ( LeiosCrypto + ( EitherLeiosF (..) + , LeiosCrypto , PraosWithLeios + , leiosContextFreeHeaderChecks , ConsensusConfig (..) ) where -import Cardano.Ledger.BaseTypes (StrictMaybe (..)) +import Cardano.Ledger.BaseTypes (Milliseconds32 (..), StrictMaybe (..)) import Cardano.Ledger.Chain (ChainChecksPParams (..)) import Cardano.Ledger.Keys (hashKey) +import Cardano.Ledger.State (emptyLeiosCommittee) import Cardano.Protocol.Crypto (Crypto, StandardCrypto) import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec import Cardano.Slotting.EpochInfo (epochInfoSlotLength) @@ -36,9 +39,11 @@ import Control.Monad (when) import Control.Monad.Except (Except, throwError) import Data.Functor.Identity (runIdentity) import Data.Kind (Type) +import Data.Proxy (Proxy (Proxy)) import Data.Typeable (Typeable) import GHC.Generics (Generic) import LeiosDemoTypes (ebAnnouncementSize, minCertificationSlot) +import qualified LeiosDemoTypes as Leios import NoThunks.Class (NoThunks) import qualified Cardano.Ledger.Dijkstra.Forecast as Dijkstra import qualified Cardano.Ledger.Shelley.API as SL @@ -46,9 +51,11 @@ import Lens.Micro ((^.)) import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Praos +import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Protocol.Praos.Common - ( EitherLeiosF + ( HasMaxMajorProtVer (..) , PraosCanBeLeader + , PraosProtocolSupportsNode (..) , PraosTiebreakerView , ShelleyProtocolHeader , fromCodecEbAnnouncement @@ -67,7 +74,8 @@ type instance ShelleyProtocolHeader (PraosWithLeios c) = LeiosCodec.Header c instance BasePraosCrypto (PraosWithLeios StandardCrypto) StandardCrypto -type LeiosCrypto c = BasePraosCrypto (PraosWithLeios c) c +class (Crypto c, BasePraosCrypto (PraosWithLeios c) c) => LeiosCrypto c +instance LeiosCrypto StandardCrypto {------------------------------------------------------------------------------- The fields only this protocol has @@ -156,7 +164,8 @@ leiosContextFreeHeaderChecks lv b = do maximum' = max 200000 maxEbBodySize when (announced > maximum') $ throwError $ - LeiosEbTooBig (LeiosLeiosRight ()) announced maximum' + LeiosHeaderErr (LeiosLeiosRight ()) $ + Leios.LeiosEbTooBig announced maximum' -- | The Leios-specific checks on a header, called by 'updateChainDepState'. -- @@ -197,10 +206,13 @@ leiosHeaderChecks cfg lv b slot cs = do announcingSlot when (slot < earliestAllowed) $ throwError $ - LeiosCertTooYoung (LeiosLeiosRight ()) announcingSlot slot earliestAllowed + LeiosHeaderErr (LeiosLeiosRight ()) $ + Leios.LeiosCertTooYoung announcingSlot slot earliestAllowed -- A state that announced an EB has necessarily applied a header, so -- 'Origin' is the same situation as announcing nothing. - _ -> throwError $ LeiosCertWithoutAnnouncement (LeiosLeiosRight ()) + _ -> + throwError $ + LeiosHeaderErr (LeiosLeiosRight ()) Leios.LeiosCertWithoutAnnouncement {------------------------------------------------------------------------------- ConsensusProtocol @@ -217,9 +229,9 @@ instance LeiosCrypto c => ConsensusProtocol (PraosWithLeios c) where protocolSecurityParam = praosSecurityParam . praosParams . leiosPraosConfig - checkIsLeader cfg = checkIsLeaderPraos (praosParams (leiosPraosConfig cfg)) + checkIsLeader cfg = checkIsLeader_BasePraos (praosParams (leiosPraosConfig cfg)) - tickChainDepState cfg = tickPraosState (praosEpochInfo (leiosPraosConfig cfg)) + tickChainDepState cfg = tickChainDepState_BasePraos (praosEpochInfo (leiosPraosConfig cfg)) updateChainDepState cfg b slot tcs = do -- The Leios header checks. Cheap, so they run before the signature checks. @@ -240,7 +252,7 @@ instance LeiosCrypto c => ConsensusProtocol (PraosWithLeios c) where cs = tickedPraosStateChainDepState tcs reupdateChainDepState cfg b slot tcs = - reupdatePraosState prms ei upd b slot (tickedPraosStateChainDepState tcs) + reupdateChainDepState_BasePraos prms ei upd b slot (tickedPraosStateChainDepState tcs) where PraosConfig prms ei = leiosPraosConfig cfg @@ -274,3 +286,69 @@ instance Dijkstra.DijkstraEraForecast era => Views.ForecastsLeios (PraosWithLeio } where cc = SL.forecastChainChecks @t @era f + +instance HasMaxMajorProtVer (PraosWithLeios c) where + protoMaxMajorPV = praosMaxMajorPV . praosParams . leiosPraosConfig + +{------------------------------------------------------------------------------- + Translation from the protocol without Leios +-------------------------------------------------------------------------------} + +-- | Crossing from Praos into Praos with Leios. +-- +-- Everything carries over unchanged; the Leios fields merely have to be +-- introduced. The announcement starts empty, since no header of the protocol we +-- are leaving could have carried one. And the ledger view seats no committee, +-- so nothing can be certified against it: the committee is empty and the quorum +-- is the entire weight. That is the truth rather than a placeholder, both +-- before the Leios era and during its first epochs, until a snapshot seated by +-- the new era's rules rotates in. And so the other values don't actually +-- matter. +instance TranslateProto (Praos c) (PraosWithLeios c) where + translateLedgerView _ lv = + Views.PraosLedgerView + { Views.plvPoolDistr = Views.plvPoolDistr lv + , Views.plvMaxHeaderSize = Views.plvMaxHeaderSize lv + , Views.plvMaxBodySize = Views.plvMaxBodySize lv + , Views.plvProtocolVersion = Views.plvProtocolVersion lv + , Views.plvCommittee = LeiosLeiosRight emptyLeiosCommittee + , Views.plvQuorumStakeThreshold = LeiosLeiosRight maxBound + , Views.plvAnnouncementPeriodLength = LeiosLeiosRight (Milliseconds32 0) + , Views.plvVotePeriodLength = LeiosLeiosRight (Milliseconds32 0) + , Views.plvDiffusionPeriodLength = LeiosLeiosRight (Milliseconds32 1000000000) + , Views.plvMaxEbBodySize = LeiosLeiosRight 0 + , Views.plvMaxEbTxsSize = LeiosLeiosRight 0 + } + + translateChainDepState _ st = + PraosState + { praosStateLastSlot = praosStateLastSlot st + , praosStateOCertCounters = praosStateOCertCounters st + , praosStateEvolvingNonce = praosStateEvolvingNonce st + , praosStateCandidateNonce = praosStateCandidateNonce st + , praosStateEpochNonce = praosStateEpochNonce st + , praosStatePreviousEpochNonce = praosStatePreviousEpochNonce st + , praosStateLabNonce = praosStateLabNonce st + , praosStateLastEpochBlockNonce = praosStateLastEpochBlockNonce st + , praosStateLeiosAnnouncement = LeiosLeiosRight SNothing + } + +{------------------------------------------------------------------------------- + PraosProtocolSupportsNode +-------------------------------------------------------------------------------} + +instance LeiosCrypto c => PraosProtocolSupportsNode (PraosWithLeios c) where + type PraosProtocolSupportsNodeCrypto (PraosWithLeios c) = c + + getPraosNonces _prx = getPraosNonces_BasePraos + + getOpCertCounters _prx = getOpCertCounters_BasePraos + +instance forall c. TranslateProto (TPraos c) (PraosWithLeios c) where + translateLedgerView _ = + translateLedgerView (Proxy @(Praos c, PraosWithLeios c)) + . translateLedgerView (Proxy @(TPraos c, Praos c)) + + translateChainDepState _ = + translateChainDepState (Proxy @(Praos c, PraosWithLeios c)) + . translateChainDepState (Proxy @(TPraos c, Praos c)) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index 40266d3be6..0cc3cb5323 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -28,6 +28,7 @@ module Ouroboros.Consensus.Protocol.Praos , Praos , PraosCannotForge (..) , BasePraosCrypto + , EitherLeiosF (..) , PraosCrypto , PraosFields (..) , PraosIsLeader (..) @@ -40,11 +41,13 @@ module Ouroboros.Consensus.Protocol.Praos , PraosValidationErr , SerialisePraosState (..) , Ticked (..) + , checkIsLeader_BasePraos , forgePraosFields + , getOpCertCounters_BasePraos + , getPraosNonces_BasePraos , praosCheckCanForge - , checkIsLeaderPraos - , reupdatePraosState - , tickPraosState + , reupdateChainDepState_BasePraos + , tickChainDepState_BasePraos , validateKESSignature , validateVRFSignature @@ -130,11 +133,12 @@ import Data.Typeable (Typeable) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (Proxy)) import Data.Void (Void) -import Data.Word (Word32, Word64) +import Data.Word (Word64) import GHC.Generics (Generic) import Lens.Micro ((^.)) import LeiosDemoTypes ( EbAnnouncement + , LeiosHeaderErr , decodeEbAnnouncement , encodeEbAnnouncement ) @@ -205,7 +209,8 @@ class instance BasePraosCrypto (Praos StandardCrypto) StandardCrypto -type PraosCrypto c = BasePraosCrypto (Praos c) c +class (Crypto c, BasePraosCrypto (Praos c) c) => PraosCrypto c +instance PraosCrypto StandardCrypto {------------------------------------------------------------------------------- Fields required by Praos in the header @@ -245,13 +250,13 @@ instance Crypto c => NoThunks (PraosToSign c) deriving instance Crypto c => Show (PraosToSign c) forgePraosFields :: - ( PraosCrypto c + ( Crypto c , KES.Signable (KES c) toSign , Monad m ) => HotKey c m -> - CanBeLeader (Praos c) -> - IsLeader (Praos c) -> + PraosCanBeLeader c -> + PraosIsLeader c -> (PraosToSign c -> toSign) -> m (PraosFields c toSign) forgePraosFields @@ -535,17 +540,9 @@ data BasePraosValidationErr proto c !String -- error message given by Consensus Layer | NoCounterForKeyHashOCERT !(KeyHash SL.BlockIssuer) -- stake pool key hash - | LeiosEbTooBig - !(EitherLeiosF proto Void ()) - !Word32 -- the announced size - !Word32 -- the bound - | LeiosCertTooYoung - !(EitherLeiosF proto Void ()) - !SlotNo -- the announcing slot - !SlotNo -- the certifying slot - !SlotNo -- the earliest the certificate was allowed - | LeiosCertWithoutAnnouncement + | LeiosHeaderErr !(EitherLeiosF proto Void ()) + !LeiosHeaderErr deriving Generic type PraosValidationErr c = BasePraosValidationErr (Praos c) c @@ -573,7 +570,7 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where protocolSecurityParam = praosSecurityParam . praosParams - checkIsLeader cfg = checkIsLeaderPraos (praosParams cfg) + checkIsLeader cfg = checkIsLeader_BasePraos (praosParams cfg) -- Updating the chain dependent state for Praos. -- @@ -585,7 +582,7 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where -- nonce derived from the last block of the previous epoch. -- - Update the "last block of previous epoch" nonce to the nonce derived -- from the last applied block. - tickChainDepState cfg = tickPraosState (praosEpochInfo cfg) + tickChainDepState cfg = tickChainDepState_BasePraos (praosEpochInfo cfg) -- Validate and update the chain dependent state as a result of processing a -- new header. @@ -601,20 +598,20 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where -- right to issue in this slot. validateVRFSignature (praosStateEpochNonce cs) lv praosLeaderF b -- Finally, we apply the changes from this header to the chain state. - pure $ reupdatePraosState prms ei id b slot cs + pure $ reupdateChainDepState_BasePraos prms ei id b slot cs where lv = tickedPraosStateLedgerView tcs cs = tickedPraosStateChainDepState tcs -- Re-update the chain dependent state as a result of processing a header. reupdateChainDepState (PraosConfig prms ei) b slot tcs = - reupdatePraosState prms ei id b slot (tickedPraosStateChainDepState tcs) + reupdateChainDepState_BasePraos prms ei id b slot (tickedPraosStateChainDepState tcs) -- | The chain-dep state update every protocol performs. -- -- The one field that differs is 'praosStateLeiosAnnouncement', so the caller -- says how to update it; 'Praos' passes 'id'. -reupdatePraosState :: +reupdateChainDepState_BasePraos :: forall proto c. PraosParams -> EpochInfo (Except History.PastHorizonException) -> @@ -625,7 +622,7 @@ reupdatePraosState :: SlotNo -> BasePraosState proto -> BasePraosState proto -reupdatePraosState +reupdateChainDepState_BasePraos PraosParams{praosRandomnessStabilisationWindow} ei updAnnouncement @@ -845,12 +842,12 @@ data PraosCannotForge c deriving instance Crypto c => Show (PraosCannotForge c) praosCheckCanForge :: - ConsensusConfig (Praos c) -> + PraosParams -> SlotNo -> HotKey.KESInfo -> Either (PraosCannotForge c) () praosCheckCanForge - PraosConfig{praosParams} + praosParams curSlot kesInfo | let startPeriod = HotKey.kesStartPeriod kesInfo @@ -876,29 +873,38 @@ instance where type PraosProtocolSupportsNodeCrypto (Praos c) = c - getPraosNonces _prx cdst = - PraosNonces - { candidateNonce = praosStateCandidateNonce - , epochNonce = praosStateEpochNonce - , evolvingNonce = praosStateEvolvingNonce - , labNonce = praosStateLabNonce - , previousLabNonce = praosStateLastEpochBlockNonce - } - where - PraosState - { praosStateCandidateNonce - , praosStateEpochNonce - , praosStateEvolvingNonce - , praosStateLabNonce - , praosStateLastEpochBlockNonce - } = cdst + getPraosNonces _prx = getPraosNonces_BasePraos - getOpCertCounters _prx cdst = - praosStateOCertCounters - where - PraosState - { praosStateOCertCounters - } = cdst + getOpCertCounters _prx = getOpCertCounters_BasePraos + +-- | 'getPraosNonces' for any Praos. +getPraosNonces_BasePraos :: BasePraosState proto -> PraosNonces +getPraosNonces_BasePraos cdst = + PraosNonces + { candidateNonce = praosStateCandidateNonce + , epochNonce = praosStateEpochNonce + , evolvingNonce = praosStateEvolvingNonce + , labNonce = praosStateLabNonce + , previousLabNonce = praosStateLastEpochBlockNonce + } + where + PraosState + { praosStateCandidateNonce + , praosStateEpochNonce + , praosStateEvolvingNonce + , praosStateLabNonce + , praosStateLastEpochBlockNonce + } = cdst + +-- | 'getOpCertCounters' for any Praos. +getOpCertCounters_BasePraos :: + BasePraosState proto -> Map (KeyHash SL.BlockIssuer) Word64 +getOpCertCounters_BasePraos cdst = + praosStateOCertCounters + where + PraosState + { praosStateOCertCounters + } = cdst {------------------------------------------------------------------------------- Translation from transitional Praos @@ -962,8 +968,8 @@ infix 1 ?! infix 1 ?!: --- | 'checkIsLeader', for any protocol whose state is a 'PraosState'. -checkIsLeaderPraos :: +-- | 'checkIsLeader' for any Praos. +checkIsLeader_BasePraos :: forall proto c. BasePraosCrypto proto c => PraosParams -> @@ -971,7 +977,7 @@ checkIsLeaderPraos :: SlotNo -> Ticked (BasePraosState proto) -> Maybe (PraosIsLeader c) -checkIsLeaderPraos +checkIsLeader_BasePraos prms PraosCanBeLeader { praosCanBeLeaderSignKeyVRF @@ -991,20 +997,20 @@ checkIsLeaderPraos rho = VRF.evalCertified () rho' praosCanBeLeaderSignKeyVRF --- | 'tickChainDepState', for any protocol whose state is a 'PraosState'. +-- | 'tickChainDepState' for any Praos. -- -- If we are not in a new epoch, nothing happens. If we are, we do three things: -- store the existing current epoch nonce as the "previous epoch" nonce; update -- the epoch nonce to the combination of the candidate nonce and the nonce -- derived from the last block of the previous epoch; and update the "last block -- of previous epoch" nonce to the one derived from the last applied block. -tickPraosState :: +tickChainDepState_BasePraos :: EpochInfo (Except History.PastHorizonException) -> Views.BasePraosLedgerView proto -> SlotNo -> BasePraosState proto -> Ticked (BasePraosState proto) -tickPraosState ei lv slot st = +tickChainDepState_BasePraos ei lv slot st = TickedPraosState { tickedPraosStateChainDepState = st' , tickedPraosStateLedgerView = lv diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs index c951db6a09..7cf8fed179 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} @@ -9,6 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | Transitional Praos. -- @@ -17,6 +19,7 @@ module Ouroboros.Consensus.Protocol.TPraos ( MaxMajorProtVer (..) , TPraos + , EitherLeiosF (..) , TPraosFields (..) , TPraosIsLeader (..) , TPraosParams (..) @@ -170,6 +173,25 @@ type TPraosValidateView c = SL.BHeader c data TPraos c +-- | TPraos has no Leios fields. +newtype instance EitherLeiosF (TPraos c) a b = TPraosLeiosLeft a + deriving (Eq, Generic, Show) + +deriving anyclass instance NoThunks a => NoThunks (EitherLeiosF (TPraos c) a b) + +instance Functor (EitherLeiosF (TPraos c) a) where + fmap _ (TPraosLeiosLeft a) = TPraosLeiosLeft a + +instance (() ~ a) => Applicative (EitherLeiosF (TPraos c) a) where + pure _ = TPraosLeiosLeft () + TPraosLeiosLeft () <*> TPraosLeiosLeft () = TPraosLeiosLeft () + +instance Foldable (EitherLeiosF (TPraos c) a) where + foldMap _ (TPraosLeiosLeft _) = mempty + +instance Traversable (EitherLeiosF (TPraos c) a) where + traverse _ (TPraosLeiosLeft a) = pure (TPraosLeiosLeft a) + -- | TPraos parameters that are node independent data TPraosParams = TPraosParams { tpraosSlotsPerKESPeriod :: !Word64 diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs index b968fa5c24..dd5190af87 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs @@ -1,14 +1,20 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Generators suitable for serialisation. Note that these are not guaranteed -- to be semantically correct at all, only structurally correct. module Test.Consensus.Protocol.Serialisation.Generators () where +import qualified Cardano.Crypto.DSIGN as DSIGN import Cardano.Crypto.KES (unsoundPureSignedKES) import Cardano.Crypto.VRF (evalCertified) +import qualified Cardano.Crypto.VRF as VRF +import Cardano.Ledger.Keys (DSIGN) +import Cardano.Protocol.Crypto (Crypto, VRF) import qualified Cardano.Protocol.Leios.BlockHeader as Leios import Cardano.Protocol.Praos.BlockHeader ( Header (Header) @@ -19,6 +25,7 @@ import Cardano.Protocol.TPraos.BlockHeader (HashHeader, PrevHash (..)) import Cardano.Protocol.TPraos.OCert ( KESPeriod (KESPeriod) , OCert (OCert) + , OCertSignable ) import Cardano.Slotting.Block (BlockNo (BlockNo)) import Cardano.Slotting.Slot @@ -26,25 +33,18 @@ import Cardano.Slotting.Slot , WithOrigin (At, Origin) ) import qualified Data.ByteString as BS -import Data.Proxy (Proxy (Proxy)) import LeiosDemoTypes ( EbAnnouncement (EbAnnouncement) , EbHash ) +import Ouroboros.Consensus.Protocol.Leios (LeiosCrypto) import Ouroboros.Consensus.Protocol.Praos ( AnnouncedBy (MkAnnouncedBy) , BasePraosState (PraosState) + , EitherLeiosF ) import qualified Ouroboros.Consensus.Protocol.Praos as Praos -import Ouroboros.Consensus.Protocol.Praos.Common - ( KnownPraosExtension (praosExtensionHasLeios) - , StrictMaybeLeios (SJustLeios, SNothingLeios) - , WhetherHasLeiosDecided - ( PextDoesNotHaveLeiosDecided - , PextHasLeiosDecided - ) - , toCodecEbAnnouncement - ) +import Ouroboros.Consensus.Protocol.Praos.Common (toCodecEbAnnouncement) import Ouroboros.Consensus.Protocol.Praos.Views (extendHeaderBodyWithLeios) import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators () import Test.Cardano.StrictContainers.Instances () @@ -66,7 +66,13 @@ instance Arbitrary AnnouncedBy where instance Arbitrary InputVRF where arbitrary = mkInputVRF <$> arbitrary <*> arbitrary -instance Praos.PraosCrypto c => Arbitrary (HeaderBody c) where +instance + ( Crypto c + , DSIGN.Signable DSIGN (OCertSignable c) + , VRF.Signable (VRF c) InputVRF + ) => + Arbitrary (HeaderBody c) + where arbitrary = let ocert = OCert @@ -105,10 +111,10 @@ instance Praos.PraosCrypto c => Arbitrary (Header c) where instance Arbitrary Leios.EbAnnouncement where arbitrary = toCodecEbAnnouncement <$> arbitrary -instance Praos.PraosCrypto c => Arbitrary (Leios.HeaderBody c) where +instance LeiosCrypto c => Arbitrary (Leios.HeaderBody c) where arbitrary = extendHeaderBodyWithLeios <$> arbitrary <*> arbitrary <*> arbitrary -instance Praos.PraosCrypto c => Arbitrary (Leios.Header c) where +instance LeiosCrypto c => Arbitrary (Leios.Header c) where arbitrary = do hBody <- arbitrary period <- arbitrary @@ -116,7 +122,13 @@ instance Praos.PraosCrypto c => Arbitrary (Leios.Header c) where let hSig = unsoundPureSignedKES () period hBody sKey pure $ Leios.Header hBody hSig -instance KnownPraosExtension pext => Arbitrary (BasePraosState pext) where +instance + forall proto. + ( Applicative (EitherLeiosF proto ()) + , Traversable (EitherLeiosF proto ()) + ) => + Arbitrary (BasePraosState proto) + where arbitrary = PraosState <$> oneof @@ -130,9 +142,4 @@ instance KnownPraosExtension pext => Arbitrary (BasePraosState pext) where <*> arbitrary <*> arbitrary <*> arbitrary - <*> traverse - (\() -> arbitrary) - ( case praosExtensionHasLeios (Proxy @pext) of - PextDoesNotHaveLeiosDecided -> SNothingLeios - PextHasLeiosDecided -> SJustLeios () - ) + <*> traverse (\() -> arbitrary) (pure () :: EitherLeiosF proto () ()) From 527b4d400bf3937662a2e9598d564129692bed67 Mon Sep 17 00:00:00 2001 From: Pascal Grange Date: Fri, 9 Oct 2026 09:32:39 +0200 Subject: [PATCH 52/60] InMemory: reject writeEbBody for unregistered points SQLite rejects a body written for a point that writeEbPoint never inserted. InMemory instead registered the point silently, so InMemory-based tests could not catch a missing registration. Today processLeiosBlock always registers the point first, so nothing hits this and the tests still pass. The guard matters once this TODO lands: -- TODO remove the 'writeEbPoint' call below once no important node's -- VolatileDB still holds an announcing RB that it fetched without this -- patch. [...] pointWritten <- writeEbPoint writer point ebBytesSize' After that, any body reaching processLeiosBlock without a centrally-processed announcement would fail on SQLite. With this change InMemory fails the same way, so the tests surface it instead of passing: ``` $> cabal test ouroboros-consensus:consensus-test --test-options='--pattern "/LeiosDemoLogic.Invariants/"' Test suite consensus-test: RUNNING... ouroboros-consensus Leios LeiosDemoLogic.Invariants curated sequences forge purges a body it already holds (offered first): FAIL ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs:136: expected: Right [] but got: Left "exception on Forge [0,1] 12: LeiosDbWriteException {writeJob = \"WriteEbBody (12, 47f6c6404a56ea658d0b40e31c47eba73beaad3d3d71a5e61fc0e90ea48d6d99)\", submittedFrom = \"CallStack (from HasCallStack):\\n resolved, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs:197:11 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.InMemory\\n writeEbBody, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs:135:5 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.Common\\n a use of `writeEbBody', called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs:1112:22 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoLogic\", writeFailure = LeiosDbException {errorMessage = \"writeEbBody: point not registered (programmer error)\", callStack = \"CallStack (from HasCallStack):\\n throwLeiosDbException, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs:297:5 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.InMemory\"}}" Use -p '/LeiosDemoLogic.Invariants/&&/forge purges a body it already holds (offered first)/' to rerun this test only. an offer of a self-forged EB is not re-fetched (forged first): FAIL ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs:138: expected: Right [] but got: Left "exception on Forge [0,1] 12: LeiosDbWriteException {writeJob = \"WriteEbBody (12, 47f6c6404a56ea658d0b40e31c47eba73beaad3d3d71a5e61fc0e90ea48d6d99)\", submittedFrom = \"CallStack (from HasCallStack):\\n resolved, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs:197:11 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.InMemory\\n writeEbBody, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs:135:5 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.Common\\n a use of `writeEbBody', called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs:1112:22 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoLogic\", writeFailure = LeiosDbException {errorMessage = \"writeEbBody: point not registered (programmer error)\", callStack = \"CallStack (from HasCallStack):\\n throwLeiosDbException, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs:297:5 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.InMemory\"}}" Use -p '/LeiosDemoLogic.Invariants/&&/an offer of a self-forged EB is not re-fetched (forged first)/' to rerun this test only. a body is claimed acquired only by a settled write: OK acquired EB kept until its greatest slot is below the immutable tip: OK an announcement raises a forged EB's max slot (so it isn't pruned early): OK an announcement's onset is recorded (earliest kept); an offer never clobbers it: OK start-up seeding marks each completed EB held, with an empty pool: OK start-up seeding: a peer's offer of a seeded EB is not re-fetched: OK a big-ledger peer has a larger, but still finite, closure budget: OK job assignment draws within the least-requested bucket, at random, respecting exclusions: OK only the announcement that takes an election's focus is tracked: OK EB-hash collision (ported from #2309) forged, then the same EB announced at a new slot: both points registered and notified: FAIL Exception: WriteEbBody (5, 47f6c6404a56ea658d0b40e31c47eba73beaad3d3d71a5e61fc0e90ea48d6d99) failed: writeEbBody: point not registered (programmer error) CallStack (from HasCallStack): throwLeiosDbException, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs:297:5 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.InMemory submitted from: CallStack (from HasCallStack): resolved, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs:197:11 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.InMemory writeEbBody, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs:135:5 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.Common a use of `writeEbBody', called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs:1112:22 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoLogic HasCallStack backtrace: collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:169:13 in ghc-internal:GHC.Internal.Exception toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO throwIO, called at ./Control/Concurrent/Async.hs:78:13 in tsty-1.5.4-843ddea7:Control.Concurrent.Async Use -p '/LeiosDemoLogic.Invariants/&&/forged, then the same EB announced at a new slot: both points registered and notified/' to rerun this test only. body held, then the same EB announced at a new slot: both points registered: OK both announced before the fetch: both points registered: OK forged, then the same EB merely offered at a new slot: the offer registers nothing: FAIL Exception: WriteEbBody (5, 47f6c6404a56ea658d0b40e31c47eba73beaad3d3d71a5e61fc0e90ea48d6d99) failed: writeEbBody: point not registered (programmer error) CallStack (from HasCallStack): throwLeiosDbException, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs:297:5 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.InMemory submitted from: CallStack (from HasCallStack): resolved, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs:197:11 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.InMemory writeEbBody, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs:135:5 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.Common a use of `writeEbBody', called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs:1112:22 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoLogic HasCallStack backtrace: collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:169:13 in ghc-internal:GHC.Internal.Exception toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO throwIO, called at ./Control/Concurrent/Async.hs:78:13 in tsty-1.5.4-843ddea7:Control.Concurrent.Async Use -p '/LeiosDemoLogic.Invariants/&&/forged, then the same EB merely offered at a new slot: the offer registers nothing/' to rerun this test only. a certificate tracks an endorser block no announcement did: OK an endorser block that references too many tx bytes is dropped, not fetched: OK an endorser block at exactly its bound is fetched: FAIL ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs:476: expected BodyAcquired, got Just (MkEbState (SlotNo 5) SNothing NoBody) Use -p '/LeiosDemoLogic.Invariants/&&/an endorser block at exactly its bound is fetched/' to rerun this test only. a certificate leaves a body we already hold held: OK outstanding-state invariants hold across arbitrary sequences: FAIL *** Failed! Falsified (after 4 tests and 1 shrink): [ArriveBody [2,3,4] 11,Announce [1,2] 11] Left "exception on Announce [1,2] 11: ExceptionInLinkedThread \"ThreadId [1]\" (LeiosDbWriteException {writeJob = \"WriteEbBody (11, ff3e90aa6fbe36b630f58be98da978061e94c0a998da2376f0b4abf615082391)\", submittedFrom = \"CallStack (from HasCallStack):\\n resolved, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs:197:11 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.InMemory\\n writeEbBody, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs:135:5 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.Common\\n a use of `writeEbBody', called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs:1112:22 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoLogic\", writeFailure = LeiosDbException {errorMessage = \"writeEbBody: point not registered (programmer error)\", callStack = \"CallStack (from HasCallStack):\\n throwLeiosDbException, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs:297:5 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.InMemory\"}})" /= Right () Use --quickcheck-replay="(SMGen 14245007439037612623 12544114665117986533,3)" to reproduce. Use -p '/LeiosDemoLogic.Invariants/&&/outstanding-state invariants hold across arbitrary sequences/' to rerun this test only. the fetch logic never requests an already-held EB body: FAIL *** Failed! Falsified (after 4 tests and 1 shrink): [ArriveBody [2,3,4] 10,Disconnect] exception on Disconnect: ExceptionInLinkedThread "ThreadId [1]" (LeiosDbWriteException {writeJob = "WriteEbBody (10, ff3e90aa6fbe36b630f58be98da978061e94c0a998da2376f0b4abf615082391)", submittedFrom = "CallStack (from HasCallStack):\n resolved, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs:197:11 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.InMemory\n writeEbBody, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs:135:5 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.Common\n a use of `writeEbBody', called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs:1112:22 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoLogic", writeFailure = LeiosDbException {errorMessage = "writeEbBody: point not registered (programmer error)", callStack = "CallStack (from HasCallStack):\n throwLeiosDbException, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs:297:5 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.InMemory"}}) Use --quickcheck-replay="(SMGen 10024954925442282638 16722750794533007117,3)" to reproduce. Use -p '/LeiosDemoLogic.Invariants/&&/the fetch logic never requests an already-held EB body/' to rerun this test only. a concurrent offer, announcement and body arrival keep the reverse index in sync (IOSimPOR): FAIL *** Failed! Falsified (after 1 test): Schedule control: ControlDefault No thread delayed Failure: FailureException (ExceptionInLinkedThread "RacyThreadId [2,2,1]" (LeiosDbWriteException {writeJob = "WriteEbBody (12, 47f6c6404a56ea658d0b40e31c47eba73beaad3d3d71a5e61fc0e90ea48d6d99)", submittedFrom = "CallStack (from HasCallStack):\n resolved, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs:197:11 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.InMemory\n writeEbBody, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs:135:5 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.Common\n a use of `writeEbBody', called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs:1112:22 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoLogic", writeFailure = LeiosDbException {errorMessage = "writeEbBody: point not registered (programmer error)", callStack = "CallStack (from HasCallStack):\n throwLeiosDbException, called at ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs:297:5 in ouroboros-consensus-3.0.1.0-inplace:LeiosDemoDb.InMemory"}})) Use --quickcheck-replay="(SMGen 7877884416199475454 17480834384350021,0)" to reproduce. Use -p '/LeiosDemoLogic.Invariants/&&/a concurrent offer, announcement and body arrival keep the reverse index in sync (IOSimPOR)/' to rerun this test only. 8 out of 22 tests failed (0.01s) ``` --- .../ouroboros-consensus/LeiosDemoDb/InMemory.hs | 6 ++++++ .../test/consensus-test/Test/LeiosDemoDb.hs | 16 ++++++++++++++++ .../test/consensus-test/Test/LeiosDemoLogic.hs | 6 +++++- 3 files changed, 27 insertions(+), 1 deletion(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs index 8d0415995c..29fb03f5ca 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs @@ -22,6 +22,7 @@ import Control.Concurrent.Class.MonadSTM.Strict , newBroadcastTChan , newTVarIO , readTVar + , readTVarIO , writeTChan ) import Data.ByteString (ByteString) @@ -289,6 +290,11 @@ imInsertEbBody stateVar notificationChan point eb fills = do ebBytesSize = encodeLeiosEbSize eb when (null items) $ throwLeiosDbException "writeEbBody: empty EB body (programmer error)" + -- As on SQLite: the point MUST already be present (inserted via + -- 'writeEbPoint' on the announcement path). + known <- Map.member point . imEbPoints <$> readTVarIO stateVar + when (not known) $ + throwLeiosDbException "writeEbBody: point not registered (programmer error)" atomically $ do let entries = IntMap.fromList diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs index 2084782cb8..e80942b0e2 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs @@ -126,6 +126,10 @@ tests = "orphanhood" [ testCase "dropping the handle does not kill its owner" test_droppingTheHandleSpreadsNoException ] + , -- InMemory only: on SQLite a failed ingest write also kills the + -- writer (see 'startWriter'), which is linked to the test thread. + testCase "InMemory: inserting a body for an unregistered point fails, as on SQLite" $ + withFreshDb InMemory test_ebBodyWithoutPointFails ] -- | Database creation strategy for different implementations. @@ -845,6 +849,18 @@ test_noReNotifyOnRelatedTxReinsert db = do -- per (slot, hash) when the closure completes, regardless of how many -- slots reference the same hash. Conflating the slots loses a -- notification. +-- | A body can only be persisted for a point already registered (via +-- 'writeEbPoint', on the announcement path). +test_ebBodyWithoutPointFails :: LeiosDbHandle IO -> IO () +test_ebBodyWithoutPointFails db = withRW db $ \con -> do + result <- tryDb $ rwInsertEbBody con (mkTestPoint (SlotNo 1) 1) (mkTestEb 2) + case result of + Left _ -> pure () + Right _ -> assertFailure "writeEbBody succeeded for a point that was never registered" + where + tryDb :: IO a -> IO (Either LeiosDbException a) + tryDb = try + test_multipleSlotsSameHash :: LeiosDbHandle IO -> IO () test_multipleSlotsSameHash db = do chan <- subscribeEbNotifications db diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs index bb0a05b58f..cb71131c76 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic.hs @@ -64,6 +64,7 @@ import LeiosDemoTypes , WhetherTxsClosureOffered (..) , demoLeiosFetchStaticEnv , emptyLeiosOutstanding + , encodeLeiosEbSize , focusElectionIfUnfocused , hashLeiosEb , hashLeiosTx @@ -418,7 +419,10 @@ serveStoredBody n = do db <- newLeiosDBInMemory let body = MkLeiosEb $ V.generate n $ \i -> (hashLeiosTx (MkLeiosTx (BS8.pack (show i))), 100) bodyPoint = MkLeiosPoint (SlotNo 0) (hashLeiosEb body) - withWriter db $ \w -> void . await =<< writeEbBody w bodyPoint body [] + -- The point first: a body can only be written for a registered point. + withWriter db $ \w -> do + void . await =<< writeEbPoint w bodyPoint (encodeLeiosEbSize body) + void . await =<< writeEbBody w bodyPoint body [] withReader db $ \r -> do ctx <- newLeiosFetchContext r msgLeiosBlockRequest nullTracer ctx bodyPoint From c178aff48bbedbfe485f661431d504aa1488cc0e Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Thu, 8 Oct 2026 10:12:19 -0400 Subject: [PATCH 53/60] Put PR S-R-Ps in cabal.project --- cabal.project | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/cabal.project b/cabal.project index d5cf9b6ac9..69da92326d 100644 --- a/cabal.project +++ b/cabal.project @@ -56,12 +56,12 @@ allow-older: constraints: , any.crypton < 1.1 --- Points to ouroboros-network/leios-prototype +-- Points to ouroboros-network/leios-prototype + matchBlock commit source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-network - tag: 4b3ab7664f609a1aee0f0c24dcfcfd0ab899fc42 - --sha256: sha256-fIqpI2whstetodpiONmUDVgnhTpzXeq1/gmzuHItK5A= + tag: a48ea7a88cd8cc0349013c3b9f99fd3444f26c3b + --sha256: sha256-VY0/lP3VFMKwQyCTE7PKzZyBjsR1ZSF77ftwEhn2U/U= subdir: ouroboros-network cardano-diffusion @@ -80,8 +80,8 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/cardano-ledger - tag: d93c654699c8f10c883a625168f65dd387abc695 - --sha256: sha256-iRshuIFnyh6a+NfxXmkfbOzbbMm5YUcezwHyRQwp7dg= + tag: f832964ff2d928be03b81db757711226b0ada703 + --sha256: sha256-M4qjoSjiw3bPsa+N1dBb1DU46//Dl991WzwxisZ4B90= subdir: libs/cardano-data libs/cardano-ledger-api From a49673a5d5d81e6709e4efb0484838b865251b31 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 9 Oct 2026 11:45:28 +0200 Subject: [PATCH 54/60] consensus-test: build with GHC 9.6 -Wno-x-partial only exists from GHC 9.8 and foldl' is only in the Prelude from GHC 9.10. Co-Authored-By: Claude Opus 5.5 (1M context) --- .../test/consensus-test/Test/LeiosDemoLogic/Invariants.hs | 2 +- ouroboros-consensus/test/consensus-test/Test/LeiosVoteState.hs | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs index d1c0619323..0f6081b760 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoLogic/Invariants.hs @@ -45,7 +45,7 @@ import Control.Monad.IOSim (IOSim, exploreSimTrace, runSimOrThrow, traceResult) import Control.Tracer (nullTracer) import qualified Data.ByteString as BS import qualified Data.ByteString.Short as SBS -import Data.Foldable (toList) +import Data.Foldable (foldl', toList) import Data.List (sort) import qualified Data.IntMap.Strict as IntMap import qualified Data.IntSet as IntSet diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosVoteState.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosVoteState.hs index f58764fcd7..1ef8220de2 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosVoteState.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosVoteState.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} +#if __GLASGOW_HASKELL__ >= 910 {-# OPTIONS_GHC -Wno-x-partial #-} +#endif module Test.LeiosVoteState (tests) where From 281deb0b91582fca6d4004d313cd2abc9b4b7b23 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 9 Oct 2026 11:45:28 +0200 Subject: [PATCH 55/60] Put orphaned haddocks back on their declarations New declarations were inserted between existing haddocks and what they documented, so the comments attached to the wrong thing. Co-Authored-By: Claude Opus 5.5 (1M context) --- .../Ouroboros/Consensus/Shelley/Node/Praos.hs | 8 ++-- .../Consensus/Storage/ChainDB/API.hs | 40 +++++++++---------- .../test/consensus-test/Test/LeiosDemoDb.hs | 10 ++--- 3 files changed, 29 insertions(+), 29 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs index 5656271a06..c0f72803c8 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs @@ -64,10 +64,6 @@ praosBlockForging praosParams hotKey credentials = slotToPeriod (SlotNo slot) = SL.KESPeriod $ fromIntegral $ slot `div` praosSlotsPerKESPeriod --- | Create a 'BlockForging' record safely using the given 'Hotkey'. --- --- The name of the era (separated by a @_@) will be appended to each --- 'forgeLabel'. -- | Shared by every Praos extension; the caller supplies the Leios token, -- since it knows which extension it is. basePraosSharedBlockForging :: @@ -113,6 +109,10 @@ basePraosSharedBlockForging , finalize = HotKey.finalize hotKey } +-- | Create a 'BlockForging' record safely using the given 'Hotkey'. +-- +-- The name of the era (separated by a @_@) will be appended to each +-- 'forgeLabel'. praosSharedBlockForging :: forall m c era. ( ShelleyCompatible (Praos c) era diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 5070d31a8f..4bc4eea0e5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -129,26 +129,6 @@ import qualified Ouroboros.Network.Mock.Chain as Chain import Ouroboros.Network.Protocol.LocalStateQuery.Type import System.FS.API.Types (FsError) --- | The chain database --- --- The chain database provides a unified interface on top of: --- --- * The ImmutableDB, storing the part of the chain that can't roll back. --- * The VolatileDB, storing the blocks near the tip of the chain, possibly in --- multiple competing forks. --- * The LedgerDB, storing snapshots of the ledger state for blocks in the --- ImmutableDB (and in-memory snapshots for the rest). --- --- In addition to providing a unifying interface on top of these disparate --- components, the main responsibilities that the ChainDB itself has are: --- --- * Chain selection (on initialization and whenever a block is added) --- * Trigger full recovery whenever we detect disk failure in any component --- * Provide iterators across fixed fragments of the current chain --- * Provide followers that track the status of the current chain --- --- The ChainDB instantiates all the various type parameters of these databases --- to conform to the unified interface we provide here. -- | What the caller knows about the block's predecessor -- -- ChainSel needs the ledger view at the predecessor's slot, because that is the @@ -196,6 +176,26 @@ trivialPredecessor = \case Origin -> NoPredecessor NotOrigin slot -> Predecessor slot () +-- | The chain database +-- +-- The chain database provides a unified interface on top of: +-- +-- * The ImmutableDB, storing the part of the chain that can't roll back. +-- * The VolatileDB, storing the blocks near the tip of the chain, possibly in +-- multiple competing forks. +-- * The LedgerDB, storing snapshots of the ledger state for blocks in the +-- ImmutableDB (and in-memory snapshots for the rest). +-- +-- In addition to providing a unifying interface on top of these disparate +-- components, the main responsibilities that the ChainDB itself has are: +-- +-- * Chain selection (on initialization and whenever a block is added) +-- * Trigger full recovery whenever we detect disk failure in any component +-- * Provide iterators across fixed fragments of the current chain +-- * Provide followers that track the status of the current chain +-- +-- The ChainDB instantiates all the various type parameters of these databases +-- to conform to the unified interface we provide here. data ChainDB m blk = ChainDB { addBlockAsync :: InvalidBlockPunishment m -> diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs index e80942b0e2..c93a15ab75 100644 --- a/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs +++ b/ouroboros-consensus/test/consensus-test/Test/LeiosDemoDb.hs @@ -844,11 +844,6 @@ test_noReNotifyOnRelatedTxReinsert db = do "completed EB should not be re-notified on re-insert of its own tx" [] -> assertFailure "test EB has no txs" --- | The same EB content can be forged at multiple slots; the DB must --- track each 'LeiosPoint' independently and emit one 'AcquiredEbTxs' --- per (slot, hash) when the closure completes, regardless of how many --- slots reference the same hash. Conflating the slots loses a --- notification. -- | A body can only be persisted for a point already registered (via -- 'writeEbPoint', on the announcement path). test_ebBodyWithoutPointFails :: LeiosDbHandle IO -> IO () @@ -861,6 +856,11 @@ test_ebBodyWithoutPointFails db = withRW db $ \con -> do tryDb :: IO a -> IO (Either LeiosDbException a) tryDb = try +-- | The same EB content can be forged at multiple slots; the DB must +-- track each 'LeiosPoint' independently and emit one 'AcquiredEbTxs' +-- per (slot, hash) when the closure completes, regardless of how many +-- slots reference the same hash. Conflating the slots loses a +-- notification. test_multipleSlotsSameHash :: LeiosDbHandle IO -> IO () test_multipleSlotsSameHash db = do chan <- subscribeEbNotifications db From e67f31f9c8d5990d44e40b17159b592bd28c02ad Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 9 Oct 2026 11:45:39 +0200 Subject: [PATCH 56/60] Leios: derive the committee from the ledger view only HasLeiosVoting keeps only getLeiosCommitteeFromView for the committee; leiosCommitteeOfTip reads a ledger state through ledgerViewOfTip, so the state- and view-derived committees are one definition. LeiosMissingThreshold becomes unreachable and goes. Also from review: minCertificationSlot takes the ledger view instead of three bare durations, the deployed testnet's exception to the announcement size limit is dropped ahead of the respin, and focusElection gets its haddock back. Co-Authored-By: Claude Opus 5.5 (1M context) --- ...00_nick.frisby_leios_committee_via_view.md | 8 +- .../Ouroboros/Consensus/Byron/Ledger/Block.hs | 5 +- .../Consensus/Shelley/Ledger/Ledger.hs | 91 ++++------------- .../Cardano/Tools/DBAnalyser/Analysis.hs | 2 +- .../Cardano/Tools/DBAnalyser/Leios.hs | 28 +++--- .../Cardano/Tools/DBSynthesizer/Forging.hs | 6 +- .../Ouroboros/Consensus/NodeKernel.hs | 14 +-- .../Test/Consensus/HardFork/Combinator/A.hs | 5 +- .../Test/Consensus/HardFork/Combinator/B.hs | 5 +- .../Ouroboros/Consensus/Protocol/Leios.hs | 51 ++++++---- .../src/ouroboros-consensus/LeiosDemoTypes.hs | 98 ++++++------------- .../src/ouroboros-consensus/LeiosVoting.hs | 8 +- .../Consensus/HardFork/Combinator/Leios.hs | 23 +---- .../Ouroboros/Consensus/Ledger/Dual.hs | 5 +- .../Consensus/Ledger/SupportsProtocol.hs | 16 ++- .../Consensus/Storage/LedgerDB/Forker.hs | 21 ++-- .../Test/Ouroboros/Storage/TestBlock.hs | 5 +- .../Test/Util/LeiosTestBlock.hs | 9 +- .../Test/Util/TestBlock.hs | 5 +- .../Ouroboros/Consensus/Mock/Ledger/Block.hs | 5 +- 20 files changed, 154 insertions(+), 256 deletions(-) diff --git a/changelog.d/20261006_004500_nick.frisby_leios_committee_via_view.md b/changelog.d/20261006_004500_nick.frisby_leios_committee_via_view.md index 611f383b59..5c1fc846f3 100644 --- a/changelog.d/20261006_004500_nick.frisby_leios_committee_via_view.md +++ b/changelog.d/20261006_004500_nick.frisby_leios_committee_via_view.md @@ -5,10 +5,10 @@ Uncomment the section that is right (remove the HTML comment wrapper). For top level release notes, leave all the headers commented out. --> -### Patch +### Breaking -- `getLeiosCommittee` and `getCurrentThreshold` now read through `getLeiosCommitteeFromView`, applied to the ledger view the state projects at its own tip slot, rather than each reaching into the state itself. Previously three definitions knew that the committee lives at `ssStakeSet . ssLeiosCommittee` and the quorum at `ppLeiosQuorumStakeThreshold`; now one does, so the view-derived accessor and the state-derived ones agree by construction instead of by copies staying in step. That the two agreed was already asserted in a comment; it is now structural. +- `HasLeiosVoting` loses `getLeiosCommittee` and `getCurrentThreshold`. Use `leiosCommitteeOfTip` from `Ouroboros.Consensus.Ledger.SupportsProtocol`, which applies `getLeiosCommitteeFromView` to `ledgerViewOfTip`, so the state-derived and the view-derived committee are one definition. -- The projection is `SL.currentForecast`, which is `SL.mkForecast` --- no TICKF --- so the state-derived accessors cost what they did before. `protocolLedgerView` and the anchor-slot branch of `ledgerViewForecastAt` are defined by the same projection for the same reason, which is what this extends to the Leios accessors. +- `getLeiosCommitteeFromView` and `getMinCertificationGap` default to `Nothing`, so eras without Leios declare an empty instance. -- No signature changed: `HasLeiosVoting` keeps all three methods, the two new helpers are module-private, and nothing downstream moved. +- `LeiosMissingThreshold` is removed: the committee and its quorum threshold now come together, so a committee without a threshold cannot be observed. diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Block.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Block.hs index 899e8ed873..222688fa28 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Block.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Block.hs @@ -108,10 +108,7 @@ instance ShowProxy ByronBlock -- | Default 'ResolveLeiosBlock' — Byron blocks never carry Leios certs. instance ResolveLeiosBlock ByronBlock -instance HasLeiosVoting ByronBlock where - getLeiosCommittee = const Nothing - getCurrentThreshold = const Nothing - getMinCertificationGap _ _ = Nothing +instance HasLeiosVoting ByronBlock instance NFData ByronBlock where rnf ByronBlock{byronBlockRaw, byronBlockSlotNo, byronBlockHash} = diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index 103392abb9..397d2c0f6a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -112,7 +112,7 @@ import qualified Data.Text as T import qualified Data.Text as Text import Data.Word import GHC.Generics (Generic) -import LeiosDemoTypes (LeiosCommittee, Weight, minCertificationGap) +import LeiosDemoTypes (minCertificationGap) import LeiosVoting (HasLeiosVoting (..)) import Lens.Micro import Lens.Micro.Extras (view) @@ -133,7 +133,6 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch) -import Ouroboros.Consensus.Protocol.Abstract (LedgerView) import Ouroboros.Consensus.Protocol.Leios (EitherLeiosF (..), PraosWithLeios) import Ouroboros.Consensus.Protocol.Praos (Praos) import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views @@ -991,90 +990,40 @@ instance LedgerSupportsPeras (ShelleyBlock proto era) where -- REVIEW: Use 'proto' instead of Praos/TPraos? --- | The ledger view this state projects at its own tip slot. --- --- 'SL.currentForecast' applies no TICKF, so this reads the state and nothing --- more. -untickedLedgerView :: - ( SL.EraForecast era - , Views.ForecastsLeios proto era - ) => - LedgerState (ShelleyBlock proto era) mk -> - Views.BasePraosLedgerView proto -untickedLedgerView = - Views.forecastToBasePraosLedgerView . SL.currentForecast . shelleyLedgerState - --- | The committee this state seats and the quorum it demands. --- --- The ledger already seats the committee, on the stake snapshot, at the era --- boundary; take it from there rather than selecting a second time here. --- --- Re-deriving it in consensus cannot honour voting-key expiry: the pool --- distribution carries a bare 'BlsKey' with no registration epoch, whereas --- the snapshot's seats were filtered by 'selectLeiosCommittee' against --- @bksRegisteredIn + maxKeyAge@ (CIP-0164). --- --- 'ssStakeSet' is the snapshot that governs /this/ epoch: NEWEPOCH sets --- @nesPd@ -- the distribution leader election runs on -- from the mark --- snapshot of the previous boundary, which is exactly what 'ssStakeSet' --- holds after the rotation. Taking the committee from the same snapshot --- keeps a pool's voting weight and its block-production weight in step. -leiosCommitteeAndQuorum :: - forall proto era mk. - ( SL.EraForecast era - , Views.ForecastsLeios proto era - , HasLeiosVoting (ShelleyBlock proto era) - , LedgerView proto ~ Views.BasePraosLedgerView proto - ) => - LedgerState (ShelleyBlock proto era) mk -> - Maybe (LeiosCommittee, Weight) -leiosCommitteeAndQuorum ls = - getLeiosCommitteeFromView (Proxy @(ShelleyBlock proto era)) $ - untickedLedgerView ls - -- TODO: Ledger-level type class EraCommittee? LedgerState era -> Committee -instance HasLeiosVoting (ShelleyBlock (TPraos c) ShelleyEra) where - getLeiosCommittee = const Nothing - getCurrentThreshold = const Nothing - getMinCertificationGap _ _ = Nothing +instance HasLeiosVoting (ShelleyBlock (TPraos c) ShelleyEra) -instance HasLeiosVoting (ShelleyBlock (TPraos c) AllegraEra) where - getLeiosCommittee = const Nothing - getCurrentThreshold = const Nothing - getMinCertificationGap _ _ = Nothing +instance HasLeiosVoting (ShelleyBlock (TPraos c) AllegraEra) -instance HasLeiosVoting (ShelleyBlock (TPraos c) MaryEra) where - getLeiosCommittee = const Nothing - getCurrentThreshold = const Nothing - getMinCertificationGap _ _ = Nothing +instance HasLeiosVoting (ShelleyBlock (TPraos c) MaryEra) -instance HasLeiosVoting (ShelleyBlock (TPraos c) AlonzoEra) where - getLeiosCommittee = const Nothing - getCurrentThreshold = const Nothing - getMinCertificationGap _ _ = Nothing +instance HasLeiosVoting (ShelleyBlock (TPraos c) AlonzoEra) -instance HasLeiosVoting (ShelleyBlock (Praos c) BabbageEra) where - getLeiosCommittee = const Nothing - getCurrentThreshold = const Nothing - getMinCertificationGap _ _ = Nothing +instance HasLeiosVoting (ShelleyBlock (Praos c) BabbageEra) -instance HasLeiosVoting (ShelleyBlock (Praos c) ConwayEra) where - getLeiosCommittee = const Nothing - getCurrentThreshold = const Nothing - getMinCertificationGap _ _ = Nothing +instance HasLeiosVoting (ShelleyBlock (Praos c) ConwayEra) instance HasLeiosVoting (ShelleyBlock (PraosWithLeios c) DijkstraEra) where - getLeiosCommittee = fmap fst . leiosCommitteeAndQuorum - - getCurrentThreshold = fmap snd . leiosCommitteeAndQuorum - getMinCertificationGap cfg = Just . minCertificationGap (shelleyLedgerSlotLength cfg) . getPParams . shelleyLedgerState + -- The ledger already seats the committee, on the stake snapshot, at the era + -- boundary; take it from there rather than selecting a second time here. + -- + -- Re-deriving it in consensus cannot honour voting-key expiry: the pool + -- distribution carries a bare 'BlsKey' with no registration epoch, whereas + -- the snapshot's seats were filtered by 'selectLeiosCommittee' against + -- @bksRegisteredIn + maxKeyAge@ (CIP-0164). + -- + -- 'ssStakeSet' is the snapshot that governs /this/ epoch: NEWEPOCH sets + -- @nesPd@ -- the distribution leader election runs on -- from the mark + -- snapshot of the previous boundary, which is exactly what 'ssStakeSet' + -- holds after the rotation. Taking the committee from the same snapshot + -- keeps a pool's voting weight and its block-production weight in step. getLeiosCommitteeFromView _ lv = case (Views.plvCommittee lv, Views.plvQuorumStakeThreshold lv) of (LeiosLeiosRight cmt, LeiosLeiosRight q) -> diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs index eb6b11141d..6b1bf4ce06 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs @@ -796,7 +796,7 @@ benchmarkLedgerOps mOutfile ledgerAppMode AnalysisEnv{db, registry, startFrom, c -- 'DP.totalTime' and 'DP.mut'. It has no column of its own. case ledgerAppMode of LedgerReapply -> pure () - LedgerApply -> case verifyCertRb st blk of + LedgerApply -> case verifyCertRb lcfg st blk of Left err -> fail $ "benchmark doesn't support invalid certificates: " diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Leios.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Leios.hs index 1858790153..645371f582 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Leios.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Leios.hs @@ -54,7 +54,10 @@ import Ouroboros.Consensus.Ledger.Abstract (ApplyBlock (getBlockKeySets)) import Ouroboros.Consensus.Ledger.Basics import Ouroboros.Consensus.Ledger.Extended import qualified Ouroboros.Consensus.Ledger.SupportsMempool as LedgerSupportsMempool -import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) +import Ouroboros.Consensus.Ledger.SupportsProtocol + ( LedgerSupportsProtocol + , leiosCommitteeOfTip + ) import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Storage.Common (BlockComponent (..)) import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB) @@ -118,33 +121,32 @@ parentAnnouncement = -- without validation: no signatures, no scripts, no balances. verifyCertRb :: forall blk. - ( ResolveLeiosBlock blk + ( LedgerSupportsProtocol blk + , ResolveLeiosBlock blk , HasLeiosVoting blk ) => + LedgerConfig blk -> -- | The unticked parent state ExtLedgerState blk EmptyMK -> blk -> Either LeiosExtValidationError () -verifyCertRb parent blk = case blockLeiosCert blk of +verifyCertRb cfg parent blk = case blockLeiosCert blk of Nothing -> Right () Just cert -> case parentAnnouncement parent of -- A cert-RB certifies the EB that its predecessor announced. If the parent -- announced none, there is nothing to certify. Nothing -> Left (LeiosCertificateWithoutAnnouncement cert) - Just (announcedPoint, _size) -> case getLeiosCommittee (ledgerState parent) of + Just (announcedPoint, _size) -> case leiosCommitteeOfTip cfg (ledgerState parent) of -- A cert-RB in an era with no Leios committee is a protocol violation. Nothing -> Left (LeiosMissingCommittee announcedPoint cert) - Just committee -> case announcingRbHash blk of + Just (committee, threshold) -> case announcingRbHash blk of -- A cert-RB always has a non-genesis announcing parent. Nothing -> Left (LeiosCertificateAfterGenesis cert announcedPoint) - Just rbHash -> case getCurrentThreshold (ledgerState parent) of - -- The era has a committee, so it must have a quorum threshold too. - Nothing -> Left LeiosMissingThreshold - Just threshold -> - case verifyLeiosCert committee threshold rbHash cert of - Left invalid -> - Left (LeiosInvalidCertificate cert announcedPoint rbHash invalid) - Right _weight -> Right () + Just rbHash -> + case verifyLeiosCert committee threshold rbHash cert of + Left invalid -> + Left (LeiosInvalidCertificate cert announcedPoint rbHash invalid) + Right _weight -> Right () -- | The EB that this block certifies. 'Nothing' for a block that carries no -- Leios certificate. diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs index 0ee4dc8f24..4c1e794634 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs @@ -49,7 +49,7 @@ import LeiosVoteState , VoteTally (..) , newLeiosVoteState ) -import LeiosVoting (HasLeiosVoting (getCurrentThreshold, getLeiosCommittee)) +import LeiosVoting (HasLeiosVoting) import Ouroboros.Consensus.Block.Abstract as Block import Ouroboros.Consensus.Block.Forging as Block ( BlockForging (..) @@ -179,8 +179,8 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg votingKey genTxs leio -- because it changes with the stake distribution snapshot at each -- epoch boundary. committee = do - ls <- ledgerState <$> getCurrentLedger chainDB - pure $ (,) <$> getLeiosCommittee ls <*> getCurrentThreshold ls + leiosCommitteeOfTip (configLedger cfg) . ledgerState + <$> getCurrentLedger chainDB -- A seat can exist without a key. If the pool registers no -- 'leiosKey', its seat is keyless. If its proof of possession does diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 42684be974..60678bb689 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -84,7 +84,7 @@ import LeiosUtils.CallTrace ) import qualified LeiosValidClaims import LeiosVoteState (LeiosVoteState (..), newLeiosVoteState) -import LeiosVoting (HasLeiosVoting (..), runLeiosVoting) +import LeiosVoting (runLeiosVoting) import Ouroboros.Consensus.Block hiding (blockMatchesHeader) import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Config @@ -95,7 +95,10 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.SupportsPeerSelection -import Ouroboros.Consensus.Ledger.SupportsProtocol (ledgerViewForecastAt) +import Ouroboros.Consensus.Ledger.SupportsProtocol + ( ledgerViewForecastAt + , leiosCommitteeOfTip + ) import Ouroboros.Consensus.Mempool import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface import Ouroboros.Consensus.MiniProtocol.ChainSync.Client @@ -887,11 +890,8 @@ initInternalState leiosVoteState <- newLeiosVoteState $ do - ls <- ledgerState <$> ChainDB.getCurrentLedger chainDB - pure $ - (,) - <$> getLeiosCommittee ls - <*> getCurrentThreshold ls + leiosCommitteeOfTip (configLedger cfg) . ledgerState + <$> ChainDB.getCurrentLedger chainDB return IS{..} diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs index 557ed3d48f..0f8dc37ba5 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs @@ -697,7 +697,4 @@ instance SerialiseBlockQueryResult BlockA BlockQuery where -- * Leios -instance HasLeiosVoting BlockA where - getLeiosCommittee = const Nothing - getCurrentThreshold = const Nothing - getMinCertificationGap _ _ = Nothing +instance HasLeiosVoting BlockA diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs index 7b555a47b8..504813ed93 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs @@ -539,7 +539,4 @@ instance SerialiseBlockQueryResult BlockB BlockQuery where -- * Leios -instance HasLeiosVoting BlockB where - getLeiosCommittee = const Nothing - getCurrentThreshold = const Nothing - getMinCertificationGap _ _ = Nothing +instance HasLeiosVoting BlockB diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Leios.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Leios.hs index 75433a3059..09c496a685 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Leios.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Leios.hs @@ -33,6 +33,7 @@ import Cardano.Protocol.Crypto (Crypto, StandardCrypto) import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec import Cardano.Slotting.EpochInfo (epochInfoSlotLength) import Cardano.Slotting.Slot (SlotNo) +import Cardano.Slotting.Time (SlotLength) import Ouroboros.Consensus.Block (WithOrigin (NotOrigin)) import Control.DeepSeq (NFData) import Control.Monad (when) @@ -42,7 +43,7 @@ import Data.Kind (Type) import Data.Proxy (Proxy (Proxy)) import Data.Typeable (Typeable) import GHC.Generics (Generic) -import LeiosDemoTypes (ebAnnouncementSize, minCertificationSlot) +import LeiosDemoTypes (certificationGapOfPeriods, ebAnnouncementSize) import qualified LeiosDemoTypes as Leios import NoThunks.Class (NoThunks) import qualified Cardano.Ledger.Dijkstra.Forecast as Dijkstra @@ -153,19 +154,10 @@ leiosContextFreeHeaderChecks lv b = do SNothing -> pure () SJust ann -> do let announced = ebAnnouncementSize ann - -- TEMPORARY KLUDGE -- DO NOT MERGE into main. - -- - -- The deployed testnet has historical announcements above the - -- 'maxEndorserBlockReferencesSize' its own Dijkstra genesis sets - -- (e.g. 102429 against 100000 at slot 709083), so enforcing the - -- ledger's value stalls the sync there. Exception granted here and - -- here only: every other use of the limit, and the genesis file - -- itself, are untouched. - maximum' = max 200000 maxEbBodySize - when (announced > maximum') $ + when (announced > maxEbBodySize) $ throwError $ LeiosHeaderErr (LeiosLeiosRight ()) $ - Leios.LeiosEbTooBig announced maximum' + Leios.LeiosEbTooBig announced maxEbBodySize -- | The Leios-specific checks on a header, called by 'updateChainDepState'. -- @@ -183,9 +175,6 @@ leiosHeaderChecks :: leiosHeaderChecks cfg lv b slot cs = do leiosContextFreeHeaderChecks lv b let LeiosLeiosRight (containsCert, _mbAnn) = Views.hvLeios b - LeiosLeiosRight announcementPeriod = Views.plvAnnouncementPeriodLength lv - LeiosLeiosRight votePeriod = Views.plvVotePeriodLength lv - LeiosLeiosRight diffusionPeriod = Views.plvDiffusionPeriodLength lv LeiosLeiosRight announcedByPredecessor = praosStateLeiosAnnouncement cs PraosConfig{praosEpochInfo} = leiosPraosConfig cfg @@ -200,9 +189,7 @@ leiosHeaderChecks cfg lv b slot cs = do (History.toPureEpochInfo praosEpochInfo) slot ) - announcementPeriod - votePeriod - diffusionPeriod + lv announcingSlot when (slot < earliestAllowed) $ throwError $ @@ -214,6 +201,34 @@ leiosHeaderChecks cfg lv b slot cs = do throwError $ LeiosHeaderErr (LeiosLeiosRight ()) Leios.LeiosCertWithoutAnnouncement +-- | The earliest slot at which a block may certify an endorser block announced +-- in the given slot +-- +-- 'certificationGapOfPeriods' rounds up because a block is forged at its slot's +-- onset, so the answer is the first slot whose onset is far enough after the +-- announcement. In the most-extreme-but-still-nonzero case, suppose all three +-- periods are 1ms. Their 5ms total is a fraction of any realistic slot, and the +-- gap rounds up to one: an announcement at the start of slot @X@ admits a +-- CertRB in slot @X + 1@. Rounding down would give a gap of zero and admit one +-- in slot @X@ itself, which is nonsensical. +-- +-- The periods come from a forecast ledger view rather than a ledger state, so +-- this cannot go through 'Leios.minCertificationGap'. Sharing +-- 'certificationGapOfPeriods' is what keeps the two from drifting. +minCertificationSlot :: + SlotLength -> + Views.BasePraosLedgerView (PraosWithLeios c) -> + -- | Slot of the announcing block + SlotNo -> + SlotNo +minCertificationSlot slotLength lv announcingSlot = + announcingSlot + + certificationGapOfPeriods slotLength announcementPeriod votePeriod diffusionPeriod + where + LeiosLeiosRight announcementPeriod = Views.plvAnnouncementPeriodLength lv + LeiosLeiosRight votePeriod = Views.plvVotePeriodLength lv + LeiosLeiosRight diffusionPeriod = Views.plvDiffusionPeriodLength lv + {------------------------------------------------------------------------------- ConsensusProtocol -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs index d35fcefef5..7a8f5056e6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs @@ -979,26 +979,6 @@ focusElectionIfUnfocused elId ebHash outstanding | Map.member elId (elFocus outstanding) = outstanding | otherwise = focusElection elId ebHash outstanding --- | Make this endorser block the one this election is fetching, whatever it was --- fetching before. --- --- Whatever it was fetching stops being asked for, unless another election is --- also fetching it. Nothing else about that endorser block is disturbed: we --- keep the body if we acquired it, and we still take whatever was already --- requested for it, since those bytes are paid for either way. --- --- TODO One election, one certified endorser block --- which holds only while --- enough of the committee's weight is honest, since two valid certificates for --- one election means the committee equivocated. Should that ever happen, this --- is last-claim-wins: the focus lands on whichever certificate we validated --- most recently, so the node can be left fetching the endorser block of one --- fork while the chain it would select needs the other, and it stays stuck --- there until something moves the focus again. The recourse is to restart the --- node and hope the certificates arrive in the other order, since this state is --- in memory only and the order they come back in is the network's to decide. We --- deliberately do not spend complexity on that case here, since it requires --- catastrophically buggy nodes and/or an amount of adversarial stake the --- protocol itself is not designed to resist. -- | A verified certificate moves its election's focus onto the endorser block -- it names, and lists that body as one to fetch. -- @@ -1031,6 +1011,26 @@ trackCertifiedEb point outstanding where MkLeiosPoint ebSlot ebHash = point +-- | Make this endorser block the one this election is fetching, whatever it was +-- fetching before. +-- +-- Whatever it was fetching stops being asked for, unless another election is +-- also fetching it. Nothing else about that endorser block is disturbed: we +-- keep the body if we acquired it, and we still take whatever was already +-- requested for it, since those bytes are paid for either way. +-- +-- TODO One election, one certified endorser block --- which holds only while +-- enough of the committee's weight is honest, since two valid certificates for +-- one election means the committee equivocated. Should that ever happen, this +-- is last-claim-wins: the focus lands on whichever certificate we validated +-- most recently, so the node can be left fetching the endorser block of one +-- fork while the chain it would select needs the other, and it stays stuck +-- there until something moves the focus again. The recourse is to restart the +-- node and hope the certificates arrive in the other order, since this state is +-- in memory only and the order they come back in is the network's to decide. We +-- deliberately do not spend complexity on that case here, since it requires +-- catastrophically buggy nodes and/or an amount of adversarial stake the +-- protocol itself is not designed to resist. focusElection :: ElId -> EbHash -> LeiosOutstanding pid -> LeiosOutstanding pid focusElection elId ebHash outstanding = case Map.lookup elId (elFocus outstanding) of Just oldEbHash | oldEbHash == ebHash -> outstanding @@ -1531,8 +1531,6 @@ data LeiosExtValidationError | -- | A CertRB reached ledger validation in an era/state with no Leios -- committee to verify the cert against. LeiosMissingCommittee !LeiosPoint !LeiosCert - | -- | No quorum stake threshold parameter available. - LeiosMissingThreshold | -- | A CertRB whose announcing ranking block could not be determined; it -- would be certifying against genesis. LeiosCertificateAfterGenesis !LeiosCert !LeiosPoint @@ -1576,22 +1574,14 @@ deriving via -- the LedgerDB layer ('applyBlock') without pulling 'ChainDB' (which -- 'runLeiosVoting' depends on) into scope. class HasLeiosVoting blk where - -- | The voting committee for the given (pre-tick) ledger state, or 'Nothing' - -- if the era does not participate in Leios voting. - getLeiosCommittee :: LedgerState blk EmptyMK -> Maybe LeiosCommittee - - -- | The currently active quorum threshold for the given ledger state, or - -- 'Nothing' if the protocol parameter does not yet exist on the current era. - getCurrentThreshold :: LedgerState blk EmptyMK -> Maybe Weight - - -- | The committee and quorum threshold according to a /forecast/ ledger view - -- rather than an applied ledger state. + -- | The committee and quorum threshold according to a ledger view, or + -- 'Nothing' if the era does not participate in Leios voting. -- - -- ChainSel validates the certificate in a CertRB before it has applied that - -- block's predecessor, so it has no ledger state to read the committee off; - -- it forecasts the view instead. The two must agree wherever both are - -- available: this is the same committee 'getLeiosCommittee' would return for - -- a state at the forecast slot. + -- A view rather than a ledger state, because ChainSel validates the + -- certificate in a CertRB before it has applied that block's predecessor, so + -- it can only forecast. Wherever there is a ledger state instead, + -- 'Ouroboros.Consensus.Ledger.SupportsProtocol.leiosCommitteeOfTip' reads it + -- through its own view, so the two cannot disagree. getLeiosCommitteeFromView :: proxy blk -> LedgerView (BlockProtocol blk) -> @@ -1607,6 +1597,7 @@ class HasLeiosVoting blk where -- for it. Either split the per-era Leios ledger parameters into their own -- class, or arrange for the forge loop not to need the gap in the first place. getMinCertificationGap :: LedgerConfig blk -> LedgerState blk EmptyMK -> Maybe SlotNo + getMinCertificationGap _ _ = Nothing -- * Tracing @@ -2732,8 +2723,6 @@ leiosExtValidationErrorToObject = \case , "announcedEb" .= T.pack (show point) , "certificate" .= T.pack (show cert) ] - LeiosMissingThreshold -> - mconcat ["kind" .= Aeson.String "LeiosMissingThreshold"] LeiosCertificateAfterGenesis cert point -> mconcat [ "kind" .= Aeson.String "LeiosCertificateAfterGenesis" @@ -2780,8 +2769,6 @@ leiosExtValidationErrorForHuman = \case <> T.pack (show point) <> " but there is no Leios committee to verify its certificate: " <> T.pack (show cert) - LeiosMissingThreshold -> - "CertRB validation, but no quorum stake threshold in pparams" LeiosCertificateAfterGenesis cert point -> "CertRB for " <> T.pack (show point) @@ -2841,35 +2828,6 @@ minCertificationGap slotLength pp = (pp ^. ppLeiosVotePeriodLengthL) (pp ^. ppLeiosDiffusionPeriodLengthL) --- | The earliest slot at which a block may certify an endorser block announced --- in the given slot --- --- 'certificationGapOfPeriods' rounds up because a block is forged at its slot's --- onset, so the answer is the first slot whose onset is far enough after the --- announcement. In the most-extreme-but-still-nonzero case, supppose all three --- periods are 1ms. Their 5ms total is a fraction of any realistic slot, and the --- gap rounds up to one: an announcement at the start of slot @X@ admits a --- CertRB in slot @X + 1@. Rounding down would give a gap of zero and admit one --- in slot @X@ itself, which is nonsensical. --- --- The header checks in @updateChainDepState@ have the periods from a forecast --- ledger view rather than a ledger state, so they cannot go through --- 'minCertificationGap'. Sharing 'certificationGapOfPeriods' is what keeps the --- two from drifting. -minCertificationSlot :: - SlotLength -> - -- | Announcement period length - Milliseconds32 -> - -- | Vote period length - Milliseconds32 -> - -- | Diffusion period length - Milliseconds32 -> - -- | Slot of the announcing block - SlotNo -> - SlotNo -minCertificationSlot slotLength announcement vote diffusion announcingSlot = - announcingSlot + certificationGapOfPeriods slotLength announcement vote diffusion - -- | Aka @L@ certificationGapOfPeriods :: SlotLength -> Milliseconds32 -> Milliseconds32 -> Milliseconds32 -> SlotNo diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosVoting.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosVoting.hs index 8c2d875100..2065dc48d4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosVoting.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosVoting.hs @@ -92,6 +92,10 @@ import Ouroboros.Consensus.Ledger.SupportsMempool , LedgerSupportsMempool (..) , WhetherToIntervene (Intervene) ) +import Ouroboros.Consensus.Ledger.SupportsProtocol + ( LedgerSupportsProtocol + , leiosCommitteeOfTip + ) import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffs) import Ouroboros.Consensus.Storage.ChainDB (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB @@ -253,9 +257,9 @@ runLeiosVoting :: , HasLeiosVoting blk , ResolveLeiosBlock blk , ConvertRawHash blk - , HasAnnTip blk , LedgerSupportsMempool blk , HasHardForkHistory blk + , LedgerSupportsProtocol blk , MonadTimer m ) => Tracer m TraceLeiosKernel -> @@ -343,7 +347,7 @@ runLeiosVoting tracer lcfg chainDB systemTime leiosDB txCache voteState = \case rbHash <- tipAnnouncerFor @blk hs point ?>= ChainTipDoesNotAnnounce committee <- - getLeiosCommittee ls ?>= NotOnCommittee + (fst <$> leiosCommitteeOfTip lcfg ls) ?>= NotOnCommittee let seats = [ (sk, seatId) | sk <- sks diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Leios.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Leios.hs index ff6ccdd24a..74c7e0bd34 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Leios.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Leios.hs @@ -49,22 +49,6 @@ instance (All HasLeiosVoting xs, CanHardFork xs) => HasLeiosVoting (HardForkBlock xs) where - getLeiosCommittee (HardForkLedgerState (HardForkState tele)) = - hcollapse $ - hcmap - (Proxy @HasLeiosVoting) - (\(Current _ (Flip ls)) -> K (getLeiosCommittee ls)) - (Telescope.tip tele) - - getCurrentThreshold (HardForkLedgerState (HardForkState tele)) = - hcollapse $ - hcmap - (Proxy @HasLeiosVoting) - (\(Current _ (Flip ls)) -> K (getCurrentThreshold ls)) - (Telescope.tip tele) - - -- As above, but dispatching on the per-era ledger /view/ the protocol layer - -- carries instead of the ledger state. getLeiosCommitteeFromView _ (HardForkLedgerView _transition (HardForkState tele)) = hcollapse $ hcmap @@ -75,10 +59,9 @@ instance eraProxy :: WrapLedgerView blk -> Proxy blk eraProxy _ = Proxy - -- Unlike the other two, this one needs the era's config as well as its - -- state, and the combinator only stores partial configs -- hence completing - -- them against an 'EpochInfo' reconstructed from the very state we are - -- dispatching on. + -- This needs the era's config as well as its state, and the combinator only + -- stores partial configs -- hence completing them against an 'EpochInfo' + -- reconstructed from the very state we are dispatching on. getMinCertificationGap cfg (HardForkLedgerState hfState@(HardForkState tele)) = hcollapse $ hczipWith diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs index 3de8b067ac..5a19f2c54c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs @@ -141,10 +141,7 @@ instance (Typeable m, Typeable a) => ResolveLeiosBlock (DualBlock m a) -instance HasLeiosVoting (DualBlock m a) where - getLeiosCommittee = const Nothing - getCurrentThreshold = const Nothing - getMinCertificationGap _ _ = Nothing +instance HasLeiosVoting (DualBlock m a) instance Condense m => Condense (DualBlock m a) where condense = condense . dualBlockMain diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs index 6f3ae7d3b6..b2ae78f3be 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs @@ -1,15 +1,18 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Ouroboros.Consensus.Ledger.SupportsProtocol ( GenesisWindow (..) , LedgerSupportsProtocol (..) + , leiosCommitteeOfTip , ledgerViewOfTip ) where import Control.Monad.Except import GHC.Stack (HasCallStack) +import LeiosDemoTypes (HasLeiosVoting (..), LeiosCommittee, Weight) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Forecast import Ouroboros.Consensus.HeaderValidation @@ -17,8 +20,6 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Protocol.Abstract --- | Link protocol to ledger - -- | The ledger view at the given ledger state's own tip slot -- -- This is 'protocolLedgerView' without the ticking. It asks the state's own @@ -48,6 +49,17 @@ ledgerViewOfTip cfg st = -- occupy, and the forecast's anchor is 'Origin', so it is in range. slot = fromWithOrigin (SlotNo 0) $ getTipSlot st +-- | The Leios committee and quorum threshold at the given ledger state's tip +leiosCommitteeOfTip :: + forall blk mk. + (LedgerSupportsProtocol blk, HasLeiosVoting blk) => + LedgerConfig blk -> + LedgerState blk mk -> + Maybe (LeiosCommittee, Weight) +leiosCommitteeOfTip cfg = + getLeiosCommitteeFromView (Proxy @blk) . ledgerViewOfTip cfg + +-- | Link protocol to ledger class ( BlockSupportsProtocol blk , UpdateLedger blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs index 2468e03162..8926ddeea4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs @@ -117,7 +117,11 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx) -import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol, ledgerViewOfTip) +import Ouroboros.Consensus.Ledger.SupportsProtocol + ( LedgerSupportsProtocol + , ledgerViewOfTip + , leiosCommitteeOfTip + ) import Ouroboros.Consensus.Ledger.Tables.Utils ( calculateDifference , forgetLedgerTables @@ -534,9 +538,9 @@ applyBlockToForker :: forall m l blk. ( ApplyBlock l blk , MonadSTM m + , LedgerSupportsProtocol blk , ResolveLeiosBlock blk , HasLeiosVoting blk - , HasLedgerTables (LedgerState blk) , l ~ ExtLedgerState blk ) => LeiosDbReader m -> @@ -563,9 +567,9 @@ applyBlock :: forall m l blk. ( ApplyBlock l blk , MonadSTM m + , LedgerSupportsProtocol blk , ResolveLeiosBlock blk , HasLeiosVoting blk - , HasLedgerTables (LedgerState blk) , l ~ ExtLedgerState blk ) => LeiosDbReader m -> @@ -653,14 +657,10 @@ applyBlock leiosDb evs cfg ap fo doResolveBlock = case ap of -- CertRB on an era without a Leios committee is itself a protocol -- violation: the era machinery shouldn't have let one through. - cm <- - getLeiosCommittee ls + (cm, threshold) <- + leiosCommitteeOfTip (configLedger (getExtLedgerCfg cfg)) ls ?>= ExtValidationErrorLeios (LeiosMissingCommittee announcedPoint cert) - -- If we have a committee, we must also have a quorum threshold. - threshold <- - getCurrentThreshold ls ?>= ExtValidationErrorLeios LeiosMissingThreshold - -- Check the certificate case verifyLeiosCert cm threshold announcingRbHashValue cert of Left invalid -> @@ -709,11 +709,10 @@ applyBlock leiosDb evs cfg ap fo doResolveBlock = case ap of -- push the resulting ledger state to the forker. applyThenPush :: ( ApplyBlock l blk - , GetHeader blk , MonadSTM m + , LedgerSupportsProtocol blk , ResolveLeiosBlock blk , HasLeiosVoting blk - , HasLedgerTables (LedgerState blk) , l ~ ExtLedgerState blk ) => LeiosDbReader m -> diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs index 1593d58bcd..a398018552 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs @@ -147,10 +147,7 @@ data TestBlock = TestBlock -- | Default 'HasLeiosVoting' / 'ResolveLeiosBlock' — storage TestBlock -- never carries Leios certs. -instance HasLeiosVoting TestBlock where - getLeiosCommittee = const Nothing - getCurrentThreshold = const Nothing - getMinCertificationGap _ _ = Nothing +instance HasLeiosVoting TestBlock instance ResolveLeiosBlock TestBlock diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs index aa0088187f..f086608bdb 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LeiosTestBlock.hs @@ -513,9 +513,6 @@ instance ResolveLeiosBlock LeiosTestBlock where -- the ledger config; the ledger /state/ carries none, so the voting-path -- methods have nothing to offer. The harness does not vote. instance HasLeiosVoting LeiosTestBlock where - getLeiosCommittee = fmap fst . ltlsCommittee - getCurrentThreshold = fmap snd . ltlsCommittee - getMinCertificationGap _ _ = Nothing getLeiosCommitteeFromView _ = ltvCommittee {------------------------------------------------------------------------------- @@ -606,9 +603,9 @@ data instance LedgerState LeiosTestBlock mk = LeiosTestLedger -- ^ The committee seated for this state's slot. -- -- Transactions never affect it; it is merely a cache of the oracle that - -- 'ltlcCommittees' is. Keeping it here is what keeps 'getLeiosCommittee' in - -- agreement with 'getLeiosCommitteeFromView': both are that oracle applied - -- to the same slot. + -- 'ltlcCommittees' is. Keeping it here is what keeps 'protocolLedgerView' in + -- agreement with 'ledgerViewForecastAt': both are that oracle applied to the + -- same slot. } deriving stock (Eq, Show, Generic) deriving anyclass NoThunks diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index 0a7aec7012..23a4c26ad7 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -327,10 +327,7 @@ isStrictDescendentOf b1 b2 = b1 `isDescendentOf` b2 && b1 /= b2 instance ShowProxy TestBlock -instance HasLeiosVoting (TestBlockWith ptype) where - getLeiosCommittee = const Nothing - getCurrentThreshold = const Nothing - getMinCertificationGap _ _ = Nothing +instance HasLeiosVoting (TestBlockWith ptype) -- | Default 'ResolveLeiosBlock' — test blocks never carry Leios certificates. instance Typeable ptype => ResolveLeiosBlock (TestBlockWith ptype) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs index b4689d7ee1..6a5c5a44dc 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -157,10 +157,7 @@ instance assumeValidatedClosureTx = ValidatedSimpleGenTx -instance HasLeiosVoting (SimpleBlock' c ext ext') where - getLeiosCommittee = const Nothing - getCurrentThreshold = const Nothing - getMinCertificationGap _ _ = Nothing +instance HasLeiosVoting (SimpleBlock' c ext ext') instance (HashAlgorithm (SimpleHash c), Typeable c, Typeable ext, Serialise ext') => From d9f70d2a372c00656dc751797210f5de61f8791c Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 9 Oct 2026 11:45:48 +0200 Subject: [PATCH 57/60] LeiosNotify server: offer each part of an EB at most once per peer A body arriving twice before its write settles is written twice, and each write notifies AcquiredEb, so the server offered the body twice and the honest client disconnected with ExnLeiosRepeatedOffer. This is the Leios ThreadNet "late join" failure reported by Pascal Grange: https://github.com/IntersectMBO/ouroboros-consensus/pull/2282#issuecomment-6062329556 The server now remembers per announced point what it offered. Co-Authored-By: Claude Opus 5.5 (1M context) --- ...0000_nick.frisby_leios_offer_validation.md | 2 + .../Ouroboros/Consensus/Network/NodeToNode.hs | 48 ++++++++++++++----- .../src/ouroboros-consensus/LeiosDemoLogic.hs | 2 +- 3 files changed, 39 insertions(+), 13 deletions(-) diff --git a/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md b/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md index e52d56ebe2..d4188e3a72 100644 --- a/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md +++ b/changelog.d/20260924_120000_nick.frisby_leios_offer_validation.md @@ -35,6 +35,8 @@ For top level release notes, leave all the headers commented out. - A node offers an EB only if it was still at least `leiosMinOfferLead` younger than the node's immutable tip, and disconnects a peer that offers one below the local immutable tip. The default is an hour's worth of current mainnet slots, which should almost always cover the gap between two honest node's imm tip's ages. A value approaching the distance between a node's immutable tip and its selection suppresses every offer, which is why the test networks need to configure their own, smaller value. +- A node offers each part of an EB at most once per connection, even when its LeiosDb reports the same acquisition twice. A repeat would make an honest peer disconnect it with `ExnLeiosRepeatedOffer`. + ### Patch - `Cardano.Tools.DBAnalyser.Leios` now imports the `AnnouncementFields` accessors it uses, so `unstable-cardano-tools` builds again. diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 07587a7876..7de68ec14f 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -385,13 +385,14 @@ data OutgoingLeiosNotify blk = MkOutgoingLeiosNotify LeiosDemoOnlyTestNotify.StIdle ) ) - , olnAnnounced :: !(Set.Set LeiosPoint) + , olnAnnounced :: !(Map.Map LeiosPoint (Set.Set Leios.OfferedBodyOrClosure)) -- ^ The endorser blocks whose announcement we have enqueued to this peer, - -- pruned to our immutable tip; see 'offer'. + -- and which of their parts we have since offered, pruned to our immutable + -- tip; see 'offer'. } emptyOutgoingLeiosNotify :: OutgoingLeiosNotify blk -emptyOutgoingLeiosNotify = MkOutgoingLeiosNotify Seq.empty Set.empty +emptyOutgoingLeiosNotify = MkOutgoingLeiosNotify Seq.empty Map.empty mkHandlers :: forall m blk addrNTN addrNTC. @@ -734,8 +735,11 @@ mkHandlers olnMessages out Seq.|> MsgLeiosBlockAnnouncement (Leios.ancHeader anc) , olnAnnounced = - Set.insert + -- A re-announcement keeps what was offered. + Map.insertWith + (\_new old -> old) (Leios.announcementLeiosPoint fields) + Set.empty (olnAnnounced out) } ) @@ -778,9 +782,9 @@ mkHandlers pruneAnnounced ( readTChan chan >>= \case AcquiredEb point ebSize -> - offer point $ MsgLeiosBlockOffer point ebSize + offer point Leios.OfferedBody $ MsgLeiosBlockOffer point ebSize AcquiredEbTxs point -> - offer point $ MsgLeiosBlockTxsOffer point + offer point Leios.OfferedClosure $ MsgLeiosBlockTxsOffer point ) <|> (getNextVote <&> \vote -> Just $ MsgLeiosVotes [vote]) @@ -799,24 +803,41 @@ mkHandlers TVar.Unchecked.writeTVar queue $ out { olnAnnounced = - Set.dropWhileAntitone + Map.dropWhileAntitone ((< immTipSlot) . Leios.pointSlotNo) (olnAnnounced out) } - -- An offer goes out only if it is fresh enough to relay and this - -- peer has been told the announcement it is for. + -- An offer goes out only if it is fresh enough to relay, this peer + -- has been told the announcement it is for, and we have not offered + -- this part to it already: an honest peer disconnects on a repeat, + -- and the LeiosDb may notify the same acquisition twice. relayDecision = Leios.leiosOfferRelayDecision (getLeiosMinOfferLead nodeKernel) (getImmTipSlot nodeKernel) - offer point msg = do + offer point part msg = do shouldRelay <- relayDecision (Leios.pointSlotNo point) case shouldRelay of Announcements.DoNotRelay -> pure Nothing Announcements.DoRelay -> do out <- TVar.Unchecked.readTVar queue - pure $ if Set.member point (olnAnnounced out) then Just msg else Nothing + pure $ case Map.lookup point (olnAnnounced out) of + Just offered | Set.notMember part offered -> Just msg + _ -> Nothing + + -- Record an offer as made once it is actually enqueued. + recordOffer :: + LeiosDemoOnlyTestNotify.Message + (LeiosNotify LeiosPoint (Header blk) LeiosVote) + LeiosDemoOnlyTestNotify.StBusy + LeiosDemoOnlyTestNotify.StIdle -> + Map LeiosPoint (Set.Set Leios.OfferedBodyOrClosure) -> + Map LeiosPoint (Set.Set Leios.OfferedBodyOrClosure) + recordOffer = \case + MsgLeiosBlockOffer point _ -> Map.adjust (Set.insert Leios.OfferedBody) point + MsgLeiosBlockTxsOffer point -> Map.adjust (Set.insert Leios.OfferedClosure) point + _ -> id pump = ( do @@ -832,7 +853,10 @@ mkHandlers out <- TVar.Unchecked.readTVar queue TVar.Unchecked.writeTVar queue - out{olnMessages = olnMessages out Seq.|> msg} + out + { olnMessages = olnMessages out Seq.|> msg + , olnAnnounced = recordOffer msg (olnAnnounced out) + } ) `finally` ( MVar.modifyMVar_ getLeiosCentralState $ pure . Announcements.deletePeerCentral peer diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs index dd16959268..7f3be19bec 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs @@ -1983,7 +1983,7 @@ instance Exception ExnLeiosWellHashedBodyRejected -- | Which of a point's two independent offers a LeiosNotify message makes. data OfferedBodyOrClosure = OfferedBody | OfferedClosure - deriving (Eq, Show) + deriving (Eq, Ord, Show) -- | Thrown when a peer relays a 'MsgLeiosBlockAnnouncement' whose header carries -- no EB announcement (so 'mkAnnouncingHeader' returns 'Nothing'); the ensuing thread From fe62db40ab4c1dd26ffdb891973b70d419bbc0a6 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 9 Oct 2026 11:45:48 +0200 Subject: [PATCH 58/60] Forecast Dijkstra views from Conway with Dijkstra's Leios parameters Translating the Conway ledger view invented the Leios fields, including a maximum EB size of 0, so a node whose selection or immutable tip was still in Conway rejected every announcing Dijkstra header. Translate the ledger state instead, as the hard fork combinator does when ticking across the boundary, and forecast with Dijkstra's rules. The new ThreadNet test forks into Dijkstra at epoch 1, which no Leios test did. Co-Authored-By: Claude Opus 5.5 (1M context) --- ...ebastian.nagel_leios_cross_era_forecast.md | 12 +++ .../Consensus/Cardano/CanHardFork.hs | 50 +++++++++- .../test/cardano-test/Test/ThreadNet/Leios.hs | 92 ++++++++++++++++++- 3 files changed, 146 insertions(+), 8 deletions(-) create mode 100644 changelog.d/20261009_120000_sebastian.nagel_leios_cross_era_forecast.md diff --git a/changelog.d/20261009_120000_sebastian.nagel_leios_cross_era_forecast.md b/changelog.d/20261009_120000_sebastian.nagel_leios_cross_era_forecast.md new file mode 100644 index 0000000000..142ef9d1cf --- /dev/null +++ b/changelog.d/20261009_120000_sebastian.nagel_leios_cross_era_forecast.md @@ -0,0 +1,12 @@ + + +### Patch + +- A Dijkstra ledger view forecast from a Conway ledger state now carries Dijkstra's Leios parameters and committee. It used to carry placeholder values, such as a maximum endorser block size of 0. A node whose selection was still in Conway then rejected every announcing Dijkstra header (`LeiosEbTooBig`), and disconnected honest peers with `ExnInvalidLeiosAnnouncement`. + +- The announcement size check no longer grants the deployed testnet's historical announcements an exception to `maxEndorserBlockReferencesSize`. diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs index 2a8bf66f9b..ac52996f71 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -66,10 +66,11 @@ import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Byron.Node () import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Forecast +import qualified Ouroboros.Consensus.Forecast as Forecast import Ouroboros.Consensus.HardFork.Combinator import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.HardFork.History - ( Bound (boundSlot) + ( Bound (boundEpoch, boundSlot) , addSlots ) import Ouroboros.Consensus.HardFork.Simple @@ -82,7 +83,7 @@ import Ouroboros.Consensus.Ledger.SupportsMempool ) import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol - ( LedgerSupportsProtocol + ( LedgerSupportsProtocol (ledgerViewForecastAt) ) import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff import Ouroboros.Consensus.Ledger.Tables.Utils @@ -186,7 +187,7 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where PCons crossEraForecastAcrossShelley $ PCons crossEraForecastAcrossShelley $ PCons crossEraForecastAcrossShelley $ - PCons crossEraForecastAcrossShelley $ + PCons crossEraForecastConwayToDijkstraWrapper $ PNil } hardForkChainSel = @@ -870,6 +871,49 @@ translateLedgerTablesConwayToDijkstraWrapper = , translateTxOutWith = SL.upgradeTxOut } +-- | Forecast a Dijkstra ledger view from a Conway ledger state +-- +-- 'crossEraForecastAcrossShelley' translates the Conway view, which has no +-- Leios parameters or committee to translate, so they would be invented. This +-- instead translates the state, as the combinator does when it ticks across +-- the boundary, and forecasts with Dijkstra's own rules. +crossEraForecastConwayToDijkstraWrapper :: + CardanoHardForkConstraints c => + RequiringBoth + WrapLedgerConfig + (CrossEraForecaster LedgerState WrapLedgerView) + (ShelleyBlock (Praos c) ConwayEra) + (ShelleyBlock (PraosWithLeios c) DijkstraEra) +crossEraForecastConwayToDijkstraWrapper = + RequireBoth $ \cfgConway cfgDijkstra -> + CrossEraForecaster $ \transition forecastFor st -> + let RequireBoth translate = translateLedgerStateConwayToDijkstraWrapper + stDijkstra = + forgetLedgerTables $ + translateLedgerStateWith + (translate cfgConway cfgDijkstra) + (boundEpoch transition) + st + maxFor = + crossEraForecastBound + (ledgerTipSlot st) + (boundSlot transition) + (SL.stabilityWindow (shelleyLedgerGlobals (unwrapLedgerConfig cfgConway))) + (SL.stabilityWindow (shelleyLedgerGlobals (unwrapLedgerConfig cfgDijkstra))) + in if forecastFor < maxFor + then + WrapLedgerView + <$> Forecast.forecastFor + (ledgerViewForecastAt (unwrapLedgerConfig cfgDijkstra) stDijkstra) + forecastFor + else + throwError + OutsideForecastRange + { outsideForecastAt = ledgerTipSlot st + , outsideForecastMaxFor = maxFor + , outsideForecastFor = forecastFor + } + getDijkstraTranslationContext :: WrapLedgerConfig (ShelleyBlock (PraosWithLeios c) DijkstraEra) -> SL.TranslationContext DijkstraEra diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Leios.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Leios.hs index 690b788683..76ea4b790f 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Leios.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Leios.hs @@ -38,6 +38,7 @@ import Cardano.Ledger.Api.Tx.In (TxIn (..)) import Cardano.Ledger.BaseTypes (ProtVer (..), StrictMaybe (..), TxIx (..), knownNonZeroBounded) import qualified Cardano.Ledger.Block as SL import Cardano.Ledger.Core (TopTx, sizeTxF, txSeqBlockBodyL) +import qualified Cardano.Ledger.Core as Ledger import Cardano.Ledger.Dijkstra.BlockBody (leiosCertBlockBodyL) import Cardano.Ledger.Dijkstra.Genesis (DijkstraGenesis (..)) import Cardano.Ledger.Dijkstra.PParams @@ -55,6 +56,7 @@ import qualified Cardano.Ledger.Shelley.LedgerState as SL ) import Cardano.Protocol.Crypto (StandardCrypto) import Cardano.Protocol.TPraos.OCert (KESPeriod (..)) +import Cardano.Slotting.Slot (EpochSize (unEpochSize)) import Cardano.Slotting.Time (SlotLength, slotLengthFromSec) import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar as StrictTVar import Control.DeepSeq (force) @@ -116,7 +118,12 @@ import Ouroboros.Consensus.Cardano.Block , pattern GenTxDijkstra , pattern LedgerStateDijkstra ) -import Ouroboros.Consensus.Cardano.Node (CardanoProtocolParams (..), protocolInfoCardano) +import Ouroboros.Consensus.Cardano.Node + ( CardanoHardForkTrigger (CardanoTriggerHardForkAtEpoch) + , CardanoHardForkTriggers (triggerHardForkDijkstra) + , CardanoProtocolParams (..) + , protocolInfoCardano + ) import Ouroboros.Consensus.Config (SecurityParam (..), TopLevelConfig, configLedger) import Ouroboros.Consensus.HeaderValidation (headerStateChainDep) import Ouroboros.Consensus.Ledger.Abstract @@ -154,7 +161,7 @@ import qualified Test.Cardano.Ledger.Alonzo.Examples as Alonzo import qualified Test.Cardano.Ledger.Conway.Examples as Conway import qualified Test.Cardano.Ledger.Dijkstra.Examples as Dijkstra import qualified Test.Cardano.Ledger.Shelley.Examples as Shelley (leTranslationContext) -import Test.Consensus.Cardano.ProtocolInfo (Era (Dijkstra), hardForkInto) +import Test.Consensus.Cardano.ProtocolInfo (Era (Conway, Dijkstra), hardForkInto) import Test.QuickCheck ( Property , Testable @@ -164,6 +171,7 @@ import Test.QuickCheck , discard , forAll , ioProperty + , once , property , tabulate , (.&&.) @@ -187,6 +195,7 @@ import Test.ThreadNet.Infra.Shelley , DecentralizationParam (..) , genCoreNode , mkCredential + , mkEpochSize , mkGenesisConfig , mkKesConfig , mkLeaderCredentials @@ -222,6 +231,7 @@ tests = testProperty "late join" prop_leios_late_join , adjustQuickCheckTests (`div` 10) $ testProperty "invalid endorsed tx is not certified" prop_leios_invalid_eb + , testProperty "hard fork from Conway" prop_leios_hard_fork_from_conway ] -- | Verify a suite of basic Leios ThreadNet invariants in a single run: @@ -688,6 +698,54 @@ prop_leios_late_join seed = where numSlots = 200 :: Word64 +-- | Nodes cross from Conway into Dijkstra while EBs are being announced. +-- +-- Until a node's selection reaches Dijkstra, it validates Dijkstra headers +-- against a view forecast across the era boundary, so that view must carry +-- Dijkstra's Leios parameters rather than ones made up for the translation. +-- An announcement checked against a made-up limit is rejected, so the nodes +-- fail to adopt each other's blocks. +prop_leios_hard_fork_from_conway :: Seed -> Property +prop_leios_hard_fork_from_conway seed = + once $ + conjoin + [ not (null announcedAfterFork) + & counterexample "no EB announced in Dijkstra" + , ( case Map.elems nodeChains of + [] -> True + c : cs -> all (== c) cs + ) + & counterexample "nodes have different chains" + & counterexample ("chain lengths: " <> show (length <$> nodeChains)) + ] + where + -- 'hardForkInto' forks at epoch 0, which skips Conway entirely. + triggers = + (hardForkInto Conway){triggerHardForkDijkstra = CardanoTriggerHardForkAtEpoch 1} + + epochLength = unEpochSize $ mkEpochSize securityParam activeSlotCoeff + + numSlots = epochLength + 200 + + numCoreNodes = NumCoreNodes 3 + + (testOutput, _) = + runThreadNetWith + triggers + seed + (NumSlots numSlots) + numCoreNodes + (trivialNodeJoinPlan numCoreNodes) + (\_nid -> id) + + nodeChains = Chain.toOldestFirst . nodeOutputFinalChain <$> testOutput.testOutputNodes + + announcedAfterFork = + [ point + | FromNode _ (FromLeios TraceLeiosBlockAnnounced{announcedEbPoint = point}) <- testOutput.allTraces + , unSlotNo point.pointSlotNo >= epochLength + ] + -- | An EB whose closure cannot apply must never be certified: the committee is -- supposed to validate the endorsed transactions before signing a vote. -- @@ -1051,7 +1109,23 @@ runThreadNet' :: TestNodeInitialization m (CardanoBlock StandardCrypto) ) -> (TestOutput (CardanoBlock StandardCrypto), ProtocolInfo (CardanoBlock StandardCrypto)) -runThreadNet' initSeed numSlots numCoreNodes joinPlan tweakNodeInit = +runThreadNet' = runThreadNetWith (hardForkInto Dijkstra) + +-- | 'runThreadNet'' with the given hard fork triggers +runThreadNetWith :: + CardanoHardForkTriggers -> + Seed -> + NumSlots -> + NumCoreNodes -> + NodeJoinPlan -> + ( forall m. + Functor m => + CoreNodeId -> + TestNodeInitialization m (CardanoBlock StandardCrypto) -> + TestNodeInitialization m (CardanoBlock StandardCrypto) + ) -> + (TestOutput (CardanoBlock StandardCrypto), ProtocolInfo (CardanoBlock StandardCrypto)) +runThreadNetWith triggers initSeed numSlots numCoreNodes joinPlan tweakNodeInit = ( runTestNetwork testConfig testConfigB @@ -1094,7 +1168,7 @@ runThreadNet' initSeed numSlots numCoreNodes joinPlan tweakNodeInit = -- that, with d=0, it's stake based leaders. pure . mkLeaderCredentials $ coreNodes !! fromIntegral nid } - , cardanoHardForkTriggers = hardForkInto Dijkstra + , cardanoHardForkTriggers = triggers , cardanoLedgerTransitionConfig = mkLatestTransitionConfig shelleyGenesis @@ -1152,7 +1226,11 @@ runThreadNet' initSeed numSlots numCoreNodes joinPlan tweakNodeInit = , ctgeShelleyCoreNodes = coreNodes , ctgeExtraTxGen = \slot cn pparams utxo -> -- NOTE: Stop generating txs 20 slots before end of test run. - if unSlotNo slot > unNumSlots numSlots - 20 + -- Only in Dijkstra: a tx the mempool injects across the era + -- boundary holds a thunk, which TxSubmission's invariant + -- rejects. + if not (isDijkstraOrLater pparams) + || unSlotNo slot > unNumSlots numSlots - 20 then pure [] else pure $ constantLoadTxs numCoreNodes (TPS 100) slot cn pparams utxo } @@ -1178,6 +1256,10 @@ maxLovelaceSupply = 100_000_000_000_000 newtype TxPerSecond = TPS Word64 -- | Generate a constant load of transactions per second over all nodes. +-- | Whether these are the protocol parameters of Dijkstra or a later era +isDijkstraOrLater :: forall era. Ledger.Era era => PParams era -> Bool +isDijkstraOrLater _ = eraProtVerLow @era >= eraProtVerLow @DijkstraEra + constantLoadTxs :: EraTx era => NumCoreNodes -> From 36adfc6f3d581f4e910ae39f6a2c14eb7181fd06 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 9 Oct 2026 11:47:02 +0200 Subject: [PATCH 59/60] ChainDB: keep the immutable tip's cert when forgetting CertRBs at start-up The keep-set held the selection's blocks but not its anchor, which the VolatileDB still holds. A CertRB there was forgotten, so its successor's copy to the ImmutableDB could not find the EB it announced to promote. Co-Authored-By: Claude Opus 5.5 (1M context) --- .../Ouroboros/Consensus/Storage/ChainDB/Impl.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index c051ccde6e..3833639337 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -251,10 +251,12 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do -- Cause this execution of the node (ie since the latest restart) to -- re-fetch CertRBs that aren't on the initial selection. See -- docs/website/contents/explanations/valid_claims_startup.md for why. + -- The anchor too: it is the immutable tip, which the VolatileDB still + -- holds and which the copy to the ImmutableDB looks up as a predecessor. VolatileDB.forgetLeiosCertsAtStartUpExcept volatileDB $ Set.fromList $ - map headerHash $ - AF.toOldestFirst chain + [h | BlockHash h <- [AF.anchorToHash (AF.anchor chain)]] + <> map headerHash (AF.toOldestFirst chain) varChain <- newTVarWithInvariantIO checkInternalChain $ InternalChain chain chainWithTime varTentativeState <- newTVarIO $ initialTentativeHeaderState (Proxy @blk) From b1cecfcbc8afe402123e19588f392503e8bad7a3 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 9 Oct 2026 13:50:56 +0200 Subject: [PATCH 60/60] db-synthesizer: keep the replay fixture's references size within the wire limit The fixture set maxEndorserBlockReferencesSize to 1 MiB, above the 512 KiB maxLeiosEbBytesSize, so guardLeiosWireLimit refused to start the mempool and the replay test failed. 100,000 is what the testnet and proto-devnet genesis files use, and leaves ample room for the 80 KiB of transactions the fixture's endorser blocks hold. Co-Authored-By: Claude Opus 5.5 (1M context) --- .../Cardano/Tools/DBSynthesizer/Test/QueueFixture.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Test/QueueFixture.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Test/QueueFixture.hs index e2aa928940..38fbe6a0d7 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Test/QueueFixture.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Test/QueueFixture.hs @@ -156,7 +156,7 @@ leiosParams = [ -- Room for the endorser block's transactions: one block body's worth. ("maxEndorserBlockTxsSize", Number 81920) , -- Bounds how many transactions an endorser block may reference. - ("maxEndorserBlockReferencesSize", Number 1048576) + ("maxEndorserBlockReferencesSize", Number 100000) , -- Seat both of the fixture's pools. Only the one below carries our key; -- the other is seated keyless and never votes. ("leiosCommitteeSize", Number 2)