diff --git a/ouroboros-consensus-cardano/golden/byron/disk/ExtLedgerState b/ouroboros-consensus-cardano/golden/byron/disk/ExtLedgerState index a927507705..a197653ef9 100644 Binary files a/ouroboros-consensus-cardano/golden/byron/disk/ExtLedgerState and b/ouroboros-consensus-cardano/golden/byron/disk/ExtLedgerState differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Allegra b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Allegra index 25272f024c..06ade5779c 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Allegra and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Allegra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Alonzo b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Alonzo index 79f0888eaf..54c63c36c1 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Alonzo and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Alonzo differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage index 8ed6bea180..fbded0d220 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Byron b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Byron index 69b0766b8c..aa8a7bb4dd 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Byron and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Byron differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway index dbd0fdf29e..e0e5802021 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra index 354075ae62..fc6bf01a74 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Mary b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Mary index 57c5b157f5..5037ce8cb7 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Mary and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Mary differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Shelley b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Shelley index f2103a2ff6..b955776005 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Shelley and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Shelley differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Allegra b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Allegra index 4c864d0336..7580006560 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Allegra and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Allegra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Alonzo b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Alonzo index 3901351365..61ff86060c 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Alonzo and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Alonzo differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Babbage b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Babbage index a6f585080d..a4593c549d 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Babbage and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Conway b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Conway index c4da25687c..20ac863c92 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Conway and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Dijkstra index 4021c4cdb5..102bdb7599 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Dijkstra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Mary b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Mary index 0962bc2974..b18b83d58b 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Mary and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Mary differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Shelley b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Shelley index 43c07c7669..4971e28a28 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Shelley and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Shelley differ diff --git a/ouroboros-consensus-cardano/golden/shelley/disk/ExtLedgerState b/ouroboros-consensus-cardano/golden/shelley/disk/ExtLedgerState index eed98545e2..f82f53ef7b 100644 Binary files a/ouroboros-consensus-cardano/golden/shelley/disk/ExtLedgerState and b/ouroboros-consensus-cardano/golden/shelley/disk/ExtLedgerState differ diff --git a/ouroboros-consensus-cardano/golden/shelley/disk/LedgerState b/ouroboros-consensus-cardano/golden/shelley/disk/LedgerState index ad773413c0..faf720709f 100644 Binary files a/ouroboros-consensus-cardano/golden/shelley/disk/LedgerState and b/ouroboros-consensus-cardano/golden/shelley/disk/LedgerState differ diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs index 9adda91b3c..3b31625fdb 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs @@ -56,7 +56,7 @@ import qualified Cardano.Chain.Update.Validation.Endorsement as UPE import qualified Cardano.Chain.Update.Validation.Interface as UPI import qualified Cardano.Chain.ValidationMode as CC import Cardano.Ledger.BaseTypes (unNonZero) -import Cardano.Ledger.Binary (fromByronCBOR, toByronCBOR) +import Cardano.Ledger.Binary (ToCBOR (..), fromByronCBOR, toByronCBOR) import Cardano.Ledger.Binary.Plain (encodeListLen, enforceSize) import Codec.CBOR.Decoding (Decoder) import qualified Codec.CBOR.Decoding as CBOR @@ -91,6 +91,7 @@ import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils +import Ouroboros.Consensus.Peras.Context (StateSupportsPerasEpochContext) import Ouroboros.Consensus.Util (ShowProxy (..)) import Ouroboros.Consensus.Util.IndexedMemPack @@ -472,6 +473,7 @@ encodeByronExtLedgerState = encodeByronLedgerState encodeByronChainDepState encodeByronAnnTip + toCBOR encodeByronHeaderState :: HeaderState ByronBlock -> Encoding encodeByronHeaderState = @@ -579,6 +581,16 @@ instance CanUpgradeLedgerTables LedgerState ByronBlock where Peras -------------------------------------------------------------------------------} +-- | Default instances with no Peras support instance LedgerStateSupportsPeras (LedgerState ByronBlock) instance LedgerStateSupportsPeras (Ticked LedgerState ByronBlock) + +-- | Byron does not support Peras, so we use the default (empty) epoch context. +-- +-- NOTE: this instance lives here rather than in +-- 'Ouroboros.Consensus.Byron.Node.Peras' because its superclasses require the +-- 'HasHardForkHistory' and 'LedgerStateSupportsPeras' instances defined in this +-- module, while 'Byron.Node.Peras' is imported (transitively) by +-- 'Byron.Ledger.PBFT' and so cannot depend on this module. +instance StateSupportsPerasEpochContext ByronBlock diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/PBFT.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/PBFT.hs index 203d39eaf4..c452c790c0 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/PBFT.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/PBFT.hs @@ -23,6 +23,7 @@ import Ouroboros.Consensus.Byron.Crypto.DSIGN import Ouroboros.Consensus.Byron.Ledger.Block import Ouroboros.Consensus.Byron.Ledger.Config import Ouroboros.Consensus.Byron.Ledger.Serialisation () +import Ouroboros.Consensus.Byron.Node.Peras () import Ouroboros.Consensus.Byron.Protocol import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.PBFT 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 a4f8fcbdb7..0364943252 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs @@ -34,6 +34,7 @@ import qualified Cardano.Crypto as Crypto import Control.Monad (guard) import Data.Coerce (coerce) import Data.Maybe +import Data.Maybe.Strict (StrictMaybe (..)) import Data.Text (Text) import Data.Void (Void) import Ouroboros.Consensus.Block @@ -42,6 +43,7 @@ import Ouroboros.Consensus.Byron.Crypto.DSIGN import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Byron.Ledger.Conversions import Ouroboros.Consensus.Byron.Ledger.Inspect () +import Ouroboros.Consensus.Byron.Node.Peras () import Ouroboros.Consensus.Byron.Node.Serialisation () import Ouroboros.Consensus.Byron.Protocol import Ouroboros.Consensus.Config @@ -49,7 +51,7 @@ import Ouroboros.Consensus.Config.SupportsNode import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) +import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Node.InitStorage import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run @@ -59,7 +61,6 @@ import Ouroboros.Consensus.Protocol.PBFT import qualified Ouroboros.Consensus.Protocol.PBFT.State as S import Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB (..)) import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo) -import Ouroboros.Consensus.Util ((....:)) import Ouroboros.Network.Magic (NetworkMagic (..)) {------------------------------------------------------------------------------- @@ -142,7 +143,8 @@ byronBlockForging creds = canBeLeader slot tickedPBftState - , forgeBlock = \cfg -> return ....: forgeByronBlock cfg + , forgeBlock = \cfg bno slot _mbPerasCert st txs proof -> + return $ forgeByronBlock cfg bno slot st txs proof , finalize = pure () } where @@ -209,13 +211,25 @@ protocolInfoByron , topLevelConfigCheckpoints = emptyCheckpointsMap } , pInfoInitLedger = - ExtLedgerState - { -- Important: don't pass the compacted genesis config to - -- 'initByronLedgerState', it needs the full one, including the AVVM - -- balances. - ledgerState = initByronLedgerState genesisConfig Nothing - , headerState = genesisHeaderState S.empty - } + let + -- Important: don't pass the compacted genesis config to + -- 'initByronLedgerState', it needs the full one, including the AVVM + -- balances. + ledgerState = initByronLedgerState genesisConfig Nothing + headerState = genesisHeaderState S.empty + perasEpochContextResolver = + initPerasEpochContextResolver + compactedGenesisConfig + (forgetLedgerTables ledgerState) + headerState + latestPerasCertOnChainRound = SNothing + in + ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } } where compactedGenesisConfig = compactGenesisConfig genesisConfig @@ -302,8 +316,6 @@ instance NodeInitStorage ByronBlock where RunNode instance -------------------------------------------------------------------------------} -instance LedgerSupportsPeras ByronBlock - instance BlockSupportsMetrics ByronBlock where isSelfIssued = isSelfIssuedConstUnknown diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Peras.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Peras.hs new file mode 100644 index 0000000000..47040975c9 --- /dev/null +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Peras.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Empty Peras support for Byron. +-- +-- NOTE: this module exists solely because the orphan module +-- 'Ouroboros.Consensus.Byron.Node.Serialisation' needs these instances, but +-- defining it there would be too confusing. +module Ouroboros.Consensus.Byron.Node.Peras () where + +import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras) +import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) + +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: Byron does not support Peras, so we can use the empty instance here. +instance BlockSupportsPeras ByronBlock diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Serialisation.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Serialisation.hs index f9a9d48380..0141b04722 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Serialisation.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Serialisation.hs @@ -24,6 +24,7 @@ import Data.Word import Ouroboros.Consensus.Block import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Byron.Ledger.Conversions +import Ouroboros.Consensus.Byron.Node.Peras () import Ouroboros.Consensus.Byron.Protocol import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Query 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 79f0fd364c..a0f61ea0e0 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 @@ -48,7 +48,6 @@ import qualified Cardano.Protocol.TPraos.Rules.Tickn as SL import Control.Monad.Except (throwError) import Data.Coerce (coerce) import qualified Data.Map.Strict as Map -import Data.Maybe.Strict (StrictMaybe (..)) import Data.Proxy import Data.SOP.BasicFunctors import Data.SOP.Functors (Flip (..)) @@ -317,7 +316,6 @@ translateLedgerStateByronToShelleyWrapper = , shelleyLedgerTransition = ShelleyTransitionInfo{shelleyAfterVoting = 0} , shelleyLedgerTables = emptyLedgerTables - , shelleyLedgerLatestPerasCertRound = SNothing } } @@ -603,13 +601,12 @@ translateLedgerStateAlonzoToBabbageWrapper = transPraosLS :: LedgerState (ShelleyBlock (TPraos c) AlonzoEra) mk -> LedgerState (ShelleyBlock (Praos c) AlonzoEra) mk - transPraosLS (ShelleyLedgerState wo nes st tb lcr) = + transPraosLS (ShelleyLedgerState wo nes st tb) = ShelleyLedgerState { shelleyLedgerTip = fmap castShelleyTip wo , shelleyLedgerState = nes , shelleyLedgerTransition = st , shelleyLedgerTables = coerce tb - , shelleyLedgerLatestPerasCertRound = lcr } translateLedgerTablesAlonzoToBabbageWrapper :: 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 9cc21c264a..042c279fb1 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 @@ -50,6 +50,7 @@ import Cardano.Binary (DecoderError (..), enforceSize) import Cardano.Chain.Slotting (EpochSlots) import qualified Cardano.Ledger.Api.Era as L import qualified Cardano.Ledger.Api.Transition as L +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import qualified Cardano.Ledger.BaseTypes as SL import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Ledger.Shelley.LedgerState (NewEpochState, esSnapshotsL, nesEsL) @@ -85,12 +86,34 @@ import Ouroboros.Consensus.Cardano.CanHardFork import Ouroboros.Consensus.Cardano.QueryHF () import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Combinator + ( ConsensusConfig + ( HardForkConsensusConfig + , hardForkConsensusConfigK + , hardForkConsensusConfigPerEra + , hardForkConsensusConfigShape + ) + , HardForkLedgerConfig + ( HardForkLedgerConfig + , hardForkLedgerConfigPerEra + , hardForkLedgerConfigShape + ) + , HasPartialConsensusConfig (PartialConsensusConfig) + , HasPartialLedgerConfig (PartialLedgerConfig) + , LedgerState (HardForkLedgerState) + , NestedCtxt_ (NCS, NCZ) + , PerEraConsensusConfig (PerEraConsensusConfig) + , PerEraLedgerConfig (PerEraLedgerConfig) + , WrapPartialConsensusConfig (WrapPartialConsensusConfig) + , WrapPartialLedgerConfig (WrapPartialLedgerConfig) + , hardForkBlockForging + ) import Ouroboros.Consensus.HardFork.Combinator.Embed.Nary import Ouroboros.Consensus.HardFork.Combinator.Serialisation import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Tables +import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run @@ -889,6 +912,23 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano :* K (Shelley.shelleyEraParams genesisShelley (Proxy @DijkstraEra)) :* Nil + ledgerConfig = + HardForkLedgerConfig + { hardForkLedgerConfigShape = shape + , hardForkLedgerConfigPerEra = + PerEraLedgerConfig + ( WrapPartialLedgerConfig partialLedgerConfigByron + :* WrapPartialLedgerConfig partialLedgerConfigShelley + :* WrapPartialLedgerConfig partialLedgerConfigAllegra + :* WrapPartialLedgerConfig partialLedgerConfigMary + :* WrapPartialLedgerConfig partialLedgerConfigAlonzo + :* WrapPartialLedgerConfig partialLedgerConfigBabbage + :* WrapPartialLedgerConfig partialLedgerConfigConway + :* WrapPartialLedgerConfig partialLedgerConfigDijkstra + :* Nil + ) + } + cfg :: TopLevelConfig (CardanoBlock c) cfg = TopLevelConfig @@ -910,21 +950,7 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano ) } , topLevelConfigLedger = - HardForkLedgerConfig - { hardForkLedgerConfigShape = shape - , hardForkLedgerConfigPerEra = - PerEraLedgerConfig - ( WrapPartialLedgerConfig partialLedgerConfigByron - :* WrapPartialLedgerConfig partialLedgerConfigShelley - :* WrapPartialLedgerConfig partialLedgerConfigAllegra - :* WrapPartialLedgerConfig partialLedgerConfigMary - :* WrapPartialLedgerConfig partialLedgerConfigAlonzo - :* WrapPartialLedgerConfig partialLedgerConfigBabbage - :* WrapPartialLedgerConfig partialLedgerConfigConway - :* WrapPartialLedgerConfig partialLedgerConfigDijkstra - :* Nil - ) - } + ledgerConfig , topLevelConfigBlock = CardanoBlockConfig blockConfigByron @@ -966,15 +992,25 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano mkInitExtLedgerStateCardano = do let HardForkLedgerState st = initLedgerState st' <- hsequence' (hap perEraInjections st) + let ledgerState = HardForkLedgerState st' + let headerState = initHeaderState + let perasEpochContextResolver = + initPerasEpochContextResolver + ledgerConfig + (forgetLedgerTables ledgerState) + headerState + let latestPerasCertOnChainRound = SNothing pure ExtLedgerState - { headerState = initHeaderState - , ledgerState = HardForkLedgerState st' + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound } where initHeaderState :: HeaderState (CardanoBlock c) initLedgerState :: LedgerState (CardanoBlock c) ValuesMK - ExtLedgerState initLedgerState initHeaderState = + ExtLedgerState initLedgerState initHeaderState _ _ = injectInitialExtLedgerState cfg $ initExtLedgerStateByron diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs index 5d957cbf84..67b4296f14 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -9,12 +10,15 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} module Ouroboros.Consensus.Shelley.Ledger.Block ( GetHeader (..) , Header (..) , IsShelleyBlock + , ShelleyPerasCertCompatibleWithLedger (..) + , LedgerPerasCertError (..) , NestedCtxt_ (..) , ShelleyBasedEra , ShelleyBlock (..) @@ -50,11 +54,13 @@ import Cardano.Ledger.Binary.Group (EncCBORGroup) import qualified Cardano.Ledger.Binary.Plain as Plain import qualified Cardano.Ledger.Block as SL (EraBlockHeader) import Cardano.Ledger.Core as SL - ( eraDecoder + ( EraBlockBody (..) + , eraDecoder , eraProtVerLow , toEraCBOR ) -import qualified Cardano.Ledger.Core as SL (BlockBody, TranslationContext, hashBlockBody) +import qualified Cardano.Ledger.Core as SL (TranslationContext) +import qualified Cardano.Ledger.Dijkstra.BlockBody as SL import Cardano.Ledger.Hashes (HASH) import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Protocol.Crypto (Crypto) @@ -62,15 +68,16 @@ import qualified Cardano.Protocol.TPraos.BlockHeader as SL import qualified Data.ByteString.Lazy as Lazy import Data.Coerce (coerce) import Data.Typeable (Typeable) +import Data.Void (absurd) import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.HardFork.Combinator ( HasPartialConsensusConfig - , LedgerState ) +import Ouroboros.Consensus.HardFork.History (EpochToPerasRoundInfo) import Ouroboros.Consensus.HeaderValidation -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras) +import Ouroboros.Consensus.Peras.Context (StateSupportsPerasEpochContext (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Praos.Common ( PraosTiebreakerView @@ -130,20 +137,18 @@ class HasPartialConsensusConfig proto , DecCBOR (SL.PState era) , Crypto (ProtoCrypto proto) + , -- Peras constraints + BlockSupportsPeras (ShelleyBlock proto era) + , ShelleyPerasCertCompatibleWithLedger proto era + , StateSupportsPerasEpochContext (ShelleyBlock proto era) + , MaybeEraIndexedEpochToPerasRoundInfo (ShelleyBlock proto era) ~ EpochToPerasRoundInfo , -- Backwards compatibility Plain.FromCBOR (LegacyPParams era) , Plain.ToCBOR (LegacyPParams era) - , -- TODO: replace the four constraints below with: - -- 'StateSupportsPerasEpochContext (ShelleyBlock proto er)' once that type - -- class is in place. - ChainDepStateSupportsPeras (ChainDepState (BlockProtocol (ShelleyBlock proto era))) - , ChainDepStateSupportsPeras (Ticked (ChainDepState (BlockProtocol (ShelleyBlock proto era)))) - , LedgerStateSupportsPeras (LedgerState (ShelleyBlock proto era)) - , LedgerStateSupportsPeras (Ticked LedgerState (ShelleyBlock proto era)) ) => ShelleyCompatible proto era -instance ShelleyCompatible proto era => ConvertRawHash (ShelleyBlock proto era) where +instance StandardHash (ShelleyBlock proto era) => ConvertRawHash (ShelleyBlock proto era) where -- 'HASH' is currently 'Blake2b_256', whose digest is 256 bits, i.e. 32 bytes, -- so this resolves to 32. type HashSize (ShelleyBlock proto era) = Crypto.HashSize HASH @@ -254,7 +259,7 @@ instance ShelleyCompatible proto era => GetPrevHash (ShelleyBlock proto era) whe . pHeaderPrevHash . shelleyHeaderRaw -instance ShelleyCompatible proto era => StandardHash (ShelleyBlock proto era) +instance StandardHash (ShelleyBlock proto era) instance ShelleyCompatible proto era => HasAnnTip (ShelleyBlock proto era) @@ -262,6 +267,55 @@ instance ShelleyCompatible proto era => HasAnnTip (ShelleyBlock proto era) -- "Ouroboros.Consensus.Shelley.Ledger.Ledger" module because of the -- dependency on the 'LedgerConfig'. +{------------------------------------------------------------------------------- + Conversion between Peras certificates type between Ledger and Consensus +-------------------------------------------------------------------------------} + +-- | Error type for Ledger <=> Consensus Peras certificate conversions +newtype LedgerPerasCertError = LedgerPerasCertError String + deriving (Eq, Show, Generic, NoThunks) + +-- | Bridge between the Peras certificates types between Consensus and Ledger +class ShelleyPerasCertCompatibleWithLedger proto era where + -- | Convert a Ledger Peras certificate to a Consensus Peras certificate + toLedgerPerasCert :: + PerasCert (ShelleyBlock proto era) -> + SL.PerasCert + default toLedgerPerasCert :: + PerasCert (ShelleyBlock proto era) ~ VoidPerasCert (ShelleyBlock proto era) => + PerasCert (ShelleyBlock proto era) -> + SL.PerasCert + toLedgerPerasCert = + absurd . unVoidPerasCert + + -- | Convert a Ledger Peras certificate to a Consensus Peras certificate + fromLedgerPerasCert :: + SL.PerasCert -> + Either LedgerPerasCertError (PerasCert (ShelleyBlock proto era)) + default fromLedgerPerasCert :: + SL.PerasCert -> + Either LedgerPerasCertError (PerasCert (ShelleyBlock proto era)) + fromLedgerPerasCert cert = + Left $ + LedgerPerasCertError $ + "this era does not support Peras certificates, but received" + <> show cert + + -- | Extract a Peras certificate from a Shelley block body, if present + extractPerasCertFromShelleyBlockBody :: + BlockBody era -> + Either LedgerPerasCertError (Maybe (PerasCert (ShelleyBlock proto era))) + extractPerasCertFromShelleyBlockBody _ = + Right Nothing + + -- | Inject a Peras certificate into a Shelley block body + injectPerasCertIntoShelleyBlockBody :: + PerasCert (ShelleyBlock proto era) -> + BlockBody era -> + BlockBody era + injectPerasCertIntoShelleyBlockBody _ = + id + {------------------------------------------------------------------------------- Conversions -------------------------------------------------------------------------------} 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 9fb6008286..1e53667240 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 @@ -49,6 +49,8 @@ forgeShelleyBlock :: BlockNo -> -- | Current slot number SlotNo -> + -- | Optional Peras certificate to include in the block + Maybe (PerasCert (ShelleyBlock proto era)) -> -- | Current ledger TickedLedgerState (ShelleyBlock proto era) mk -> -- | Txs to include @@ -61,6 +63,7 @@ forgeShelleyBlock cfg curNo curSlot + mbPerasCert tickedLedger txs isLeader = do @@ -84,7 +87,8 @@ forgeShelleyBlock body = SL.mkBasicBlockBody - & SL.txSeqBlockBodyL .~ Seq.fromList (fmap extractTx txs) + & (SL.txSeqBlockBodyL .~ Seq.fromList (fmap extractTx txs)) + & maybe id injectPerasCertIntoShelleyBlockBody mbPerasCert actualBodySize = SL.blockBodySize protocolVersion body 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 7be446c4d6..3cdeb5105a 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 @@ -101,7 +101,6 @@ import Control.Monad.Except import qualified Control.State.Transition.Extended as STS import Data.Coerce import Data.Functor.Identity -import Data.Maybe.Strict (StrictMaybe (..), maybeToStrictMaybe, strictMaybeToMaybe) import Data.MemPack import qualified Data.Text as T import qualified Data.Text as Text @@ -116,17 +115,16 @@ import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.HardFork.Combinator.PartialConfig import qualified Ouroboros.Consensus.HardFork.History as HardFork -import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (..)) +import Ouroboros.Consensus.HardFork.History.EraParams + ( EraParams (..) + ) import Ouroboros.Consensus.HardFork.History.Util import Ouroboros.Consensus.HardFork.Simple import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Extended -import Ouroboros.Consensus.Ledger.SupportsPeras - ( LedgerStateSupportsPeras (..) - , LedgerSupportsPeras (..) - ) +import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras (..)) import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch) import Ouroboros.Consensus.Shelley.Eras (ShelleyBasedEra (..)) @@ -139,12 +137,7 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract , envelopeChecks ) import Ouroboros.Consensus.Util -import Ouroboros.Consensus.Util.CBOR - ( decodeStrictMaybe - , decodeWithOrigin - , encodeStrictMaybe - , encodeWithOrigin - ) +import Ouroboros.Consensus.Util.CBOR (decodeWithOrigin, encodeWithOrigin) import Ouroboros.Consensus.Util.IndexedMemPack import Ouroboros.Consensus.Util.Versioned @@ -290,7 +283,6 @@ data instance LedgerState (ShelleyBlock proto era) mk = ShelleyLedgerState , shelleyLedgerState :: !(SL.NewEpochState era) , shelleyLedgerTransition :: !ShelleyTransition , shelleyLedgerTables :: !(LedgerTables (ShelleyBlock proto era) mk) - , shelleyLedgerLatestPerasCertRound :: !(StrictMaybe PerasRoundNo) } deriving Generic @@ -404,14 +396,12 @@ instance , shelleyLedgerState , shelleyLedgerTransition , shelleyLedgerTables = tables - , shelleyLedgerLatestPerasCertRound } where ShelleyLedgerState { shelleyLedgerTip , shelleyLedgerState , shelleyLedgerTransition - , shelleyLedgerLatestPerasCertRound } = st instance @@ -425,14 +415,12 @@ instance , tickedShelleyLedgerTransition , tickedShelleyLedgerState , tickedShelleyLedgerTables = tables - , tickedShelleyLedgerLatestPerasCertRound } where TickedShelleyLedgerState { untickedShelleyLedgerTip , tickedShelleyLedgerTransition , tickedShelleyLedgerState - , tickedShelleyLedgerLatestPerasCertRound } = st instance @@ -445,7 +433,6 @@ instance , shelleyLedgerState = shelleyLedgerState' , shelleyLedgerTransition = shelleyLedgerTransition , shelleyLedgerTables = emptyLedgerTables - , shelleyLedgerLatestPerasCertRound = shelleyLedgerLatestPerasCertRound } where (_, shelleyLedgerState') = shelleyLedgerState `slUtxoL` SL.UTxO (coerceMapKeys m) @@ -454,7 +441,6 @@ instance , shelleyLedgerState , shelleyLedgerTransition , shelleyLedgerTables = LedgerTables (ValuesMK m) - , shelleyLedgerLatestPerasCertRound } = st unstowLedgerTables st = ShelleyLedgerState @@ -462,7 +448,6 @@ instance , shelleyLedgerState = shelleyLedgerState' , shelleyLedgerTransition = shelleyLedgerTransition , shelleyLedgerTables = LedgerTables (ValuesMK (coerceMapKeys $ SL.unUTxO tbs)) - , shelleyLedgerLatestPerasCertRound = shelleyLedgerLatestPerasCertRound } where (tbs, shelleyLedgerState') = shelleyLedgerState `slUtxoL` mempty @@ -470,7 +455,6 @@ instance { shelleyLedgerTip , shelleyLedgerState , shelleyLedgerTransition - , shelleyLedgerLatestPerasCertRound } = st instance @@ -483,7 +467,6 @@ instance , tickedShelleyLedgerTransition = tickedShelleyLedgerTransition , tickedShelleyLedgerState = tickedShelleyLedgerState' , tickedShelleyLedgerTables = emptyLedgerTables - , tickedShelleyLedgerLatestPerasCertRound = tickedShelleyLedgerLatestPerasCertRound } where (_, tickedShelleyLedgerState') = @@ -493,7 +476,6 @@ instance , tickedShelleyLedgerTransition , tickedShelleyLedgerState , tickedShelleyLedgerTables = LedgerTables (ValuesMK tbs) - , tickedShelleyLedgerLatestPerasCertRound } = st unstowLedgerTables st = @@ -502,7 +484,6 @@ instance , tickedShelleyLedgerTransition = tickedShelleyLedgerTransition , tickedShelleyLedgerState = tickedShelleyLedgerState' , tickedShelleyLedgerTables = LedgerTables (ValuesMK (coerceMapKeys (SL.unUTxO tbs))) - , tickedShelleyLedgerLatestPerasCertRound = tickedShelleyLedgerLatestPerasCertRound } where (tbs, tickedShelleyLedgerState') = tickedShelleyLedgerState `slUtxoL` mempty @@ -510,7 +491,6 @@ instance { untickedShelleyLedgerTip , tickedShelleyLedgerTransition , tickedShelleyLedgerState - , tickedShelleyLedgerLatestPerasCertRound } = st slUtxoL :: SL.NewEpochState era -> SL.UTxO era -> (SL.UTxO era, SL.NewEpochState era) @@ -547,7 +527,6 @@ data instance Ticked LedgerState (ShelleyBlock proto era) mk = TickedShelleyLedg -- must be reset when /ticking/, not when applying a block. , tickedShelleyLedgerState :: !(SL.NewEpochState era) , tickedShelleyLedgerTables :: !(LedgerTables (ShelleyBlock proto era) mk) - , tickedShelleyLedgerLatestPerasCertRound :: !(StrictMaybe PerasRoundNo) } deriving Generic @@ -569,7 +548,6 @@ instance ShelleyBasedEra era => IsLedger LedgerState (ShelleyBlock proto era) wh { shelleyLedgerTip , shelleyLedgerState , shelleyLedgerTransition - , shelleyLedgerLatestPerasCertRound } = appTick globals shelleyLedgerState slotNo <&> \l' -> TickedShelleyLedgerState @@ -585,8 +563,6 @@ instance ShelleyBasedEra era => IsLedger LedgerState (ShelleyBlock proto era) wh , -- The UTxO set is only mutated by block/transaction execution and -- era translations, that is why we put empty tables here. tickedShelleyLedgerTables = emptyLedgerTables - , tickedShelleyLedgerLatestPerasCertRound = - shelleyLedgerLatestPerasCertRound } where globals = shelleyLedgerGlobals cfg @@ -725,8 +701,6 @@ applyHelper f cfg blk stBefore = do shelleyAfterVoting tickedShelleyLedgerTransition } , shelleyLedgerTables = emptyLedgerTables - , shelleyLedgerLatestPerasCertRound = - shelleyLedgerLatestPerasCertRound' } where globals = shelleyLedgerGlobals cfg @@ -748,25 +722,6 @@ applyHelper f cfg blk stBefore = do votingDeadline :: SlotNo votingDeadline = subSlots (2 * swindow) startOfNextEpoch - -- Update the latest Peras certificate round if the new block contains a - -- certificate from a round more recent than the currently cached one. - shelleyLedgerLatestPerasCertRound' :: StrictMaybe PerasRoundNo - shelleyLedgerLatestPerasCertRound' = - case getPerasCertRoundInBlock blk of - SNothing -> - tickedShelleyLedgerLatestPerasCertRound stBefore - SJust certRoundInBlock -> - case tickedShelleyLedgerLatestPerasCertRound stBefore of - SNothing -> - SJust certRoundInBlock - SJust latestCertRoundInLedgerState -> - SJust (certRoundInBlock `max` latestCertRoundInLedgerState) - - -- Extract the round number of the Peras certificate stored in a block, if any - getPerasCertRoundInBlock :: ShelleyBlock proto era -> StrictMaybe PerasRoundNo - getPerasCertRoundInBlock = - fmap getPerasCertRound . maybeToStrictMaybe . getPerasCertInBlock - instance ShelleyBasedEra era => HasHardForkHistory (ShelleyBlock proto era) where type HardForkIndices (ShelleyBlock proto era) = '[ShelleyBlock proto era] hardForkSummary = @@ -882,15 +837,13 @@ encodeShelleyLedgerState { shelleyLedgerTip , shelleyLedgerState , shelleyLedgerTransition - , shelleyLedgerLatestPerasCertRound } = encodeVersion serialisationFormatVersion2 $ mconcat $ - [ CBOR.encodeListLen 4 + [ CBOR.encodeListLen 3 , encodeWithOrigin encodeShelleyTip shelleyLedgerTip , toCBOR shelleyLedgerState , encodeShelleyTransition shelleyLedgerTransition - , encodeStrictMaybe toCBOR shelleyLedgerLatestPerasCertRound ] decodeShelleyLedgerState :: @@ -904,18 +857,16 @@ decodeShelleyLedgerState = where decodeShelleyLedgerState2 :: Decoder s' (LedgerState (ShelleyBlock proto era) EmptyMK) decodeShelleyLedgerState2 = do - enforceSize "ShelleyLedgerState" 4 + enforceSize "ShelleyLedgerState" 3 shelleyLedgerTip <- decodeWithOrigin decodeShelleyTip shelleyLedgerState <- fromCBOR shelleyLedgerTransition <- decodeShelleyTransition - shelleyLedgerLatestPerasCertRound <- decodeStrictMaybe fromCBOR return ShelleyLedgerState { shelleyLedgerTip , shelleyLedgerState , shelleyLedgerTransition , shelleyLedgerTables = emptyLedgerTables - , shelleyLedgerLatestPerasCertRound } instance CanUpgradeLedgerTables LedgerState (ShelleyBlock proto era) where @@ -925,11 +876,6 @@ instance CanUpgradeLedgerTables LedgerState (ShelleyBlock proto era) where LedgerSupportsPeras -------------------------------------------------------------------------------} -instance LedgerSupportsPeras (ShelleyBlock proto era) where - getLatestPerasCertRound = - strictMaybeToMaybe - . shelleyLedgerLatestPerasCertRound - instance LedgerStateSupportsPeras (LedgerState (ShelleyBlock proto era)) where getPoolDistr = nesPd . shelleyLedgerState diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs index 86967e3b4b..dd7634985d 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -24,7 +25,6 @@ import qualified Data.Map.Strict as Map import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Combinator.Abstract.NoHardForks -import Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits) import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol ) @@ -32,6 +32,7 @@ import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.TPraos +import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Ledger.Inspect () import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion () @@ -107,11 +108,64 @@ instance ConsensusProtocol proto => BlockSupportsSanityCheck (ShelleyBlock proto configAllSecurityParams = pure . protocolSecurityParam . topLevelConfigProtocol instance - ( ShelleyCompatible proto era - , LedgerSupportsProtocol (ShelleyBlock proto era) - , BlockSupportsSanityCheck (ShelleyBlock proto era) - , TxLimits (ShelleyBlock proto era) - , NoHardForks (ShelleyBlock proto era) + ( ShelleyCompatible proto ShelleyEra + , LedgerSupportsProtocol (ShelleyBlock proto ShelleyEra) + , BlockSupportsSanityCheck (ShelleyBlock proto ShelleyEra) + , NoHardForks (ShelleyBlock proto ShelleyEra) , Crypto (ProtoCrypto proto) ) => - RunNode (ShelleyBlock proto era) + RunNode (ShelleyBlock proto ShelleyEra) + +instance + ( ShelleyCompatible proto AllegraEra + , LedgerSupportsProtocol (ShelleyBlock proto AllegraEra) + , BlockSupportsSanityCheck (ShelleyBlock proto AllegraEra) + , NoHardForks (ShelleyBlock proto AllegraEra) + , Crypto (ProtoCrypto proto) + ) => + RunNode (ShelleyBlock proto AllegraEra) + +instance + ( ShelleyCompatible proto MaryEra + , LedgerSupportsProtocol (ShelleyBlock proto MaryEra) + , BlockSupportsSanityCheck (ShelleyBlock proto MaryEra) + , NoHardForks (ShelleyBlock proto MaryEra) + , Crypto (ProtoCrypto proto) + ) => + RunNode (ShelleyBlock proto MaryEra) + +instance + ( ShelleyCompatible proto AlonzoEra + , LedgerSupportsProtocol (ShelleyBlock proto AlonzoEra) + , BlockSupportsSanityCheck (ShelleyBlock proto AlonzoEra) + , NoHardForks (ShelleyBlock proto AlonzoEra) + , Crypto (ProtoCrypto proto) + ) => + RunNode (ShelleyBlock proto AlonzoEra) + +instance + ( ShelleyCompatible proto BabbageEra + , LedgerSupportsProtocol (ShelleyBlock proto BabbageEra) + , BlockSupportsSanityCheck (ShelleyBlock proto BabbageEra) + , NoHardForks (ShelleyBlock proto BabbageEra) + , Crypto (ProtoCrypto proto) + ) => + RunNode (ShelleyBlock proto BabbageEra) + +instance + ( ShelleyCompatible proto ConwayEra + , LedgerSupportsProtocol (ShelleyBlock proto ConwayEra) + , BlockSupportsSanityCheck (ShelleyBlock proto ConwayEra) + , NoHardForks (ShelleyBlock proto ConwayEra) + , Crypto (ProtoCrypto proto) + ) => + RunNode (ShelleyBlock proto ConwayEra) + +instance + ( ShelleyCompatible proto DijkstraEra + , LedgerSupportsProtocol (ShelleyBlock proto DijkstraEra) + , BlockSupportsSanityCheck (ShelleyBlock proto DijkstraEra) + , NoHardForks (ShelleyBlock proto DijkstraEra) + , Crypto (ProtoCrypto proto) + ) => + RunNode (ShelleyBlock proto DijkstraEra) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs new file mode 100644 index 0000000000..dceffe1f0a --- /dev/null +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Peras support for Shelley. +-- +-- NOTE: this module exists solely because the orphan module +-- 'Ouroboros.Consensus.Shelley.Node.Serialisation' needs these instances, but +-- defining it there would be too confusing. +module Ouroboros.Consensus.Shelley.Node.Peras () where + +import Cardano.Binary (Decoder, Encoding, FromCBOR (..), ToCBOR (..)) +import Cardano.Ledger.Api +import qualified Cardano.Ledger.Binary as CBOR +import qualified Cardano.Ledger.Dijkstra.BlockBody as SL +import qualified Cardano.Ledger.Shelley.API as SL +import qualified Codec.CBOR.Read as CBOR +import Data.Array.Byte (ByteArray) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.ByteString.Short as ShortByteString +import Data.Maybe.Strict (StrictMaybe (..)) +import Data.MemPack.Buffer + ( byteArrayFromShortByteString + , byteArrayToShortByteString + ) +import Data.Typeable (Typeable) +import Lens.Micro ((.~), (^.)) +import Ouroboros.Consensus.Block.Abstract (ConvertRawHash) +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (..) + ) +import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import Ouroboros.Consensus.Peras.Context + ( StateSupportsPerasEpochContext (..) + , mkBoundedPerasEpochContextWith + ) +import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS +import Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe + ( unsafePerasBLSPrivateKeyFromEnv + ) +import qualified Ouroboros.Consensus.Peras.Error.V1 as V1 +import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 +import qualified Ouroboros.Consensus.Peras.Voting.V1 as V1 +import Ouroboros.Consensus.Protocol.Abstract + ( ChainDepStateSupportsPeras + , ConsensusProtocol (..) + ) +import Ouroboros.Consensus.Shelley.Ledger.Block + ( LedgerPerasCertError (..) + , ShelleyBlock (..) + , ShelleyPerasCertCompatibleWithLedger (..) + ) +import Ouroboros.Consensus.Shelley.Ledger.Ledger () +import Ouroboros.Consensus.Ticked (Ticked) + +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +instance Typeable proto => BlockSupportsPeras (ShelleyBlock proto ShelleyEra) +instance Typeable proto => BlockSupportsPeras (ShelleyBlock proto AllegraEra) +instance Typeable proto => BlockSupportsPeras (ShelleyBlock proto MaryEra) +instance Typeable proto => BlockSupportsPeras (ShelleyBlock proto AlonzoEra) +instance Typeable proto => BlockSupportsPeras (ShelleyBlock proto BabbageEra) +instance Typeable proto => BlockSupportsPeras (ShelleyBlock proto ConwayEra) + +instance + ( Typeable proto + , ConvertRawHash (ShelleyBlock proto DijkstraEra) + ) => + BlockSupportsPeras (ShelleyBlock proto DijkstraEra) + where + type PerasVote (ShelleyBlock proto DijkstraEra) = V1.PerasVote (ShelleyBlock proto DijkstraEra) + type PerasCert (ShelleyBlock proto DijkstraEra) = V1.PerasCert (ShelleyBlock proto DijkstraEra) + type PerasError (ShelleyBlock proto DijkstraEra) = V1.PerasError (ShelleyBlock proto DijkstraEra) + type PerasCrypto (ShelleyBlock proto DijkstraEra) = BLS.PerasBLSCrypto + type PerasVotingCommitteeScheme (ShelleyBlock proto DijkstraEra) = V1.PerasVotingCommitteeScheme + + getPerasCertInBlock blk = + let blockBody = SL.blockBody (shelleyBlockRaw blk) + in case extractPerasCertFromShelleyBlockBody blockBody of + Left _err -> + -- NOTE: for now, we just ignore any conversion error between the + -- (opaque) Peras certificate stored in the block body and the one + -- expected here. This is to avoid propagating errors cases caused by + -- an implementation detail that will eventually disappear when Ledger + -- becomes aware of the Peras types used by Consensus. Until then, + -- discarding invalid Peras certificates should be safe enough here. + Right Nothing + Right mbCert -> + Right mbCert + + readPerasPrivateKeyFromEnv _proxy = + unsafePerasBLSPrivateKeyFromEnv + +{------------------------------------------------------------------------------- + StateSupportsPerasEpochContext +-------------------------------------------------------------------------------} + +instance + ( Typeable proto + , ChainDepStateSupportsPeras (ChainDepState proto) + , ChainDepStateSupportsPeras (Ticked (ChainDepState proto)) + ) => + StateSupportsPerasEpochContext (ShelleyBlock proto ShelleyEra) +instance + ( Typeable proto + , ChainDepStateSupportsPeras (ChainDepState proto) + , ChainDepStateSupportsPeras (Ticked (ChainDepState proto)) + ) => + StateSupportsPerasEpochContext (ShelleyBlock proto AllegraEra) +instance + ( Typeable proto + , ChainDepStateSupportsPeras (ChainDepState proto) + , ChainDepStateSupportsPeras (Ticked (ChainDepState proto)) + ) => + StateSupportsPerasEpochContext (ShelleyBlock proto MaryEra) +instance + ( Typeable proto + , ChainDepStateSupportsPeras (ChainDepState proto) + , ChainDepStateSupportsPeras (Ticked (ChainDepState proto)) + ) => + StateSupportsPerasEpochContext (ShelleyBlock proto AlonzoEra) +instance + ( Typeable proto + , ChainDepStateSupportsPeras (ChainDepState proto) + , ChainDepStateSupportsPeras (Ticked (ChainDepState proto)) + ) => + StateSupportsPerasEpochContext (ShelleyBlock proto BabbageEra) +instance + ( Typeable proto + , ChainDepStateSupportsPeras (ChainDepState proto) + , ChainDepStateSupportsPeras (Ticked (ChainDepState proto)) + ) => + StateSupportsPerasEpochContext (ShelleyBlock proto ConwayEra) + +instance + ( Typeable proto + , ConvertRawHash (ShelleyBlock proto DijkstraEra) + , ChainDepStateSupportsPeras (ChainDepState proto) + , ChainDepStateSupportsPeras (Ticked (ChainDepState proto)) + ) => + StateSupportsPerasEpochContext (ShelleyBlock proto DijkstraEra) + where + mkBoundedPerasEpochContext = + mkBoundedPerasEpochContextWith V1.mkPerasVotingCommitteeInput + +{------------------------------------------------------------------------------- + ShelleyPerasCertCompatibleWithLedger +-------------------------------------------------------------------------------} + +instance ShelleyPerasCertCompatibleWithLedger proto ShelleyEra +instance ShelleyPerasCertCompatibleWithLedger proto AllegraEra +instance ShelleyPerasCertCompatibleWithLedger proto MaryEra +instance ShelleyPerasCertCompatibleWithLedger proto AlonzoEra +instance ShelleyPerasCertCompatibleWithLedger proto BabbageEra +instance ShelleyPerasCertCompatibleWithLedger proto ConwayEra + +instance + Typeable proto => + ShelleyPerasCertCompatibleWithLedger proto DijkstraEra + where + toLedgerPerasCert = + SL.PerasCert . toByteArray . toCBOR + where + toByteArray :: Encoding -> ByteArray + toByteArray = + byteArrayFromShortByteString + . ShortByteString.toShort + . CBOR.toStrictByteString + + fromLedgerPerasCert (SL.PerasCert byteArray) = + fromByteArray fromCBOR byteArray + where + fromByteArray :: + (forall s. Decoder s (V1.PerasCert blk)) -> + ByteArray -> + Either LedgerPerasCertError (V1.PerasCert blk) + fromByteArray decoder = + handleParseErrors + . CBOR.deserialiseFromBytes decoder + . LazyByteString.fromStrict + . ShortByteString.fromShort + . byteArrayToShortByteString + + handleParseErrors :: + Either CBOR.DeserialiseFailure (ByteString, a) -> + Either LedgerPerasCertError a + handleParseErrors = \case + Left err -> failure err + Right (trailing, a) + | not (LazyByteString.null trailing) -> failure "trailing bytes" + | otherwise -> pure a + where + failure err = + Left $ + LedgerPerasCertError $ + "Failed to deserialize opaque Peras certificate from byte array: " + <> show err + + extractPerasCertFromShelleyBlockBody blockBody = + case blockBody ^. SL.perasCertBlockBodyL of + SNothing -> + Right Nothing + SJust ledgerCert -> + case fromLedgerPerasCert ledgerCert of + Left err -> + Left err + Right cert -> + Right (Just cert) + + injectPerasCertIntoShelleyBlockBody cert = + SL.perasCertBlockBodyL .~ SJust (toLedgerPerasCert cert) 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..0a2a70c56a 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 @@ -87,10 +87,15 @@ praosSharedBlockForging praosCheckCanForge (configConsensus cfg) curSlot - , forgeBlock = \cfg -> + , forgeBlock = \cfg blkNo slotNo mbPerasCert ledgerState txs -> forgeShelleyBlock hotKey canBeLeader cfg + blkNo + slotNo + mbPerasCert + ledgerState + txs , finalize = HotKey.finalize hotKey } 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 e0aa6b1277..d972613b4e 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 @@ -45,6 +45,7 @@ import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion () +import Ouroboros.Consensus.Shelley.Node.Peras () import Ouroboros.Consensus.Shelley.Protocol.Abstract ( pHeaderBlockSize , pHeaderSize @@ -126,22 +127,47 @@ instance SerialiseNodeToNode -------------------------------------------------------------------------------} -instance +-- | Shared implementation of 'estimateBlockSize' for all Shelley-based eras. +estimateBlockSizeShelley :: ShelleyCompatible proto era => - SerialiseNodeToNodeConstraints (ShelleyBlock proto era) + Header (ShelleyBlock proto era) -> + SizeInBytes +estimateBlockSizeShelley hdr = overhead + hdrSize + bodySize + where + -- The maximum block size is 65536, the CBOR-in-CBOR tag for this block + -- is: + -- + -- > D8 18 # tag(24) + -- > 1A 00010000 # bytes(65536) + -- + -- Which is 7 bytes, enough for up to 4294967295 bytes. + overhead = 7 {- CBOR-in-CBOR -} + 1 {- encodeListLen -} + bodySize = fromIntegral . pHeaderBlockSize . shelleyHeaderRaw $ hdr + hdrSize = fromIntegral . pHeaderSize . shelleyHeaderRaw $ hdr + +instance ShelleyCompatible proto ShelleyEra => SerialiseNodeToNodeConstraints (ShelleyBlock proto ShelleyEra) where + estimateBlockSize = estimateBlockSizeShelley + +instance ShelleyCompatible proto AllegraEra => SerialiseNodeToNodeConstraints (ShelleyBlock proto AllegraEra) where + estimateBlockSize = estimateBlockSizeShelley + +instance ShelleyCompatible proto MaryEra => SerialiseNodeToNodeConstraints (ShelleyBlock proto MaryEra) where + estimateBlockSize = estimateBlockSizeShelley + +instance ShelleyCompatible proto AlonzoEra => SerialiseNodeToNodeConstraints (ShelleyBlock proto AlonzoEra) where + estimateBlockSize = estimateBlockSizeShelley + +instance ShelleyCompatible proto BabbageEra => SerialiseNodeToNodeConstraints (ShelleyBlock proto BabbageEra) where + estimateBlockSize = estimateBlockSizeShelley + +instance ShelleyCompatible proto ConwayEra => SerialiseNodeToNodeConstraints (ShelleyBlock proto ConwayEra) where + estimateBlockSize = estimateBlockSizeShelley + +instance + ShelleyCompatible proto DijkstraEra => + SerialiseNodeToNodeConstraints (ShelleyBlock proto DijkstraEra) where - estimateBlockSize hdr = overhead + hdrSize + bodySize - where - -- The maximum block size is 65536, the CBOR-in-CBOR tag for this block - -- is: - -- - -- > D8 18 # tag(24) - -- > 1A 00010000 # bytes(65536) - -- - -- Which is 7 bytes, enough for up to 4294967295 bytes. - overhead = 7 {- CBOR-in-CBOR -} + 1 {- encodeListLen -} - bodySize = fromIntegral . pHeaderBlockSize . shelleyHeaderRaw $ hdr - hdrSize = fromIntegral . pHeaderSize . shelleyHeaderRaw $ hdr + estimateBlockSize = estimateBlockSizeShelley -- | CBOR-in-CBOR for the annotation. This also makes it compatible with the -- wrapped ('Serialised') variant. 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 cf9c67372a..97e3994205 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 @@ -120,11 +120,16 @@ shelleySharedBlockForging hotKey slotToPeriod credentials = (configConsensus cfg) forgingVRFHash curSlot - , forgeBlock = \cfg -> + , forgeBlock = \cfg blkNo slotNo mbPerasCert ledgerState txs -> forgeShelleyBlock hotKey canBeLeader cfg + blkNo + slotNo + mbPerasCert + ledgerState + txs , finalize = HotKey.finalize hotKey } where @@ -204,11 +209,20 @@ protocolInfoTPraosShelleyBased transitionCfg protVer = assertWithMsg (validateGenesis genesis) $ do - initLedgerState <- mkInitLedgerState + ledgerState <- mkInitLedgerState + let headerState = genesisHeaderState initChainDepState + let perasEpochContextResolver = + initPerasEpochContextResolver + ledgerConfig + (forgetLedgerTables ledgerState) + headerState + let latestPerasCertOnChainRound = SNothing let initExtLedgerState = ExtLedgerState - { ledgerState = initLedgerState - , headerState = genesisHeaderState initChainDepState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound } pure ( ProtocolInfo @@ -279,7 +293,6 @@ protocolInfoTPraosShelleyBased protVer genesis (shelleyBlockIssuerVKey <$> credentialss) - storageConfig :: StorageConfig (ShelleyBlock (TPraos c) era) storageConfig = ShelleyStorageConfig @@ -301,7 +314,6 @@ protocolInfoTPraosShelleyBased , shelleyLedgerState = injected , shelleyLedgerTransition = ShelleyTransitionInfo{shelleyAfterVoting = 0} , shelleyLedgerTables = emptyLedgerTables - , shelleyLedgerLatestPerasCertRound = SNothing } initChainDepState :: TPraosState 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 0ace6e0fcc..8987f6e49b 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -79,7 +79,6 @@ import Ouroboros.Consensus.HardFork.History (Bound (boundSlot)) import Ouroboros.Consensus.HardFork.Simple import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits) -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol , ledgerViewForecastAt @@ -165,21 +164,105 @@ instance -- includes an era wrapper. Each block should do this from the start to be -- prepared for future hard forks without having to do any bit twiddling. instance - ( ShelleyCompatible proto era - , LedgerSupportsProtocol (ShelleyBlock proto era) - , LedgerSupportsPeras (ShelleyBlock proto era) - , TxLimits (ShelleyBlock proto era) + ( ShelleyCompatible proto ShelleyEra + , LedgerSupportsProtocol (ShelleyBlock proto ShelleyEra) + , TxLimits (ShelleyBlock proto ShelleyEra) , Crypto (ProtoCrypto proto) ) => - SerialiseHFC '[ShelleyBlock proto era] + SerialiseHFC '[ShelleyBlock proto ShelleyEra] instance - ( ShelleyCompatible proto era - , LedgerSupportsProtocol (ShelleyBlock proto era) - , TxLimits (ShelleyBlock proto era) + ( ShelleyCompatible proto AllegraEra + , LedgerSupportsProtocol (ShelleyBlock proto AllegraEra) + , TxLimits (ShelleyBlock proto AllegraEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto AllegraEra] +instance + ( ShelleyCompatible proto MaryEra + , LedgerSupportsProtocol (ShelleyBlock proto MaryEra) + , TxLimits (ShelleyBlock proto MaryEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto MaryEra] +instance + ( ShelleyCompatible proto AlonzoEra + , LedgerSupportsProtocol (ShelleyBlock proto AlonzoEra) + , TxLimits (ShelleyBlock proto AlonzoEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto AlonzoEra] +instance + ( ShelleyCompatible proto BabbageEra + , LedgerSupportsProtocol (ShelleyBlock proto BabbageEra) + , TxLimits (ShelleyBlock proto BabbageEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto BabbageEra] +instance + ( ShelleyCompatible proto ConwayEra + , LedgerSupportsProtocol (ShelleyBlock proto ConwayEra) + , TxLimits (ShelleyBlock proto ConwayEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto ConwayEra] +instance + ( ShelleyCompatible proto DijkstraEra + , LedgerSupportsProtocol (ShelleyBlock proto DijkstraEra) + , TxLimits (ShelleyBlock proto DijkstraEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto DijkstraEra] + +instance + ( ShelleyCompatible proto ShelleyEra + , LedgerSupportsProtocol (ShelleyBlock proto ShelleyEra) + , TxLimits (ShelleyBlock proto ShelleyEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseConstraintsHFC (ShelleyBlock proto ShelleyEra) +instance + ( ShelleyCompatible proto AllegraEra + , LedgerSupportsProtocol (ShelleyBlock proto AllegraEra) + , TxLimits (ShelleyBlock proto AllegraEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseConstraintsHFC (ShelleyBlock proto AllegraEra) +instance + ( ShelleyCompatible proto MaryEra + , LedgerSupportsProtocol (ShelleyBlock proto MaryEra) + , TxLimits (ShelleyBlock proto MaryEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseConstraintsHFC (ShelleyBlock proto MaryEra) +instance + ( ShelleyCompatible proto AlonzoEra + , LedgerSupportsProtocol (ShelleyBlock proto AlonzoEra) + , TxLimits (ShelleyBlock proto AlonzoEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseConstraintsHFC (ShelleyBlock proto AlonzoEra) +instance + ( ShelleyCompatible proto BabbageEra + , LedgerSupportsProtocol (ShelleyBlock proto BabbageEra) + , TxLimits (ShelleyBlock proto BabbageEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseConstraintsHFC (ShelleyBlock proto BabbageEra) +instance + ( ShelleyCompatible proto ConwayEra + , LedgerSupportsProtocol (ShelleyBlock proto ConwayEra) + , TxLimits (ShelleyBlock proto ConwayEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseConstraintsHFC (ShelleyBlock proto ConwayEra) +instance + ( ShelleyCompatible proto DijkstraEra + , LedgerSupportsProtocol (ShelleyBlock proto DijkstraEra) + , TxLimits (ShelleyBlock proto DijkstraEra) , Crypto (ProtoCrypto proto) ) => - SerialiseConstraintsHFC (ShelleyBlock proto era) + SerialiseConstraintsHFC (ShelleyBlock proto DijkstraEra) {------------------------------------------------------------------------------- Protocol type definition @@ -369,7 +452,7 @@ instance SL.TranslateEra era (Flip LedgerState mk :.: ShelleyBlock proto) where translateEra ctxt (Comp (Flip st)) = do - let ShelleyLedgerState tip state _transition tables latestPerasCertRound = st + let ShelleyLedgerState tip state _transition tables = st tip' <- mapM (SL.translateEra ctxt) tip state' <- SL.translateEra ctxt state return $ @@ -380,7 +463,6 @@ instance , shelleyLedgerState = state' , shelleyLedgerTransition = ShelleyTransitionInfo 0 , shelleyLedgerTables = translateShelleyTables tables - , shelleyLedgerLatestPerasCertRound = latestPerasCertRound } translateShelleyTables :: 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 4a9bfd2366..32f14d3f12 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 @@ -19,6 +19,7 @@ import qualified Cardano.Chain.Genesis as Impl import qualified Cardano.Chain.UTxO as Impl import qualified Cardano.Chain.Update as Impl import qualified Cardano.Chain.Update.Validation.Interface as Impl +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import Data.Either (fromRight) import Data.Map.Strict (Map) import Data.Maybe (fromMaybe) @@ -35,7 +36,7 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Dual import Ouroboros.Consensus.Ledger.Extended -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) +import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Node.InitStorage import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run @@ -43,7 +44,6 @@ import Ouroboros.Consensus.NodeId import Ouroboros.Consensus.Protocol.PBFT import qualified Ouroboros.Consensus.Protocol.PBFT.State as S import Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB (..)) -import Ouroboros.Consensus.Util ((.....:)) import qualified Test.Cardano.Chain.Elaboration.Block as Spec.Test import qualified Test.Cardano.Chain.Elaboration.Delegation as Spec.Test import qualified Test.Cardano.Chain.Elaboration.Keys as Spec.Test @@ -65,7 +65,8 @@ dualByronBlockForging creds = , updateForgeState = \cfg -> fmap castForgeStateUpdateInfo .: updateForgeState (dualTopLevelConfigMain cfg) , checkCanForge = checkCanForge . dualTopLevelConfigMain - , forgeBlock = return .....: forgeDualByronBlock + , forgeBlock = \cfg slot bno _mbPerasCert lst txs proof -> + return $ forgeDualByronBlock cfg slot bno lst txs proof , finalize = return () } where @@ -88,48 +89,60 @@ protocolInfoDualByron :: , m [BlockForging m DualByronBlock] ) protocolInfoDualByron abstractGenesis@ByronSpecGenesis{..} params credss = - ( ProtocolInfo - { pInfoConfig = - TopLevelConfig - { topLevelConfigProtocol = - PBftConfig - { pbftParams = params - } - , topLevelConfigLedger = - DualLedgerConfig - { dualLedgerConfigMain = concreteGenesis - , dualLedgerConfigAux = abstractConfig - } - , topLevelConfigBlock = - DualBlockConfig - { dualBlockConfigMain = concreteConfig - , dualBlockConfigAux = ByronSpecBlockConfig - } - , topLevelConfigCodec = - DualCodecConfig - { dualCodecConfigMain = mkByronCodecConfig concreteGenesis - , dualCodecConfigAux = ByronSpecCodecConfig - } - , topLevelConfigStorage = - DualStorageConfig - { dualStorageConfigMain = ByronStorageConfig concreteConfig - , dualStorageConfigAux = ByronSpecStorageConfig - } - , topLevelConfigCheckpoints = emptyCheckpointsMap - } - , pInfoInitLedger = - ExtLedgerState - { ledgerState = - DualLedgerState - { dualLedgerStateMain = initConcreteState - , dualLedgerStateAux = initAbstractState - , dualLedgerStateBridge = initBridge - } - , headerState = genesisHeaderState S.empty - } - } - , return $ dualByronBlockForging . byronLeaderCredentials <$> credss - ) + let ledgerConfig = + DualLedgerConfig + { dualLedgerConfigMain = concreteGenesis + , dualLedgerConfigAux = abstractConfig + } + in ( ProtocolInfo + { pInfoConfig = + TopLevelConfig + { topLevelConfigProtocol = + PBftConfig + { pbftParams = params + } + , topLevelConfigLedger = + ledgerConfig + , topLevelConfigBlock = + DualBlockConfig + { dualBlockConfigMain = concreteConfig + , dualBlockConfigAux = ByronSpecBlockConfig + } + , topLevelConfigCodec = + DualCodecConfig + { dualCodecConfigMain = mkByronCodecConfig concreteGenesis + , dualCodecConfigAux = ByronSpecCodecConfig + } + , topLevelConfigStorage = + DualStorageConfig + { dualStorageConfigMain = ByronStorageConfig concreteConfig + , dualStorageConfigAux = ByronSpecStorageConfig + } + , topLevelConfigCheckpoints = emptyCheckpointsMap + } + , pInfoInitLedger = + let ledgerState = + DualLedgerState + { dualLedgerStateMain = initConcreteState + , dualLedgerStateAux = initAbstractState + , dualLedgerStateBridge = initBridge + } + headerState = genesisHeaderState S.empty + perasEpochContextResolver = + initPerasEpochContextResolver + ledgerConfig + (forgetLedgerTables ledgerState) + headerState + latestPerasCertOnChainRound = SNothing + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } + } + , return $ dualByronBlockForging . byronLeaderCredentials <$> credss + ) where initUtxo :: Impl.UTxO txIdMap :: Map Spec.TxId Impl.TxId @@ -267,8 +280,6 @@ instance NodeInitStorage DualByronBlock where RunNode instance -------------------------------------------------------------------------------} -instance LedgerSupportsPeras DualByronBlock - instance BlockSupportsMetrics DualByronBlock where isSelfIssued = isSelfIssuedConstUnknown diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs index 9f89caaac3..0291944391 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -30,7 +31,7 @@ import qualified Cardano.Chain.Byron.API as CC import qualified Cardano.Chain.Common as CC import qualified Cardano.Chain.UTxO as CC import qualified Cardano.Chain.Update.Validation.Interface as CC.UPI -import Cardano.Ledger.BaseTypes (knownNonZeroBounded) +import Cardano.Ledger.BaseTypes (StrictMaybe (..), knownNonZeroBounded) import Control.Monad.Except (runExcept) import qualified Data.Map.Strict as Map import Ouroboros.Consensus.Block @@ -219,10 +220,20 @@ exampleHeaderState = HeaderState (NotOrigin exampleAnnTip) exampleChainDepState exampleExtLedgerState :: ExtLedgerState ByronBlock ValuesMK exampleExtLedgerState = - ExtLedgerState - { ledgerState = exampleLedgerState - , headerState = exampleHeaderState - } + let ledgerState = exampleLedgerState + headerState = exampleHeaderState + perasEpochContextResolver = + initPerasEpochContextResolver + ledgerConfig + (forgetLedgerTables ledgerState) + headerState + latestPerasCertOnChainRound = SNothing + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } exampleHeaderHash :: ByronHash exampleHeaderHash = blockHash exampleBlock diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs index f328b2e41d..8c17af51eb 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs @@ -83,7 +83,6 @@ import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol ) @@ -184,8 +183,8 @@ type ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 = , ShelleyCompatible proto2 era2 , LedgerSupportsProtocol (ShelleyBlock proto1 era1) , LedgerSupportsProtocol (ShelleyBlock proto2 era2) - , LedgerSupportsPeras (ShelleyBlock proto1 era1) - , LedgerSupportsPeras (ShelleyBlock proto2 era2) + , SerialiseConstraintsHFC (ShelleyBlock proto1 era1) + , SerialiseConstraintsHFC (ShelleyBlock proto2 era2) , TxLimits (ShelleyBlock proto1 era1) , TxLimits (ShelleyBlock proto2 era2) , TranslateTxMeasure 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 19254c54a2..6eece8a8e4 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 @@ -24,6 +24,7 @@ module Cardano.Tools.DBAnalyser.Analysis , runAnalysis ) where +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import qualified Cardano.Slotting.Slot as Slotting import qualified Cardano.Tools.DBAnalyser.Analysis.BenchmarkLedgerOps.FileWriting as F import qualified Cardano.Tools.DBAnalyser.Analysis.BenchmarkLedgerOps.SlotDataPoint as DP @@ -42,6 +43,7 @@ import Data.Bifunctor (bimap) import Data.Int (Int64) import Data.List (intercalate) import qualified Data.Map.Strict as Map +import Data.SOP (All, Top) import Data.Singletons import Data.Word (Word16, Word32, Word64) import qualified Debug.Trace as Debug @@ -50,6 +52,7 @@ import NoThunks.Class (noThunks) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Forecast (forecastFor) +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..)) import Ouroboros.Consensus.HeaderValidation ( HasAnnTip (..) , HeaderState (..) @@ -70,6 +73,9 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils import qualified Ouroboros.Consensus.Mempool as Mempool import Ouroboros.Consensus.Mempool.Impl.Common +import Ouroboros.Consensus.Peras.Context + ( StateSupportsPerasEpochContext + ) import Ouroboros.Consensus.Protocol.Abstract (LedgerView) import Ouroboros.Consensus.Storage.Common (BlockComponent (..)) import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB) @@ -87,10 +93,13 @@ import qualified System.IO as IO runAnalysis :: forall blk. ( HasAnalysis blk + , All Top (HardForkIndices blk) , LedgerSupportsMempool.HasTxId (LedgerSupportsMempool.GenTx blk) , LedgerSupportsMempool.HasTxs blk , LedgerSupportsMempool blk , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk , CanStowLedgerTables (LedgerState blk) , Show (TxIn blk) , Show (TxOut blk) @@ -235,7 +244,13 @@ data TraceEvent blk Int64 Int64 -instance (HasAnalysis blk, LedgerSupportsProtocol blk) => Show (TraceEvent blk) where +instance + ( HasAnalysis blk + , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + ) => + Show (TraceEvent blk) + where show (StartedEvent analysisName) = "Started " <> (show analysisName) show DoneEvent = "Done" show (BlockSlotEvent bn sn h) = @@ -416,7 +431,10 @@ showEBBs AnalysisEnv{db, registry, startFrom, limit, tracer} = do storeLedgerStateAt :: forall blk. - ( LedgerSupportsProtocol blk + ( All Top (HardForkIndices blk) + , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk , HasAnalysis blk ) => SlotNo -> @@ -498,8 +516,11 @@ countBlocks (AnalysisEnv{db, registry, startFrom, limit, tracer}) = do checkNoThunksEvery :: forall blk. - ( HasAnalysis blk + ( All Top (HardForkIndices blk) + , HasAnalysis blk , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk , CanStowLedgerTables (LedgerState blk) ) => Word64 -> @@ -555,8 +576,11 @@ checkNoThunksEvery traceLedgerProcessing :: forall blk. - ( HasAnalysis blk + ( All Top (HardForkIndices blk) + , HasAnalysis blk , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk ) => Analysis blk StartFromLedgerState traceLedgerProcessing @@ -612,8 +636,10 @@ traceLedgerProcessing benchmarkLedgerOps :: forall blk. - ( LedgerSupportsProtocol blk + ( All Top (HardForkIndices blk) , HasAnalysis blk + , LedgerSupportsProtocol blk + , StateSupportsPerasEpochContext blk ) => Maybe FilePath -> LedgerApplicationMode -> @@ -699,7 +725,21 @@ benchmarkLedgerOps mOutfile ledgerAppMode AnalysisEnv{db, registry, startFrom, c F.writeDataPoint outFileHandle outFormat slotDataPoint - LedgerDB.push intLedgerDB $ ExtLedgerState (prependDiffs tkLdgrSt newLedger) newHeader + LedgerDB.push intLedgerDB $ + let ledgerState = (prependDiffs tkLdgrSt newLedger) + headerState = newHeader + perasEpochContextResolver = + initPerasEpochContextResolver + lcfg + (forgetLedgerTables ledgerState) + headerState + latestPerasCertOnChainRound = SNothing + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } where rp = blockRealPoint blk @@ -781,7 +821,10 @@ withFile Nothing = \f -> f IO.stdout getBlockApplicationMetrics :: forall blk. ( HasAnalysis blk + , All Top (HardForkIndices blk) , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk ) => NumberOfBlocks -> Maybe FilePath -> Analysis blk StartFromLedgerState getBlockApplicationMetrics (NumberOfBlocks nrBlocks) mOutFile env = do diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs index 904e27c40c..2a1dad04ee 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs @@ -17,11 +17,12 @@ import Control.Monad (unless) import Control.Monad.Trans.Class import Control.ResourceRegistry import Control.Tracer (mkTracer, nullTracer, (>$<)) +import Data.SOP (All, Top) import Data.Singletons (Sing, SingI (..)) import qualified Debug.Trace as Debug import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config -import Ouroboros.Consensus.HardFork.Abstract +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..)) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect @@ -32,6 +33,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import qualified Ouroboros.Consensus.Node as Node import qualified Ouroboros.Consensus.Node.InitStorage as Node import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..)) +import Ouroboros.Consensus.Peras.Context (StateSupportsPerasEpochContext) import Ouroboros.Consensus.Protocol.Abstract import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB @@ -64,9 +66,11 @@ import Text.Printf (printf) openLedgerDB :: forall blk. - ( LedgerSupportsProtocol blk + ( All Top (HardForkIndices blk) + , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk , InspectLedger blk - , HasHardForkHistory blk ) => Complete LedgerDB.LedgerDbArgs IO blk -> ImmutableDB.ImmutableDB IO blk -> 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 8918ee14aa..ed3db39f3c 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 @@ -231,6 +231,7 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg genTxs = do cfg bcBlockNo currentSlot + Nothing -- [TODO PERAS CERT INCLUSION] determine whether we need this (forgetLedgerTables tickedLedgerState) txs proof 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 6555ca47f4..bbf0edad29 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 @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -189,13 +190,18 @@ fromShelleyLedgerExamples , shelleyLedgerState = leNewEpochState , shelleyLedgerTransition = ShelleyTransitionInfo{shelleyAfterVoting = 0} , shelleyLedgerTables = LedgerTables EmptyMK - , shelleyLedgerLatestPerasCertRound = SNothing } chainDepState = TPraosState (NotOrigin 1) pleChainDepState extLedgerState = - ExtLedgerState - ledgerState - (genesisHeaderState chainDepState) + let headerState = genesisHeaderState chainDepState + perasEpochContextResolver = initPerasEpochContextResolver ledgerConfig ledgerState headerState + latestPerasCertOnChainRound = SNothing + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } ledgerConfig = exampleShelleyLedgerConfig leTranslationContext @@ -326,15 +332,20 @@ fromShelleyLedgerExamplesPraos , shelleyLedgerState = leNewEpochState , shelleyLedgerTransition = ShelleyTransitionInfo{shelleyAfterVoting = 0} , shelleyLedgerTables = emptyLedgerTables - , shelleyLedgerLatestPerasCertRound = SNothing } chainDepState = translateChainDepState (Proxy @(TPraos StandardCrypto, Praos StandardCrypto)) $ TPraosState (NotOrigin 1) pleChainDepState extLedgerState = - ExtLedgerState - ledgerState - (genesisHeaderState chainDepState) + let headerState = genesisHeaderState chainDepState + perasEpochContextResolver = initPerasEpochContextResolver ledgerConfig ledgerState headerState + latestPerasCertOnChainRound = SNothing + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } ledgerConfig = exampleShelleyLedgerConfig leTranslationContext 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 877c7195bf..93388979fc 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 @@ -18,7 +18,6 @@ import qualified Cardano.Protocol.TPraos.BlockHeader as SL import Cardano.Slotting.EpochInfo import Control.Monad (replicateM) import Data.Coerce (coerce) -import Data.Maybe.Strict (StrictMaybe (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract @@ -225,7 +224,6 @@ instance <*> arbitrary <*> arbitrary <*> pure (LedgerTables EmptyMK) - <*> frequency [(1, pure SNothing), (3, SJust . PerasRoundNo <$> arbitrary)] instance (Arbitrary (InstantStake era), CanMock proto era) => @@ -237,7 +235,6 @@ instance <*> arbitrary <*> arbitrary <*> (LedgerTables . ValuesMK <$> arbitrary) - <*> frequency [(1, pure SNothing), (3, SJust . PerasRoundNo <$> arbitrary)] deriving newtype instance Arbitrary BigEndianTxIn diff --git a/ouroboros-consensus-cardano/test/shelley-test/Main.hs b/ouroboros-consensus-cardano/test/shelley-test/Main.hs index 0c4f764bef..705c241e9c 100644 --- a/ouroboros-consensus-cardano/test/shelley-test/Main.hs +++ b/ouroboros-consensus-cardano/test/shelley-test/Main.hs @@ -3,6 +3,7 @@ module Main (main) where import qualified Test.Consensus.Shelley.Coherence (tests) import qualified Test.Consensus.Shelley.Golden (tests) import qualified Test.Consensus.Shelley.LedgerTables (tests) +import qualified Test.Consensus.Shelley.Peras (tests) import qualified Test.Consensus.Shelley.Serialisation (tests) import qualified Test.Consensus.Shelley.SupportedNetworkProtocolVersion (tests) import Test.Tasty @@ -22,6 +23,7 @@ tests = [ Test.Consensus.Shelley.Coherence.tests , Test.Consensus.Shelley.Golden.tests , Test.Consensus.Shelley.LedgerTables.tests + , Test.Consensus.Shelley.Peras.tests , Test.Consensus.Shelley.Serialisation.tests , Test.Consensus.Shelley.SupportedNetworkProtocolVersion.tests , Test.ThreadNet.Shelley.tests diff --git a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Peras.hs b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Peras.hs new file mode 100644 index 0000000000..b82f4dd411 --- /dev/null +++ b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Peras.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Consensus.Shelley.Peras (tests) where + +import Cardano.Binary (ToCBOR (toCBOR)) +import qualified Cardano.Ledger.Dijkstra.BlockBody as SL +import qualified Codec.CBOR.Write as CBOR +import qualified Data.ByteString.Short as Short +import Data.MemPack.Buffer (byteArrayFromShortByteString) +import Ouroboros.Consensus.Block (Point (..)) +import Ouroboros.Consensus.Block.SupportsPeras (PerasCert) +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) +import Ouroboros.Consensus.Shelley.HFEras (StandardDijkstraBlock) +import Ouroboros.Consensus.Shelley.Ledger.Block + ( ShelleyPerasCertCompatibleWithLedger (..) + ) +import Ouroboros.Consensus.Shelley.Node.Peras () +import Test.Ouroboros.Storage.TestBlock (TestBlock) +import Test.QuickCheck + ( Gen + , Property + , counterexample + , forAll + , property + , (===) + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Test.Util.Peras (genPerasCert) +import Test.Util.Peras.Common (genRoundNo) +import Test.Util.Peras.Mock (genMockPerasVoterIndices) + +tests :: TestTree +tests = + testGroup + "ShelleyBlockPerasCert" + [ testProperty + "Roundtrip through ShelleyBlockPerasCert for Dijkstra" + prop_DijkstraPerasCertRoundtrip + , testProperty + "Deserializing an invalid Dijkstra Peras certificate fails" + prop_DijkstraPerasCertRoundtripError + ] + +prop_DijkstraPerasCertRoundtrip :: Property +prop_DijkstraPerasCertRoundtrip = + forAll (genPerasCert @StandardDijkstraBlock True) $ \cert -> do + let ledgerCert = toLedgerPerasCert cert + counterexample ("Ledger cert: " <> show ledgerCert) $ + fromLedgerPerasCert ledgerCert === Right cert + +prop_DijkstraPerasCertRoundtripError :: Property +prop_DijkstraPerasCertRoundtripError = + forAll genInvalidLedgerPerasCert $ \ledgerCert -> + case fromLedgerPerasCert ledgerCert of + Left _ -> + property True + Right (cert :: PerasCert StandardDijkstraBlock) -> + counterexample + ("Didn't fail to decode an invalid Dijkstra cert from: " <> show cert) + $ False + +-- | Generate an invalid ledger Peras cert by serializing a random mocked one. +genInvalidLedgerPerasCert :: Gen SL.PerasCert +genInvalidLedgerPerasCert = do + mockCertRound <- genRoundNo + mockCertVoters <- genMockPerasVoterIndices + let mockCertBlock = GenesisPoint @TestBlock + pure + . SL.PerasCert + . byteArrayFromShortByteString + . Short.toShort + . CBOR.toStrictByteString + . toCBOR + $ MockPerasCert + { mockCertRound + , mockCertBlock + , mockCertVoters + } 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 0f6ff48dd5..2bbfe7f716 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 @@ -275,8 +275,9 @@ mkHandlers :: ( IOLike m , MonadTime m , MonadTimer m - , LedgerSupportsMempool blk , HasTxId (GenTx blk) + , BlockSupportsPeras blk + , LedgerSupportsMempool blk , LedgerSupportsProtocol blk , Ord addrNTN , Hashable addrNTN @@ -380,7 +381,10 @@ mkHandlers , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 ) - (makePerasCertPoolWriterFromChainDB systemTime getChainDB) + ( makePerasCertPoolWriterFromChainDB + systemTime + getChainDB + ) version controlMessageSTM , hPerasCertDiffusionServer = \version peer -> @@ -398,13 +402,6 @@ mkHandlers ) ( makePerasVotePoolWriterFromChainDB systemTime - -- TODO: when actual plumbing for Peras is ready, we will have to - -- extract the committee selection data from the chainDB to pass - -- it here, instead of relying on an empty the stake distribution. - -- - -- Note that the empty stake distribution will cause all votes to - -- be considered invalid. - (pure (PerasVoteStakeDistr mempty)) getChainDB ) version @@ -620,6 +617,8 @@ showTracers :: , Show (Header blk) , Show (GenTx blk) , Show (GenTxId blk) + , Show (PerasVote blk) + , Show (PerasCert blk) , HasHeader blk , HasNestedContent Header blk ) => @@ -772,10 +771,13 @@ mkApps :: , Exception e , NFData e , LedgerSupportsProtocol blk + , BlockSupportsPeras blk , ShowProxy blk , ShowProxy (Header blk) , ShowProxy (TxId (GenTx blk)) , ShowProxy (GenTx blk) + , ShowProxy (PerasVote blk) + , ShowProxy (PerasCert blk) , Show addrNTN , LedgerSupportsMempool blk , HasTxId (GenTx blk) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/RethrowPolicy.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/RethrowPolicy.hs index 724f657dc7..ea2c5995d5 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/RethrowPolicy.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/RethrowPolicy.hs @@ -105,6 +105,7 @@ consensusRethrowPolicy pb = case e of MultipleWinnersInRound{} -> ourBug -- TODO: should we instead shutdown the node? ForgingCertError{} -> ourBug + EpochContextNotFoundForRound{} -> ourBug ) -- Some chain sync client exceptions indicate malicious behaviour, -- others merely mean that we should disconnect from this client diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs index 951804186a..615309de28 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs @@ -208,6 +208,7 @@ showTracers :: , Show (TxMeasurePhase2 blk) , Show (PerasVote blk) , Show (PerasCert blk) + , Show (PerasError blk) , Show remotePeer , HasRawTxId (GenTxId blk) , LedgerSupportsProtocol blk @@ -427,6 +428,7 @@ deriving instance , Eq (CannotForge blk) , Eq (TxMeasurePhase1 blk) , Eq (TxMeasurePhase2 blk) + , Eq (PerasError blk) ) => Eq (TraceForgeEvent blk) deriving instance @@ -437,6 +439,7 @@ deriving instance , Show (CannotForge blk) , Show (TxMeasurePhase1 blk) , Show (TxMeasurePhase2 blk) + , Show (PerasError blk) ) => Show (TraceForgeEvent blk) 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 ba1609a754..735a16f561 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 @@ -22,7 +22,7 @@ module Ouroboros.Consensus.NodeKernel , toConsensusMode ) where -import Cardano.Base.FeatureFlags (CardanoFeatureFlag) +import Cardano.Base.FeatureFlags (CardanoFeatureFlag (..)) import Cardano.Network.ConsensusMode (ConsensusMode (..)) import Cardano.Network.LedgerStateJudgement (LedgerStateJudgement (..)) import Cardano.Network.NodeToNode @@ -39,6 +39,8 @@ import Control.DeepSeq (force) import Control.Monad import qualified Control.Monad.Class.MonadTimer.SI as SI import Control.Monad.Except +import Control.Monad.Trans.Maybe (hoistMaybe, runMaybeT) +import Control.Monad.Writer (runWriterT, tell) import Control.ResourceRegistry import Control.Tracer import Data.Bifunctor (second) @@ -50,17 +52,20 @@ import Data.Functor ((<&>)) import Data.Hashable (Hashable) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Maybe (isJust) +import Data.Maybe (isJust, isNothing) import Data.Proxy -import Data.Set (Set) +import Data.Set (Set, member) import qualified Data.Text as Text import Data.Void (Void) +import Data.Word (Word64) import Ouroboros.Consensus.Block hiding (blockMatchesHeader) import qualified Ouroboros.Consensus.Block as Block import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Config import Ouroboros.Consensus.Forecast import Ouroboros.Consensus.Genesis.Governor (gddWatcher) +import qualified Ouroboros.Consensus.HardFork.History.EraParams as HF +import Ouroboros.Consensus.HardFork.History.Qry (slotToPerasRoundNo') import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended @@ -92,6 +97,19 @@ import Ouroboros.Consensus.Node.Genesis ) import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Tracers +import Ouroboros.Consensus.Peras.Cert.Inclusion + ( PerasCertInclusionRulesDecision (..) + , needCertWithHandle + ) +import Ouroboros.Consensus.Peras.Context + ( forgePerasVoteIfEligibleWithHandle + , runQueryWithContextHandle + ) +import Ouroboros.Consensus.Peras.Voting.Rules + ( PerasVotingRulesDecision (..) + , isPerasVotingAllowedWithHandle + ) +import Ouroboros.Consensus.Peras.Voting.Trace (TracePerasVoteForgingEvent (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API ( AddBlockResult (..) @@ -257,11 +275,13 @@ initNodeKernel args@NodeKernelArgs { registry , cfg + , featureFlags , tracers , chainDB , initChainDB , blockFetchConfiguration , btime + , systemTime , gsmArgs , peerSharingRng , publicPeerSelectionStateVar @@ -401,6 +421,12 @@ initNodeKernel sharedTxStateVar peerTxRegistry + void $ + forkLinkedWatcher registry "NodeKernel.perasVoteForging" $ + knownSlotWatcher btime $ \currentSlot -> + whenPerasEnabled currentSlot $ \roundInfo -> + withEarlyExit_ $ perasVoteForgingController systemTime st roundInfo + return NodeKernel { getChainDB = chainDB @@ -425,6 +451,26 @@ initNodeKernel , getTxDecisionPolicy = txDecisionPolicy miniProtocolParameters } where + -- Start a thread conditionally when the PerasFlag is provided and the + -- current block type supports Peras. + whenPerasEnabled currentSlot f = + if PerasFlag `member` featureFlags + then do + roundInfo <- atomically $ do + runQueryWithContextHandle + (ChainDB.getTimeResolutionContextHandle chainDB) + (slotToPerasRoundNo' currentSlot) + >>= \case + Left err -> throwSTM err + -- We don't know whether Peras is enabled at this point. + -- Abort if it isn't. + Right HF.NoPerasEnabled -> pure Nothing + Right (HF.PerasEnabled roundInfo) -> pure (Just roundInfo) + case roundInfo of + Nothing -> pure () + Just roundInfo' -> f roundInfo' + else pure () + blockForgingController :: InternalState m remotePeer localPeer blk -> STM m [MkBlockForging m blk] -> @@ -438,6 +484,81 @@ initNodeKernel blockForging' <- traverse (forkBlockForging st) blockForging go blockForging' +perasVoteForgingController :: + forall m remotePeer localPeer blk. + ( IOLike m + , BlockSupportsPeras blk + ) => + SystemTime m -> + InternalState m remotePeer localPeer blk -> + (PerasRoundNo, Word64) -> + WithEarlyExit m () +perasVoteForgingController + systemTime + IS{chainDB, tracers} + (roundNo, slotInRound) = do + -- Get crypto data from environment variables + -- TODO: move the code outside of the vote forging controller once + -- they are properly obtained from the ledger/context. + poolId <- case readPerasPoolIdFromEnv (Proxy @blk) of + Left err -> do + trace $ TracePerasVotingCantReadEnv err + exitEarly + Right poolId -> pure poolId + + privateKey <- case readPerasPrivateKeyFromEnv (Proxy @blk) of + Left err -> do + trace $ TracePerasVotingCantReadEnv err + exitEarly + Right privateKey -> pure privateKey + + -- We run all 3 STM computations in a WriterT monad so that we can have proper logging, + -- while keeping everything in the same transaction. We also use MaybeT because there is + -- a natural abort/continue logic within the transaction. Unfortunately, we can't leverage + -- the outer WithEarlyExit monad, because we _always_ want to get the trace. + (mVote, traceEvents :: [TracePerasVoteForgingEvent blk]) <- lift $ atomically $ runWriterT $ runMaybeT $ do + when (slotInRound /= 0) $ do + tell [TracePerasVotingNoVoteAfterFirstSlotInRound roundNo slotInRound] + hoistMaybe Nothing + + -- Do the voting rules state that we should vote? + votingDecision <- + dyel $ + isPerasVotingAllowedWithHandle + (ChainDB.getPerasVotingViewHandle chainDB) + roundNo + tell [TracePerasVotingRulesDecision roundNo votingDecision] + candidateBlock <- case votingDecision of + NoVote _ -> hoistMaybe Nothing + Vote _ block -> pure block + + -- Forge the vote, if allowed + mVote <- + dyel $ + forgePerasVoteIfEligibleWithHandle + (ChainDB.getPerasEpochContextResolverHandle chainDB) + poolId + privateKey + roundNo + candidateBlock + when (isNothing mVote) $ tell $ [TracePerasVotingNotAVoterInRound roundNo] + hoistMaybe mVote + + traverse_ trace traceEvents + vote <- maybe exitEarly pure mVote + tickedVote <- lift $ addArrivalTime systemTime vote + trace $ TracePerasVotingForgedVote roundNo tickedVote + -- Add vote and potential cert to the DB + (addVoteResult, mAddCertChainSelOutcome) <- lift $ ChainDB.addPerasVoteSync chainDB tickedVote + trace $ TracePerasVotingAddVoteResult roundNo addVoteResult + traverse_ (trace . TracePerasVotingAddCertChainSelOutcome roundNo) mAddCertChainSelOutcome + where + trace :: TracePerasVoteForgingEvent blk -> WithEarlyExit m () + trace = lift . traceWith (perasVoteForgingTracer tracers) + + -- Do you even lift, bro? + dyel = lift . lift + castTraceFetchDecision :: forall remotePeer blk. TraceDecisionEvent remotePeer (HeaderWithTime blk) -> TraceDecisionEvent remotePeer (Header blk) @@ -723,6 +844,50 @@ forkBlockForging IS{..} (MkBlockForging blockForgingM) = , ledgerTipPoint (ledgerState unticked) ) + -- Decide if we need to include a Peras certificate in this block. + mbResult <- lift $ atomically $ do + runQueryWithContextHandle + (ChainDB.getTimeResolutionContextHandle chainDB) + (slotToPerasRoundNo' currentSlot) + >>= \case + Left err -> + throwSTM err + -- We don't know whether Peras is enabled at this point. + -- Abort if it isn't. + Right HF.NoPerasEnabled -> + pure Nothing + Right (HF.PerasEnabled roundInfo) -> do + let certInclusionViewHandle = ChainDB.getPerasCertInclusionViewHandle chainDB + let (currentRoundNo, _) = roundInfo + decision <- needCertWithHandle certInclusionViewHandle currentRoundNo + pure $ Just (currentRoundNo, decision) + + mbPerasCert <- + case mbResult of + Nothing -> + pure Nothing + Just (currentRoundNo, perasCertDecision) -> + case perasCertDecision of + -- NOTE: if constructing a certificate inclusion decision fails, this + -- indicates that we have not seen any certificate we could include in + -- a block yet, so we can just ignore this case. + Nothing -> do + tracePerasCertInclusion $ + TracePerasCertInclusionNoCertToInclude + currentSlot + pure Nothing + Just decision -> do + tracePerasCertInclusion $ + TracePerasCertInclusionRulesDecision + currentSlot + currentRoundNo + decision + case decision of + DoNotIncludeCert _ -> + pure Nothing + IncludeCert _ cert -> do + pure $ Just (vpcCert (forgetArrivalTime cert)) + -- Actually produce the block newBlock <- lift $ @@ -731,6 +896,7 @@ forkBlockForging IS{..} (MkBlockForging blockForgingM) = cfg bcBlockNo currentSlot + mbPerasCert tickedLedgerState txs proof @@ -800,6 +966,11 @@ forkBlockForging IS{..} (MkBlockForging blockForgingM) = . traceWith (forgeTracer tracers) . TraceLabelCreds (forgeLabel blockForging) + tracePerasCertInclusion :: TracePerasCertInclusionEvent blk -> WithEarlyExit m () + tracePerasCertInclusion = + lift + . traceWith (perasCertInclusionTracer tracers) + -- | Context required to forge a block data BlockContext blk = BlockContext { bcBlockNo :: !BlockNo diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs index 1c943ccb5f..4924c5b979 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs @@ -48,6 +48,7 @@ import qualified Ouroboros.Consensus.Block.Abstract as BA import qualified Ouroboros.Consensus.BlockchainTime as BTime import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Consensus.Ledger.Extended (ExtValidationError) +import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run @@ -283,7 +284,12 @@ data BlockRejection blk = BlockRejection , brReason :: !(ExtValidationError blk) , brRejector :: !NodeId } - deriving Show + +deriving instance + ( LedgerSupportsProtocol blk + , BlockSupportsPeras blk + ) => + Show (BlockRejection blk) data PropGeneralArgs blk = PropGeneralArgs { pgaBlockProperty :: blk -> Property 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 12f8ababaa..bcf89ac78b 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 @@ -883,11 +883,12 @@ runThreadNetwork TopLevelConfig blk -> BlockNo -> SlotNo -> + Maybe (PerasCert blk) -> TickedLedgerState blk mk -> [Validated (GenTx blk)] -> IsLeader (BlockProtocol blk) -> m blk - customForgeBlock origBlockForging cfg' currentBno currentSlot tickedLdgSt txs prf = do + customForgeBlock origBlockForging cfg' currentBno currentSlot mbPerasCert tickedLdgSt txs prf = do let currentEpoch = HFF.futureSlotToEpoch future currentSlot -- EBBs are only ever possible in the first era @@ -911,6 +912,7 @@ runThreadNetwork cfg' currentBno currentSlot + mbPerasCert (forgetLedgerTables tickedLdgSt) txs prf @@ -957,6 +959,7 @@ runThreadNetwork cfg' currentBno currentSlot + mbPerasCert (forgetLedgerTables tickedLdgSt') txs prf @@ -1746,6 +1749,7 @@ nullDebugTracers :: ( Monad m , Show peer , LedgerSupportsProtocol blk + , BlockSupportsPeras blk , TracingConstraints blk ) => Tracers m peer Void blk @@ -1777,6 +1781,8 @@ type TracingConstraints blk = , Show (TxMeasurePhase1 blk) , Show (TxMeasurePhase2 blk) , Show (ReasonForSwitch (TiebreakerView (BlockProtocol blk))) + , Show (PerasVote blk) + , Show (PerasCert blk) , HasNestedContent Header blk , HasRawTxId (GenTxId blk) ) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs index c4f7c6ba9d..77cfaea969 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs @@ -22,6 +22,7 @@ import Control.Monad.Class.MonadAsync import Control.Monad.IOSim (IOSim, runSimStrictShutdown) import Control.Tracer (debugTracer, traceWith) import Data.Maybe (mapMaybe) +import Data.SOP (All, Top) import Ouroboros.Consensus.Block.Abstract ( ChainHash (..) , ConvertRawHash @@ -31,17 +32,18 @@ import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Block.SupportsDiffusionPipelining ( BlockSupportsDiffusionPipelining ) +import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras) import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode) -import Ouroboros.Consensus.HardFork.Abstract +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..)) import Ouroboros.Consensus.Ledger.Basics (LedgerState) import Ouroboros.Consensus.Ledger.Inspect (InspectLedger) -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol ) import Ouroboros.Consensus.MiniProtocol.ChainSync.Client ( ChainSyncClientException (..) ) +import Ouroboros.Consensus.Peras.Context (StateSupportsPerasEpochContext) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB import Ouroboros.Consensus.Storage.LedgerDB.API ( CanUpgradeLedgerTables @@ -153,17 +155,18 @@ runSimStrictShutdownOrThrow action = -- | Runs the given 'GenesisTest' and 'PointSchedule' and evaluates the given -- property on the final 'StateView'. runGenesisTest :: - ( Condense (StateView blk) + ( All Top (HardForkIndices blk) + , Condense (StateView blk) , CondenseList (NodeState blk) , ShowProxy blk , ShowProxy (Header blk) , ConfigSupportsNode blk , LedgerSupportsProtocol blk - , LedgerSupportsPeras blk + , StateSupportsPerasEpochContext blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk - , HasHardForkHistory blk , ConvertRawHash blk , CanUpgradeLedgerTables LedgerState blk , HasPointScheduleTestParams blk @@ -215,17 +218,18 @@ _runGenesisTest' schedulerConfig genesisTest makeProperty = idempotentIOProperty -- and checks whether the given property holds on the resulting 'StateView'. runConformanceTest :: forall blk. - ( Condense (StateView blk) + ( All Top (HardForkIndices blk) + , Condense (StateView blk) , CondenseList (NodeState blk) , ShowProxy blk , ShowProxy (Header blk) , ConfigSupportsNode blk , LedgerSupportsProtocol blk - , LedgerSupportsPeras blk + , StateSupportsPerasEpochContext blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk - , HasHardForkHistory blk , ConvertRawHash blk , CanUpgradeLedgerTables LedgerState blk , HasPointScheduleTestParams blk diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/TestSuite.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/TestSuite.hs index 768bdd1032..d11c6d0fc4 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/TestSuite.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/TestSuite.hs @@ -32,20 +32,22 @@ import qualified Data.Map.Monoidal as MMap import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Monoid (Endo (..)) +import Data.SOP (All, Top) import GHC.Generics (Generic, Generically (..)) import Ouroboros.Consensus.Block ( BlockSupportsDiffusionPipelining + , BlockSupportsPeras , ConvertRawHash , Header ) import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode) -import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory) +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..)) import Ouroboros.Consensus.Ledger.Basics (LedgerState) import Ouroboros.Consensus.Ledger.Inspect (InspectLedger) -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol ) +import Ouroboros.Consensus.Peras.Context (StateSupportsPerasEpochContext) import Ouroboros.Consensus.Storage.ChainDB (SerialiseDiskConstraints) import Ouroboros.Consensus.Storage.LedgerDB.API ( CanUpgradeLedgerTables @@ -177,17 +179,18 @@ render (TestTrie here children) = -- | Compile a 'TestSuite' into a list of tasty 'TestTree'. toTestTree :: - ( Condense (StateView blk) + ( All Top (HardForkIndices blk) + , Condense (StateView blk) , CondenseList (NodeState blk) , ShowProxy blk , ShowProxy (Header blk) , ConfigSupportsNode blk , LedgerSupportsProtocol blk - , LedgerSupportsPeras blk + , StateSupportsPerasEpochContext blk , SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk - , HasHardForkHistory blk , ConvertRawHash blk , CanUpgradeLedgerTables LedgerState blk , HasPointScheduleTestParams blk diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs index bff2ed126d..07b4b1a029 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs @@ -7,6 +7,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} @@ -18,6 +19,7 @@ module Test.Consensus.HardFork.Combinator (tests) where import Cardano.Ledger.BaseTypes (nonZero, unNonZero) import Data.Function (on) import qualified Data.Map.Strict as Map +import Data.Maybe.Strict (StrictMaybe (..)) import Data.MemPack import Data.SOP.BasicFunctors import Data.SOP.Counting @@ -46,6 +48,7 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool +import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId @@ -74,6 +77,7 @@ import Test.ThreadNet.Util.NodeToNodeVersion import Test.ThreadNet.Util.NodeTopology import Test.ThreadNet.Util.Seed import Test.Util.HardFork.Future +import Test.Util.Peras (divisorClosestToQuotient) import Test.Util.SanityCheck (prop_sanityChecks) import Test.Util.Slots (NumSlots (..)) import Test.Util.Time (dawnOfTime) @@ -106,7 +110,7 @@ data TestSetup = TestSetup instance Arbitrary TestSetup where arbitrary = do - testSetupEpochSize <- abM $ EpochSize <$> choose (1, 10) + testSetupEpochSize <- abM $ EpochSize <$> choose (2, 10) testSetupK <- SecurityParam <$> choose (2, 10) `suchThatMap` nonZero -- TODO why does k=1 cause the nodes to only forge in the first epoch? testSetupTxSlot <- SlotNo <$> choose (0, 9) @@ -162,7 +166,22 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = (History.StandardSafeZone (safeFromTipA k)) (safeZoneB k) <*> pure (GenesisWindow ((unNonZero $ maxRollbacks k) * 2)) - <*> pure dijkstraPerasRoundLength + <*> AB + (mkPerasRoundLength (getA testSetupEpochSize)) + (mkPerasRoundLength (getB testSetupEpochSize)) + + -- Epoch size is a number between 1 and 10 perasRoundLength should divide it. + -- Picking the closest divisor to get us about 2 Peras rounds per epoch gives + -- us a suitable distribution of perasRoundLengths: + -- >>> flip divisorClosestToQuotient 2 <$> [1..10] + -- [1,1,1,2,1,3,1,4,3,5] + -- TODO: it would be better to generate PerasRoundLength randomly in + -- accordance with the epoch length directly, see: + -- https://github.com/tweag/cardano-peras/issues/257 + mkPerasRoundLength epochSize = + History.PerasEnabled $ + PerasRoundLength $ + divisorClosestToQuotient (unEpochSize epochSize) 2 shape :: History.Shape '[BlockA, BlockB] shape = History.Shape $ exactlyTwo eraParamsA eraParamsB @@ -242,21 +261,34 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = protocolInfo :: CoreNodeId -> ProtocolInfo TestBlock protocolInfo nid = - ProtocolInfo - { pInfoConfig = - topLevelConfig nid - , pInfoInitLedger = - ExtLedgerState - { ledgerState = - HardForkLedgerState $ - initHardForkState - (Flip initLedgerState) - , headerState = - genesisHeaderState $ - initHardForkState - (WrapChainDepState initChainDepState) - } - } + let topConfig = topLevelConfig nid + ledgerConfig = topLevelConfigLedger topConfig + in ProtocolInfo + { pInfoConfig = + topConfig + , pInfoInitLedger = + let ledgerState = + HardForkLedgerState $ + initHardForkState + (Flip initLedgerState) + headerState = + genesisHeaderState $ + initHardForkState + (WrapChainDepState initChainDepState) + perasEpochContextResolver = + initPerasEpochContextResolver + ledgerConfig + (forgetLedgerTables ledgerState) + headerState + latestPerasCertOnChainRound = + SNothing + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } + } blockForging :: Monad m => [MkBlockForging m TestBlock] blockForging = 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 160b9e9a26..bf6fc04d3e 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 @@ -65,6 +65,7 @@ import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Config import Ouroboros.Consensus.Config.SupportsNode import Ouroboros.Consensus.Forecast +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..)) import Ouroboros.Consensus.HardFork.Combinator import Ouroboros.Consensus.HardFork.Combinator.Condense import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common @@ -80,13 +81,25 @@ import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.SupportsPeerSelection -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras, LedgerSupportsPeras) +import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Node.InitStorage import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Serialisation +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert) +import Ouroboros.Consensus.Peras.Context + ( StateSupportsPerasEpochContext (..) + , mkBoundedPerasEpochContextWith + ) +import Ouroboros.Consensus.Peras.Crypto.Mock + ( MockPerasCrypto + , MockPerasVotingCommitteeScheme + ) +import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) +import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote) +import Ouroboros.Consensus.Peras.Voting.Mock (mkMockPerasVotingCommitteeInput) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo) import Ouroboros.Consensus.Storage.Serialisation @@ -307,12 +320,17 @@ instance LedgerSupportsProtocol BlockA where protocolLedgerView _ _ = () ledgerViewForecastAt _ = trivialForecast -instance LedgerSupportsPeras BlockA - instance LedgerStateSupportsPeras (LedgerState BlockA) instance LedgerStateSupportsPeras (Ticked LedgerState BlockA) +instance BlockSupportsPeras BlockA where + type PerasCrypto BlockA = MockPerasCrypto BlockA + type PerasVotingCommitteeScheme BlockA = MockPerasVotingCommitteeScheme BlockA + type PerasVote BlockA = MockPerasVote BlockA + type PerasCert BlockA = MockPerasCert BlockA + type PerasError BlockA = MockPerasError BlockA + instance HasPartialConsensusConfig ProtocolA instance HasPartialLedgerConfig BlockA where @@ -360,7 +378,7 @@ blockForgingA = , canBeLeader = () , updateForgeState = \_ _ _ -> return $ ForgeStateUpdated () , checkCanForge = \_ _ _ _ _ -> return () - , forgeBlock = \cfg bno slot st txs proof -> + , forgeBlock = \cfg bno slot _mbPerasCert st txs proof -> return $ forgeBlockA cfg bno slot st (fmap txForgetValidated txs) proof , finalize = return () @@ -626,6 +644,16 @@ instance SerialiseNodeToClient BlockA (EpochInfo Identity, PartialLedgerConfigA) encodeNodeToClient = error "BlockA being used as a SingleEraBlock" decodeNodeToClient = error "BlockA being used as a SingleEraBlock" +-- NOTE: BlockA is only ever used wrapped in the +-- hard fork combinator (which implements 'hardForkSummary' directly and never +-- delegates to the underlying era), so this method is never actually called. +instance HasHardForkHistory BlockA where + type HardForkIndices BlockA = '[BlockA] + hardForkSummary = error "BlockA being used as a SingleEraBlock" + +instance StateSupportsPerasEpochContext BlockA where + mkBoundedPerasEpochContext = mkBoundedPerasEpochContextWith mkMockPerasVotingCommitteeInput + instance SerialiseConstraintsHFC BlockA instance SerialiseDiskConstraints BlockA instance SerialiseNodeToClientConstraints 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 4c04eb7f90..721166eb84 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 @@ -53,6 +53,7 @@ import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Config import Ouroboros.Consensus.Config.SupportsNode import Ouroboros.Consensus.Forecast +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..)) import Ouroboros.Consensus.HardFork.Combinator import Ouroboros.Consensus.HardFork.Combinator.Condense import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common @@ -64,13 +65,22 @@ import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.SupportsPeerSelection -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras, LedgerSupportsPeras) +import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Node.InitStorage import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Serialisation +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert) +import Ouroboros.Consensus.Peras.Context + ( StateSupportsPerasEpochContext (..) + , mkBoundedPerasEpochContextWith + ) +import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCrypto, MockPerasVotingCommitteeScheme) +import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) +import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote) +import Ouroboros.Consensus.Peras.Voting.Mock (mkMockPerasVotingCommitteeInput) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo) import Ouroboros.Consensus.Storage.Serialisation @@ -263,12 +273,17 @@ instance LedgerSupportsProtocol BlockB where protocolLedgerView _ _ = () ledgerViewForecastAt _ = trivialForecast -instance LedgerSupportsPeras BlockB - instance LedgerStateSupportsPeras (LedgerState BlockB) instance LedgerStateSupportsPeras (Ticked LedgerState BlockB) +instance BlockSupportsPeras BlockB where + type PerasCrypto BlockB = MockPerasCrypto BlockB + type PerasVotingCommitteeScheme BlockB = MockPerasVotingCommitteeScheme BlockB + type PerasVote BlockB = MockPerasVote BlockB + type PerasCert BlockB = MockPerasCert BlockB + type PerasError BlockB = MockPerasError BlockB + instance HasPartialConsensusConfig ProtocolB instance HasPartialLedgerConfig BlockB @@ -306,7 +321,7 @@ blockForgingB = , canBeLeader = () , updateForgeState = \_ _ _ -> return $ ForgeStateUpdated () , checkCanForge = \_ _ _ _ _ -> return () - , forgeBlock = \cfg bno slot st txs proof -> + , forgeBlock = \cfg bno slot _mbPerasCert st txs proof -> return $ forgeBlockB cfg bno slot st (fmap txForgetValidated txs) proof , finalize = return () @@ -468,6 +483,17 @@ instance HasBinaryBlockInfo BlockB where , headerSize = fromIntegral $ Lazy.length (serialise blkB_header) } +-- NOTE: BlockB is only ever used +-- wrapped in the hard fork combinator (which implements 'hardForkSummary' +-- directly and never delegates to the underlying era), so this method is never +-- actually called. +instance HasHardForkHistory BlockB where + type HardForkIndices BlockB = '[BlockB] + hardForkSummary = error "BlockB being used as a SingleEraBlock" + +instance StateSupportsPerasEpochContext BlockB where + mkBoundedPerasEpochContext = mkBoundedPerasEpochContextWith mkMockPerasVotingCommitteeInput + instance SerialiseConstraintsHFC BlockB instance SerialiseDiskConstraints BlockB instance SerialiseNodeToClientConstraints BlockB 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 491744990b..5d3191e3d4 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 @@ -22,7 +22,7 @@ import Control.Tracer ) import Data.Proxy (Proxy (..)) import Network.TypedProtocol.Codec (AnyMessage) -import Ouroboros.Consensus.Block (Header, Point) +import Ouroboros.Consensus.Block (BlockSupportsPeras, Header, Point) import Ouroboros.Consensus.BlockchainTime (RelativeTime (..)) import Ouroboros.Consensus.Config ( DiffusionPipeliningSupport (..) @@ -94,7 +94,10 @@ import Test.Util.Orphans.IOLike () -- messages and the “in future” checks are disabled. basicChainSyncClient :: forall m blk. - (IOLike m, LedgerSupportsProtocol blk) => + ( IOLike m + , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + ) => PeerId -> Tracer m (TraceEvent blk) -> TopLevelConfig blk -> @@ -148,7 +151,13 @@ basicChainSyncClient -- 'basicChainSyncClient', synchronously. Exceptions are caught, sent to the -- 'StateViewTracers' and logged. runChainSyncClient :: - (IOLike m, MonadTimer m, LedgerSupportsProtocol blk, ShowProxy blk, ShowProxy (Header blk)) => + ( IOLike m + , MonadTimer m + , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , ShowProxy blk + , ShowProxy (Header blk) + ) => Tracer m (TraceEvent blk) -> TopLevelConfig blk -> ChainDbView m blk -> diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs index 5eed3de7f8..2ffa61b8fa 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs @@ -17,17 +17,17 @@ module Test.Consensus.PeerSimulator.NodeLifecycle import Control.ResourceRegistry import Control.Tracer (Tracer, mkTracer, traceWith) import Data.Functor (void) +import Data.SOP (All, Top) import Data.Set (Set) import qualified Data.Set as Set import Data.Typeable (Typeable) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config (TopLevelConfig (..)) -import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory) +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..)) import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) import Ouroboros.Consensus.Ledger.Basics (LedgerState) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) import Ouroboros.Consensus.Ledger.Inspect (InspectLedger) -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol ) @@ -35,6 +35,7 @@ import Ouroboros.Consensus.Ledger.Tables.MapKind (ValuesMK) import Ouroboros.Consensus.MiniProtocol.ChainSync.Client ( ChainSyncClientHandleCollection (..) ) +import Ouroboros.Consensus.Peras.Context (StateSupportsPerasEpochContext) import Ouroboros.Consensus.Storage.ChainDB.API import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB @@ -133,12 +134,13 @@ data NodeLifecycle blk m = NodeLifecycle -- candidate fragments. mkChainDb :: IOLike m => - ( LedgerSupportsProtocol blk - , LedgerSupportsPeras blk + ( All Top (HardForkIndices blk) + , LedgerSupportsProtocol blk + , StateSupportsPerasEpochContext blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk - , HasHardForkHistory blk , ConvertRawHash blk , CanUpgradeLedgerTables LedgerState blk ) => @@ -186,12 +188,13 @@ mkChainDb resources = do -- intervals, the ChainDB and its persisted state. restoreNode :: ( IOLike m + , All Top (HardForkIndices blk) , LedgerSupportsProtocol blk - , LedgerSupportsPeras blk + , StateSupportsPerasEpochContext blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk - , HasHardForkHistory blk , ConvertRawHash blk , CanUpgradeLedgerTables LedgerState blk ) => @@ -216,12 +219,13 @@ restoreNode resources LiveIntervalResult{lirPeerResults, lirActive} = do lifecycleStart :: forall m blk. ( IOLike m + , All Top (HardForkIndices blk) , LedgerSupportsProtocol blk - , LedgerSupportsPeras blk + , StateSupportsPerasEpochContext blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk - , HasHardForkHistory blk , ConvertRawHash blk , CanUpgradeLedgerTables LedgerState blk ) => 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 eef1496169..75d49aa933 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 @@ -21,16 +21,16 @@ import Data.List (sort) import qualified Data.List.NonEmpty as NonEmpty import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.SOP (All, Top) import Data.Typeable import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config (TopLevelConfig (..)) import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode) import Ouroboros.Consensus.Genesis.Governor (gddWatcher) -import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory) +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..)) import Ouroboros.Consensus.HeaderValidation (HeaderWithTime) import Ouroboros.Consensus.Ledger.Basics (LedgerState) import Ouroboros.Consensus.Ledger.Inspect (InspectLedger) -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol ) @@ -47,6 +47,7 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.Node.GsmState as GSM import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..)) +import Ouroboros.Consensus.Peras.Context (StateSupportsPerasEpochContext) import Ouroboros.Consensus.Storage.ChainDB.API import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB @@ -169,7 +170,13 @@ debugScheduler conf = conf{scDebug = True} -- Execution is started asynchronously, returning an action that kills the thread, -- to allow extraction of a potential exception. startChainSyncConnectionThread :: - (IOLike m, MonadTimer m, LedgerSupportsProtocol blk, ShowProxy blk, ShowProxy (Header blk)) => + ( IOLike m + , MonadTimer m + , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , ShowProxy blk + , ShowProxy (Header blk) + ) => ResourceRegistry m -> Tracer m (TraceEvent blk) -> TopLevelConfig blk -> @@ -414,6 +421,7 @@ startNode :: , MonadTime m , MonadTimer m , LedgerSupportsProtocol blk + , BlockSupportsPeras blk , ShowProxy blk , ShowProxy (Header blk) , BlockSupportsDiffusionPipelining blk @@ -552,17 +560,18 @@ startNode protocolInfo schedulerConfig genesisTest interval = do -- | Set up all resources related to node start/shutdown. nodeLifecycle :: ( IOLike m + , All Top (HardForkIndices blk) , MonadTime m , MonadTimer m , ShowProxy blk , ShowProxy (Header blk) , ConfigSupportsNode blk , LedgerSupportsProtocol blk - , LedgerSupportsPeras blk + , StateSupportsPerasEpochContext blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk - , HasHardForkHistory blk , ConvertRawHash blk , CanUpgradeLedgerTables LedgerState blk , HasPointScheduleTestParams blk @@ -611,17 +620,18 @@ nodeLifecycle protocolArgs schedulerConfig genesisTest lrTracer lrRegistry lrPee runPointSchedule :: forall m blk. ( IOLike m + , All Top (HardForkIndices blk) , MonadTime m , MonadTimer m , ShowProxy blk , ShowProxy (Header blk) , ConfigSupportsNode blk , LedgerSupportsProtocol blk - , LedgerSupportsPeras blk + , StateSupportsPerasEpochContext blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk - , HasHardForkHistory blk , ConvertRawHash blk , CanUpgradeLedgerTables LedgerState blk , HasPointScheduleTestParams blk diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index dbda5458d1..7a89a0da54 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -241,6 +241,8 @@ library Ouroboros.Consensus.Peras.Cert.V1 Ouroboros.Consensus.Peras.Context Ouroboros.Consensus.Peras.Crypto.BLS + Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe + Ouroboros.Consensus.Peras.Error.V1 Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView Ouroboros.Consensus.Peras.Types @@ -251,6 +253,7 @@ library Ouroboros.Consensus.Peras.Voting.Adapter Ouroboros.Consensus.Peras.Voting.Rules Ouroboros.Consensus.Peras.Voting.Trace + Ouroboros.Consensus.Peras.Voting.V1 Ouroboros.Consensus.Peras.Voting.View Ouroboros.Consensus.Peras.Weight Ouroboros.Consensus.Protocol.Abstract @@ -453,6 +456,7 @@ library unstable-consensus-testlib Ouroboros.Consensus.Peras.Crypto.Mock Ouroboros.Consensus.Peras.Error.Mock Ouroboros.Consensus.Peras.Vote.Mock + Ouroboros.Consensus.Peras.Voting.Mock Test.LedgerTables Test.Ouroboros.Consensus.ChainGenerator.Adversarial Test.Ouroboros.Consensus.ChainGenerator.BitVector @@ -597,6 +601,7 @@ library unstable-mock-block Ouroboros.Consensus.Mock.Node.Abstract Ouroboros.Consensus.Mock.Node.BFT Ouroboros.Consensus.Mock.Node.PBFT + Ouroboros.Consensus.Mock.Node.Peras Ouroboros.Consensus.Mock.Node.Praos Ouroboros.Consensus.Mock.Node.PraosRule Ouroboros.Consensus.Mock.Node.Serialisation @@ -838,7 +843,6 @@ test-suite storage-test cardano-ledger-binary:testlib, cardano-ledger-core:cardano-ledger-core, cardano-slotting:{cardano-slotting, testlib}, - cardano-strict-containers, cborg, containers, contra-tracer, @@ -851,6 +855,7 @@ test-suite storage-test io-sim, mempack, mtl, + nonempty-containers, nothunks, ouroboros-consensus:{lsm, ouroboros-consensus}, ouroboros-network:{api, api-tests-lib, protocols-tests-lib}, @@ -1348,6 +1353,7 @@ library cardano Ouroboros.Consensus.Byron.Ledger.PBFT Ouroboros.Consensus.Byron.Ledger.Serialisation Ouroboros.Consensus.Byron.Node + Ouroboros.Consensus.Byron.Node.Peras Ouroboros.Consensus.Byron.Node.Serialisation Ouroboros.Consensus.Byron.Protocol Ouroboros.Consensus.Cardano @@ -1380,6 +1386,7 @@ library cardano Ouroboros.Consensus.Shelley.Node Ouroboros.Consensus.Shelley.Node.Common Ouroboros.Consensus.Shelley.Node.DiffusionPipelining + Ouroboros.Consensus.Shelley.Node.Peras Ouroboros.Consensus.Shelley.Node.Praos Ouroboros.Consensus.Shelley.Node.Serialisation Ouroboros.Consensus.Shelley.Node.TPraos @@ -1600,6 +1607,7 @@ test-suite shelley-test Test.Consensus.Shelley.Coherence Test.Consensus.Shelley.Golden Test.Consensus.Shelley.LedgerTables + Test.Consensus.Shelley.Peras Test.Consensus.Shelley.Serialisation Test.Consensus.Shelley.SupportedNetworkProtocolVersion Test.ThreadNet.Shelley @@ -1607,12 +1615,13 @@ test-suite shelley-test build-depends: base, bytestring, + cardano-binary, cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib}, cardano-ledger-api, cardano-ledger-babbage:testlib, cardano-ledger-conway:testlib, cardano-ledger-core, - cardano-ledger-dijkstra:testlib, + cardano-ledger-dijkstra:{cardano-ledger-dijkstra, testlib}, cardano-ledger-shelley, cardano-protocol-tpraos, cardano-slotting, diff --git a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs index 71c70d63fc..f5b9f104dc 100644 --- a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs +++ b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs @@ -11,7 +11,7 @@ module Main (main) where import Bench.Consensus.ChainSyncClient.Driver (mainWith) import Cardano.Crypto.DSIGN.Mock -import Cardano.Ledger.BaseTypes (knownNonZeroBounded) +import Cardano.Ledger.BaseTypes (StrictMaybe (..), knownNonZeroBounded) import Control.Monad (void) import Control.ResourceRegistry import Control.Tracer (contramap, debugTracer, nullTracer) @@ -27,6 +27,7 @@ import Ouroboros.Consensus.Config import qualified Ouroboros.Consensus.HardFork.History as HardFork import qualified Ouroboros.Consensus.HeaderStateHistory as HeaderStateHistory import qualified Ouroboros.Consensus.HeaderValidation as HV +import Ouroboros.Consensus.Ledger.Extended (initPerasEpochContextResolver) import qualified Ouroboros.Consensus.Ledger.Extended as Extended import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck @@ -201,8 +202,7 @@ inTheYearOneBillion = oracularLedgerDB :: Point B -> Extended.ExtLedgerState B mk oracularLedgerDB p = - Extended.ExtLedgerState - { Extended.headerState = + let headerState = HV.HeaderState { HV.headerStateTip = case pointToWithOriginRealPoint p of Origin -> Origin @@ -216,12 +216,24 @@ oracularLedgerDB p = } , HV.headerStateChainDep = () } - , Extended.ledgerState = + ledgerState = TB.TestLedger { TB.lastAppliedPoint = p , TB.payloadDependentState = TB.EmptyPLDS } - } + in Extended.ExtLedgerState + { Extended.headerState = + headerState + , Extended.ledgerState = + ledgerState + , Extended.perasEpochContextResolver = + initPerasEpochContextResolver + (topLevelConfigLedger topConfig) + ledgerState + headerState + , Extended.latestPerasCertOnChainRound = + SNothing + } -- | A convenient fact about 'TB.TestBlock' testBlockHashBlockNo :: TB.TestHash -> BlockNo diff --git a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs index 64c7a22f02..3fbafe551f 100644 --- a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs +++ b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs @@ -115,7 +115,7 @@ fragments = iterate' addSuccessorBlock genesisFragment in (xs AF.:> x) AF.:> TestBlock.mkNextBlock x nextBlockSlot dummyBody dummyBody :: TestBody - dummyBody = TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} + dummyBody = TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} -- | Given a chain fragment, construct a weight snapshot where there's a boosted block every 90 slots uniformWeightSnapshot :: AF.AnchoredFragment TestBlock -> PerasWeightSnapshot TestBlock diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs index 99cb16e2d4..e1d25babb5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs @@ -28,6 +28,7 @@ import Data.Kind (Type) import Data.Text (Text) import GHC.Stack import Ouroboros.Consensus.Block.Abstract +import Ouroboros.Consensus.Block.SupportsPeras (PerasCert) import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool @@ -122,6 +123,7 @@ data BlockForging m blk = BlockForging TopLevelConfig blk -> BlockNo -> -- Current block number SlotNo -> -- Current slot number + Maybe (PerasCert blk) -> -- Optional Peras certificate to include TickedLedgerState blk EmptyMK -> -- Current ledger state [Validated (GenTx blk)] -> -- Transactions to include IsLeader (BlockProtocol blk) -> -- Proof we are leader diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 64a290d252..2c76e2134a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -1,10 +1,15 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -25,16 +30,9 @@ module Ouroboros.Consensus.Block.SupportsPeras -- * BlockSupportsPeras class , BlockSupportsPeras (..) - -- * To be removed in favor of using per-blk definitions - , PerasCert' (..) - , PerasVote' (..) - - -- * To be removed in favor of using a 'PerasEpochContext' directly - , PerasVoteStakeDistr (..) - -- * Validated types - , ValidatedPerasCert (..) , ValidatedPerasVote (..) + , ValidatedPerasCert (..) -- * Peras error types , IsPerasError (..) @@ -66,21 +64,22 @@ module Ouroboros.Consensus.Block.SupportsPeras , module Ouroboros.Consensus.Peras.Vote.Class ) where -import Cardano.Binary (FromCBOR (..), ToCBOR (..)) -import Codec.Serialise (Serialise (..)) -import Codec.Serialise.Decoding (decodeListLenOf) -import Codec.Serialise.Encoding (encodeListLen) +import Cardano.Binary (FromCBOR (..), ToCBOR (..), decodeListLenOf, encodeListLen) +import qualified Cardano.Crypto.Hash as Hash +import Cardano.Ledger.Hashes (KeyHash (..)) import Control.Exception (assert) -import Data.Containers.NonEmpty (HasNonEmpty (..)) +import Control.Exception.Base (Exception) +import Data.Bifunctor (bimap) +import Data.Containers.NonEmpty (NE) import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.NonEmpty as NEMap import Data.Map.Strict (Map) -import Data.Proxy (Proxy (..)) +import Data.Traversable (for) import Data.Typeable (Typeable) import GHC.Generics (Generic) -import NoThunks.Class -import Ouroboros.Consensus.Block.Abstract +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.Abstract (Point, StandardHash) import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) import Ouroboros.Consensus.Committee.Class ( CryptoSupportsVotingCommittee (..) @@ -88,17 +87,22 @@ import Ouroboros.Consensus.Committee.Class , VotingCommittee , unsafeUniqueVotesWithSameTarget ) -import Ouroboros.Consensus.Committee.Crypto (VoteCandidate) +import qualified Ouroboros.Consensus.Committee.Class as Committee +import Ouroboros.Consensus.Committee.Crypto + ( ElectionId + , PrivateKey + , VoteCandidate + ) +import Ouroboros.Consensus.Committee.Types (PoolId (..)) import Ouroboros.Consensus.Peras.Cert.Class import Ouroboros.Consensus.Peras.Params import Ouroboros.Consensus.Peras.Types import Ouroboros.Consensus.Peras.Void import Ouroboros.Consensus.Peras.Vote.Class import Ouroboros.Consensus.Peras.Voting.Adapter - ( PerasConversionError - , PerasVoteCompatibleWithVotingCommittee (..) - ) -import Ouroboros.Consensus.Util +import Ouroboros.Consensus.Util.Orphans () +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO) -- * Voting committee types for Peras @@ -172,20 +176,61 @@ deriving instance deriving instance Generic (PerasEpochContext blk) --- * Peras types - --- TODO: to be removed in favor of using a 'PerasEpochContext' directly. -newtype PerasVoteStakeDistr = PerasVoteStakeDistr - { unPerasVoteStakeDistr :: Map PerasSeatIndex VoteWeight - } - deriving newtype NoThunks - deriving stock (Show, Eq, Generic) - -- * BlockSupportsPeras class class - ( Show (PerasParams blk) + ( -- Basic block constraints + StandardHash blk + , Typeable blk + , -- PerasVote constraints + Typeable (PerasVote blk) + , Show (PerasVote blk) + , Eq (PerasVote blk) + , NoThunks (PerasVote blk) + , IsPerasVote (PerasVote blk) blk + , Typeable (BoostedBlock (PerasVote blk)) + , Show (BoostedBlock (PerasVote blk)) + , Eq (BoostedBlock (PerasVote blk)) + , NoThunks (BoostedBlock (PerasVote blk)) + , -- PerasCert constraints + Typeable (PerasCert blk) + , Show (PerasCert blk) + , Eq (PerasCert blk) , NoThunks (PerasCert blk) + , IsPerasCert (PerasCert blk) blk + , Typeable (BoostedBlock (PerasCert blk)) + , Show (BoostedBlock (PerasCert blk)) + , Eq (BoostedBlock (PerasCert blk)) + , NoThunks (BoostedBlock (PerasCert blk)) + , -- PerasError constraints + Typeable (PerasError blk) + , Show (PerasError blk) + , Eq (PerasError blk) + , NoThunks (PerasError blk) + , IsPerasError (PerasError blk) blk + , Exception (PerasError blk) + , -- PerasVotingCommittee constraints + Typeable (PerasVotingCommittee blk) + , Show (PerasVotingCommittee blk) + , Eq (PerasVotingCommittee blk) + , NoThunks (PerasVotingCommittee blk) + , -- PerasEpochContext constraints + Typeable (PerasEpochContext blk) + , Show (PerasEpochContext blk) + , Eq (PerasEpochContext blk) + , NoThunks (PerasEpochContext blk) + , -- Compatiblity with committee/crypto + Show (PerasCrypto blk) + , Eq (PerasCrypto blk) + , Typeable (PerasCrypto blk) + , NoThunks (PerasCrypto blk) + , Show (PerasVotingCommitteeScheme blk) + , Eq (PerasVotingCommitteeScheme blk) + , Typeable (PerasVotingCommitteeScheme blk) + , NoThunks (PerasVotingCommitteeScheme blk) + , ElectionId (PerasCrypto blk) ~ PerasRoundNo + , VoteCandidate (PerasCrypto blk) ~ BoostedBlock (PerasVote blk) + , VoteCandidate (PerasCrypto blk) ~ BoostedBlock (PerasCert blk) ) => BlockSupportsPeras blk where @@ -218,21 +263,152 @@ class type PerasVotingCommitteeScheme blk = VoidPerasVotingCommitteeScheme - validatePerasCert :: - PerasParams blk -> - PerasCert blk -> - Either (PerasError blk) (ValidatedPerasCert blk) - - validatePerasVote :: - PerasParams blk -> - PerasVoteStakeDistr -> + -- | Forge a Peras vote if the given pool is eligible to vote in the given round. + forgePerasVoteIfEligible :: + PerasEpochContext blk -> + PoolId -> + PrivateKey (PerasCrypto blk) -> + PerasRoundNo -> + Point blk -> + Either (PerasError blk) (Maybe (ValidatedPerasVote blk)) + default forgePerasVoteIfEligible :: + ( CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) + , PerasVoteCompatibleWithVotingCommittee + (PerasVote blk) + (PerasCrypto blk) + (PerasVotingCommitteeScheme blk) + ) => + PerasEpochContext blk -> + PoolId -> + PrivateKey (PerasCrypto blk) -> + PerasRoundNo -> + Point blk -> + Either (PerasError blk) (Maybe (ValidatedPerasVote blk)) + forgePerasVoteIfEligible context ourId ourPrivateKey roundNo point = do + let committee = pecCommittee context + mbWitness <- + bimap injectVotingCommitteeError id $ + Committee.checkShouldVote committee ourId ourPrivateKey roundNo + for mbWitness $ \witness -> do + let voteWeight = eligiblePartyVoteWeight committee witness + let boostedBlock = pointToBoostedBlock point + let abstractVote = Committee.forgeVote witness ourPrivateKey roundNo boostedBlock + concreteVote <- + bimap injectConversionError id $ + toPerasVote @(PerasVote blk) abstractVote + pure $ + ValidatedPerasVote + { vpvVote = concreteVote + , vpvVoteWeight = voteWeight + } + + -- | Verify a Peras vote and return its weight if valid. + verifyPerasVote :: + PerasEpochContext blk -> + PerasVote blk -> + Either (PerasError blk) (ValidatedPerasVote blk) + default verifyPerasVote :: + ( CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) + , PerasVoteCompatibleWithVotingCommittee + (PerasVote blk) + (PerasCrypto blk) + (PerasVotingCommitteeScheme blk) + ) => + PerasEpochContext blk -> PerasVote blk -> Either (PerasError blk) (ValidatedPerasVote blk) + verifyPerasVote context vote = do + let committee = pecCommittee context + -- NOTE: checking that the voted point is not from the future w.r.t. the + -- starting slot of the 'PerasRoundNo' will have to be done at the HFC level + -- since here we don't have 'PerasRoundNo' -> 'SlotNo' resolution device. + abstractVote <- + bimap injectConversionError id $ + fromPerasVote @(PerasVote blk) vote + witness <- + bimap injectVotingCommitteeError id $ + Committee.verifyVote committee abstractVote + let voteWeight = eligiblePartyVoteWeight committee witness + pure $ + ValidatedPerasVote + { vpvVote = vote + , vpvVoteWeight = voteWeight + } + -- | Forge a Peras certificate from a collection of votes reaching quorum. forgePerasCert :: - PerasParams blk -> + PerasEpochContext blk -> PerasVoteCollectionWithQuorum blk -> Either (PerasError blk) (ValidatedPerasCert blk) + default forgePerasCert :: + ( CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) + , PerasVoteCompatibleWithVotingCommittee + (PerasVote blk) + (PerasCrypto blk) + (PerasVotingCommitteeScheme blk) + , PerasCertCompatibleWithVotingCommittee + (PerasCert blk) + (PerasCrypto blk) + (PerasVotingCommitteeScheme blk) + ) => + PerasEpochContext blk -> + PerasVoteCollectionWithQuorum blk -> + Either (PerasError blk) (ValidatedPerasCert blk) + forgePerasCert context voteCollection = do + let params = pecParams context + abstractVoteCollection <- + bimap injectConversionError id $ + toUniqueVotesWithSameTarget voteCollection + abstractCert <- + bimap injectVotingCommitteeError id $ + Committee.forgeCert abstractVoteCollection + concreteCert <- + bimap injectConversionError id $ + toPerasCert abstractCert + pure $ + ValidatedPerasCert + { vpcCert = concreteCert + , vpcCertBoost = perasWeight params + } + + -- | Verify a Peras certificate and return its boost if valid. + verifyPerasCert :: + PerasEpochContext blk -> + PerasCert blk -> + Either (PerasError blk) (ValidatedPerasCert blk) + default verifyPerasCert :: + ( CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) + , PerasCertCompatibleWithVotingCommittee + (PerasCert blk) + (PerasCrypto blk) + (PerasVotingCommitteeScheme blk) + ) => + PerasEpochContext blk -> + PerasCert blk -> + Either (PerasError blk) (ValidatedPerasCert blk) + verifyPerasCert context cert = do + let committee = pecCommittee context + let params = pecParams context + -- NOTE: checking that the voted point is not from the future w.r.t. the + -- starting slot of the 'PerasRoundNo' will have to be done at the HFC level + -- since here we don't have 'PerasRoundNo' -> 'SlotNo' resolution device. + abstractCert <- + bimap injectConversionError id $ + fromPerasCert @(PerasCert blk) cert + witnesses <- + bimap injectVotingCommitteeError id $ + Committee.verifyCert committee abstractCert + let totalVoteWeight = sum (eligiblePartyVoteWeight committee <$> witnesses) + if weightAboveThreshold params totalVoteWeight + then + Right $ + ValidatedPerasCert + { vpcCert = cert + , vpcCertBoost = perasWeight params + } + else + Left $ + injectQuorumNotReachedError totalVoteWeight -- | Extract a Peras certificate optionally stored in a block. -- @@ -240,105 +416,52 @@ class -- if the block is from an era that does not support Peras certificates. getPerasCertInBlock :: blk -> - Maybe (PerasCert blk) - --- TODO: degenerate instance for all blks to get things to compile --- see https://github.com/tweag/cardano-peras/issues/73 -instance StandardHash blk => BlockSupportsPeras blk where - type PerasCrypto blk = VoidPerasCrypto blk - type PerasVotingCommitteeScheme blk = VoidPerasVotingCommitteeScheme - type PerasError blk = VoidPerasError blk - - type PerasCert blk = PerasCert' blk - type PerasVote blk = PerasVote' blk - - validatePerasCert params cert = - Right - ValidatedPerasCert - { vpcCert = cert - , vpcCertBoost = perasWeight params - } - - validatePerasVote _params _stakeDistr vote = - Right - ValidatedPerasVote - { vpvVote = vote - , vpvVoteWeight = VoteWeight 0 - } - - forgePerasCert params votes = - Right $ - ValidatedPerasCert - { vpcCert = - PerasCert - { pcCertRound = pvtRoundNo (pvcTarget (forgetQuorum votes)) - , pcCertBoostedBlock = pvtBlock (pvcTarget (forgetQuorum votes)) - } - , vpcCertBoost = perasWeight params - } - - getPerasCertInBlock _ = Nothing + Either (PerasError blk) (Maybe (PerasCert blk)) + getPerasCertInBlock _ = + Right Nothing --- | NOTE: to be removed in favor of using per-blk definitions. -data PerasCert' blk - = PerasCert - { pcCertRound :: PerasRoundNo - , pcCertBoostedBlock :: Point blk - } - deriving stock (Generic, Eq, Ord, Show) - deriving anyclass NoThunks - --- | NOTE: to be removed in favor of using per-blk definitions. -data PerasVote' blk - = PerasVote - { pvVoteRound :: PerasRoundNo - , pvVoteBlock :: Point blk - , pvVoteVoterId :: PerasSeatIndex - } - deriving stock (Generic, Eq, Ord, Show) - deriving anyclass NoThunks - -instance ShowProxy blk => ShowProxy (PerasCert' blk) where - showProxy _ = "PerasCert " <> showProxy (Proxy @blk) - -instance ShowProxy blk => ShowProxy (PerasVote' blk) where - showProxy _ = "PerasVote " <> showProxy (Proxy @blk) - -instance Serialise (HeaderHash blk) => Serialise (PerasCert' blk) where - encode PerasCert{pcCertRound, pcCertBoostedBlock} = - encodeListLen 2 - <> encode pcCertRound - <> encode pcCertBoostedBlock - decode = do - decodeListLenOf 2 - pcCertRound <- decode - pcCertBoostedBlock <- decode - pure $ PerasCert{pcCertRound, pcCertBoostedBlock} - -instance Serialise (HeaderHash blk) => Serialise (PerasVote' blk) where - encode PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId} = - encodeListLen 3 - <> encode pvVoteRound - <> encode pvVoteBlock - <> toCBOR pvVoteVoterId - decode = do - decodeListLenOf 3 - pvVoteRound <- decode - pvVoteBlock <- decode - pvVoteVoterId <- fromCBOR - pure $ PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId} - -type instance BoostedBlock (PerasCert' blk) = Point blk -type instance BoostedBlock (PerasVote' blk) = Point blk - -instance IsPerasCert (PerasCert' blk) blk where - getPerasCertRound = pcCertRound - getPerasCertBlock = pcCertBoostedBlock - -instance IsPerasVote (PerasVote' blk) blk where - getPerasVoteRound = pvVoteRound - getPerasVoteBlock = pvVoteBlock - getPerasVoteSeatIndex = pvVoteVoterId + -- | Read the private key for Peras voting from the env vars. + -- + -- NOTE: this is a temporary workaround for testnet, this is supposed to be + -- replaced for Peras-to-mainnet with proper key registration and retrieval + -- mechanisms. + readPerasPrivateKeyFromEnv :: + proxy blk -> + Either String (PrivateKey (PerasCrypto blk)) + default readPerasPrivateKeyFromEnv :: + PrivateKey (PerasCrypto blk) ~ () => + proxy blk -> + Either String (PrivateKey (PerasCrypto blk)) + readPerasPrivateKeyFromEnv _ = + Right () + + -- | Read the PoolId from the environment variable 'PERAS_POOL_ID'. + -- + -- NOTE: this is a temporary workaround for testnet, we still need to figure + -- out how to properly thread the PoolId throughout a node creation for + -- Peras-to-mainnet. + readPerasPoolIdFromEnv :: + proxy blk -> + Either String PoolId + default readPerasPoolIdFromEnv :: + proxy blk -> + Either String PoolId + readPerasPoolIdFromEnv _ = + unsafePerformIO $ + lookupEnv envVar >>= \case + Nothing -> do + pure $ Left $ "Environment variable " <> envVar <> "not set." + Just rawKey -> do + pure $ decodeKey rawKey + where + envVar = + "PERAS_POOL_ID" + + decodeKey key = + case Hash.hashFromStringAsHex key of + Just hash -> Right $ PoolId (KeyHash hash) + Nothing -> Left $ "failed to decode PoolId, invalid hash bytes: " <> show key + {-# NOINLINE readPerasPoolIdFromEnv #-} -- * Validated types @@ -389,7 +512,7 @@ instance getPerasCertRound = getPerasCertRound . vpcCert getPerasCertBlock = getPerasCertBlock . vpcCert ---- * Peras error types +-- * Peras error types -- | Error types that support injecting certain types of Peras errors class IsPerasError err blk | err -> blk where @@ -397,6 +520,14 @@ class IsPerasError err blk | err -> blk where injectConversionError :: PerasConversionError -> err injectQuorumNotReachedError :: VoteWeight -> err +instance IsPerasError (VoidPerasError blk) blk where + injectVotingCommitteeError _ = + error "injectVotingCommitteeError: VoidPerasError cannot be inhabited" + injectConversionError _ = + error "injectConversionError: VoidPerasError cannot be inhabited" + injectQuorumNotReachedError _ = + error "injectQuorumNotReachedError: VoidPerasError cannot be inhabited" + -- * Types and functions related to Peras vote collection and quorum checking -- | Collection of Peras votes for a given target. @@ -574,6 +705,8 @@ toUniqueVotesWithSameTarget :: ( vote ~ PerasVote blk , crypto ~ PerasCrypto blk , committee ~ PerasVotingCommitteeScheme blk + , ElectionId crypto ~ PerasRoundNo + , CryptoSupportsVotingCommittee crypto committee , PerasVoteCompatibleWithVotingCommittee vote crypto committee , Eq (VoteCandidate crypto) ) => diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs index cb45003a48..2496bbe54d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs @@ -10,6 +10,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Abstract.CanHardFork ( CanHardFork (..) , HashSizeOfHead + , EqualHashSizeOfHead , rawHashNS ) where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs index 815eea5117..a56068439a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs @@ -38,17 +38,20 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config.SupportsNode import Ouroboros.Consensus.HardFork.Combinator.Info import Ouroboros.Consensus.HardFork.Combinator.PartialConfig -import Ouroboros.Consensus.HardFork.History (Bound, EraParams) +import Ouroboros.Consensus.HardFork.History (Bound, EpochToPerasRoundInfo, EraParams) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.SupportsPeerSelection -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras, LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Node.InitStorage import Ouroboros.Consensus.Node.Serialisation +import Ouroboros.Consensus.Peras.Context + ( MaybeEraIndexedEpochToPerasRoundInfo + , StateSupportsPerasEpochContext + ) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Ticked @@ -61,7 +64,6 @@ import Ouroboros.Consensus.Util.Condense -- | Blocks from which we can assemble a hard fork class ( LedgerSupportsProtocol blk - , LedgerSupportsPeras blk , InspectLedger blk , LedgerSupportsMempool blk , ConvertRawTxId (GenTx blk) @@ -78,14 +80,11 @@ class , ConfigSupportsNode blk , NodeInitStorage blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk + , MaybeEraIndexedEpochToPerasRoundInfo blk ~ EpochToPerasRoundInfo , BlockSupportsMetrics blk , SerialiseNodeToClient blk (PartialLedgerConfig blk) - , -- TODO: replace the four constraints below with: - -- 'StateSupportsPerasEpochContext blk' once that type class is in place. - ChainDepStateSupportsPeras (ChainDepState (BlockProtocol blk)) - , ChainDepStateSupportsPeras (Ticked (ChainDepState (BlockProtocol blk))) - , LedgerStateSupportsPeras (LedgerState blk) - , LedgerStateSupportsPeras (Ticked LedgerState blk) , -- LedgerTables CanStowLedgerTables (LedgerState blk) , HasLedgerTables LedgerState blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index 2d0fb28a30..636d16f307 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs @@ -1,15 +1,25 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +-- TODO: figure out how to move the 'IsPerasVote'/'IsPerasCert' next to the +-- definition of 'OneEraPerasVote' and 'OneEraPerasCert'. +{-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.HardFork.Combinator.Basics ( -- * Hard fork protocol, block, and ledger state @@ -31,6 +41,15 @@ module Ouroboros.Consensus.HardFork.Combinator.Basics , completeLedgerConfig'' , distribLedgerConfig , distribTopLevelConfig + , projectHFCPerasContext + , injectHFCPerasEpochContext + , projectHFCBoundedPerasEpochContext + , injectHFCBoundedPerasEpochContext + , castHFCPerasEpochContextResolverAtIndex + , injectHFCPerasEpochContextResolver + , EitherF (..) + , mkEitherF + , hcollect -- ** Convenience re-exports , EpochInfo @@ -38,31 +57,72 @@ module Ouroboros.Consensus.HardFork.Combinator.Basics ) where import Cardano.Slotting.EpochInfo +import Data.Bifunctor (bimap) +import Data.Functor.Product (Product (..)) import Data.Kind (Type) -import Data.SOP (K (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.NonEmpty (NEMap) +import qualified Data.Map.NonEmpty as NEMap +import Data.SOP (I (..), K (..), type (:.:) (..)) import Data.SOP.Constraint +import Data.SOP.Dict (Dict (..)) +import qualified Data.SOP.Dict as Dict import Data.SOP.Functors +import Data.SOP.Index (Index (..), himap, injectNS) +import Data.SOP.Match (matchNS) import Data.SOP.Strict import Data.Typeable import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (..) + , BoostedBlock + , IsPerasCert (..) + , IsPerasError (..) + , IsPerasVote (..) + , PerasEpochContext (..) + , PerasRoundNo + , PerasVoteCollection (..) + , PerasVoteCollectionWithQuorum (..) + , ValidatedPerasCert (..) + , ValidatedPerasVote (..) + , castPerasParams + , unsafeAssumeQuorum + , unsafePerasVoteCollection + ) +import Ouroboros.Consensus.BlockchainTime (WithArrivalTime (..)) +import Ouroboros.Consensus.Committee.Crypto + ( ElectionId + , VoteCandidate + ) import Ouroboros.Consensus.Config -import Ouroboros.Consensus.HardFork.Combinator.Abstract +import Ouroboros.Consensus.HardFork.Combinator.Abstract.CanHardFork + ( CanHardFork + , EqualHashSizeOfHead + , HashSizeOfHead + ) +import Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock + ( SingleEraBlock + , proxySingle + ) import Ouroboros.Consensus.HardFork.Combinator.AcrossEras import Ouroboros.Consensus.HardFork.Combinator.PartialConfig import qualified Ouroboros.Consensus.HardFork.Combinator.State.Infra as State import Ouroboros.Consensus.HardFork.Combinator.State.Instances () import Ouroboros.Consensus.HardFork.Combinator.State.Types import qualified Ouroboros.Consensus.HardFork.History as History +import qualified Ouroboros.Consensus.HardFork.History.EraParams as HF import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.SupportsPeras - ( LedgerStateSupportsPeras (..) - , LedgerSupportsPeras (..) +import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras (..)) +import Ouroboros.Consensus.Peras.Context + ( BoundedPerasEpochContext (..) + , PerasEpochContextResolver (..) ) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (ShowProxy) +import Ouroboros.Consensus.Util.RedundantConstraints (keepRedundantConstraint) {------------------------------------------------------------------------------- Hard fork protocol, block, and ledger state @@ -252,15 +312,673 @@ distribTopLevelConfig ei tlc = ) {------------------------------------------------------------------------------- - LedgerSupportsPeras + NS helpers for Peras +-------------------------------------------------------------------------------} + +-- | Ensure that all elements of a non-empty list of 'NS' values are in the same +-- era, collecting them into a single 'NS' containing a 'NonEmpty'. +ensureSameEraNonEmpty :: + SListI xs => + NonEmpty (NS f xs) -> + Maybe (NS (NonEmpty :.: f) xs) +ensureSameEraNonEmpty (x :| rest) = + foldl go (Just $ hmap (Comp . (:| [])) x) rest + where + go Nothing _ = + Nothing + go (Just acc) ns = + case matchNS acc ns of + Left _mismatch -> + Nothing + Right nsPair -> + Just + . hmap + ( \(Pair (Comp fs) f) -> + Comp $ + fs <> (f :| []) + ) + $ nsPair + +-- | Ensure that all elements of a non-empty map of 'NS' values are in the same +-- era, collecting them into a single 'NS' containing a 'NEMap'. +ensureSameEraNonEmptyMap :: + ( Ord k + , All Top xs + ) => + NEMap k (NS f xs) -> + Maybe (NS (NEMap k :.: f) xs) +ensureSameEraNonEmptyMap neMap = + case ensureSameEraNonEmpty keyValPairs of + Nothing -> + Nothing + Just ns -> + Just + . hmap + ( \(Comp neKeyValPairs) -> + Comp + . NEMap.fromList + . fmap (\(Pair (K k) v) -> (k, v)) + $ neKeyValPairs + ) + $ ns + where + keyValPairs = + fmap (\(k, v) -> hmap (\v' -> Pair (K k) v') v) + . NEMap.toList + $ neMap + +-- | Ensure that two 'NS' values are in the same era, pairing them together. +-- Returns 'Left ParamsEraMismatch' if they are from different eras. +ensureSameEraPair :: + ( NS f xs + , NS g xs + ) -> + Maybe (NS (Product f g) xs) +ensureSameEraPair (l, r) = + case matchNS l r of + Left _mismatch -> + Nothing + Right nsQueryResAndLedgerView -> + Just nsQueryResAndLedgerView + +-- | Align an 'NP' and an 'NS' of the same length, pairing them together. +alignNPWithNS :: + All Top xs => + NP f xs -> + NS g xs -> + NS (Product f g) xs +alignNPWithNS = + hzipWith Pair + +-- | A wrapper for 'Either' that is a functor in its last argument. +newtype EitherF f g x = EitherF {unEitherF :: Either (f x) (g x)} + +-- | Construct an 'EitherF' from two functions and an 'Either' value. +mkEitherF :: (a -> f x) -> (b -> g x) -> Either a b -> EitherF f g x +mkEitherF f g = EitherF . bimap f g + +-- | Collect an 'NS' of 'EitherF' values into an 'Either' of 'NS' values. +hcollect :: + All Top xs => + NS (EitherF f g) xs -> + Either (NS f xs) (NS g xs) +hcollect ns = + hcollapse (himap f ns) + where + f idx (EitherF (Left fx)) = K $ Left $ injectNS idx fx + f idx (EitherF (Right gx)) = K $ Right $ injectNS idx gx + +{------------------------------------------------------------------------------- + HFC injection/projection helpers for Peras +-------------------------------------------------------------------------------} + +-- | Downcast a 'Point' of the hard fork block to a 'Point' of a single era +-- by decoding the raw hash via 'fromShortRawHash'. Used when delegating +-- operations that take a 'Point' argument to a single-era implementation. +downcastHardForkPoint :: + forall blk xs. + ( SingleEraBlock blk + , HashSize (HardForkBlock xs) ~ HashSize blk + ) => + Point (HardForkBlock xs) -> + Point blk +downcastHardForkPoint = \case + GenesisPoint -> + GenesisPoint + BlockPoint s (OneEraHash h) -> + -- The constraints ensure that the hash sizes match, so we can safely use + -- the unsafe variant of 'fromShortRawHash' here. + BlockPoint s (unsafeFromShortRawHash (Proxy @blk) h) + where + _ = keepRedundantConstraint (Proxy @(HashSize (HardForkBlock xs) ~ HashSize blk)) + +-- | Upcast a 'Point' from a single era into a 'Point' of the hard fork block +-- by encoding the raw hash via 'toShortRawHash'. Used by accessor instances +-- to return 'Point (HardForkBlock xs)' from single-era point values. +upcastToHardForkPoint :: + forall blk xs. + SingleEraBlock blk => + Point blk -> + Point (HardForkBlock xs) +upcastToHardForkPoint = \case + GenesisPoint -> + GenesisPoint + BlockPoint s h -> + BlockPoint s (OneEraHash (toShortRawHash (Proxy @blk) h)) + +-- | Project a 'PerasVoteCollectionWithQuorum' of the hard fork block into a +-- 'NS' of 'PerasVoteCollectionWithQuorum' of the single era blocks. +projectHFCPerasVoteCollectionWithQuorum :: + All SingleEraBlock xs => + PerasVoteCollectionWithQuorum (HardForkBlock xs) -> + Maybe (NS PerasVoteCollectionWithQuorum xs) +projectHFCPerasVoteCollectionWithQuorum hfcCollection = + let votes = pvcVotes $ forgetQuorum hfcCollection + neMapNs = projectHFCWatValidatedPerasVote <$> votes + in case ensureSameEraNonEmptyMap neMapNs of + Nothing -> Nothing + Just nsNeMap -> + Just $ + hcmap + proxySingle + ( \(Comp compedValMap) -> + unsafeAssumeQuorum $ + unsafePerasVoteCollection + ((\(Comp v) -> v) <$> compedValMap) + ) + nsNeMap + +-- NOTE: this assumes PerasParams are the same for all eras. +-- +-- In the future, @pecParams@ will be an @NP@ of @PerasParams@. +projectHFCPerasContext :: + All Top xs => + PerasEpochContext (HardForkBlock xs) -> + NS PerasEpochContext xs +projectHFCPerasContext PerasEpochContext{pecCommittee, pecParams} = + hmap + ( \(WrapPerasVotingCommittee committee) -> + PerasEpochContext + { pecCommittee = committee + , pecParams = castPerasParams pecParams + } + ) + . getOneEraPerasVotingCommittee + $ pecCommittee + +injectHFCPerasEpochContext :: + All Top xs => + NS PerasEpochContext xs -> + PerasEpochContext (HardForkBlock xs) +injectHFCPerasEpochContext nsContext = + PerasEpochContext + { pecCommittee = + OneEraPerasVotingCommittee + . hmap (WrapPerasVotingCommittee . pecCommittee) + $ nsContext + , pecParams = + hcollapse + . hmap (K . castPerasParams . pecParams) + $ nsContext + } + +-- | Project a 'BoundedPerasEpochContext' of the hard fork block into a 'NS' of +-- 'BoundedPerasEpochContext' of the single era blocks. +projectHFCBoundedPerasEpochContext :: + All Top xs => + BoundedPerasEpochContext (HardForkBlock xs) -> + NS BoundedPerasEpochContext xs +projectHFCBoundedPerasEpochContext + BoundedPerasEpochContext + { startPerasRoundNo + , endPerasRoundNo + , epochContext + } = + hmap + ( \(WrapPerasVotingCommittee committee) -> + BoundedPerasEpochContext + { startPerasRoundNo = + startPerasRoundNo + , endPerasRoundNo = + endPerasRoundNo + , epochContext = + PerasEpochContext + { pecCommittee = committee + , pecParams = castPerasParams (pecParams epochContext) + } + } + ) + . getOneEraPerasVotingCommittee + $ pecCommittee epochContext + +-- | Inject a 'NS' of 'BoundedPerasEpochContext' of the single era blocks into a +-- 'BoundedPerasEpochContext' of the hard fork block. +injectHFCBoundedPerasEpochContext :: + All Top xs => + NS BoundedPerasEpochContext xs -> + BoundedPerasEpochContext (HardForkBlock xs) +injectHFCBoundedPerasEpochContext nsBoundedContext = + BoundedPerasEpochContext + { startPerasRoundNo = + hcollapse + . hmap (K . startPerasRoundNo) + $ nsBoundedContext + , endPerasRoundNo = + hcollapse + . hmap (K . endPerasRoundNo) + $ nsBoundedContext + , epochContext = + injectHFCPerasEpochContext $ + hmap epochContext nsBoundedContext + } + +-- | Try to cast a 'PerasEpochContextResolver' of a 'HardForkBlock' into a +-- 'PerasEpochContextResolver' of the single era block represented by the given +-- index. +-- +-- A 'PerasEpochContextResolver' is made of two maybe-like values, one for the +-- context of the current epoch, and one for the context of the past epoch. The +-- current epoch has to be in the current era, i.e. the era represented by the +-- given index; so the current context cast into the requested single era must +-- succeed for the whole operation to be succesful. +-- +-- However, the past epoch may be in the past era under normal conditions. So +-- the cast of the previous epoch context into the era block represented by the +-- given index should be allowed to fail gracefully. So when it doesn't match +-- the requested index, the previous context is simply discarded and replaced +-- with a 'HF.NoPerasEnabled'. +-- +-- Note that when the current context is 'HF.NoPerasEnabled', and the previous +-- one is 'HF.PerasEnabled cPrev' with 'cPrev' incompatible with the requested +-- era; the output of the cast is a: +-- 'PerasEpochContextResolver HF.NoPerasEnabled HF.NoPerasEnabled', +-- which is no functionally different from a: +-- 'PerasEpochContextResolverError', since it won't be able to resolve anything. +castHFCPerasEpochContextResolverAtIndex :: + All Top xs => + Index xs blk -> + PerasEpochContextResolver (HardForkBlock xs) -> + PerasEpochContextResolver blk +castHFCPerasEpochContextResolverAtIndex idx = \case + PerasEpochContextResolverError err -> + PerasEpochContextResolverError err + PerasEpochContextResolver peCurrentBoundedContext pePrevBoundedContext -> + case (peCurrentBoundedContext, pePrevBoundedContext) of + (HF.PerasEnabled currentBoundedContext, HF.PerasEnabled prevBoundedContext) -> + case ensureSameEraPair + ( getIndex idx + , projectHFCBoundedPerasEpochContext currentBoundedContext + ) of + Nothing -> + eraMismatchErrorResolver + Just nsIdxCurrPair -> + hcollapse $ + hmap + ( \(Pair Refl currentBoundedContext') -> + K + $ PerasEpochContextResolver + (HF.PerasEnabled currentBoundedContext') + $ case ensureSameEraPair + ( getIndex idx + , projectHFCBoundedPerasEpochContext prevBoundedContext + ) of + Nothing -> + -- The current context is from the right era, but the + -- previous one is from a different one. Instead of + -- erroring out, we just discard the previous context. + HF.NoPerasEnabled + Just nsIdxPrevPair -> + hcollapse $ + hmap + ( \(Pair Refl prevBoundedContext') -> + K $ HF.PerasEnabled prevBoundedContext' + ) + nsIdxPrevPair + ) + nsIdxCurrPair + (HF.PerasEnabled currentBoundedContext, HF.NoPerasEnabled) -> + case ensureSameEraPair + ( getIndex idx + , projectHFCBoundedPerasEpochContext currentBoundedContext + ) of + Nothing -> + eraMismatchErrorResolver + Just nsIdxCurrPair -> + hcollapse $ + hmap + ( \(Pair Refl currentBoundedContext') -> + K $ + PerasEpochContextResolver + (HF.PerasEnabled currentBoundedContext') + HF.NoPerasEnabled + ) + nsIdxCurrPair + (HF.NoPerasEnabled, HF.PerasEnabled prevBoundedContext) -> + case ensureSameEraPair + ( getIndex idx + , projectHFCBoundedPerasEpochContext prevBoundedContext + ) of + Nothing -> + -- The current context is for an epoch/era where Peras is disabled, + -- and the previous context is from a different era than the + -- requested one, so we just return an empty resolver. + -- + -- TODO: Should we error out instead? + -- It would probably give the same end result. + PerasEpochContextResolver + HF.NoPerasEnabled + HF.NoPerasEnabled + Just nsIdxPrevPair -> + hcollapse $ + hmap + ( \(Pair Refl prevBoundedContext') -> + K $ + PerasEpochContextResolver + HF.NoPerasEnabled + (HF.PerasEnabled prevBoundedContext') + ) + nsIdxPrevPair + (HF.NoPerasEnabled, HF.NoPerasEnabled) -> + PerasEpochContextResolver + HF.NoPerasEnabled + HF.NoPerasEnabled + where + eraMismatchErrorResolver = + PerasEpochContextResolverError $ + unlines + [ "projectHFCPerasEpochContextResolver: currentBoundedContext" + , " is not in the same era as the supplied index" + ] + +-- | Inject a 'NS' of 'PerasEpochContextResolver' of the single era blocks into +-- a 'PerasEpochContextResolver' of the hard fork block. +injectHFCPerasEpochContextResolver :: + All Top xs => + NS PerasEpochContextResolver xs -> + PerasEpochContextResolver (HardForkBlock xs) +injectHFCPerasEpochContextResolver = + hcollapse + . himap + ( \idx resolver -> + case resolver of + PerasEpochContextResolverError err -> + K $ PerasEpochContextResolverError err + PerasEpochContextResolver currBoundedContext prevBoundedContext -> + let hfcCurrentBoundedContext = + injectHFCBoundedPerasEpochContext + . injectNS idx + <$> currBoundedContext + hfcPrevBoundedContext = + injectHFCBoundedPerasEpochContext + . injectNS idx + <$> prevBoundedContext + in K $ + PerasEpochContextResolver + hfcCurrentBoundedContext + hfcPrevBoundedContext + ) + +injectHFCValidatedPerasVote :: + All Top xs => + NS ValidatedPerasVote xs -> + ValidatedPerasVote (HardForkBlock xs) +injectHFCValidatedPerasVote ns = + ValidatedPerasVote + { vpvVote = OneEraPerasVote (hmap (WrapPerasVote . vpvVote) ns) + , vpvVoteWeight = hcollapse (hmap (K . vpvVoteWeight) ns) + } + +injectHFCValidatedPerasCert :: + All Top xs => + NS ValidatedPerasCert xs -> + ValidatedPerasCert (HardForkBlock xs) +injectHFCValidatedPerasCert ns = + ValidatedPerasCert + { vpcCert = OneEraPerasCert (hmap (WrapPerasCert . vpcCert) ns) + , vpcCertBoost = hcollapse (hmap (K . vpcCertBoost) ns) + } + +projectHFCValidatedPerasVote :: + All Top xs => + ValidatedPerasVote (HardForkBlock xs) -> + NS ValidatedPerasVote xs +projectHFCValidatedPerasVote + ValidatedPerasVote + { vpvVote + , vpvVoteWeight + } = + hmap + ( \(WrapPerasVote v) -> + ValidatedPerasVote + { vpvVote = v + , vpvVoteWeight + } + ) + . getOneEraPerasVote + $ vpvVote + +projectHFCWatValidatedPerasVote :: + All Top xs => + WithArrivalTime (ValidatedPerasVote (HardForkBlock xs)) -> + NS (WithArrivalTime :.: ValidatedPerasVote) xs +projectHFCWatValidatedPerasVote (WithArrivalTime arrivalTime validatedVote) = + hmap (Comp . WithArrivalTime arrivalTime) + . projectHFCValidatedPerasVote + $ validatedVote + +{------------------------------------------------------------------------------- + BlockSupportsPeras -------------------------------------------------------------------------------} -instance CanHardFork xs => LedgerSupportsPeras (HardForkBlock xs) where - getLatestPerasCertRound = +-- ** Type and class instances that are required for the 'BlockSupportsPeras' + +-- instance of 'HardForkBlock' + +type instance ElectionId (OneEraPerasCrypto xs) = PerasRoundNo +type instance BoostedBlock (OneEraPerasVote xs) = Point (HardForkBlock xs) +type instance BoostedBlock (OneEraPerasCert xs) = Point (HardForkBlock xs) +type instance VoteCandidate (OneEraPerasCrypto xs) = Point (HardForkBlock xs) + +instance + ( CanHardFork xs + , All SingleEraBlock xs + ) => + IsPerasVote (OneEraPerasVote xs) (HardForkBlock xs) + where + getPerasVoteRound = hcollapse - . hcmap proxySingle (K . getLatestPerasCertRound . unFlip) - . State.tip - . hardForkLedgerStatePerEra + . hcmap proxySingle (K . getPerasVoteRound . unwrapPerasVote) + . getOneEraPerasVote + getPerasVoteSeatIndex = + hcollapse + . hcmap proxySingle (K . getPerasVoteSeatIndex . unwrapPerasVote) + . getOneEraPerasVote + getPerasVoteBlock = + hcollapse + . hcmap proxySingle (K . upcastToHardForkPoint . getPerasVotePoint . unwrapPerasVote) + . getOneEraPerasVote + +instance + ( CanHardFork xs + , All SingleEraBlock xs + ) => + IsPerasCert (OneEraPerasCert xs) (HardForkBlock xs) + where + getPerasCertRound = + hcollapse + . hcmap proxySingle (K . getPerasCertRound . unwrapPerasCert) + . getOneEraPerasCert + getPerasCertBlock = + hcollapse + . hcmap proxySingle (K . upcastToHardForkPoint . getPerasCertPoint . unwrapPerasCert) + . getOneEraPerasCert + +instance + ( CanHardFork xs + , All SingleEraBlock xs + ) => + IsPerasError (HardForkPerasError xs) (HardForkBlock xs) + where + -- NOTE: in practice this is never produced at the HFC level + injectVotingCommitteeError _ = HardForkPerasErrorCommitteeError + + -- NOTE: in practice this is never produced at the HFC level + injectConversionError _ = HardForkPerasErrorConversionError + + -- NOTE: in practice this is never produced at the HFC level + injectQuorumNotReachedError _ = HardForkPerasErrorQuorumNotReachedError + +-- ** 'BlockSupportsPeras' instance for 'HardForkBlock' + +class + ( SingleEraBlock blk + , EqualHashSizeOfHead xs blk + ) => + SingleEraBlockWithHashSizeOfHead xs blk + +instance + ( SingleEraBlock blk + , EqualHashSizeOfHead xs blk + ) => + SingleEraBlockWithHashSizeOfHead xs blk + +proofSingleEraBlockWithHashSizeOfHead :: + forall xs. + ( All SingleEraBlock xs + , All (EqualHashSizeOfHead xs) xs + ) => + Dict (All (SingleEraBlockWithHashSizeOfHead xs)) xs +proofSingleEraBlockWithHashSizeOfHead = + Dict.mapAll + (\Dict -> Dict) + ( Dict.zipAll + (Dict :: Dict (All SingleEraBlock) xs) + (Dict :: Dict (All (EqualHashSizeOfHead xs)) xs) + ) + +instance + ( StandardHash (HardForkBlock xs) + , HashSize (HardForkBlock xs) ~ HashSizeOfHead xs + , CanHardFork xs + ) => + BlockSupportsPeras (HardForkBlock xs) + where + type PerasVote (HardForkBlock xs) = OneEraPerasVote xs + type PerasCert (HardForkBlock xs) = OneEraPerasCert xs + type PerasError (HardForkBlock xs) = HardForkPerasError xs + type PerasCrypto (HardForkBlock xs) = OneEraPerasCrypto xs + type PerasVotingCommitteeScheme (HardForkBlock xs) = OneEraPerasVotingCommitteeScheme xs + + forgePerasVoteIfEligible context poolId privKey roundNo point = + let + nsPrivKeyContext = + alignNPWithNS + (getPerEraPerasPrivateKey privKey) + (projectHFCPerasContext context) + in + case proofSingleEraBlockWithHashSizeOfHead @xs of + Dict -> + bimap + (HardForkPerasErrorOneEraPerasError . OneEraPerasError) + (fmap injectHFCValidatedPerasVote . hsequence') + . hcollect + . hcmap + (Proxy @(SingleEraBlockWithHashSizeOfHead xs)) + ( \(Pair (WrapPerasPrivateKey privKey') context') -> + mkEitherF + WrapPerasError + Comp + $ forgePerasVoteIfEligible + context' + poolId + privKey' + roundNo + (downcastHardForkPoint point) + ) + $ nsPrivKeyContext + + verifyPerasVote context vote = + case ensureSameEraPair + ( projectHFCPerasContext context + , getOneEraPerasVote vote + ) of + Nothing -> + Left HardForkPerasErrorEraMismatch + Just nsContextVote -> + bimap + (HardForkPerasErrorOneEraPerasError . OneEraPerasError) + injectHFCValidatedPerasVote + . hcollect + . hcmap + proxySingle + ( \(Pair context' (WrapPerasVote vote')) -> + mkEitherF + WrapPerasError + id + $ verifyPerasVote context' vote' + ) + $ nsContextVote + + forgePerasCert context collection = + case projectHFCPerasVoteCollectionWithQuorum collection of + Nothing -> + Left HardForkPerasErrorEraMismatch + Just nsCollection -> + case ensureSameEraPair + ( projectHFCPerasContext context + , nsCollection + ) of + Nothing -> Left HardForkPerasErrorEraMismatch + Just nsContextCollection -> + bimap + (HardForkPerasErrorOneEraPerasError . OneEraPerasError) + injectHFCValidatedPerasCert + . hcollect + . hcmap + proxySingle + ( \(Pair context' collection') -> + mkEitherF + WrapPerasError + id + $ forgePerasCert context' collection' + ) + $ nsContextCollection + + verifyPerasCert context cert = + case ensureSameEraPair + ( projectHFCPerasContext context + , getOneEraPerasCert cert + ) of + Nothing -> + Left HardForkPerasErrorEraMismatch + Just nsContextCert -> + bimap + (HardForkPerasErrorOneEraPerasError . OneEraPerasError) + injectHFCValidatedPerasCert + . hcollect + . hcmap + proxySingle + ( \(Pair context' (WrapPerasCert cert')) -> + mkEitherF + WrapPerasError + id + $ verifyPerasCert context' cert' + ) + $ nsContextCert + + getPerasCertInBlock (HardForkBlock (OneEraBlock nsBlock)) = + bimap + (HardForkPerasErrorOneEraPerasError . OneEraPerasError) + (fmap OneEraPerasCert . hsequence') + . hcollect + . hcmap + proxySingle + ( \(I block) -> + mkEitherF + WrapPerasError + (Comp . fmap WrapPerasCert) + $ getPerasCertInBlock block + ) + $ nsBlock + + readPerasPrivateKeyFromEnv _proxy = + fmap PerEraPerasPrivateKey $ + hsequence' $ + hcpure proxySingle dispatchReadKey + where + dispatchReadKey :: + forall blk. + SingleEraBlock blk => + (Either String :.: WrapPerasPrivateKey) blk + dispatchReadKey = + Comp + . fmap WrapPerasPrivateKey + . readPerasPrivateKeyFromEnv + $ Proxy @blk + +{------------------------------------------------------------------------------- + LedgerSupportsPeras +-------------------------------------------------------------------------------} instance CanHardFork xs => LedgerStateSupportsPeras (LedgerState (HardForkBlock xs)) where getPoolDistr = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Block.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Block.hs index 1b9df0e189..56fd59e918 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Block.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Block.hs @@ -20,6 +20,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Block ( -- * Type family instances Header (..) , NestedCtxt_ (..) + , ConvertRawHash (..) -- * AnnTip , distribAnnTip diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs index 7005e301b9..b698ce1820 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -10,6 +11,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Embed.Binary (protocolInfoBinary) import Control.Exception (assert) import qualified Control.Tracer as Tracer import Data.Align (alignWith) +import Data.Maybe.Strict (StrictMaybe (..)) import Data.SOP.Counting (exactlyTwo) import Data.SOP.Functors (Flip (..)) import Data.SOP.OptNP (NonEmptyOptNP, OptNP (..)) @@ -23,6 +25,7 @@ import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Basics (LedgerConfig) import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Protocol.Abstract (protocolSecurityParam) import Ouroboros.Consensus.TypeFamilyWrappers @@ -33,7 +36,11 @@ import Ouroboros.Consensus.TypeFamilyWrappers protocolInfoBinary :: forall m kesAgentTrace blk1 blk2. - (CanHardFork '[blk1, blk2], Monad m) => + ( Monad m + , CanHardFork '[blk1, blk2] + , HasCanonicalTxIn '[blk1, blk2] + , HasHardForkTxOut '[blk1, blk2] + ) => -- First era ProtocolInfo blk1 -> (Tracer.Tracer m kesAgentTrace -> m [MkBlockForging m blk1]) -> @@ -60,58 +67,71 @@ protocolInfoBinary eraParams2 toPartialConsensusConfig2 toPartialLedgerConfig2 = - ( ProtocolInfo - { pInfoConfig = - TopLevelConfig - { topLevelConfigProtocol = - HardForkConsensusConfig - { hardForkConsensusConfigK = k - , hardForkConsensusConfigShape = shape - , hardForkConsensusConfigPerEra = - PerEraConsensusConfig - ( WrapPartialConsensusConfig (toPartialConsensusConfig1 consensusConfig1) - :* WrapPartialConsensusConfig (toPartialConsensusConfig2 consensusConfig2) - :* Nil - ) - } - , topLevelConfigLedger = - HardForkLedgerConfig - { hardForkLedgerConfigShape = shape - , hardForkLedgerConfigPerEra = - PerEraLedgerConfig - ( WrapPartialLedgerConfig (toPartialLedgerConfig1 ledgerConfig1) - :* WrapPartialLedgerConfig (toPartialLedgerConfig2 ledgerConfig2) - :* Nil - ) - } - , topLevelConfigBlock = - HardForkBlockConfig $ - PerEraBlockConfig $ - (blockConfig1 :* blockConfig2 :* Nil) - , topLevelConfigCodec = - HardForkCodecConfig $ - PerEraCodecConfig $ - (codecConfig1 :* codecConfig2 :* Nil) - , topLevelConfigStorage = - HardForkStorageConfig $ - PerEraStorageConfig $ - (storageConfig1 :* storageConfig2 :* Nil) - , topLevelConfigCheckpoints = emptyCheckpointsMap - } - , pInfoInitLedger = - ExtLedgerState - { ledgerState = - HardForkLedgerState $ - initHardForkState (Flip initLedgerState1) - , headerState = - genesisHeaderState $ - initHardForkState $ - WrapChainDepState $ - headerStateChainDep initHeaderState1 - } - } - , \tr -> alignWith alignBlockForging <$> blockForging1 tr <*> blockForging2 tr - ) + let ledgerConfig = + HardForkLedgerConfig + { hardForkLedgerConfigShape = shape + , hardForkLedgerConfigPerEra = + PerEraLedgerConfig + ( WrapPartialLedgerConfig (toPartialLedgerConfig1 ledgerConfig1) + :* WrapPartialLedgerConfig (toPartialLedgerConfig2 ledgerConfig2) + :* Nil + ) + } + in ( ProtocolInfo + { pInfoConfig = + TopLevelConfig + { topLevelConfigProtocol = + HardForkConsensusConfig + { hardForkConsensusConfigK = k + , hardForkConsensusConfigShape = shape + , hardForkConsensusConfigPerEra = + PerEraConsensusConfig + ( WrapPartialConsensusConfig (toPartialConsensusConfig1 consensusConfig1) + :* WrapPartialConsensusConfig (toPartialConsensusConfig2 consensusConfig2) + :* Nil + ) + } + , topLevelConfigLedger = + ledgerConfig + , topLevelConfigBlock = + HardForkBlockConfig $ + PerEraBlockConfig $ + (blockConfig1 :* blockConfig2 :* Nil) + , topLevelConfigCodec = + HardForkCodecConfig $ + PerEraCodecConfig $ + (codecConfig1 :* codecConfig2 :* Nil) + , topLevelConfigStorage = + HardForkStorageConfig $ + PerEraStorageConfig $ + (storageConfig1 :* storageConfig2 :* Nil) + , topLevelConfigCheckpoints = emptyCheckpointsMap + } + , pInfoInitLedger = + let ledgerState = + HardForkLedgerState $ + initHardForkState (Flip initLedgerState1) + headerState = + genesisHeaderState $ + initHardForkState $ + WrapChainDepState $ + headerStateChainDep initHeaderState1 + perasEpochContextResolver = + initPerasEpochContextResolver + ledgerConfig + (forgetLedgerTables ledgerState) + headerState + latestPerasCertOnChainRound = + SNothing + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } + } + , \tr -> alignWith alignBlockForging <$> blockForging1 tr <*> blockForging2 tr + ) where ProtocolInfo { pInfoConfig = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs index 033c189278..d16c171d60 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs @@ -30,6 +30,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Embed.Nary import Data.Bifunctor (first) import Data.Coerce (Coercible, coerce) +import Data.Maybe.Strict (StrictMaybe) import Data.SOP.BasicFunctors import Data.SOP.Constraint import Data.SOP.Counting (Exactly (..)) @@ -50,9 +51,13 @@ import Ouroboros.Consensus.HeaderValidation , genesisHeaderState ) import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..)) +import Ouroboros.Consensus.Ledger.Extended + ( ExtLedgerState (..) + , initPerasEpochContextResolver + ) import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.Tables.Utils +import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolver (..)) import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.TypeFamilyWrappers @@ -234,6 +239,11 @@ instance Inject (Flip LedgerState mk) where instance Inject WrapChainDepState where inject = coerce .: injectHardForkState +instance Inject PerasEpochContextResolver where + inject iidx = + injectHFCPerasEpochContextResolver + . injectNS (forgetInjectionIndex iidx) + instance Inject HeaderState where inject iidx HeaderState{..} = HeaderState @@ -250,6 +260,8 @@ instance Inject (Flip ExtLedgerState mk) where ExtLedgerState { ledgerState = unFlip $ inject iidx (Flip ledgerState) , headerState = inject iidx headerState + , perasEpochContextResolver = inject iidx perasEpochContextResolver + , latestPerasCertOnChainRound = latestPerasCertOnChainRound } {------------------------------------------------------------------------------- @@ -279,6 +291,8 @@ injectInitialExtLedgerState cfg extLedgerState0 = ExtLedgerState { ledgerState = targetEraLedgerState , headerState = targetEraHeaderState + , perasEpochContextResolver = targetEraPerasEpochContextResolver + , latestPerasCertOnChainRound = targetEraLatestPerasCertOnChainRound } where cfgs :: NP TopLevelConfig (x ': xs) @@ -326,3 +340,13 @@ injectInitialExtLedgerState cfg extLedgerState0 = targetEraHeaderState :: HeaderState (HardForkBlock (x ': xs)) targetEraHeaderState = genesisHeaderState targetEraChainDepState + + targetEraPerasEpochContextResolver :: PerasEpochContextResolver (HardForkBlock (x ': xs)) + targetEraPerasEpochContextResolver = + initPerasEpochContextResolver + (configLedger cfg) + (forgetLedgerTables targetEraLedgerState) + targetEraHeaderState + + targetEraLatestPerasCertOnChainRound :: StrictMaybe PerasRoundNo + targetEraLatestPerasCertOnChainRound = latestPerasCertOnChainRound extLedgerState0 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs index 62ee9c2f54..544e03b552 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} @@ -68,6 +69,7 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Node.ProtocolInfo +import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolver (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.Init as InitChainDB @@ -361,14 +363,32 @@ instance Isomorphic (Flip ExtLedgerState mk) where ExtLedgerState { ledgerState = unFlip $ project $ Flip ledgerState , headerState = project headerState + , perasEpochContextResolver = projectPerasEpochContextResolver perasEpochContextResolver + , latestPerasCertOnChainRound = latestPerasCertOnChainRound } + where + projectPerasEpochContextResolver = \case + PerasEpochContextResolverError err -> + PerasEpochContextResolverError err + PerasEpochContextResolver hfcCurrentBoundedContext hfcPrevBoundedContext -> + PerasEpochContextResolver + (fromZ . projectHFCBoundedPerasEpochContext <$> hfcCurrentBoundedContext) + (fromZ . projectHFCBoundedPerasEpochContext <$> hfcPrevBoundedContext) + + fromZ :: NS f '[a] -> f a + fromZ (Z x) = x inject (Flip ExtLedgerState{..}) = Flip $ ExtLedgerState { ledgerState = unFlip $ inject $ Flip ledgerState , headerState = inject headerState + , perasEpochContextResolver = injectHFCPerasEpochContextResolver . toZ $ perasEpochContextResolver + , latestPerasCertOnChainRound = latestPerasCertOnChainRound } + where + toZ :: f a -> NS f '[a] + toZ x = Z x instance Isomorphic AnnTip where project :: forall blk. NoHardForks blk => AnnTip (HardForkBlock '[blk]) -> AnnTip blk @@ -459,17 +479,21 @@ instance Functor m => Isomorphic (BlockForging m) where ) (inject' (Proxy @(WrapIsLeader blk)) isLeader) (inject' (Proxy @(WrapForgeStateInfo blk)) forgeStateInfo) - , forgeBlock = \cfg bno sno tickedLgrSt txs isLeader -> + , forgeBlock = \cfg bno sno mbPerasCert tickedLgrSt txs isLeader -> project' (Proxy @(I blk)) <$> forgeBlock (inject cfg) bno sno + (injectPerasCert mbPerasCert) (getFlipTickedLedgerState (inject (FlipTickedLedgerState tickedLgrSt))) (inject' (Proxy @(WrapValidatedGenTx blk)) <$> txs) (inject' (Proxy @(WrapIsLeader blk)) isLeader) } where + injectPerasCert :: Maybe (PerasCert blk) -> Maybe (PerasCert (HardForkBlock '[blk])) + injectPerasCert = fmap (OneEraPerasCert . Z . WrapPerasCert) + injTickedChainDepSt :: EpochInfo (Except PastHorizonException) -> Ticked (ChainDepState (BlockProtocol blk)) -> @@ -505,17 +529,21 @@ instance Functor m => Isomorphic (BlockForging m) where (projTickedChainDepSt tickedChainDepSt) (project' (Proxy @(WrapIsLeader blk)) isLeader) (project' (Proxy @(WrapForgeStateInfo blk)) forgeStateInfo) - , forgeBlock = \cfg bno sno tickedLgrSt txs isLeader -> + , forgeBlock = \cfg bno sno mbPerasCert tickedLgrSt txs isLeader -> inject' (Proxy @(I blk)) <$> forgeBlock (project cfg) bno sno + (projectPerasCert mbPerasCert) (getFlipTickedLedgerState (project (FlipTickedLedgerState tickedLgrSt))) (project' (Proxy @(WrapValidatedGenTx blk)) <$> txs) (project' (Proxy @(WrapIsLeader blk)) isLeader) } where + projectPerasCert :: Maybe (PerasCert (HardForkBlock '[blk])) -> Maybe (PerasCert blk) + projectPerasCert = fmap (unwrapPerasCert . unZ . getOneEraPerasCert) + projTickedChainDepSt :: Ticked (ChainDepState (HardForkProtocol '[blk])) -> Ticked (ChainDepState (BlockProtocol blk)) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs index c04b44231f..1d098857f2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs @@ -310,6 +310,7 @@ hardForkForgeBlock :: TopLevelConfig (HardForkBlock xs) -> BlockNo -> SlotNo -> + Maybe (PerasCert (HardForkBlock xs)) -> TickedLedgerState (HardForkBlock xs) EmptyMK -> [Validated (GenTx (HardForkBlock xs))] -> HardForkIsLeader xs -> @@ -319,6 +320,7 @@ hardForkForgeBlock cfg bno sno + mbPerasCert (TickedHardForkLedgerState transition ledgerState) txs isLeader = @@ -375,6 +377,35 @@ hardForkForgeBlock error "Impossible! some transactions were rejected as untranslatable by rematchValidatedTxs but all of them have been translated and applied just now." + -- If we crossed an era boundary in this forge, and we are supposed to + -- include a Peras certificate in this block, we must ensure that the + -- certificate being passed to us (i.e., the latest certificate seen) is + -- from the same era as the block being forged. Otherwise, we drop it + -- (treating it as absent), since inter-era certificate inclusion is not + -- supported for now. In the unlikely event of recovering from a cooldown + -- period that crosses an era boundary, one should jumpstart the voting + -- process again via the same type of governance action that started this + -- process in the first place, but in the new era. + maybeInjectSameEraPerasCert :: + Index xs blk -> + PerasCert (HardForkBlock xs) -> + Maybe (PerasCert blk) + maybeInjectSameEraPerasCert index hardForkPerasCert = + case ( Match.matchNS + (getIndex index) + (getOneEraPerasCert hardForkPerasCert) + ) of + -- The Peras certificate is from a different era than the block being + -- forged, so we drop it (treating it as absent). + Left _mismatch -> + Nothing + -- The Peras certificate is from the same era as the block being forged, + -- so we keep it and pass it down to the current era's 'forgeBlock'. + Right nsPair -> + hcollapse $ + hmap (\(Pair Refl (WrapPerasCert cert)) -> K (Just cert)) $ + nsPair + -- \| Unwraps all the layers needed for SOP and call 'forgeBlock'. forgeBlockOne :: Index xs blk -> @@ -404,6 +435,7 @@ hardForkForgeBlock cfg' bno sno + (mbPerasCert >>= maybeInjectSameEraPerasCert index) ledgerState' (map unwrapValidatedGenTx txs') isLeader' diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs index ded1d8d759..5ccba74642 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs @@ -50,6 +50,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Ledger import Control.Monad (guard) import Control.Monad.Except (throwError, withExcept) import qualified Control.State.Transition.Extended as STS +import Data.Bifunctor (bimap) import Data.Functor ((<&>)) import Data.Functor.Product import Data.Kind (Type) @@ -90,8 +91,12 @@ import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.HardFork.Combinator.Translation import Ouroboros.Consensus.HardFork.History ( Bound (..) + , EpochToPerasRoundInfo + , EraIndexed , EraParams , SafeZone (..) + , eraIndexedToNS + , forgetEraIndex ) import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.HeaderValidation @@ -100,6 +105,9 @@ import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras (..)) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils +import Ouroboros.Consensus.Peras.Context + ( StateSupportsPerasEpochContext (..) + ) import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.IndexedMemPack (IndexedMemPack) @@ -340,6 +348,43 @@ instance . State.tip . tickedHardForkLedgerStatePerEra +-- | Defined here rather than alongside the other hard fork protocol instances +-- because its superclasses ('HasHardForkHistory' and the ticked +-- 'LedgerStateSupportsPeras' instance above) are not in scope in +-- "Ouroboros.Consensus.HardFork.Combinator.Protocol". +instance + ( StandardHash (HardForkBlock xs) + , CanHardFork xs + , All Top xs + ) => + StateSupportsPerasEpochContext (HardForkBlock xs) + where + type + MaybeEraIndexedEpochToPerasRoundInfo (HardForkBlock xs) = + EraIndexed xs EpochToPerasRoundInfo + + fromMaybeEraIndexedEpochToPerasRoundInfo _ = forgetEraIndex + toMaybeEraIndexedEpochToPerasRoundInfo _ = id + + mkBoundedPerasEpochContext epochToPerasRoundInfo ledgerState headerState = + bimap + (HardForkPerasErrorOneEraPerasError . OneEraPerasError) + injectHFCBoundedPerasEpochContext + ( hcollect + . hcmap + proxySingle + ( \_ -> + mkEitherF + WrapPerasError + id + $ mkBoundedPerasEpochContext + (fromMaybeEraIndexedEpochToPerasRoundInfo (Proxy @(HardForkBlock xs)) epochToPerasRoundInfo) + ledgerState + headerState + ) + $ eraIndexedToNS epochToPerasRoundInfo + ) + {------------------------------------------------------------------------------- HeaderValidation -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs index a5ec083d1b..05bb4c1a39 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs @@ -217,7 +217,7 @@ instance answerPureBlockQuery (ExtLedgerCfg cfg) query - ext@(ExtLedgerState st@(HardForkLedgerState hardForkState) _) = + ext@(ExtLedgerState st@(HardForkLedgerState hardForkState) _ _ _) = case query of QueryIfCurrent queryIfCurrent -> interpretQueryIfCurrent @@ -294,12 +294,26 @@ answerBlockQueryHelper distribExtLedgerState :: All SingleEraBlock xs => ExtLedgerState (HardForkBlock xs) mk -> NS (Flip ExtLedgerState mk) xs -distribExtLedgerState (ExtLedgerState ledgerState headerState) = - hmap (\(Pair hst lst) -> Flip $ ExtLedgerState (unFlip lst) hst) $ - mustMatchNS - "HeaderState" - (distribHeaderState headerState) - (State.tip (hardForkLedgerStatePerEra ledgerState)) +distribExtLedgerState + ( ExtLedgerState + ledgerState + headerState + perasResolver + latestPerasCertOnChainRound + ) = + himap + ( \idx (Pair hst lst) -> + Flip $ + ExtLedgerState + (unFlip lst) + hst + (castHFCPerasEpochContextResolverAtIndex idx perasResolver) + latestPerasCertOnChainRound + ) + $ mustMatchNS + "HeaderState" + (distribHeaderState headerState) + (State.tip (hardForkLedgerStatePerEra ledgerState)) -- | Precondition: the 'headerStateTip' and 'headerStateChainDep' should be from -- the same era. In practice, this is _always_ the case, unless the diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs index fda1547659..2bd8dacdd5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs @@ -8,6 +8,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Node () where import Data.Proxy +import Data.SOP (All, Top) import Data.SOP.BasicFunctors import Data.SOP.Strict import GHC.Stack @@ -60,7 +61,8 @@ getSameConfigValue getValue blockConfig = getSameValue values -------------------------------------------------------------------------------} instance - ( CanHardFork xs + ( All Top xs + , CanHardFork xs , HasCanonicalTxIn xs , HasHardForkTxOut xs , BlockSupportsHFLedgerQuery xs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs index 3b998b40ad..6fb387a2e2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs @@ -104,6 +104,7 @@ import Ouroboros.Consensus.HardFork.Combinator.State.Instances import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run +import Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToNode) import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Network.Block (Serialised) @@ -205,6 +206,9 @@ class , LedgerDbSerialiseConstraints (HardForkBlock xs) , VolatileDbSerialiseConstraints (HardForkBlock xs) , EncodeDiskDep (NestedCtxt Header) (HardForkBlock xs) + , -- Required for Peras + SerialiseNodeToNode (HardForkBlock xs) (PerasVote (HardForkBlock xs)) + , SerialiseNodeToNode (HardForkBlock xs) (PerasCert (HardForkBlock xs)) ) => SerialiseHFC xs where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseNodeToNode.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseNodeToNode.hs index 48ee317ff7..84fd9d0da1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseNodeToNode.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseNodeToNode.hs @@ -164,3 +164,21 @@ instance where encodeNodeToNode = dispatchEncoder `after` (getOneEraGenTxId . getHardForkGenTxId) decodeNodeToNode = fmap (HardForkGenTxId . OneEraGenTxId) .: dispatchDecoder + +{------------------------------------------------------------------------------- + Peras +-------------------------------------------------------------------------------} + +instance + SerialiseHFC xs => + SerialiseNodeToNode (HardForkBlock xs) (OneEraPerasVote xs) + where + encodeNodeToNode = dispatchEncoder `after` getOneEraPerasVote + decodeNodeToNode = fmap OneEraPerasVote .: dispatchDecoder + +instance + SerialiseHFC xs => + SerialiseNodeToNode (HardForkBlock xs) (OneEraPerasCert xs) + where + encodeNodeToNode = dispatchEncoder `after` getOneEraPerasCert + decodeNodeToNode = fmap OneEraPerasCert .: dispatchDecoder diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs index 4a450c78a4..a758aa6327 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs @@ -207,7 +207,7 @@ mkHeaderStateWithTime :: LedgerConfig blk -> ExtLedgerState blk mk -> HeaderStateWithTime blk -mkHeaderStateWithTime lcfg (ExtLedgerState lst hst) = +mkHeaderStateWithTime lcfg (ExtLedgerState lst hst _ _) = mkHeaderStateWithTimeFromSummary summary hst where -- A summary can always translate the tip slot of the ledger state it was 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 c59cb4dd8e..63eb29747f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs @@ -62,7 +62,7 @@ module Ouroboros.Consensus.Ledger.Dual , encodeDualLedgerState ) where -import Cardano.Binary (enforceSize) +import Cardano.Binary (FromCBOR, ToCBOR, enforceSize) import Codec.CBOR.Decoding (Decoder) import Codec.CBOR.Encoding (Encoding, encodeListLen) import Codec.Serialise @@ -73,6 +73,7 @@ import qualified Data.ByteString.Short as Short import Data.Coerce import Data.Functor ((<&>)) import Data.Kind (Type) +import Data.SOP.Constraint (All, Top) import Data.Typeable import GHC.Generics (Generic) import GHC.Stack @@ -93,6 +94,8 @@ import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils +import Ouroboros.Consensus.Peras.Context (StateSupportsPerasEpochContext) +import Ouroboros.Consensus.Protocol.Abstract (ChainDepState, ChainDepStateSupportsPeras) import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util (ShowProxy (..)) import Ouroboros.Consensus.Util.Condense @@ -267,6 +270,12 @@ class , Serialise (BridgeLedger m a) , Serialise (BridgeBlock m a) , Serialise (BridgeTx m a) + , -- Requirements for Peras epoch context + Show (PerasEpochContext (DualBlock m a)) + , Eq (PerasEpochContext (DualBlock m a)) + , NoThunks (PerasEpochContext (DualBlock m a)) + , FromCBOR (PerasEpochContext (DualBlock m a)) + , ToCBOR (PerasEpochContext (DualBlock m a)) , Show (BridgeTx m a) ) => Bridge m a @@ -533,6 +542,10 @@ dualExtValidationErrorMain :: dualExtValidationErrorMain = \case ExtValidationErrorLedger e -> ExtValidationErrorLedger (dualLedgerErrorMain e) ExtValidationErrorHeader e -> ExtValidationErrorHeader (castHeaderError e) + ExtValidationErrorPerasEpochContextResolver e -> ExtValidationErrorPerasEpochContextResolver e + +-- NOTE: the pattern below is redundant because PerasError (DualBlock m a) ~ VoidPerasError m +-- ExtValidationErrorPerasCertInBlock e -> ExtValidationErrorPerasCertInBlock e {------------------------------------------------------------------------------- LedgerSupportsProtocol @@ -1206,3 +1219,21 @@ instance instance LedgerStateSupportsPeras (LedgerState (DualBlock m a)) instance LedgerStateSupportsPeras (Ticked LedgerState (DualBlock m a)) + +instance + ( Bridge m a + , StandardHash m + , Typeable m + , Typeable a + , All Top (HardForkIndices (DualBlock m a)) + , ChainDepStateSupportsPeras (ChainDepState (BlockProtocol m)) + , ChainDepStateSupportsPeras (Ticked (ChainDepState (BlockProtocol m))) + ) => + StateSupportsPerasEpochContext (DualBlock m a) + +instance + ( StandardHash m + , Typeable m + , Typeable a + ) => + BlockSupportsPeras (DualBlock m a) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs index 0f8b55290d..34a41e0816 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} @@ -26,29 +27,63 @@ module Ouroboros.Consensus.Ledger.Extended , decodeExtLedgerState , encodeDiskExtLedgerState , encodeExtLedgerState + , initPerasEpochContextResolver + , mkPerasEpochContextResolverHandle -- * Type family instances , LedgerTables (..) , Ticked (..) ) where +import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Codec.CBOR.Decoding (Decoder, decodeListLenOf) import Codec.CBOR.Encoding (Encoding, encodeListLen) import Control.DeepSeq (NFData) import Control.Monad.Except +import Control.Monad.Trans.Except (except) import Data.Functor ((<&>)) +import Data.Maybe.Strict (StrictMaybe (..)) import Data.Proxy +import Data.SOP.Constraint (All, Top) import Data.Typeable import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import NoThunks.Class (NoThunks (..)) -import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Block.Abstract + ( BlockConfig + , BlockProtocol + , CodecConfig + , GetHeader (getHeader) + , HeaderHash + , StandardHash + , StorageConfig + , castPoint + ) +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (..) + , IsPerasCert (..) + , PerasRoundNo + , ValidatedPerasCert + ) import Ouroboros.Consensus.Config +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (HardForkIndices)) import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) +import Ouroboros.Consensus.Peras.Context + ( PerasEpochContextNotFoundForRound + , PerasEpochContextResolver + , PerasEpochContextResolverHandle (..) + , StateSupportsPerasEpochContext (..) + , initPerasEpochContextResolver + , resolveRoundNo + , tickPerasEpochContextResolver + ) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.Serialisation +import Ouroboros.Consensus.Util.CBOR (decodeStrictMaybe, encodeStrictMaybe) +import Ouroboros.Consensus.Util.IOLike (MonadSTM (STM)) import Ouroboros.Consensus.Util.IndexedMemPack {------------------------------------------------------------------------------- @@ -58,11 +93,25 @@ import Ouroboros.Consensus.Util.IndexedMemPack data ExtValidationError blk = ExtValidationErrorLedger !(LedgerErr LedgerState blk) | ExtValidationErrorHeader !(HeaderError blk) + | ExtValidationErrorPerasEpochContextResolver !PerasEpochContextNotFoundForRound + | ExtValidationErrorPerasCertInBlock !(PerasError blk) deriving Generic -deriving instance LedgerSupportsProtocol blk => Eq (ExtValidationError blk) -deriving instance LedgerSupportsProtocol blk => NoThunks (ExtValidationError blk) -deriving instance LedgerSupportsProtocol blk => Show (ExtValidationError blk) +deriving instance + ( Eq (PerasError blk) + , LedgerSupportsProtocol blk + ) => + Eq (ExtValidationError blk) +deriving instance + ( NoThunks (PerasError blk) + , LedgerSupportsProtocol blk + ) => + NoThunks (ExtValidationError blk) +deriving instance + ( Show (PerasError blk) + , LedgerSupportsProtocol blk + ) => + Show (ExtValidationError blk) -- | Extended ledger state -- @@ -70,14 +119,27 @@ deriving instance LedgerSupportsProtocol blk => Show (ExtValidationError blk) data ExtLedgerState blk mk = ExtLedgerState { ledgerState :: !(LedgerState blk mk) , headerState :: !(HeaderState blk) + , perasEpochContextResolver :: !(PerasEpochContextResolver blk) + , latestPerasCertOnChainRound :: !(StrictMaybe PerasRoundNo) } deriving Generic +mkPerasEpochContextResolverHandle :: + MonadSTM m => STM m (ExtLedgerState blk mk) -> PerasEpochContextResolverHandle m blk +mkPerasEpochContextResolverHandle getLedgerStateSTM = + PerasEpochContextResolverHandle $ perasEpochContextResolver <$> getLedgerStateSTM + deriving instance - (EqMK mk, LedgerSupportsProtocol blk) => + ( EqMK mk + , LedgerSupportsProtocol blk + , Eq (PerasEpochContextResolver blk) + ) => Eq (ExtLedgerState blk mk) deriving instance - (ShowMK mk, LedgerSupportsProtocol blk) => + ( ShowMK mk + , LedgerSupportsProtocol blk + , Show (PerasEpochContextResolver blk) + ) => Show (ExtLedgerState blk mk) -- | We override 'showTypeOf' to show the type of the block @@ -85,7 +147,10 @@ deriving instance -- This makes debugging a bit easier, as the block gets used to resolve all -- kinds of type families. instance - (NoThunksMK mk, LedgerSupportsProtocol blk) => + ( NoThunksMK mk + , LedgerSupportsProtocol blk + , NoThunks (PerasEpochContextResolver blk) + ) => NoThunks (ExtLedgerState blk mk) where showTypeOf _ = show $ typeRep (Proxy @(ExtLedgerState blk)) @@ -137,39 +202,67 @@ data instance Ticked ExtLedgerState blk mk = TickedExtLedgerState { tickedLedgerState :: Ticked LedgerState blk mk , ledgerView :: LedgerView (BlockProtocol blk) , tickedHeaderState :: Ticked (HeaderState blk) + , tickedPerasEpochContextResolver :: PerasEpochContextResolver blk + , tickedLatestPerasCertOnChainRound :: StrictMaybe PerasRoundNo } instance IsLedger LedgerState blk => GetTip (Ticked ExtLedgerState blk) where getTip = castPoint . getTip . tickedLedgerState instance - LedgerSupportsProtocol blk => + ( LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk + , All Top (HardForkIndices blk) + ) => IsLedger ExtLedgerState blk where type LedgerErr ExtLedgerState blk = ExtValidationError blk - applyChainTickLedgerResult evs cfg slot (ExtLedgerState ledger header) = - castLedgerResult ledgerResult <&> \tickedLedgerState -> - let ledgerView :: LedgerView (BlockProtocol blk) - ledgerView = protocolLedgerView lcfg tickedLedgerState - - tickedHeaderState :: Ticked (HeaderState blk) - tickedHeaderState = - tickHeaderState - (configConsensus $ getExtLedgerCfg cfg) - ledgerView - slot - header - in TickedExtLedgerState{..} - where - lcfg :: LedgerConfig blk - lcfg = configLedger $ getExtLedgerCfg cfg - - ledgerResult = applyChainTickLedgerResult evs lcfg slot ledger + applyChainTickLedgerResult + evs + cfg + slot + ExtLedgerState + { ledgerState + , headerState + , latestPerasCertOnChainRound + , perasEpochContextResolver + } = + castLedgerResult ledgerResult <&> \tickedLedgerState -> + let ledgerView :: LedgerView (BlockProtocol blk) + ledgerView = protocolLedgerView lcfg tickedLedgerState + + tickedHeaderState :: Ticked (HeaderState blk) + tickedHeaderState = + tickHeaderState + (configConsensus $ getExtLedgerCfg cfg) + ledgerView + slot + headerState + + tickedPerasEpochContextResolver :: PerasEpochContextResolver blk + tickedPerasEpochContextResolver = + tickPerasEpochContextResolver + lcfg + (perasEpochContextResolver, ledgerState, headerState) + (slot, forgetLedgerTables tickedLedgerState, tickedHeaderState) + + tickedLatestPerasCertOnChainRound :: StrictMaybe PerasRoundNo + tickedLatestPerasCertOnChainRound = latestPerasCertOnChainRound + in TickedExtLedgerState{..} + where + lcfg :: LedgerConfig blk + lcfg = configLedger $ getExtLedgerCfg cfg + + ledgerResult = applyChainTickLedgerResult evs lcfg slot ledgerState applyHelper :: forall blk. - (HasCallStack, LedgerSupportsProtocol blk) => + ( HasCallStack + , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + ) => ( HasCallStack => ComputeLedgerEvents -> LedgerCfg LedgerState blk -> @@ -201,9 +294,77 @@ applyHelper f opts cfg blk TickedExtLedgerState{..} = do ledgerView (getHeader blk) tickedHeaderState - pure $ (\l -> ExtLedgerState l hdr) <$> castLedgerResult ledgerResult -instance (GetBlockKeySets blk, LedgerSupportsProtocol blk) => ApplyBlock ExtLedgerState blk where + -- Only when ticking the 'ExtLedgerState' do we need to update the + -- 'PerasEpochContextResolver'. When applying block on top of a 'Ticked + -- ExtLedgerState', the 'PerasEpochContextResolver' has already been put to + -- the right state by the ticking. + let perasResolver = tickedPerasEpochContextResolver + + -- Update the latest Peras certificate round if the new block contains a + -- certificate from a round more recent than the currently cached one. + mbPerasCert <- extractAndValidatePerasCertFromBlock perasResolver blk + let latestPerasCertOnChainRound = + case getPerasCertRound <$> mbPerasCert of + -- The block does not contain a Peras certificate => keep the old one + Nothing -> do + tickedLatestPerasCertOnChainRound + -- The block contains a Peras certificate => compare it with the old one + Just certInBlockRound -> do + case tickedLatestPerasCertOnChainRound of + SNothing -> + SJust certInBlockRound + SJust prevLatestCertOnChainRound -> + SJust (certInBlockRound `max` prevLatestCertOnChainRound) + pure $ + (\l -> ExtLedgerState l hdr perasResolver latestPerasCertOnChainRound) + <$> castLedgerResult ledgerResult + +-- | Extract and validate a Peras certificate from a block, if it exists. +-- +-- This can fail in several ways: +-- 1. The block contains an opaque Peras certificate that cannot be deserialized. +-- 2. The certificate claims to be from a round we cannot resolve. +-- 3. The certificate is invalid in the epoch resolved for its round. +extractAndValidatePerasCertFromBlock :: + forall blk. + BlockSupportsPeras blk => + PerasEpochContextResolver blk -> + blk -> + Except (LedgerErr ExtLedgerState blk) (Maybe (ValidatedPerasCert blk)) +extractAndValidatePerasCertFromBlock perasResolver blk = do + getPerasCertInBlockOrFail blk >>= \case + Nothing -> + pure Nothing + Just cert -> do + let roundNo = getPerasCertRound cert + context <- resolveRoundNoOrFail roundNo + Just <$> verifyPerasCertOrFail context cert + where + getPerasCertInBlockOrFail = + withExcept ExtValidationErrorPerasCertInBlock + . except + . getPerasCertInBlock + + resolveRoundNoOrFail = + withExcept ExtValidationErrorPerasEpochContextResolver + . except + . resolveRoundNo perasResolver + + verifyPerasCertOrFail context = + withExcept ExtValidationErrorPerasCertInBlock + . except + . verifyPerasCert context + +instance + ( GetBlockKeySets blk + , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk + , All Top (HardForkIndices blk) + ) => + ApplyBlock ExtLedgerState blk + where applyBlockLedgerResultWithValidation doValidate = applyHelper (applyBlockLedgerResultWithValidation doValidate) @@ -211,7 +372,8 @@ instance (GetBlockKeySets blk, LedgerSupportsProtocol blk) => ApplyBlock ExtLedg applyHelper applyBlockLedgerResult reapplyBlockLedgerResult evs cfg blk TickedExtLedgerState{..} = - (\l -> ExtLedgerState l hdr) <$> castLedgerResult ledgerResult + (\l -> ExtLedgerState l hdr perasResolver latestPerasCertOnChainRound) + <$> castLedgerResult ledgerResult where ledgerResult = reapplyBlockLedgerResult @@ -226,6 +388,13 @@ instance (GetBlockKeySets blk, LedgerSupportsProtocol blk) => ApplyBlock ExtLedg (getHeader blk) tickedHeaderState + -- Only when ticking the 'ExtLedgerState' do we need to update the + -- 'PerasEpochContextResolver'. When applying block on top of a 'Ticked + -- ExtLedgerState', the 'PerasEpochContextResolver' has already been put to + -- the right state by the ticking. + perasResolver = tickedPerasEpochContextResolver + latestPerasCertOnChainRound = tickedLatestPerasCertOnChainRound + {------------------------------------------------------------------------------- Serialisation -------------------------------------------------------------------------------} @@ -234,17 +403,26 @@ encodeExtLedgerState :: (LedgerState blk mk -> Encoding) -> (ChainDepState (BlockProtocol blk) -> Encoding) -> (AnnTip blk -> Encoding) -> + (PerasEpochContextResolver blk -> Encoding) -> ExtLedgerState blk mk -> Encoding encodeExtLedgerState encodeLedgerState encodeChainDepState encodeAnnTip - ExtLedgerState{ledgerState, headerState} = + encodePerasEpochContextResolver + ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } = mconcat - [ encodeListLen 2 + [ encodeListLen 4 , encodeLedgerState ledgerState , encodeHeaderState' headerState + , encodePerasEpochContextResolver perasEpochContextResolver + , encodeLatestPerasCertOnChainRound latestPerasCertOnChainRound ] where encodeHeaderState' = @@ -252,11 +430,15 @@ encodeExtLedgerState encodeChainDepState encodeAnnTip + encodeLatestPerasCertOnChainRound :: StrictMaybe PerasRoundNo -> Encoding + encodeLatestPerasCertOnChainRound = encodeStrictMaybe toCBOR + encodeDiskExtLedgerState :: forall blk. ( EncodeDisk blk (LedgerState blk EmptyMK) , EncodeDisk blk (ChainDepState (BlockProtocol blk)) , EncodeDisk blk (AnnTip blk) + , EncodeDisk blk (PerasEpochContextResolver blk) ) => (CodecConfig blk -> ExtLedgerState blk EmptyMK -> Encoding) encodeDiskExtLedgerState cfg = @@ -264,31 +446,46 @@ encodeDiskExtLedgerState cfg = (encodeDisk cfg) (encodeDisk cfg) (encodeDisk cfg) + (encodeDisk cfg) decodeExtLedgerState :: (forall s. Decoder s (LedgerState blk EmptyMK)) -> (forall s. Decoder s (ChainDepState (BlockProtocol blk))) -> (forall s. Decoder s (AnnTip blk)) -> + (forall s. Decoder s (PerasEpochContextResolver blk)) -> (forall s. Decoder s (ExtLedgerState blk EmptyMK)) decodeExtLedgerState decodeLedgerState decodeChainDepState - decodeAnnTip = do - decodeListLenOf 2 + decodeAnnTip + decodePerasEpochContextResolver = do + decodeListLenOf 4 ledgerState <- decodeLedgerState headerState <- decodeHeaderState' - return ExtLedgerState{ledgerState, headerState} + perasEpochContextResolver <- decodePerasEpochContextResolver + latestPerasCertOnChainRound <- decodeLatestPerasCertOnChainRound + return + ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } where decodeHeaderState' = decodeHeaderState decodeChainDepState decodeAnnTip + decodeLatestPerasCertOnChainRound :: forall s. Decoder s (StrictMaybe PerasRoundNo) + decodeLatestPerasCertOnChainRound = decodeStrictMaybe fromCBOR + decodeDiskExtLedgerState :: forall blk. ( DecodeDisk blk (LedgerState blk EmptyMK) , DecodeDisk blk (ChainDepState (BlockProtocol blk)) , DecodeDisk blk (AnnTip blk) + , DecodeDisk blk (PerasEpochContextResolver blk) ) => (CodecConfig blk -> forall s. Decoder s (ExtLedgerState blk EmptyMK)) decodeDiskExtLedgerState cfg = @@ -296,6 +493,7 @@ decodeDiskExtLedgerState cfg = (decodeDisk cfg) (decodeDisk cfg) (decodeDisk cfg) + (decodeDisk cfg) {------------------------------------------------------------------------------- Ledger Tables @@ -305,55 +503,60 @@ instance (NoThunks (TxIn blk), NoThunks (TxOut blk), HasLedgerTables LedgerState blk) => HasLedgerTables ExtLedgerState blk where - projectLedgerTables (ExtLedgerState lstate _) = + projectLedgerTables (ExtLedgerState lstate _ _ _) = projectLedgerTables lstate - withLedgerTables (ExtLedgerState lstate hstate) tables = + withLedgerTables (ExtLedgerState lstate hstate perasResolver latestPerasCertOnChainRound) tables = ExtLedgerState (lstate `withLedgerTables` tables) hstate + perasResolver + latestPerasCertOnChainRound instance (NoThunks (TxIn blk), NoThunks (TxOut blk), HasLedgerTables (Ticked LedgerState) blk) => HasLedgerTables (Ticked ExtLedgerState) blk where - projectLedgerTables (TickedExtLedgerState lstate _view _hstate) = + projectLedgerTables (TickedExtLedgerState lstate _view _hstate _perasResolver _latestPerasCertOnChainRound) = projectLedgerTables lstate withLedgerTables - (TickedExtLedgerState lstate view hstate) + (TickedExtLedgerState lstate view hstate perasResolver latestPerasCertOnChainRound) tables = TickedExtLedgerState (lstate `withLedgerTables` tables) view hstate + perasResolver + latestPerasCertOnChainRound instance CanStowLedgerTables (LedgerState blk) => CanStowLedgerTables (ExtLedgerState blk) where - stowLedgerTables (ExtLedgerState lstate hstate) = - ExtLedgerState (stowLedgerTables lstate) hstate + stowLedgerTables (ExtLedgerState lstate hstate perasResolver latestPerasCertOnChainRound) = + ExtLedgerState (stowLedgerTables lstate) hstate perasResolver latestPerasCertOnChainRound - unstowLedgerTables (ExtLedgerState lstate hstate) = - ExtLedgerState (unstowLedgerTables lstate) hstate + unstowLedgerTables (ExtLedgerState lstate hstate perasResolver latestPerasCertOnChainRound) = + ExtLedgerState (unstowLedgerTables lstate) hstate perasResolver latestPerasCertOnChainRound instance CanUpgradeLedgerTables LedgerState blk => CanUpgradeLedgerTables ExtLedgerState blk where - upgradeTables (ExtLedgerState st0 _) (ExtLedgerState st1 _) = + upgradeTables (ExtLedgerState st0 _ _ _) (ExtLedgerState st1 _ _ _) = upgradeTables st0 st1 instance (txout ~ TxOut blk, IndexedMemPack LedgerState blk txout) => IndexedMemPack ExtLedgerState blk txout where - indexedTypeName p (ExtLedgerState st _) = indexedTypeName p st - indexedPackedByteCount (ExtLedgerState st _) = indexedPackedByteCount st - indexedPackM (ExtLedgerState st _) = indexedPackM st - indexedUnpackM (ExtLedgerState st _) = indexedUnpackM st + indexedTypeName p (ExtLedgerState st _ _ _) = indexedTypeName p st + indexedPackedByteCount (ExtLedgerState st _ _ _) = indexedPackedByteCount st + indexedPackM (ExtLedgerState st _ _ _) = indexedPackM st + indexedUnpackM (ExtLedgerState st _ _ _) = indexedUnpackM st instance LedgerTablesAreTrivial LedgerState blk => LedgerTablesAreTrivial ExtLedgerState blk where - convertMapKind (ExtLedgerState st hst) = ExtLedgerState (convertMapKind st) hst + convertMapKind (ExtLedgerState st hst perasResolver latestPerasCertOnChainRound) = + ExtLedgerState (convertMapKind st) hst perasResolver latestPerasCertOnChainRound instance SerializeTablesWithHint LedgerState blk => SerializeTablesWithHint ExtLedgerState blk where decodeTablesWithHint st = decodeTablesWithHint (ledgerState st) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeras.hs index 3117956bbb..6665bc08d0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeras.hs @@ -4,8 +4,7 @@ {-# LANGUAGE TypeApplications #-} module Ouroboros.Consensus.Ledger.SupportsPeras - ( LedgerSupportsPeras (..) - , LedgerStateSupportsPeras (..) + ( LedgerStateSupportsPeras (..) ) where @@ -14,25 +13,8 @@ import Cardano.Ledger.Coin (Coin (..), compactCoinOrError, knownNonZeroCoin) import Cardano.Ledger.Keys (KeyHash (..), toVRFVerKeyHash) import Cardano.Ledger.State (IndividualPoolStake (..), PoolDistr (..)) import qualified Data.Map as Map -import Ouroboros.Consensus.Block.SupportsPeras - ( PerasParams - , PerasRoundNo - , defaultPerasParams - ) -import Ouroboros.Consensus.Ledger.Abstract (EmptyMK, LedgerState) - --- | Extract Peras information stored in the ledger state (deprecated). --- --- IMPORTANT: we are moving the cached latest Peras cert round from the --- (non-extended) ledger state into the extended one, so we will remove this --- type class during that refactor. -class LedgerSupportsPeras blk where - -- | Extract the round number of the latest Peras certificate stored in the - -- given ledger state (if any). This is needed to coordinate the end of a - -- cooldown period. - getLatestPerasCertRound :: LedgerState blk mk -> Maybe PerasRoundNo - default getLatestPerasCertRound :: LedgerState blk mk -> Maybe PerasRoundNo - getLatestPerasCertRound _ = Nothing +import Ouroboros.Consensus.Block.SupportsPeras (PerasParams, defaultPerasParams) +import Ouroboros.Consensus.Ledger.Abstract (EmptyMK) -- | Extract Peras information stored in the ledger state. class LedgerStateSupportsPeras ledgerState where 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 1e9615d0ba..378b2850c9 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 @@ -344,6 +344,7 @@ bracketChainSyncClient :: ( IOLike m , Ord peer , LedgerSupportsProtocol blk + , BlockSupportsPeras blk , MonadTimer m ) => Tracer m (TraceChainSyncClientEvent blk) -> @@ -856,6 +857,7 @@ chainSyncClient :: forall m blk. ( IOLike m , LedgerSupportsProtocol blk + , BlockSupportsPeras blk ) => ConfigEnv m blk -> DynamicEnv m blk -> @@ -999,6 +1001,7 @@ findIntersectionTop :: forall m blk arrival judgment. ( IOLike m , LedgerSupportsProtocol blk + , BlockSupportsPeras blk ) => ConfigEnv m blk -> DynamicEnv m blk -> @@ -1195,6 +1198,7 @@ knownIntersectionStateTop :: forall m blk arrival judgment. ( IOLike m , LedgerSupportsProtocol blk + , BlockSupportsPeras blk ) => ConfigEnv m blk -> DynamicEnv m blk -> @@ -1649,6 +1653,7 @@ checkKnownInvalid :: forall m blk arrival judgment. ( IOLike m , LedgerSupportsProtocol blk + , BlockSupportsPeras blk ) => ConfigEnv m blk -> DynamicEnv m blk -> @@ -2098,6 +2103,7 @@ invalidBlockRejector :: forall m blk. ( IOLike m , LedgerSupportsProtocol blk + , BlockSupportsPeras blk ) => Tracer m (TraceChainSyncClientEvent blk) -> NodeToNodeVersion -> @@ -2287,7 +2293,9 @@ data ChainSyncClientException -- We store the intersection point the upstream node sent us. (Their (Tip blk)) | forall blk. - LedgerSupportsProtocol blk => + ( LedgerSupportsProtocol blk + , BlockSupportsPeras blk + ) => InvalidBlock -- | Block that triggered the validity check. (Point blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs index a2a02a3aa8..87fd348a58 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} -- | Instantiate 'ObjectPoolReader' and 'ObjectPoolWriter' using Peras -- certificates from the 'PerasCertDB' (or the 'ChainDB' which is wrapping the @@ -11,21 +10,29 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert , makePerasCertPoolWriterFromChainDB ) where -import Control.Monad (join) -import Data.Either (partitionEithers) -import Data.Functor (void) +import Data.Foldable (traverse_) import Data.Map (Map) import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set -import GHC.Exception (throw) -import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (PerasCert) + , IsPerasCert (getPerasCertRound) + , PerasRoundNo + , ValidatedPerasCert (vpcCert) + ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( SystemTime (..) , WithArrivalTime (..) ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API -import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) + ( ObjectPoolReader (..) + , ObjectPoolWriter (..) + ) +import Ouroboros.Consensus.Peras.Context + ( PerasEpochContextResolverHandle + , verifyPerasCertWithHandle + ) +import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB, getPerasEpochContextResolverHandle) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Storage.PerasCertDB.API ( PerasCertDB @@ -33,6 +40,9 @@ import Ouroboros.Consensus.Storage.PerasCertDB.API ) import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB import Ouroboros.Consensus.Util.IOLike + ( IOLike + , MonadSTM (STM, atomically) + ) -- | TODO: replace by `Data.Map.take` as soon as we move to GHC 9.8 takeAscMap :: Int -> Map k v -> Map k v @@ -44,7 +54,9 @@ takeAscMap n = Map.fromDistinctAscList . take n . Map.toAscList -- | Internal helper: create a pool reader from a @getCertsAfter@ function. makePerasCertPoolReader :: - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => ( PerasCertTicketNo -> STM m (Map PerasCertTicketNo (m (WithArrivalTime (ValidatedPerasCert blk)))) ) -> @@ -65,7 +77,9 @@ makePerasCertPoolReader getCertsAfterSTM = } makePerasCertPoolReaderFromCertDB :: - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m makePerasCertPoolReaderFromCertDB perasCertDB = @@ -73,7 +87,9 @@ makePerasCertPoolReaderFromCertDB perasCertDB = (PerasCertDB.getCertsAfter perasCertDB) makePerasCertPoolReaderFromChainDB :: - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => ChainDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m makePerasCertPoolReaderFromChainDB chainDB = @@ -89,20 +105,27 @@ makePerasCertPoolReaderFromChainDB chainDB = -- see 'makePerasCertPoolWriterFromChainDB' which creates a pool writer from the -- 'ChainDB' with proper handling of chain selection side-effects. makePerasCertPoolWriterFromCertDB :: - (StandardHash blk, IOLike m) => + ( IOLike m + , BlockSupportsPeras blk + ) => SystemTime m -> PerasCertDB m blk -> + PerasEpochContextResolverHandle m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m -makePerasCertPoolWriterFromCertDB systemTime perasCertDB = +makePerasCertPoolWriterFromCertDB systemTime perasCertDB resolverHandle = ObjectPoolWriter { opwObjectId = getPerasCertRound - , opwAddObjects = \certs -> - processCerts - systemTime - (PerasCertDB.getCertIds perasCertDB) - (validatePerasCert defaultPerasParams) -- TODO replace when actual plumbing is in place - (void . join . atomically . PerasCertDB.addCert perasCertDB) - certs + , opwAddObjects = \certs -> do + now <- systemTimeCurrent systemTime + atomically $ do + alreadyInDb <- PerasCertDB.getCertIds perasCertDB + let certsNotAlreadyInDb = filter ((`Set.notMember` alreadyInDb) . getPerasCertRound) certs + validatedCerts <- traverse (verifyPerasCertWithHandle resolverHandle) certsNotAlreadyInDb + -- Some certs are invalid => reject the whole batch + -- We could combine the two 'traverse' operations into one in which case + -- any validated cert would be immediately added no matter what is the + -- validity of the other certs in the batch. + traverse_ (PerasCertDB.addCert perasCertDB . WithArrivalTime now) validatedCerts , opwHasObject = do certIds <- PerasCertDB.getCertIds perasCertDB pure $ \roundNo -> Set.member roundNo certIds @@ -111,75 +134,28 @@ makePerasCertPoolWriterFromCertDB systemTime perasCertDB = -- | Create a pool writer from the 'ChainDB'. This properly handles any needed -- chain selection side-effects. makePerasCertPoolWriterFromChainDB :: - (StandardHash blk, IOLike m) => + ( IOLike m + , BlockSupportsPeras blk + ) => SystemTime m -> ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m makePerasCertPoolWriterFromChainDB systemTime chainDB = - ObjectPoolWriter - { opwObjectId = getPerasCertRound - , opwAddObjects = \certs -> - processCerts - systemTime - (ChainDB.getPerasCertIds chainDB) - -- TODO replace when actual plumbing is in place - (validatePerasCert defaultPerasParams) - -- We do not want to block the writer thread on waiting for ChainSel - -- side-effects to complete, so we use the async version of adding - -- certs to the ChainDB and ignore the returned promise. - -- The async action is still launched and executed behind the scenes - -- even though we drop the promise. - (void . ChainDB.addPerasCertAsync chainDB) - certs - , opwHasObject = do - certIds <- ChainDB.getPerasCertIds chainDB - pure $ \roundNo -> Set.member roundNo certIds - } - -data PerasCertInboundException - = forall blk. PerasCertValidationError [PerasError blk] - -deriving instance Show PerasCertInboundException - -instance Exception PerasCertInboundException - --- | Process a batch of inbound Peras certificates received from a peer. --- --- Certificates whose round number is already present in the database (as --- determined by @alreadyInDbSTM@) are silently skipped. The remaining --- certificates are validated; if /any/ certificate in the batch fails --- validation, the entire batch is rejected by throwing a --- 'PerasCertInboundException' (which should make us disconnect from the distant --- peer, see 'withPeer' bracket function from `ouroboros-network`). Otherwise, --- each valid certificate is timestamped with the current wall-clock time and --- added to the database via @addCert@. -processCerts :: - MonadSTM m => - SystemTime m -> - STM m (Set PerasRoundNo) -> - (PerasCert blk -> Either (PerasError blk) (ValidatedPerasCert blk)) -> - (WithArrivalTime (ValidatedPerasCert blk) -> m ()) -> - [PerasCert blk] -> - m () -processCerts systemTime alreadyInDbSTM validateCert addCert certs = do - alreadyInDb <- atomically alreadyInDbSTM - let certsNotAlreadyInDb = filter (not . (`Set.member` alreadyInDb) . getPerasCertRound) certs - now <- systemTimeCurrent systemTime - case partitionEithers (validateCert <$> certsNotAlreadyInDb) of - -- All certs are valid => add them to the pool - ([], validatedCerts) -> - mapM_ - (addCert . WithArrivalTime now) - validatedCerts - -- Some certs are invalid => reject the whole batch - -- - -- N.B. it has been requested in PR review - -- https://github.com/IntersectMBO/ouroboros-consensus/pull/1768#discussion_r2747873186 - -- to gather all validation errors and report them together in the exception - -- rather than just report the first error encountered. - -- This assumes that cert validation is cheap, which may not be true in - -- practice depending on the actual crypto/committee selection scheme. - -- Hence we may revisit this to lazily abort validation upon the first error - -- encountered. - (errs, _) -> - throw (PerasCertValidationError errs) + let resolverHandle = getPerasEpochContextResolverHandle chainDB + in ObjectPoolWriter + { opwObjectId = getPerasCertRound + , opwAddObjects = \certs -> do + now <- systemTimeCurrent systemTime + validatedCerts <- atomically $ do + alreadyInDb <- ChainDB.getPerasCertIds chainDB + let certsNotAlreadyInDb = filter ((`Set.notMember` alreadyInDb) . getPerasCertRound) certs + traverse (verifyPerasCertWithHandle resolverHandle) certsNotAlreadyInDb + -- Some certs are invalid => reject the whole batch + -- We could combine the two 'traverse' operations into one in which case + -- any validated cert would be immediately added no matter what is the + -- validity of the other certs in the batch. + traverse_ (ChainDB.addPerasCertAsync chainDB . WithArrivalTime now) validatedCerts + , opwHasObject = do + certIds <- ChainDB.getPerasCertIds chainDB + pure $ \roundNo -> Set.member roundNo certIds + } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs index 8c853d016d..d8b2dcc2bf 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} -- | Instantiate 'ObjectPoolReader' and 'ObjectPoolWriter' using Peras -- votes from the 'PerasVoteDB' (or the 'ChainDB' which is wrapping the @@ -11,20 +10,30 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote , makePerasVotePoolWriterFromChainDB ) where -import Control.Monad (join) -import Data.Either (partitionEithers) -import Data.Functor (void) +import Data.Foldable (traverse_) import Data.Map (Map) import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set -import GHC.Exception (throw) -import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (PerasVote) + , IsPerasVote + , PerasVoteId + , ValidatedPerasVote (vpvVote) + , getPerasVoteId + ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( SystemTime (..) , WithArrivalTime (..) ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API + ( ObjectPoolReader (..) + , ObjectPoolWriter (..) + ) +import Ouroboros.Consensus.Peras.Context + ( PerasEpochContextResolverHandle + , verifyPerasVoteWithHandle + ) +import Ouroboros.Consensus.Storage.ChainDB (getPerasEpochContextResolverHandle) import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Storage.PerasVoteDB.API @@ -34,6 +43,9 @@ import Ouroboros.Consensus.Storage.PerasVoteDB.API ) import qualified Ouroboros.Consensus.Storage.PerasVoteDB.API as PerasVoteDB import Ouroboros.Consensus.Util.IOLike + ( IOLike + , MonadSTM (STM, atomically) + ) -- | TODO: replace by `Data.Map.take` as soon as we move to GHC 9.8 takeAscMap :: Int -> Map k v -> Map k v @@ -45,7 +57,9 @@ takeAscMap n = Map.fromDistinctAscList . take n . Map.toAscList -- | Internal helper: create a pool reader from a @getVotesAfter@ function. makePerasVotePoolReader :: - IOLike m => + ( IOLike m + , IsPerasVote (PerasVote blk) blk + ) => ( PerasVoteTicketNo -> STM m (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))) ) -> @@ -64,7 +78,9 @@ makePerasVotePoolReader getVotesAfterSTM = } makePerasVotePoolReaderFromVoteDB :: - IOLike m => + ( IOLike m + , IsPerasVote (PerasVote blk) blk + ) => PerasVoteDB m blk -> ObjectPoolReader PerasVoteId (PerasVote blk) PerasVoteTicketNo m makePerasVotePoolReaderFromVoteDB perasVoteDB = @@ -72,7 +88,9 @@ makePerasVotePoolReaderFromVoteDB perasVoteDB = (PerasVoteDB.getVotesAfter perasVoteDB) makePerasVotePoolReaderFromChainDB :: - IOLike m => + ( IOLike m + , IsPerasVote (PerasVote blk) blk + ) => ChainDB m blk -> ObjectPoolReader PerasVoteId (PerasVote blk) PerasVoteTicketNo m makePerasVotePoolReaderFromChainDB chainDB = @@ -90,27 +108,27 @@ makePerasVotePoolReaderFromChainDB chainDB = -- see 'makePerasVotePoolWriterFromChainDB' which creates a pool writer from the -- 'ChainDB' and thus properly handles the produced certs. makePerasVotePoolWriterFromVoteDB :: - (StandardHash blk, IOLike m) => + ( IOLike m + , BlockSupportsPeras blk + ) => SystemTime m -> - -- | This is needed for validating votes (since it is during the validation of - -- votes that we give them a verified weight. In the future, we won't read it - -- from the stake distr directly, but rather use the committee selection data) - STM m PerasVoteStakeDistr -> PerasVoteDB m blk -> + PerasEpochContextResolverHandle m blk -> ObjectPoolWriter PerasVoteId (PerasVote blk) m -makePerasVotePoolWriterFromVoteDB systemTime getStakeDistrSTM perasVoteDB = +makePerasVotePoolWriterFromVoteDB systemTime perasVoteDB resolverHandle = ObjectPoolWriter { opwObjectId = getPerasVoteId - , opwAddObjects = \votes -> - processVotes - systemTime - (PerasVoteDB.getVoteIds perasVoteDB) - -- TODO: in the future we won't need just the stake distribution for - -- validating votes, but also the whole committee selection context - -- (containing vote weights of committee members = voters) - (\vote -> getStakeDistrSTM >>= \sd -> pure $ validatePerasVote defaultPerasParams sd vote) - (void . join . atomically . PerasVoteDB.addVote perasVoteDB) - votes + , opwAddObjects = \votes -> do + now <- systemTimeCurrent systemTime + atomically $ do + alreadyInDb <- PerasVoteDB.getVoteIds perasVoteDB + let votesNotAlreadyInDb = filter ((`Set.notMember` alreadyInDb) . getPerasVoteId) votes + validatedVotes <- traverse (verifyPerasVoteWithHandle resolverHandle) votesNotAlreadyInDb + -- Some votes are invalid => reject the whole batch + -- We could combine the two 'traverse' operations into one in which case + -- any validated vote would be immediately added no matter what is the + -- validity of the other votes in the batch. + traverse_ (PerasVoteDB.addVote perasVoteDB . WithArrivalTime now) validatedVotes , opwHasObject = do voteIds <- PerasVoteDB.getVoteIds perasVoteDB pure $ \voteId -> Set.member voteId voteIds @@ -120,82 +138,28 @@ makePerasVotePoolWriterFromVoteDB systemTime getStakeDistrSTM perasVoteDB = -- This properly handles the produced certs by letting the ChainDB take care -- of them (see 'ChainDB.addPerasVoteWithAsyncCertHandling'). makePerasVotePoolWriterFromChainDB :: - (StandardHash blk, IOLike m) => + ( IOLike m + , BlockSupportsPeras blk + ) => SystemTime m -> - -- | This is needed for validating votes (since its during the validation of - -- votes that we give them a verified weight. In the future, we won't read it - -- from the stake distr directly, but rather use the committee selection data) - STM m PerasVoteStakeDistr -> ChainDB m blk -> ObjectPoolWriter PerasVoteId (PerasVote blk) m -makePerasVotePoolWriterFromChainDB systemTime getStakeDistrSTM chainDB = - ObjectPoolWriter - { opwObjectId = getPerasVoteId - , opwAddObjects = \votes -> - processVotes - systemTime - (ChainDB.getPerasVoteIds chainDB) - -- TODO: in the future we won't need just the stake distribution for - -- validating votes, but also the whole committee selection context - -- (containing vote weights of committee members = voters) - (\vote -> getStakeDistrSTM >>= \sd -> pure $ validatePerasVote defaultPerasParams sd vote) - -- We do not want to block the writer thread on waiting for ChainSel - -- side-effects to complete, so we use the async version of adding - -- votes to the ChainDB and ignore the returned promise. - -- The async action (if any) is still launched and executed behind the - -- scenes even though we drop the promise. - (void . ChainDB.addPerasVoteWithAsyncCertHandling chainDB) - votes - , opwHasObject = do - voteIds <- ChainDB.getPerasVoteIds chainDB - pure $ \voteId -> Set.member voteId voteIds - } - -data PerasVoteInboundException - = forall blk. PerasVoteValidationError [PerasError blk] - -deriving instance Show PerasVoteInboundException - -instance Exception PerasVoteInboundException - --- | Process a batch of inbound Peras votes received from a peer. --- --- Votes whose ID is already present in the database (as determined by --- @alreadyInDbSTM@) are silently skipped. The remaining votes are validated; --- if /any/ vote in the batch fails validation, the entire batch is rejected --- by throwing a 'PerasVoteInboundException' (which should make us disconnect --- from the distant peer, see 'withPeer' bracket function from --- `ouroboros-network`). Otherwise, each valid vote is timestamped with the --- current wall-clock time and added to the database via @addVote@. -processVotes :: - MonadSTM m => - SystemTime m -> - STM m (Set PerasVoteId) -> - (PerasVote blk -> STM m (Either (PerasError blk) (ValidatedPerasVote blk))) -> - (WithArrivalTime (ValidatedPerasVote blk) -> m ()) -> - [PerasVote blk] -> - m () -processVotes systemTime alreadyInDbSTM validateVote addVote votes = do - validationResults <- atomically $ do - alreadyInDb <- alreadyInDbSTM - let votesNotAlreadyInDb = filter (not . (`Set.member` alreadyInDb) . getPerasVoteId) votes - mapM validateVote votesNotAlreadyInDb - now <- systemTimeCurrent systemTime - case partitionEithers validationResults of - -- All votes are valid => add them to the pool - ([], validatedVotes) -> - mapM_ - (addVote . WithArrivalTime now) - validatedVotes - -- Some votes are invalid => reject the whole batch - -- - -- N.B. it has been requested in PR review - -- https://github.com/IntersectMBO/ouroboros-consensus/pull/1768#discussion_r2747873186 - -- to gather all validation errors and report them together in the exception - -- rather than just report the first error encountered. - -- This assumes that vote validation is cheap, which may not be true in - -- practice depending on the actual crypto/committee selection scheme. - -- Hence we may revisit this to lazily abort validation upon the first error - -- encountered. - (errs, _) -> - throw (PerasVoteValidationError errs) +makePerasVotePoolWriterFromChainDB systemTime chainDB = + let resolverHandle = getPerasEpochContextResolverHandle chainDB + in ObjectPoolWriter + { opwObjectId = getPerasVoteId + , opwAddObjects = \votes -> do + now <- systemTimeCurrent systemTime + validatedVotes <- atomically $ do + alreadyInDb <- ChainDB.getPerasVoteIds chainDB + let votesNotAlreadyInDb = filter ((`Set.notMember` alreadyInDb) . getPerasVoteId) votes + traverse (verifyPerasVoteWithHandle resolverHandle) votesNotAlreadyInDb + -- Some votes are invalid => reject the whole batch + -- We could combine the two 'traverse' operations into one in which case + -- any validated vote would be immediately added no matter what is the + -- validity of the other votes in the batch. + traverse_ (ChainDB.addPerasVoteWithAsyncCertHandling chainDB . WithArrivalTime now) validatedVotes + , opwHasObject = do + voteIds <- ChainDB.getPerasVoteIds chainDB + pure $ \voteId -> Set.member voteId voteIds + } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs index 60879daaed..7e71b11ba7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UndecidableSuperClasses #-} -- | Infrastructure required to run a node -- @@ -21,6 +22,7 @@ module Ouroboros.Consensus.Node.Run , RunNode ) where +import Data.SOP (All, Top) import Data.Typeable (Typeable) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config.SupportsNode @@ -31,11 +33,11 @@ import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.SupportsPeerSelection -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Node.InitStorage import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Serialisation +import Ouroboros.Consensus.Peras.Context (StateSupportsPerasEpochContext) import Ouroboros.Consensus.Storage.ChainDB ( ImmutableDbSerialiseConstraints , SerialiseDiskConstraints @@ -60,6 +62,8 @@ class , SerialiseNodeToNode blk (SerialisedHeader blk) , SerialiseNodeToNode blk (GenTx blk) , SerialiseNodeToNode blk (GenTxId blk) + , SerialiseNodeToNode blk (PerasVote blk) + , SerialiseNodeToNode blk (PerasCert blk) ) => SerialiseNodeToNodeConstraints blk where @@ -91,8 +95,8 @@ class SerialiseNodeToClientConstraints blk class - ( LedgerSupportsProtocol blk - , LedgerSupportsPeras blk + ( All Top (HardForkIndices blk) + , LedgerSupportsProtocol blk , InspectLedger blk , HasHardForkHistory blk , LedgerSupportsMempool blk @@ -111,6 +115,8 @@ class , NodeInitStorage blk , BlockSupportsMetrics blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk , BlockSupportsSanityCheck blk , Show (CannotForge blk) , Show (ForgeStateInfo blk) @@ -121,6 +127,8 @@ class , ShowProxy (Header blk) , ShowProxy (BlockQuery blk) , ShowProxy (TxId (GenTx blk)) + , ShowProxy (PerasVote blk) + , ShowProxy (PerasCert blk) , (forall fp. ShowQuery (BlockQuery blk fp)) , CanUpgradeLedgerTables LedgerState blk ) => diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs index 8c7aae0a5b..b75999ddf6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs @@ -42,6 +42,8 @@ import Codec.CBOR.Encoding (Encoding, encodeListLen) import Codec.Serialise (Serialise (decode, encode)) import Data.Kind import Data.SOP.BasicFunctors +import Data.Typeable (Typeable) +import Data.Void (absurd) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool @@ -49,6 +51,8 @@ import Ouroboros.Consensus.Ledger.SupportsMempool , GenTxId ) import Ouroboros.Consensus.Node.NetworkProtocolVersion +import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (Some (..)) import Ouroboros.Network.Block @@ -185,6 +189,14 @@ deriving newtype instance SerialiseNodeToNode blk (GenTxId blk) => SerialiseNodeToNode blk (WrapGenTxId blk) +deriving newtype instance + SerialiseNodeToNode blk (PerasVote blk) => + SerialiseNodeToNode blk (WrapPerasVote blk) + +deriving newtype instance + SerialiseNodeToNode blk (PerasCert blk) => + SerialiseNodeToNode blk (WrapPerasCert blk) + instance ConvertRawHash blk => SerialiseNodeToNode blk (Point blk) where encodeNodeToNode _ccfg _version = encodePoint $ encodeRawHash (Proxy @blk) decodeNodeToNode _ccfg _version = decodePoint $ decodeRawHash (Proxy @blk) @@ -201,32 +213,6 @@ instance SerialiseNodeToNode blk PerasSeatIndex where encodeNodeToNode _ccfg _version = toCBOR . unPerasSeatIndex decodeNodeToNode _ccfg _version = PerasSeatIndex <$> fromCBOR -instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasCert' blk) where - -- Consistent with the 'Serialise' instance for 'PerasCert' defined in Ouroboros.Consensus.Block.SupportsPeras - encodeNodeToNode ccfg version PerasCert{..} = - encodeListLen 2 - <> encodeNodeToNode ccfg version pcCertRound - <> encodeNodeToNode ccfg version pcCertBoostedBlock - decodeNodeToNode ccfg version = do - decodeListLenOf 2 - pcCertRound <- decodeNodeToNode ccfg version - pcCertBoostedBlock <- decodeNodeToNode ccfg version - pure $ PerasCert pcCertRound pcCertBoostedBlock - -instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasVote' blk) where - -- Consistent with the 'Serialise' instance for 'PerasVote' defined in Ouroboros.Consensus.Block.SupportsPeras - encodeNodeToNode ccfg version PerasVote{..} = - encodeListLen 3 - <> encodeNodeToNode ccfg version pvVoteRound - <> encodeNodeToNode ccfg version pvVoteBlock - <> encodeNodeToNode ccfg version pvVoteVoterId - decodeNodeToNode ccfg version = do - decodeListLenOf 3 - pvVoteRound <- decodeNodeToNode ccfg version - pvVoteBlock <- decodeNodeToNode ccfg version - pvVoteVoterId <- decodeNodeToNode ccfg version - pure $ PerasVote pvVoteRound pvVoteBlock pvVoteVoterId - instance SerialiseNodeToNode blk PerasVoteId where -- Consistent with the 'Serialise' instance for 'PerasVoteId' defined in Ouroboros.Consensus.Block.SupportsPeras encodeNodeToNode ccfg version PerasVoteId{..} = @@ -239,6 +225,22 @@ instance SerialiseNodeToNode blk PerasVoteId where pviSeatIndex <- decodeNodeToNode ccfg version pure $ PerasVoteId pviRoundNo pviSeatIndex +instance SerialiseNodeToNode blk (VoidPerasVote blk) where + encodeNodeToNode _ _ = absurd . unVoidPerasVote + decodeNodeToNode _ _ = fail "VoidPerasVote cannot be decoded" + +instance SerialiseNodeToNode blk (VoidPerasCert blk) where + encodeNodeToNode _ _ = absurd . unVoidPerasCert + decodeNodeToNode _ _ = fail "VoidPerasCert cannot be decoded" + +instance Typeable tag => SerialiseNodeToNode blk (V1.PerasVote tag) where + encodeNodeToNode _ccfg _version = toCBOR + decodeNodeToNode _ccfg _version = fromCBOR + +instance Typeable tag => SerialiseNodeToNode blk (V1.PerasCert tag) where + encodeNodeToNode _ccfg _version = toCBOR + decodeNodeToNode _ccfg _version = fromCBOR + deriving newtype instance SerialiseNodeToClient blk (GenTxId blk) => SerialiseNodeToClient blk (WrapGenTxId blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs index c868bd0c12..a04e2f80d8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs @@ -17,9 +17,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} --- TODO: remove this after getting rid of the degenerate 'BlockSupportsPeras' --- instance that renders some of the constraints here redundant. -{-# OPTIONS_GHC -Wno-redundant-constraints #-} module Ouroboros.Consensus.Peras.Context ( -- * Bounded Peras epoch context @@ -34,6 +31,9 @@ module Ouroboros.Consensus.Peras.Context , PerasEpochContextResolverHandle (..) , mockPerasEpochContextResolverHandle , withResolvedRoundNo + , verifyPerasVoteWithHandle + , verifyPerasCertWithHandle + , forgePerasVoteIfEligibleWithHandle -- * Extracting and resolving Peras epoch contexts from the node state , StateSupportsPerasEpochContext (..) @@ -78,19 +78,28 @@ import GHC.Generics (Generic) import Ouroboros.Consensus.Block.Abstract ( BlockProtocol , EpochNo (..) + , Point , SlotNo , WithOrigin (..) ) import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) + , IsPerasCert (..) , IsPerasError (..) + , PerasCert , PerasEpochContext (..) , PerasRoundNo + , PerasVote , PerasVotingCommittee , PerasVotingCommitteeInput + , ValidatedPerasCert + , ValidatedPerasVote + , getPerasVoteRound ) import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee) import qualified Ouroboros.Consensus.Committee.Class as Committee +import Ouroboros.Consensus.Committee.Crypto (PrivateKey) +import Ouroboros.Consensus.Committee.Types (PoolId) import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..)) import Ouroboros.Consensus.HardFork.History.Qry ( EpochToPerasRoundInfo (..) @@ -489,6 +498,55 @@ withResolvedRoundNo handle roundNo k = do Left err -> throwSTM err Right a -> pure a +-- | Like 'verifyPerasVote', but using a 'PerasEpochContextResolverHandle' to +-- resolve the epoch context for the round number of the given vote. +verifyPerasVoteWithHandle :: + ( MonadSTM m + , MonadThrow (STM m) + , BlockSupportsPeras blk + -- , StateSupportsPerasEpochContext blk + ) => + PerasEpochContextResolverHandle m blk -> + PerasVote blk -> + STM m (ValidatedPerasVote blk) +verifyPerasVoteWithHandle handle vote = + withResolvedRoundNo handle (getPerasVoteRound vote) $ \context -> + verifyPerasVote context vote + +-- | Like 'verifyPerasCert', but using a 'PerasEpochContextResolverHandle' to +-- resolve the epoch context for the round number of the given certificate. +verifyPerasCertWithHandle :: + ( MonadSTM m + , MonadThrow (STM m) + , BlockSupportsPeras blk + -- , StateSupportsPerasEpochContext blk + ) => + PerasEpochContextResolverHandle m blk -> + PerasCert blk -> + STM m (ValidatedPerasCert blk) +verifyPerasCertWithHandle handle cert = + withResolvedRoundNo handle (getPerasCertRound cert) $ \context -> + verifyPerasCert context cert + +-- | Like 'forgePerasVoteIfEligible', but using a +-- 'PerasEpochContextResolverHandle' to resolve the epoch context for the given +-- round number. +forgePerasVoteIfEligibleWithHandle :: + ( MonadSTM m + , MonadThrow (STM m) + , BlockSupportsPeras blk + -- , StateSupportsPerasEpochContext blk + ) => + PerasEpochContextResolverHandle m blk -> + PoolId -> + PrivateKey (PerasCrypto blk) -> + PerasRoundNo -> + Point blk -> + STM m (Maybe (ValidatedPerasVote blk)) +forgePerasVoteIfEligibleWithHandle handle poolId privateKey roundNo point = + withResolvedRoundNo handle roundNo $ \context -> + forgePerasVoteIfEligible context poolId privateKey roundNo point + -- * Extracting and resolving Peras epoch contexts from the node state -- | Type-class for blocks that support constructing a Peras epoch contexts from diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS/Unsafe.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS/Unsafe.hs new file mode 100644 index 0000000000..1b2725f384 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS/Unsafe.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Temporary hack for retrieving BLS keys from the environment. +-- +-- * Our private key can be read directly from the value of the environment +-- variable 'PERAS_PRIVATE_KEY'. +-- +-- * Public keys from all nodes (including oneself) can be read from a JSON file +-- specified in the environment variable 'PERAS_PUBLIC_KEY_FILE'. +-- +-- NOTE: keys read using this module always have the "TESTNET" scope. +-- +-- WARNING: this is a temporary hack for testing purposes, and should not be +-- used under any circumstances in production. This will be replaced with proper +-- on-chain key registration in the future. +module Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe + ( unsafePerasBLSPrivateKeyFromEnv + , unsafeExtendPerasStakeDistrWithPublicKeysFromEnv + , unsafePerasBLSPublicKeysFromEnv + ) where + +import Cardano.Ledger.State (IndividualPoolStake (..), PoolDistr (..)) +import Data.Aeson (eitherDecodeFileStrict') +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.String (IsString (..)) +import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS +import Ouroboros.Consensus.Committee.Types (LedgerStake (..), PoolId (..)) +import Ouroboros.Consensus.Peras.Crypto.BLS (PerasPrivateKey (..), PerasPublicKey (..)) +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO) + +keyScope :: BLS.KeyScope +keyScope = "TESTNET" + +-- | Read a private key from the environment variable 'PERAS_PRIVATE_KEY' +unsafePerasBLSPrivateKeyFromEnv :: Either String PerasPrivateKey +unsafePerasBLSPrivateKeyFromEnv = + unsafePerformIO $ + lookupEnv envVar >>= \case + Nothing -> do + pure $ Left $ "Environment variable " <> envVar <> "not set." + Just rawKey -> do + pure $ decodeKey rawKey + where + envVar = + "PERAS_PRIVATE_KEY" + + decodeKey key = + case BLS.rawDeserialisePrivateKey keyScope (fromString key) of + Nothing -> + Left $ "Invalid private key format: " <> key + Just sk -> + Right $ PerasPrivateKey sk +{-# NOINLINE unsafePerasBLSPrivateKeyFromEnv #-} + +-- | Extend a given 'PoolDistr' with the corresponding BLS public keys for each +-- pool retrieved from the JSON file specified in the environment variable +-- 'PERAS_PUBLIC_KEY_FILE'. +-- +-- WARNING: this is a temporary hack for testing purposes, and should not be +-- used under any circumstances in production. This will be replaced with proper +-- on-chain key registration in the future. +unsafeExtendPerasStakeDistrWithPublicKeysFromEnv :: + PoolDistr -> + Either + String + (Map PoolId (LedgerStake, PerasPublicKey)) +unsafeExtendPerasStakeDistrWithPublicKeysFromEnv poolDistr = do + publicKeys <- unsafePerasBLSPublicKeysFromEnv -- uses 'unsafePerformIO' + Map.traverseWithKey + ( \poolId stake -> do + let ledgerStake = + LedgerStake (individualPoolStake stake) + case Map.lookup poolId publicKeys of + Nothing -> + Left ("Public key not found for pool: " <> show poolId) + Just publicKey -> + Right (ledgerStake, publicKey) + ) + . Map.mapKeysMonotonic PoolId + . unPoolDistr + $ poolDistr + +-- | Retrieve the BLS public keys for the Peras committee members from a JSON +-- file specified in the environment variable 'PERAS_PUBLIC_KEY_FILE'. +-- +-- WARNING: this is a temporary hack for testing purposes, and should not be +-- used under any circumstances in production. This will be replaced with proper +-- on-chain key registration in the future. +unsafePerasBLSPublicKeysFromEnv :: Either String (Map PoolId PerasPublicKey) +unsafePerasBLSPublicKeysFromEnv = + unsafePerformIO $ + lookupEnv envVar >>= \case + Nothing -> do + pure $ Left $ "Environment variable " <> envVar <> " not set." + Just keysFile -> do + eitherDecodeFileStrict' keysFile >>= \case + Left err -> do + pure $ Left $ "Failed to parse public keys from file: " <> err + Right rawKeys -> do + pure $ traverse decodeKey (Map.mapKeysMonotonic PoolId rawKeys) + where + envVar = + "PERAS_PUBLIC_KEY_FILE" + + decodeKey key = + case BLS.rawDeserialisePublicKey keyScope (fromString key) of + Nothing -> + Left $ "Invalid public key format: " <> key + Just pk -> + Right $ PerasPublicKey pk +{-# NOINLINE unsafePerasBLSPublicKeysFromEnv #-} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs index b306799ce6..7f71b0880c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs @@ -47,9 +47,10 @@ -- -- = Quorum Threshold and Multiple Winners -- --- The quorum threshold is parameterized via 'PerasParams'. Depending on this --- configuration and the weight distribution, it may be theoretically possible --- for multiple targets to exceed the threshold within the same round. +-- The quorum threshold is parameterized via 'PerasParams' inside +-- 'PerasEpochContext'. Depending on this configuration and the weight +-- distribution, it may be theoretically possible for multiple targets to exceed +-- the threshold within the same round. -- -- This module treats multiple winners as an error condition and rejects votes -- that would cause this, raising instead a 'RoundVoteStateLoserAboveQuorum' @@ -90,18 +91,25 @@ module Ouroboros.Consensus.Peras.Vote.Aggregation , PerasTargetVoteState , getPerasTargetVoteStateTotalWeight , getPerasTargetVoteStateBlock + , PerasVoteCollectionWithQuorum (..) ) where import Control.Exception (assert) +import Control.Monad.Class.MonadSTM (MonadSTM (..)) +import Data.Bifunctor (Bifunctor (..)) import Data.Functor.Compose (Compose (..)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (WithArrivalTime) +import Ouroboros.Consensus.Peras.Context + ( PerasEpochContextNotFoundForRound + , PerasEpochContextResolverHandle (..) + , resolveRoundNo + ) {------------------------------------------------------------------------------- Voting state for a given Peras round @@ -110,6 +118,7 @@ import Ouroboros.Consensus.BlockchainTime (WithArrivalTime) -- | Current vote state for a given round data PerasRoundVoteState blk = PerasRoundVoteState { prvsRoundNo :: !PerasRoundNo + , prvsEpochContext :: !(PerasEpochContext blk) , prvsState :: !(Either (NoQuorum blk) (Quorum blk)) } @@ -234,18 +243,27 @@ getPerasRoundVoteStateMaxTargetedSlot PerasRoundVoteState{prvsState} = -- | Create a fresh round vote state for the given round number freshRoundVoteState :: + MonadSTM m => PerasRoundNo -> - PerasRoundVoteState blk -freshRoundVoteState roundNo = - PerasRoundVoteState - { prvsRoundNo = roundNo - , prvsState = - Left - NoQuorum - { candidateStates = - Map.empty - } - } + PerasEpochContextResolverHandle m blk -> + STM m (Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)) +freshRoundVoteState roundNo resolverHandle = do + resolver <- getPerasEpochContextResolver resolverHandle + pure $ + bimap RoundVoteStateEpochContextNotFound mkFreshRoundVoteState $ + resolveRoundNo resolver roundNo + where + mkFreshRoundVoteState context = + PerasRoundVoteState + { prvsRoundNo = roundNo + , prvsEpochContext = context + , prvsState = + Left + NoQuorum + { candidateStates = + Map.empty + } + } -- | Errors that may occur when updating the round vote state with a new vote data UpdateRoundVoteStateError blk @@ -254,6 +272,8 @@ data UpdateRoundVoteStateError blk (PerasTargetVoteState blk 'Loser) | RoundVoteStateForgingCertError (PerasError blk) + | RoundVoteStateEpochContextNotFound + PerasEpochContextNotFoundForRound -- | Add a vote to an existing round vote aggregate. -- @@ -263,13 +283,12 @@ data UpdateRoundVoteStateError blk -- quorum) or if forging the certificate fails. updatePerasRoundVoteState :: forall blk. - StandardHash blk => + BlockSupportsPeras blk => WithArrivalTime (ValidatedPerasVote blk) -> - PerasParams blk -> PerasRoundVoteState blk -> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk) -updatePerasRoundVoteState vote params roundState = - assert (getPerasVoteRound vote == prvsRoundNo roundState) $ do +updatePerasRoundVoteState vote roundState = + assert (getPerasVoteRound vote == getPerasRoundVoteStateRound roundState) $ do case roundState of -- Quorum not yet reached state@PerasRoundVoteState @@ -281,9 +300,9 @@ updatePerasRoundVoteState vote params roundState = } -> do let updateMaybeCandidateState = \case Nothing -> - candidateOrWinnerVoteStateSingleton params vote + candidateOrWinnerVoteStateSingleton (prvsEpochContext roundState) vote Just oldCandidateState -> - updateCandidateVoteState params vote oldCandidateState + updateCandidateVoteState (prvsEpochContext roundState) vote oldCandidateState candidateOrWinnerState <- updateMaybeCandidateState (Map.lookup (getPerasVotePoint vote) candidateStates) case candidateOrWinnerState of @@ -312,6 +331,7 @@ updatePerasRoundVoteState vote params roundState = PerasRoundVoteState { prvsRoundNo = prvsRoundNo roundState + , prvsEpochContext = prvsEpochContext roundState , prvsState = Right Quorum @@ -355,9 +375,9 @@ updatePerasRoundVoteState vote params roundState = else do let updateMaybeLoserVoteState = \case Nothing -> - loserVoteStateSingleton params winnerState vote + loserVoteStateSingleton (prvsEpochContext roundState) winnerState vote Just oldLoserState -> - updateLoserVoteState params winnerState vote oldLoserState + updateLoserVoteState (prvsEpochContext roundState) winnerState vote oldLoserState loserStates' <- Map.alterF (\mState -> Just <$> updateMaybeLoserVoteState mState) votePoint loserStates @@ -380,49 +400,59 @@ updatePerasRoundVoteState vote params roundState = -- May fail if the state transition is invalid (e.g., a loser going above -- quorum) or if forging the certificate fails. updatePerasRoundVoteStates :: - forall blk. - StandardHash blk => + forall m blk. + (BlockSupportsPeras blk, MonadSTM m) => WithArrivalTime (ValidatedPerasVote blk) -> - PerasParams blk -> + PerasEpochContextResolverHandle m blk -> Map PerasRoundNo (PerasRoundVoteState blk) -> - Either - (UpdateRoundVoteStateError blk) - (PerasRoundVoteState blk, Map PerasRoundNo (PerasRoundVoteState blk)) -updatePerasRoundVoteStates vote params = + STM + m + ( Either + (UpdateRoundVoteStateError blk) + (PerasRoundVoteState blk, Map PerasRoundNo (PerasRoundVoteState blk)) + ) +updatePerasRoundVoteStates vote epochContextResolverHandle = alterMapAndReturnUpdatedValue updateMaybePerasRoundVoteState (getPerasVoteRound vote) where - -- We use the Functor instance of `Compose (Either e) ((,) s)` ≅ - -- `λt. Either e (s, t)` in `Map.alterF`. That way, we can return both the + -- We use the Functor instance of `Compose (STM m) (Compose (Either e) ((,) s))` ≅ + -- `λt. STM m (Either e (s, t))` in `Map.alterF`. That way, we can return both the -- updated map and the updated leaf in one pass, and still handle errors. alterMapAndReturnUpdatedValue :: Ord k => - (Maybe a -> Either e (a, a)) -> + (Maybe a -> STM m (Either e (a, a))) -> k -> Map k a -> - Either e (a, Map k a) + STM m (Either e (a, Map k a)) alterMapAndReturnUpdatedValue f k = - getCompose . Map.alterF (fmap Just . (Compose . f)) k + getCompose . getCompose . Map.alterF (fmap Just . (Compose . Compose . f)) k -- If there is no existing state for the vote's round, create a fresh one. existingOrFreshRoundVoteState :: Maybe (PerasRoundVoteState blk) -> - PerasRoundVoteState blk - existingOrFreshRoundVoteState = - fromMaybe (freshRoundVoteState (getPerasVoteRound vote)) + STM m (Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)) + existingOrFreshRoundVoteState = \case + Nothing -> freshRoundVoteState (getPerasVoteRound vote) epochContextResolverHandle + Just roundState -> pure (Right roundState) -- Update the round state, creating a fresh one if necessary, and returning -- the updated state. updateMaybePerasRoundVoteState :: Maybe (PerasRoundVoteState blk) -> - Either - (UpdateRoundVoteStateError blk) - (PerasRoundVoteState blk, PerasRoundVoteState blk) + STM + m + ( Either + (UpdateRoundVoteStateError blk) + (PerasRoundVoteState blk, PerasRoundVoteState blk) + ) updateMaybePerasRoundVoteState mRoundState = do - let roundState = existingOrFreshRoundVoteState mRoundState - newRoundState <- updatePerasRoundVoteState vote params roundState - pure (newRoundState, newRoundState) + existingOrFreshRoundVoteState mRoundState >>= \case + Left err -> pure (Left err) + Right roundState -> do + case updatePerasRoundVoteState vote roundState of + Left err -> pure (Left err) + Right newRoundState -> pure (Right (newRoundState, newRoundState)) {------------------------------------------------------------------------------- Peras round vote state pattern synonyms @@ -543,28 +573,29 @@ ptvsVoteCollection = \case candidateOrWinnerVoteStateSingleton :: BlockSupportsPeras blk => - PerasParams blk -> + PerasEpochContext blk -> WithArrivalTime (ValidatedPerasVote blk) -> Either (UpdateRoundVoteStateError blk) (PerasVoteStateCandidateOrWinner blk) -candidateOrWinnerVoteStateSingleton params vote = +candidateOrWinnerVoteStateSingleton epochContext vote = let voteCollection = perasVoteCollectionSingleton vote - in case perasVoteCollectionCheckQuorum params voteCollection of + in case perasVoteCollectionCheckQuorum (pecParams epochContext) voteCollection of Just votesWithQuorum -> do - cert <- forgePerasCert params votesWithQuorum `onErr` RoundVoteStateForgingCertError + cert <- forgePerasCert epochContext votesWithQuorum `onErr` RoundVoteStateForgingCertError pure $ BecameWinner $ PerasTargetVoteWinner voteCollection cert Nothing -> pure $ RemainedCandidate $ PerasTargetVoteCandidate voteCollection loserVoteStateSingleton :: - PerasParams blk -> + BlockSupportsPeras blk => + PerasEpochContext blk -> PerasTargetVoteState blk 'Winner -> WithArrivalTime (ValidatedPerasVote blk) -> Either (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser) -loserVoteStateSingleton params winnerState vote = +loserVoteStateSingleton epochContext winnerState vote = let voteCollection = perasVoteCollectionSingleton vote - in case perasVoteCollectionCheckQuorum params voteCollection of + in case perasVoteCollectionCheckQuorum (pecParams epochContext) voteCollection of Just _ -> Left $ RoundVoteStateLoserAboveQuorum winnerState (PerasTargetVoteLoser voteCollection) Nothing -> @@ -590,20 +621,20 @@ data PerasVoteStateCandidateOrWinner blk -- -- May fail if the candidate is elected winner but forging the certificate fails. updateCandidateVoteState :: - StandardHash blk => - PerasParams blk -> + BlockSupportsPeras blk => + PerasEpochContext blk -> WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteState blk 'Candidate -> Either (UpdateRoundVoteStateError blk) (PerasVoteStateCandidateOrWinner blk) -updateCandidateVoteState params vote oldState = +updateCandidateVoteState epochContext vote oldState = let newVoteCollection = perasVoteCollectionAddVote vote (ptvsVoteCollection oldState) in - case perasVoteCollectionCheckQuorum params newVoteCollection of + case perasVoteCollectionCheckQuorum (pecParams epochContext) newVoteCollection of Just votesWithQuorum -> do - cert <- forgePerasCert params votesWithQuorum `onErr` RoundVoteStateForgingCertError + cert <- forgePerasCert epochContext votesWithQuorum `onErr` RoundVoteStateForgingCertError pure $ BecameWinner (PerasTargetVoteWinner newVoteCollection cert) Nothing -> do pure $ RemainedCandidate (PerasTargetVoteCandidate newVoteCollection) @@ -614,16 +645,16 @@ updateCandidateVoteState params vote oldState = -- -- May fail if the loser goes above quorum by adding the vote. updateLoserVoteState :: - StandardHash blk => - PerasParams blk -> + BlockSupportsPeras blk => + PerasEpochContext blk -> PerasTargetVoteState blk 'Winner -> WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteState blk 'Loser -> Either (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser) -updateLoserVoteState params winnerState vote oldState = +updateLoserVoteState epochContext winnerState vote oldState = assert (getPerasVoteTarget vote == pvcTarget (ptvsVoteCollection oldState)) $ do let newVoteCollection = perasVoteCollectionAddVote vote (ptvsVoteCollection oldState) - in case perasVoteCollectionCheckQuorum params newVoteCollection of + in case perasVoteCollectionCheckQuorum (pecParams epochContext) newVoteCollection of Just _ -> Left $ RoundVoteStateLoserAboveQuorum winnerState (PerasTargetVoteLoser newVoteCollection) Nothing -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/V1.hs new file mode 100644 index 0000000000..7d25341969 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/V1.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Ouroboros.Consensus.Peras.Voting.V1 + ( PerasVotingCommitteeScheme + , mkPerasVotingCommitteeInput + ) where + +import Data.Bifunctor (Bifunctor (..)) +import Data.Data (Proxy (..)) +import Ouroboros.Consensus.Block.SupportsPeras (PerasCrypto, PerasParams (..)) +import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) +import Ouroboros.Consensus.Committee.WFA + ( mkExtWFAStakeDistr + , wFATiebreakerWithEpochNonce + ) +import Ouroboros.Consensus.Committee.WFALS (VotingCommitteeInput (..), WFALS) +import Ouroboros.Consensus.Ledger.Abstract (EmptyMK) +import Ouroboros.Consensus.Ledger.SupportsPeras + ( LedgerStateSupportsPeras (..) + ) +import Ouroboros.Consensus.Peras.Crypto.BLS (PerasBLSCrypto) +import Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe + ( unsafeExtendPerasStakeDistrWithPublicKeysFromEnv + ) +import qualified Ouroboros.Consensus.Peras.Error.V1 as V1 +import Ouroboros.Consensus.Protocol.Abstract + ( ChainDepStateSupportsPeras (..) + ) + +type PerasVotingCommitteeScheme = WFALS + +mkPerasVotingCommitteeInput :: + forall blk ledgerState chainDepState. + ( PerasCrypto blk ~ PerasBLSCrypto + , LedgerStateSupportsPeras ledgerState + , ChainDepStateSupportsPeras chainDepState + ) => + ledgerState EmptyMK -> + chainDepState -> + Either (V1.PerasError blk) (VotingCommitteeInput (PerasCrypto blk) WFALS) +mkPerasVotingCommitteeInput ledgerState headerState = do + let epochNonce = getEpochNonce headerState + poolDistr = getPoolDistr ledgerState + -- TODO: replace the following hack with proper on-chain key registration. + stakeDistrWithPublicKeys <- + bimap V1.PerasTemporaryPublicKeyHackError id $ + unsafeExtendPerasStakeDistrWithPublicKeysFromEnv poolDistr + extWFAStakeDistr <- + bimap V1.PerasVotingWFAError id $ + mkExtWFAStakeDistr + (wFATiebreakerWithEpochNonce epochNonce) + stakeDistrWithPublicKeys + pure $ + WFALSVotingCommitteeInput + epochNonce + (perasTargetCommitteeSize (getPerasParams (Proxy @blk) ledgerState)) + extWFAStakeDistr diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs index de345e8de0..751860e3e6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs @@ -28,6 +28,9 @@ module Ouroboros.Consensus.Peras.Weight , weightBoostOfFragment , totalWeightOfFragment , takeVolatileSuffix + + -- * Re-exports + , PerasWeight (..) ) where import Data.Foldable as Foldable (foldl') 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 d77a8bc0e3..12ad36f87f 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 @@ -29,6 +29,8 @@ module Ouroboros.Consensus.Storage.ChainDB.API , AddPerasVoteResult (..) , addPerasCertSync , addPerasVoteSync + , WithBoostedBlockStatus (..) + , forgetBoostedBlockStatus -- * Trigger chain selection , ChainSelectionPromise (..) @@ -94,6 +96,15 @@ import Ouroboros.Consensus.HeaderStateHistory import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended + ( ExtLedgerState + , ExtValidationError + ) +import Ouroboros.Consensus.Peras.Cert.Inclusion (PerasCertInclusionViewHandle) +import Ouroboros.Consensus.Peras.Context + ( PerasEpochContextResolverHandle + , TimeResolutionContextHandle + ) +import Ouroboros.Consensus.Peras.Voting.View (PerasVotingViewHandle (..)) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment import Ouroboros.Consensus.Storage.Common @@ -106,7 +117,8 @@ import Ouroboros.Consensus.Storage.LedgerDB import Ouroboros.Consensus.Storage.PerasCertDB.API ( AddPerasCertResult (..) , PerasCertTicketNo - , WithBoostedBlockStatus + , WithBoostedBlockStatus (..) + , forgetBoostedBlockStatus ) import Ouroboros.Consensus.Storage.PerasVoteDB.API ( AddPerasVoteResult (..) @@ -466,6 +478,21 @@ data ChainDB m blk = ChainDB -- given one, in ascending order. , getPerasVoteIds :: STM m (Set PerasVoteId) -- ^ Get the set of all Peras vote IDs currently in the database. + , getPerasVotingViewHandle :: + PerasVotingViewHandle m blk + -- ^ Returns a handle to obtain a 'PerasVotingView' that is used to decide + -- when to vote with respects to the voting rules. + -- + -- NOTE: This needs to be part of the API because the implementation of the ChainDB + -- has access, during initialization, to the 'TopLevelConfig', but it isn't + -- stored/exposed by the API itself. + , getPerasCertInclusionViewHandle :: + PerasCertInclusionViewHandle m blk + , getTimeResolutionContextHandle :: + TimeResolutionContextHandle m blk + , getPerasEpochContextResolverHandle :: + PerasEpochContextResolverHandle m blk + -- ^ Returns a handle to obtain the 'PerasEpochContext' for a given 'PerasRoundNo' , waitForImmutableBlock :: RealPoint blk -> m (Either SeekBlockError (RealPoint blk)) -- ^ Wait until the immutable tip's slot is equal or greater than the given slot: -- - returns the block when it becomes the immutable tip, 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 a78974d6a9..7fca10a48d 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,16 +50,23 @@ import Control.Tracer import Data.Functor ((<&>)) import qualified Data.Map.Strict as Map import Data.Maybe.Strict (StrictMaybe (..)) +import Data.SOP (All, Top) import GHC.Stack (HasCallStack) import NoThunks.Class import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config -import Ouroboros.Consensus.HardFork.Abstract +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..)) import Ouroboros.Consensus.HeaderValidation (mkHeaderWithTime) -import Ouroboros.Consensus.Ledger.Extended (ledgerState) +import Ouroboros.Consensus.Ledger.Extended (ledgerState, mkPerasEpochContextResolverHandle) import Ouroboros.Consensus.Ledger.Inspect -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.Cert.Inclusion (PerasCertInclusionViewHandle (..)) +import Ouroboros.Consensus.Peras.Context + ( PerasEpochContextResolverHandle (PerasEpochContextResolverHandle) + , StateSupportsPerasEpochContext + , TimeResolutionContextHandle (..) + ) +import Ouroboros.Consensus.Peras.Voting.View (PerasVotingViewHandle (PerasVotingViewHandle)) import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as API import Ouroboros.Consensus.Storage.ChainDB.Impl.Args @@ -99,11 +106,12 @@ import Ouroboros.Network.BlockFetch.ConsensusInterface withDB :: forall m blk a. ( IOLike m + , All Top (HardForkIndices blk) , LedgerSupportsProtocol blk - , LedgerSupportsPeras blk + , StateSupportsPerasEpochContext blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk - , HasHardForkHistory blk , ConvertRawHash blk , SerialiseDiskConstraints blk ) => @@ -115,11 +123,12 @@ withDB args = bracket (fst <$> openDBInternal args True) API.closeDB openDB :: forall m blk. ( IOLike m + , All Top (HardForkIndices blk) , LedgerSupportsProtocol blk - , LedgerSupportsPeras blk + , StateSupportsPerasEpochContext blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk - , HasHardForkHistory blk , ConvertRawHash blk , SerialiseDiskConstraints blk ) => @@ -130,11 +139,12 @@ openDB args = fst <$> openDBInternal args True openDBInternal :: forall m blk. ( IOLike m + , All Top (HardForkIndices blk) , LedgerSupportsProtocol blk - , LedgerSupportsPeras blk + , StateSupportsPerasEpochContext blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk - , HasHardForkHistory blk , ConvertRawHash blk , SerialiseDiskConstraints blk , HasCallStack @@ -196,7 +206,13 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do traceWith tracer $ TraceOpenEvent OpenedLgrDB perasCertDB <- PerasCertDB.createDB argsPerasCertDB - perasVoteDB <- PerasVoteDB.createDB argsPerasVoteDB + perasVoteDB <- + PerasVoteDB.createDB + PerasVoteDB.PerasVoteDbArgs + { PerasVoteDB.pvdbaTracer = PerasVoteDB.pvdbaTracer incompleteArgsPerasVoteDB + , PerasVoteDB.pvdbaPerasEpochContextResolverHandle = + mkPerasEpochContextResolverHandle (LedgerDB.getVolatileTip lgrDB) + } varInvalid <- newTVarIO (WithFingerprint Map.empty (Fingerprint 0)) @@ -311,6 +327,25 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do , addPerasVoteWithAsyncCertHandling = getEnv1 h ChainSel.addPerasVoteWithAsyncCertHandling , getPerasVotesAfter = getEnvSTM1 h Query.getPerasVotesAfter , getPerasVoteIds = getEnvSTM h Query.getPerasVoteIds + , getPerasVotingViewHandle = + PerasVotingViewHandle $ \roundNo -> + getEnvSTM h $ + Query.getPerasVotingView + (topLevelConfigLedger (Args.cdbsTopLevelConfig cdbSpecificArgs)) + roundNo + , getPerasCertInclusionViewHandle = + PerasCertInclusionViewHandle $ \roundNo -> + getEnvSTM h $ + Query.getPerasCertInclusionView roundNo + , getPerasEpochContextResolverHandle = + PerasEpochContextResolverHandle $ + getEnvSTM h $ + Query.getPerasEpochContextResolver + , getTimeResolutionContextHandle = + TimeResolutionContextHandle $ + getEnvSTM h $ + Query.getTimeResolutionContext + (topLevelConfigLedger (Args.cdbsTopLevelConfig cdbSpecificArgs)) , waitForImmutableBlock = getEnv1 h Query.waitForImmutableBlock , getLatestPerasCertOnChainRound = getEnvSTM h Query.getLatestPerasCertOnChainRound } @@ -352,7 +387,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do argsVolatileDb argsLgrDb argsPerasCertDB - argsPerasVoteDB + incompleteArgsPerasVoteDB cdbSpecificArgs = args -- The LedgerDB requires a criterion ('LedgerDB.GetVolatileSuffix') diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs index 47f32ccfd6..7dd45433c3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs @@ -56,7 +56,7 @@ data ChainDbArgs f m blk = ChainDbArgs , cdbVolDbArgs :: VolatileDB.VolatileDbArgs f m blk , cdbLgrDbArgs :: LedgerDB.LedgerDbArgs f m blk , cdbPerasCertDbArgs :: PerasCertDB.PerasCertDbArgs f m blk - , cdbPerasVoteDbArgs :: PerasVoteDB.PerasVoteDbArgs f m blk + , cdbPerasVoteDbArgs :: Incomplete PerasVoteDB.PerasVoteDbArgs m blk , cdbsArgs :: ChainDbSpecificArgs f m blk } @@ -228,7 +228,7 @@ completeChainDbArgs , cdbPerasVoteDbArgs = PerasVoteDB.PerasVoteDbArgs { PerasVoteDB.pvdbaTracer = PerasVoteDB.pvdbaTracer (cdbPerasVoteDbArgs defArgs) - , PerasVoteDB.pvdbaPerasParams = defaultPerasParams + , PerasVoteDB.pvdbaPerasEpochContextResolverHandle = NoDefault } , cdbsArgs = (cdbsArgs defArgs) 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 e7874a1778..060562feaa 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 @@ -92,6 +92,7 @@ import System.Random launchBgTasks :: forall m blk. ( IOLike m + , IsPerasCert (PerasCert blk) blk , LedgerSupportsProtocol blk , BlockSupportsDiffusionPipelining blk , InspectLedger blk @@ -572,6 +573,7 @@ dumpGcSchedule (GcSchedule varQueue) = toList <$> readTVar varQueue -- ChainDB. addBlockRunner :: ( IOLike m + , IsPerasCert (PerasCert blk) blk , LedgerSupportsProtocol blk , BlockSupportsDiffusionPipelining blk , InspectLedger 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 bcbb1c4a36..22cac4b02a 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 @@ -301,7 +301,9 @@ addBlockAsync CDB{cdbTracer, cdbChainSelQueue} = addPerasCertAsync :: forall m blk. - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => ChainDbEnv m blk -> WithArrivalTime (ValidatedPerasCert blk) -> m (AddPerasCertPromise m) @@ -313,7 +315,9 @@ addPerasCertAsync CDB{cdbTracer, cdbChainSelQueue} = -- the ChainDB as well. addPerasVoteWithAsyncCertHandling :: forall m blk. - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => ChainDbEnv m blk -> WithArrivalTime (ValidatedPerasVote blk) -> m (AddPerasVoteResult blk, Maybe (AddPerasCertPromise m)) @@ -346,6 +350,7 @@ triggerChainSelectionAsync CDB{cdbTracer, cdbChainSelQueue} = chainSelSync :: forall m blk. ( IOLike m + , IsPerasCert (PerasCert blk) blk , LedgerSupportsProtocol blk , BlockSupportsDiffusionPipelining blk , InspectLedger blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs index e660989933..ce43a1a7c3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs @@ -27,6 +27,10 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query , getPerasCertIds , getPerasVotesAfter , getPerasVoteIds + , getPerasVotingView + , getPerasCertInclusionView + , getPerasEpochContextResolver + , getTimeResolutionContext , getLatestPerasCertOnChainRound , getStatistics , getTipBlock @@ -43,7 +47,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query , getChainSelStarvation ) where -import Cardano.Ledger.BaseTypes (WithOrigin (..)) +import Cardano.Ledger.BaseTypes (WithOrigin (..), strictMaybeToMaybe) import Control.Monad (void) import Control.Monad.Trans.Class import Control.ResourceRegistry @@ -55,13 +59,31 @@ import Data.Typeable import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Config +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (hardForkSummary)) import Ouroboros.Consensus.HeaderStateHistory ( HeaderStateHistory (..) ) import Ouroboros.Consensus.HeaderValidation (HeaderWithTime) import Ouroboros.Consensus.Ledger.Abstract (EmptyMK) +import Ouroboros.Consensus.Ledger.Basics (LedgerConfig) import Ouroboros.Consensus.Ledger.Extended -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) +import Ouroboros.Consensus.Peras.Cert.Inclusion + ( PerasCertInclusionView + , mkPerasCertInclusionView + ) +import Ouroboros.Consensus.Peras.Context + ( PerasEpochContextResolver + , StateSupportsPerasEpochContext + , TimeResolutionContext (..) + , resolveRoundNo + ) +import Ouroboros.Consensus.Peras.Voting.View + ( PerasVotingView + , WithBoostedBlockStatus + , mkPerasVotingView + , perasChainAtCandidateBlock + , runPerasQry + ) import Ouroboros.Consensus.Peras.Weight ( PerasWeightSnapshot , takeVolatileSuffix @@ -78,7 +100,7 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import Ouroboros.Consensus.Storage.PerasCertDB.API ( PerasCertTicketNo - , WithBoostedBlockStatus + , forgetBoostedBlockStatus ) import Ouroboros.Consensus.Storage.PerasVoteDB.API ( PerasVoteTicketNo @@ -371,6 +393,91 @@ getPerasVoteIds :: ChainDbEnv m blk -> STM m (Set PerasVoteId) getPerasVoteIds CDB{..} = PerasVoteDB.getVoteIds cdbPerasVoteDB +getPerasEpochContextResolver :: + MonadSTM m => + ChainDbEnv m blk -> + STM m (PerasEpochContextResolver blk) +getPerasEpochContextResolver = + fmap perasEpochContextResolver . getCurrentLedger + +getPerasVotingView :: + ( StateSupportsPerasEpochContext blk + , IOLike m + , ConsensusProtocol (BlockProtocol blk) + , GetHeader blk + , BlockSupportsPeras blk + ) => + LedgerConfig blk -> + PerasRoundNo -> + ChainDbEnv m blk -> + STM m (PerasVotingView (WithArrivalTime (ValidatedPerasCert blk)) blk) +getPerasVotingView ledgerConfig roundNo env = do + resolver <- getPerasEpochContextResolver env + perasParams <- case resolveRoundNo resolver roundNo of + Left err -> throwSTM err + Right perasContext -> pure $ pecParams perasContext + latestCertSeen <- + withOriginFromMaybe + <$> getLatestPerasCertSeen env + latestCertOnChainRoundNo <- + withOriginFromMaybe + <$> getLatestPerasCertOnChainRound env + let blockMinSlots = perasBlockMinSlots perasParams + currentChain <- getCurrentChain env + let qry = + perasChainAtCandidateBlock blockMinSlots roundNo currentChain >>= \chainAtCandidateBlock -> + mkPerasVotingView + perasParams + roundNo + latestCertSeen + latestCertOnChainRoundNo + chainAtCandidateBlock + summary <- hardForkSummary ledgerConfig . ledgerState <$> getCurrentLedger env + case runPerasQry summary qry of + Left err -> throwSTM err + Right view -> pure view + +getPerasCertInclusionView :: + ( IOLike m + , BlockSupportsPeras blk + ) => + PerasRoundNo -> + ChainDbEnv m blk -> + STM m (Maybe (PerasCertInclusionView (WithArrivalTime (ValidatedPerasCert blk)) blk)) +getPerasCertInclusionView roundNo env = do + mbLatestCertSeen <- + fmap forgetBoostedBlockStatus + <$> getLatestPerasCertSeen env + case mbLatestCertSeen of + Nothing -> + pure Nothing + Just latestCertSeen -> do + resolver <- getPerasEpochContextResolver env + perasParams <- case resolveRoundNo resolver roundNo of + Left err -> throwSTM err + Right perasContext -> pure $ pecParams perasContext + latestCertOnChainRoundNo <- + withOriginFromMaybe + <$> getLatestPerasCertOnChainRound env + certsInChainDB <- + getPerasCertIds env + pure $ + Just $ + mkPerasCertInclusionView + perasParams + roundNo + latestCertSeen + latestCertOnChainRoundNo + certsInChainDB + +getTimeResolutionContext :: + MonadSTM m => + LedgerConfig blk -> + ChainDbEnv m blk -> + STM m (TimeResolutionContext blk) +getTimeResolutionContext ledgerConfig = + fmap (TimeResolutionContext ledgerConfig . ledgerState) . getCurrentLedger + -- | Wait until the slot of the given point is smaller or equal than the immutable tip slot, -- and then return: -- - the block at the target slot if there is a block in the immutable DB at that slot; @@ -406,12 +513,12 @@ waitForImmutableBlock CDB{cdbImmutableDB} targetRealPoint = do result@Right{} -> pure result getLatestPerasCertOnChainRound :: - (IOLike m, LedgerSupportsPeras blk) => + IOLike m => ChainDbEnv m blk -> STM m (Maybe PerasRoundNo) getLatestPerasCertOnChainRound CDB{..} = do - volatileLedger <- ledgerState <$> LedgerDB.getVolatileTip cdbLedgerDB - pure (getLatestPerasCertRound volatileLedger) + strictMaybeToMaybe . latestPerasCertOnChainRound + <$> LedgerDB.getVolatileTip cdbLedgerDB {------------------------------------------------------------------------------- Unifying interface over the immutable DB and volatile DB, but independent 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 59920d3243..fe73180e4e 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 @@ -394,7 +394,11 @@ data ChainDbEnv m blk = CDB -- (but avoid including @m@ because we cannot impose @Typeable m@ as a -- constraint and still have it work with the simulator) instance - (IOLike m, LedgerSupportsProtocol blk, BlockSupportsDiffusionPipelining blk) => + ( IOLike m + , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , BlockSupportsDiffusionPipelining blk + ) => NoThunks (ChainDbEnv m blk) where showTypeOf _ = "ChainDbEnv m " ++ show (typeRep (Proxy @blk)) @@ -542,7 +546,23 @@ data InvalidBlockInfo blk = InvalidBlockInfo { invalidBlockReason :: !(ExtValidationError blk) , invalidBlockSlotNo :: !SlotNo } - deriving (Eq, Show, Generic, NoThunks) + +deriving instance + ( LedgerSupportsProtocol blk + , BlockSupportsPeras blk + ) => + Show (InvalidBlockInfo blk) +deriving instance + ( LedgerSupportsProtocol blk + , BlockSupportsPeras blk + ) => + Eq (InvalidBlockInfo blk) +deriving instance + ( LedgerSupportsProtocol blk + , BlockSupportsPeras blk + ) => + NoThunks (InvalidBlockInfo blk) +deriving instance Generic (InvalidBlockInfo blk) {------------------------------------------------------------------------------- Blocks to add @@ -638,7 +658,9 @@ addBlockToAdd tracer (ChainSelQueue{varChainSelQueue, varChainSelPoints}) punish -- | Add a Peras certificate to the background queue. addPerasCertToQueue :: - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => Tracer m (TraceAddPerasCertEvent blk) -> ChainSelQueue m blk -> WithArrivalTime (ValidatedPerasCert blk) -> @@ -790,9 +812,10 @@ data TraceEvent blk deriving instance ( Show (Header blk) + , Show (TraceAddBlockEvent blk) , LedgerSupportsProtocol blk + , BlockSupportsPeras blk , InspectLedger blk - , Show (TraceAddBlockEvent blk) ) => Show (TraceEvent blk) @@ -943,6 +966,7 @@ data TraceAddBlockEvent blk deriving instance ( Eq (Header blk) , LedgerSupportsProtocol blk + , BlockSupportsPeras blk , InspectLedger blk , Eq (ReasonForSwitch (WithEmptyFragment (WeightedSelectView (BlockProtocol blk)))) , Eq (ReasonForSwitch (SelectView (BlockProtocol blk))) @@ -951,6 +975,7 @@ deriving instance deriving instance ( Show (Header blk) , LedgerSupportsProtocol blk + , BlockSupportsPeras blk , InspectLedger blk , Show (ReasonForSwitch (WithEmptyFragment (WeightedSelectView (BlockProtocol blk)))) , Show (ReasonForSwitch (SelectView (BlockProtocol blk))) @@ -970,11 +995,13 @@ data TraceValidationEvent blk deriving instance ( Eq (Header blk) , LedgerSupportsProtocol blk + , BlockSupportsPeras blk ) => Eq (TraceValidationEvent blk) deriving instance ( Show (Header blk) , LedgerSupportsProtocol blk + , BlockSupportsPeras blk ) => Show (TraceValidationEvent blk) @@ -1004,11 +1031,13 @@ data TraceInitChainSelEvent blk deriving instance ( Eq (Header blk) , LedgerSupportsProtocol blk + , BlockSupportsPeras blk ) => Eq (TraceInitChainSelEvent blk) deriving instance ( Show (Header blk) , LedgerSupportsProtocol blk + , BlockSupportsPeras blk ) => Show (TraceInitChainSelEvent blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs index c88b01f9d6..3d4cff858f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -18,12 +19,14 @@ module Ouroboros.Consensus.Storage.LedgerDB import Control.Monad.Trans.Class import Control.ResourceRegistry import Control.Tracer ((>$<)) +import Data.SOP (All, Top) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config -import Ouroboros.Consensus.HardFork.Abstract +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..)) import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.Context (StateSupportsPerasEpochContext) import Ouroboros.Consensus.Storage.ImmutableDB.Stream import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Args @@ -47,10 +50,12 @@ import System.FS.API openDB :: forall m blk st. ( IOLike m + , All Top (HardForkIndices blk) , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk , InspectLedger blk , HasCallStack - , HasHardForkHistory blk ) => -- | Stateless initializaton arguments Complete LedgerDbArgs m blk -> 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 070dc632a8..a0471c5bed 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 @@ -220,6 +220,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.API , WhereToTakeSnapshot (..) ) where +import Cardano.Binary (FromCBOR, ToCBOR) import Codec.CBOR.Decoding import Codec.CBOR.Read import Codec.Serialise @@ -231,6 +232,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.MemPack import Data.Proxy import Data.Set (Set) +import Data.Typeable (Typeable) import Data.Word import GHC.Generics (Generic) import NoThunks.Class @@ -275,6 +277,12 @@ type LedgerDbSerialiseConstraints blk = , IndexedMemPack LedgerState blk (TxOut blk) , MemPack (TxIn blk) , SerializeTablesWithHint LedgerState blk + , -- Needed for Peras + Typeable blk + , Typeable (PerasCrypto blk) + , Typeable (PerasVotingCommitteeScheme blk) + , FromCBOR (PerasVotingCommittee blk) + , ToCBOR (PerasVotingCommittee blk) ) -- | The core API of the LedgerDB component 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 0c99b4e023..d09f8490fe 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 @@ -27,6 +27,7 @@ import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (mapMaybe) +import Data.SOP (All, Top) import Data.Set (Set) import qualified Data.Set as Set import Data.Traversable (for) @@ -45,6 +46,7 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.Context (StateSupportsPerasEpochContext) import Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Args @@ -70,8 +72,10 @@ newtype SnapshotExc blk = SnapshotExc {getSnapshotFailure :: SnapshotFailure blk mkInitDb :: forall m blk backend. - ( LedgerSupportsProtocol blk - , HasHardForkHistory blk + ( All Top (HardForkIndices blk) + , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk , Backend m backend blk , IOLike m ) => diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs index 350d6eddba..59889ce713 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs @@ -142,7 +142,9 @@ data AddPerasCertResult -- | After adding a cert, its round number should be present in 'getCertIds'. prop_addCertThenGetCertIds :: - MonadSTM m => + ( MonadSTM m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDB m blk -> WithArrivalTime (ValidatedPerasCert blk) -> m Bool @@ -157,7 +159,9 @@ prop_addCertThenGetCertIds db cert = -- | 'getCertsAfter' with ticket 0 should return all certs in the database. -- NOTE: this property is not purely STM. prop_getCertsAfterZero :: - MonadSTM m => + ( MonadSTM m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDB m blk -> m Bool prop_getCertsAfterZero db = do @@ -167,10 +171,9 @@ prop_getCertsAfterZero db = do pure (allCerts, certIds) allCertValues <- sequence (Map.elems allCertActions) let allCertIds = - Set.fromList $ - fmap - (getPerasCertRound . forgetArrivalTime) - allCertValues + Set.fromList + . fmap getPerasCertRound + $ allCertValues pure $ length allCertActions == Set.size certIds && allCertIds == certIds @@ -192,7 +195,9 @@ prop_getCertsAfterMonotonic db ticketNo = -- | After garbage collection for slot S, no certs with target slot < S should remain. -- NOTE: this property is not purely STM. prop_garbageCollectRemovesOldCerts :: - MonadSTM m => + ( MonadSTM m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDB m blk -> SlotNo -> m Bool @@ -208,7 +213,9 @@ prop_garbageCollectRemovesOldCerts db slotNo = do -- | After adding a cert, the round number reported by 'getLatestCertSeen' -- should be greater than or equal to its previous value. prop_addCertLatestCertSeenMonotonic :: - MonadSTM m => + ( MonadSTM m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDB m blk -> WithArrivalTime (ValidatedPerasCert blk) -> m Bool @@ -225,7 +232,9 @@ prop_addCertLatestCertSeenMonotonic db cert = -- | 'getLatestCertSeen' is not affected by garbage collection. prop_garbageCollectPreservesLatestCertSeen :: - MonadSTM m => + ( MonadSTM m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDB m blk -> SlotNo -> m Bool diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs index ae7b6e97b1..99e2fa9179 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE UndecidableInstances #-} @@ -63,8 +64,15 @@ data PerasCertDbState blk = PerasCertDbState -- ^ The certificate with the highest round number that has been added to the -- db since it has been opened. } - deriving stock (Show, Generic) - deriving anyclass NoThunks + +deriving instance + Show (PerasCert blk) => + Show (PerasCertDbState blk) +deriving instance + NoThunks (PerasCert blk) => + NoThunks (PerasCertDbState blk) +deriving instance + Generic (PerasCertDbState blk) initialPerasCertDbState :: WithFingerprint (PerasCertDbState blk) initialPerasCertDbState = @@ -79,8 +87,8 @@ initialPerasCertDbState = -- | Check that the fields of 'PerasCertDbState' are in sync. invariantForPerasCertDbState :: - WithFingerprint (PerasCertDbState blk) -> - Either String () + IsPerasCert (PerasCert blk) blk => + WithFingerprint (PerasCertDbState blk) -> Either String () invariantForPerasCertDbState pcds = do checkEqual "pcdsCertsByTicket" @@ -115,7 +123,15 @@ data TraceEvent blk AddPerasCertResult | GarbageCollected SlotNo - deriving stock (Show, Eq, Generic) + +deriving instance + Show (PerasCert blk) => + Show (TraceEvent blk) +deriving instance + Eq (PerasCert blk) => + Eq (TraceEvent blk) +deriving instance + Generic (TraceEvent blk) {------------------------------------------------------------------------------ Creating the database @@ -135,7 +151,7 @@ defaultArgs = createDB :: forall m blk. ( IOLike m - , StandardHash blk + , BlockSupportsPeras blk ) => Complete PerasCertDbArgs m blk -> m (PerasCertDB m blk) @@ -170,7 +186,9 @@ createDB args = do -- TODO: we will need to update this method with non-trivial validation logic -- see https://github.com/tweag/cardano-peras/issues/120 implAddCert :: - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDbEnv m blk -> WithArrivalTime (ValidatedPerasCert blk) -> STM m (m AddPerasCertResult) @@ -211,6 +229,7 @@ implAddCert PerasCertDbEnv{pcdbTracer, pcdbState} cert = do implGetWeightSnapshot :: ( IOLike m , StandardHash blk + , IsPerasCert (PerasCert blk) blk ) => PerasCertDbEnv m blk -> STM m (WithFingerprint (PerasWeightSnapshot blk)) @@ -254,7 +273,9 @@ implGetLatestCertSeen PerasCertDbEnv{pcdbState} = do implGarbageCollect :: forall m blk. - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDbEnv m blk -> SlotNo -> STM m (m ()) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs index ef61c941e7..bfc5b39362 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs @@ -3,8 +3,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Storage.PerasVoteDB.API ( PerasVoteDB (..) @@ -32,11 +35,13 @@ import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set +import Data.Typeable (Typeable) import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) +import Ouroboros.Consensus.Peras.Context (PerasEpochContextNotFoundForRound) import Ouroboros.Consensus.Util.MonadSTM.NormalForm (MonadSTM (..)) data PerasVoteDB m blk = PerasVoteDB @@ -83,8 +88,21 @@ data AddPerasVoteResult blk = PerasVoteAlreadyInDB | AddedPerasVoteButDidntGenerateNewCert | AddedPerasVoteAndGeneratedNewCert (ValidatedPerasCert blk) - deriving stock (Generic, Eq, Ord, Show) - deriving anyclass NoThunks + +deriving instance + Show (PerasCert blk) => + Show (AddPerasVoteResult blk) +deriving instance + Eq (PerasCert blk) => + Eq (AddPerasVoteResult blk) +deriving instance + Ord (PerasCert blk) => + Ord (AddPerasVoteResult blk) +deriving instance + NoThunks (PerasCert blk) => + NoThunks (AddPerasVoteResult blk) +deriving instance + Generic (AddPerasVoteResult blk) {------------------------------------------------------------------------------- Exceptions @@ -98,17 +116,31 @@ newtype BlockedPerasRoundWinner blk = BlockedPerasRoundWinner (Point blk, VoteWeight) deriving stock (Show, Eq) -data PerasVoteDbError blk - = -- | Attempted to add a vote that would lead to multiple winners for the - -- same round - MultipleWinnersInRound - PerasRoundNo - (ExistingPerasRoundWinner blk) - (BlockedPerasRoundWinner blk) - | -- | An error occurred while forging a certificate - ForgingCertError (PerasError blk) - deriving stock Show - deriving anyclass Exception +data PerasVoteDbError blk where + -- | Attempted to add a vote that would lead to multiple winners for the same round + MultipleWinnersInRound :: + PerasRoundNo -> + (ExistingPerasRoundWinner blk) -> + (BlockedPerasRoundWinner blk) -> + PerasVoteDbError blk + -- | An error occurred while forging a certificate + ForgingCertError :: + Show (PerasError blk) => + PerasError blk -> + PerasVoteDbError blk + -- | The epoch context for the round of the vote could not be found + EpochContextNotFoundForRound :: + PerasEpochContextNotFoundForRound -> + PerasVoteDbError blk + +deriving instance + StandardHash blk => + Show (PerasVoteDbError blk) +deriving instance + ( StandardHash blk + , Typeable blk + ) => + Exception (PerasVoteDbError blk) -- * Invariants @@ -116,7 +148,9 @@ data PerasVoteDbError blk -- | After adding a vote, its ID should be present in 'getVoteIds'. prop_addVoteThenGetVoteIds :: - MonadSTM m => + ( MonadSTM m + , IsPerasVote (PerasVote blk) blk + ) => PerasVoteDB m blk -> WithArrivalTime (ValidatedPerasVote blk) -> m Bool @@ -130,7 +164,9 @@ prop_addVoteThenGetVoteIds db vote = -- | 'getVotesAfter' with ticket 0 should return all votes in the database. prop_getVotesAfterZero :: - MonadSTM m => + ( MonadSTM m + , IsPerasVote (PerasVote blk) blk + ) => PerasVoteDB m blk -> m Bool prop_getVotesAfterZero db = @@ -161,7 +197,9 @@ prop_getVotesAfterMonotonic db ticketNo = -- | After garbage collection for slot S, no votes with target slot < S should remain. prop_garbageCollectRemovesOldVotes :: - MonadSTM m => + ( MonadSTM m + , IsPerasVote (PerasVote blk) blk + ) => PerasVoteDB m blk -> SlotNo -> m Bool @@ -180,7 +218,10 @@ prop_garbageCollectRemovesOldVotes db slotNo = -- | When adding a vote results in a certificate just being forged for a round, -- this certificate should also be retrievable via 'getForgedCertForRound'. prop_addVoteThenGetForgedCertForRound :: - (MonadSTM m, StandardHash blk) => + ( MonadSTM m + , Eq (PerasCert blk) + , IsPerasVote (PerasVote blk) blk + ) => PerasVoteDB m blk -> WithArrivalTime (ValidatedPerasVote blk) -> m Bool diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs index b049d2dab5..e546cb5b2e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs @@ -4,9 +4,13 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Storage.PerasVoteDB.Impl ( -- * Opening @@ -21,7 +25,6 @@ module Ouroboros.Consensus.Storage.PerasVoteDB.Impl import Control.Monad (when) import Control.Monad.Except (throwError) import Control.Tracer (Tracer, nullTracer, traceWith) -import Data.Data (Typeable) import Data.Foldable (for_) import Data.Foldable qualified as Foldable import Data.Kind (Type) @@ -33,6 +36,7 @@ import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (WithArrivalTime (..)) +import Ouroboros.Consensus.Peras.Context import Ouroboros.Consensus.Peras.Vote.Aggregation import Ouroboros.Consensus.Storage.PerasVoteDB.API import Ouroboros.Consensus.Util.Args @@ -61,8 +65,30 @@ data PerasVoteDbState blk = PerasVoteDbState , pvdsLastTicketNo :: !PerasVoteTicketNo -- ^ The most recent 'PerasVoteTicketNo' (or 'zeroPerasVoteTicketNo' otherwise). } - deriving stock (Show, Generic) - deriving anyclass NoThunks + +deriving instance + ( StandardHash blk + , Show (PerasVote blk) + , Show (PerasCert blk) + , Show (PerasVotingCommittee blk) + ) => + Show (PerasVoteDbState blk) +deriving instance + ( StandardHash blk + , Eq (PerasVote blk) + , Eq (PerasCert blk) + , Eq (PerasVotingCommittee blk) + ) => + Eq (PerasVoteDbState blk) +deriving instance + ( StandardHash blk + , NoThunks (PerasVote blk) + , NoThunks (PerasCert blk) + , NoThunks (PerasVotingCommittee blk) + ) => + NoThunks (PerasVoteDbState blk) +deriving instance + Generic (PerasVoteDbState blk) initialPerasVoteDbState :: WithFingerprint (PerasVoteDbState blk) initialPerasVoteDbState = @@ -77,6 +103,7 @@ initialPerasVoteDbState = -- | Check that the fields of 'PerasVoteState' are in sync. invariantForPerasVoteDbState :: + IsPerasVote (PerasVote blk) blk => WithFingerprint (PerasVoteDbState blk) -> Either String () invariantForPerasVoteDbState pvs = do for_ (Map.toList pvdsRoundVoteStates) $ \(roundNo, prvs) -> @@ -118,7 +145,24 @@ data TraceEvent blk (AddPerasVoteResult blk) | GarbageCollected SlotNo - deriving stock (Show, Eq, Generic) + +deriving instance + ( Show (PerasVote blk) + , Show (PerasCert blk) + ) => + Show (TraceEvent blk) +deriving instance + ( Eq (PerasVote blk) + , Eq (PerasCert blk) + ) => + Eq (TraceEvent blk) +deriving instance + ( NoThunks (PerasVote blk) + , NoThunks (PerasCert blk) + ) => + NoThunks (TraceEvent blk) +deriving instance + Generic (TraceEvent blk) {------------------------------------------------------------------------------ Creating the database @@ -127,25 +171,24 @@ data TraceEvent blk type PerasVoteDbArgs :: (Type -> Type) -> (Type -> Type) -> Type -> Type data PerasVoteDbArgs f m blk = PerasVoteDbArgs { pvdbaTracer :: Tracer m (TraceEvent blk) - , pvdbaPerasParams :: HKD f (PerasParams blk) + , pvdbaPerasEpochContextResolverHandle :: HKD f (PerasEpochContextResolverHandle m blk) } defaultArgs :: Monad m => Incomplete PerasVoteDbArgs m blk defaultArgs = PerasVoteDbArgs { pvdbaTracer = nullTracer - , pvdbaPerasParams = noDefault + , pvdbaPerasEpochContextResolverHandle = noDefault } createDB :: forall m blk. ( IOLike m - , StandardHash blk - , Typeable blk + , BlockSupportsPeras blk ) => Complete PerasVoteDbArgs m blk -> m (PerasVoteDB m blk) -createDB args@PerasVoteDbArgs{pvdbaPerasParams} = do +createDB args@PerasVoteDbArgs{pvdbaPerasEpochContextResolverHandle} = do pvdeState <- newTVarWithInvariantIO (either Just (const Nothing) . invariantForPerasVoteDbState) @@ -157,7 +200,7 @@ createDB args@PerasVoteDbArgs{pvdbaPerasParams} = do } pure PerasVoteDB - { addVote = implAddVote pvdbaPerasParams env + { addVote = implAddVote pvdbaPerasEpochContextResolverHandle env , getVoteIds = implGetVoteIds env , getVotesAfter = implGetVotesAfter env , getForgedCertForRound = implGetForgedCertForRound env @@ -175,15 +218,15 @@ createDB args@PerasVoteDbArgs{pvdbaPerasParams} = do -- TODO: we will need to update this method with non-trivial validation logic -- see https://github.com/tweag/cardano-peras/issues/120 implAddVote :: + forall m blk. ( IOLike m - , StandardHash blk - , Typeable blk + , BlockSupportsPeras blk ) => - PerasParams blk -> + PerasEpochContextResolverHandle m blk -> PerasVoteDbEnv m blk -> WithArrivalTime (ValidatedPerasVote blk) -> STM m (m (AddPerasVoteResult blk)) -implAddVote perasParams PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do +implAddVote resolverHandle PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do let voteId = getPerasVoteId vote addPerasVoteRes <- do WithFingerprint pvds fp <- readTVar pvdeState @@ -208,7 +251,7 @@ implAddVote perasParams PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do pvsVotesByTicket' = Map.insert pvsLastTicketNo' vote (pvdsVotesByTicket pvds) (addPerasVoteRes, pvsRoundVoteStates') <- - case updatePerasRoundVoteStates vote perasParams (pvdsRoundVoteStates pvds) of + updatePerasRoundVoteStates vote resolverHandle (pvdsRoundVoteStates pvds) >>= \case -- Added vote and reached a quorum, forging a new certificate Right (VoteGeneratedNewCert cert, pvsRoundVoteStates') -> pure (AddedPerasVoteAndGeneratedNewCert cert, pvsRoundVoteStates') @@ -237,6 +280,9 @@ implAddVote perasParams PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do Left (RoundVoteStateForgingCertError forgeErr) -> throwSTM $ ForgingCertError forgeErr + Left (RoundVoteStateEpochContextNotFound resolverErr) -> + throwSTM $ + EpochContextNotFoundForRound @blk resolverErr pure ( addPerasVoteRes @@ -281,7 +327,9 @@ implGetForgedCertForRound PerasVoteDbEnv{pvdeState} roundNo = do implGarbageCollect :: forall m blk. - IOLike m => + ( IOLike m + , IsPerasVote (PerasVote blk) blk + ) => PerasVoteDbEnv m blk -> SlotNo -> STM m (m ()) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Ouroboros/Consensus/Peras/Voting/Mock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Ouroboros/Consensus/Peras/Voting/Mock.hs new file mode 100644 index 0000000000..725991d890 --- /dev/null +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Ouroboros/Consensus/Peras/Voting/Mock.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +module Ouroboros.Consensus.Peras.Voting.Mock + ( mkMockPerasVotingCommitteeInput + ) where + +import Cardano.Ledger.State (IndividualPoolStake (..), PoolDistr (..)) +import Cardano.Prelude (maybeToEither) +import Data.Bifunctor (Bifunctor (..)) +import Data.List.NonEmpty (nonEmpty) +import qualified Data.Map as Map +import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras (..)) +import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) +import Ouroboros.Consensus.Committee.Types (LedgerStake (..), PoolId (..)) +import Ouroboros.Consensus.Ledger.Abstract (EmptyMK) +import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras (..)) +import Ouroboros.Consensus.Peras.Crypto.Mock + ( MockPerasCrypto + , MockPerasVotingCommitteeScheme + , VotingCommitteeInput (..) + ) +import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError (..)) + +mkMockPerasVotingCommitteeInput :: + forall blk ledgerState chainDepState. + ( PerasCrypto blk ~ MockPerasCrypto blk + , LedgerStateSupportsPeras ledgerState + ) => + ledgerState EmptyMK -> + chainDepState -> + Either + (MockPerasError blk) + (VotingCommitteeInput (PerasCrypto blk) (MockPerasVotingCommitteeScheme blk)) +mkMockPerasVotingCommitteeInput ledgerState _chainDepState = do + MockPerasVotingCommitteeInput + <$> maybeToEither InputStakeDistrIsEmpty stakeDistr + where + stakeDistr = + nonEmpty + . fmap (bimap PoolId (LedgerStake . individualPoolStake)) + . Map.toList + . unPoolDistr + . getPoolDistr + $ ledgerState 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 7fed326afb..464d83c330 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 @@ -63,9 +63,9 @@ module Test.Ouroboros.Storage.TestBlock , shrinkCorruptions ) where -import Cardano.Binary (DecoderError) +import Cardano.Binary (DecoderError, FromCBOR (..), ToCBOR (..)) import Cardano.Crypto.DSIGN -import Cardano.Ledger.BaseTypes (unNonZero) +import Cardano.Ledger.BaseTypes (StrictMaybe (..), unNonZero) import qualified Codec.CBOR.Decoding as CBOR import qualified Codec.CBOR.Encoding as CBOR import qualified Codec.CBOR.Read as CBOR @@ -86,6 +86,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe (maybeToList) +import Data.Set.NonEmpty.Internal (NESet (..)) import Data.TreeDiff import Data.Void (Void) import Data.Word @@ -108,15 +109,29 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect -import Ouroboros.Consensus.Ledger.SupportsPeras - ( LedgerStateSupportsPeras (..) - , LedgerSupportsPeras (..) - ) +import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras (..)) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Peras.Cert.Mock + ( MockPerasCert (..) + ) +import Ouroboros.Consensus.Peras.Context + ( StateSupportsPerasEpochContext (..) + , mkBoundedPerasEpochContextWith + ) +import Ouroboros.Consensus.Peras.Crypto.Mock + ( MockPerasCrypto + , MockPerasVotingCommitteeScheme + , VotingCommitteeError + ) +import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) +import Ouroboros.Consensus.Peras.Vote.Mock + ( MockPerasVote (..) + ) +import Ouroboros.Consensus.Peras.Voting.Mock (mkMockPerasVotingCommitteeInput) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.BFT import Ouroboros.Consensus.Protocol.ModChainSel @@ -129,6 +144,7 @@ import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.IndexedMemPack import Ouroboros.Consensus.Util.Orphans () import qualified Ouroboros.Network.Mock.Chain as Chain +import Ouroboros.Network.Point (Block) import System.FS.API.Lazy import Test.Cardano.Slotting.Numeric () import Test.Cardano.Slotting.TreeDiff () @@ -136,6 +152,7 @@ import Test.QuickCheck import Test.Util.Orphans.Arbitrary () import Test.Util.Orphans.SignableRepresentation () import Test.Util.Orphans.ToExpr () +import Test.Util.Peras (divisorClosestToQuotient) {------------------------------------------------------------------------------- TestBlock @@ -201,13 +218,13 @@ data TestBody = TestBody -- Note that this is a /local/ number, it is specific to this block, -- other blocks need not be aware of it. , tbIsValid :: !Bool - , tbPerasCertRound :: !(Maybe PerasRoundNo) + , tbPerasCert :: !(Maybe (PerasCert TestBlock)) -- ^ Some real blocks will ocasionally carry a Peras certificate inside their - -- body to coordinate the end of a cooldown period. For the purposes of the - -- ChainDB, we don't really care about the details of the certificate other - -- than its round number, which needs to be stored (and carefully updated - -- whenever a newer one pops up) so it can be used to evaluate the Peras - -- voting rules and decide if a node should resume voting. + -- body to coordinate the end of a cooldown period. + -- NOTE: for the purposes of the ChainDB, we don't care about the details of + -- the certificate other than its round number, which needs to be stored (and + -- carefully updated whenever a newer one pops up) so it can be used to + -- evaluate the Peras voting rules and decide if a node should resume voting. } deriving stock (Eq, Show, Generic) deriving anyclass (NFData, NoThunks, Serialise, Hashable) @@ -625,22 +642,18 @@ instance ApplyBlock LedgerState TestBlock where TestLedger (Chain.blockPoint tb) (BlockHash (blockHash tb)) - ( let - -- NOTE: this bypasses the degenerate global implementation of - -- 'BlockSupportsPeras.getPerasCertInBlock' for 'TestBlock', - -- which currently always returns 'Nothing'. - -- - -- TODO: refactor this to use 'getPerasCertInBlock' after the - -- HFC plumbing for 'BlockSupportsPeras' is in place. - certRoundInBlock = tbPerasCertRound testBody - in - -- the highest Peras certificate round number we've seen so far - case (certRoundInBlock, latestPerasCertRound) of - (Nothing, Nothing) -> Nothing - (Just rb, Nothing) -> Just rb - (Nothing, Just rl) -> Just rl - (Just rb, Just rl) -> Just (rb `max` rl) - ) + latestPerasCertRound' + where + -- The round number of the Peras certificate stored in this block, if any + perasCertRoundInBlock = + either (const Nothing) (fmap getPerasCertRound) (getPerasCertInBlock tb) + -- The highest Peras certificate round number we've seen so far + latestPerasCertRound' = + case (perasCertRoundInBlock, latestPerasCertRound) of + (Nothing, Nothing) -> Nothing + (Just rb, Nothing) -> Just rb + (Nothing, Just rl) -> Just rl + (Just rb, Just rl) -> Just (rb `max` rl) applyBlockLedgerResult = defaultApplyBlockLedgerResult reapplyBlockLedgerResult = @@ -725,13 +738,26 @@ instance LedgerSupportsProtocol TestBlock where protocolLedgerView _ _ = () ledgerViewForecastAt _ = trivialForecast -instance LedgerSupportsPeras TestBlock where - getLatestPerasCertRound = latestPerasCertRound +instance StateSupportsPerasEpochContext TestBlock where + mkBoundedPerasEpochContext = mkBoundedPerasEpochContextWith mkMockPerasVotingCommitteeInput + +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} instance LedgerStateSupportsPeras (LedgerState TestBlock) instance LedgerStateSupportsPeras (Ticked LedgerState TestBlock) +-- NOTE: this is a mocked up implementation without crypto! +instance BlockSupportsPeras TestBlock where + type PerasCrypto TestBlock = MockPerasCrypto TestBlock + type PerasVotingCommitteeScheme TestBlock = MockPerasVotingCommitteeScheme TestBlock + type PerasVote TestBlock = MockPerasVote TestBlock + type PerasCert TestBlock = MockPerasCert TestBlock + type PerasError TestBlock = MockPerasError TestBlock + getPerasCertInBlock = Right . tbPerasCert . testBody + instance HasHardForkHistory TestBlock where type HardForkIndices TestBlock = '[TestBlock] hardForkSummary = neverForksHardForkSummary id @@ -743,12 +769,18 @@ instance InspectLedger TestBlock testInitLedger :: LedgerState TestBlock EmptyMK testInitLedger = TestLedger GenesisPoint GenesisHash Nothing -testInitExtLedger :: ExtLedgerState TestBlock EmptyMK -testInitExtLedger = - ExtLedgerState - { ledgerState = testInitLedger - , headerState = genesisHeaderState () - } +testInitExtLedger :: LedgerConfig TestBlock -> ExtLedgerState TestBlock EmptyMK +testInitExtLedger ledgerConfig = + let ledgerState = testInitLedger + headerState = genesisHeaderState () + perasEpochContextResolver = initPerasEpochContextResolver ledgerConfig ledgerState headerState + latestPerasCertOnChainRound = SNothing + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } -- Only for a single node mkTestConfig :: SecurityParam -> ChunkSize -> TopLevelConfig TestBlock @@ -789,7 +821,19 @@ mkTestConfig k ChunkSize{chunkCanContainEBB, numRegularBlocks} = , eraSlotLength = slotLength , eraSafeZone = HardFork.StandardSafeZone (unNonZero (maxRollbacks k) * 2) , eraGenesisWin = GenesisWindow (unNonZero (maxRollbacks k) * 2) - , eraPerasRoundLength = dijkstraPerasRoundLength + , -- Epoch size is 'numRegularBlocks' (between 5 and 15), and + -- perasRoundLength should divive it. + -- picking the closest divisor to get us about 3 Peras rounds per epoch + -- gives us a suitable distribution of perasRoundLengths: + -- >>> flip divisorClosestToQuotient 3 <$> [5..15] + -- [1,2,1,2,3,2,1,4,1,7,5] + -- TODO: it would be better to generate PerasRoundLength randomly in + -- accordance with the 'ChunkInfo' directly, but that would require an + -- overhaul of how test config is propagated all over this file. + -- See https://github.com/tweag/cardano-peras/issues/257 + eraPerasRoundLength = + PerasEnabled . PerasRoundLength $ + divisorClosestToQuotient numRegularBlocks 3 } instance ImmutableEraParams TestBlock where @@ -940,16 +984,24 @@ corruptionFiles = map snd . NE.toList Orphans -------------------------------------------------------------------------------} +-- ** Hashable + deriving newtype instance Hashable SlotNo deriving newtype instance Hashable BlockNo deriving newtype instance Hashable PerasRoundNo -instance Hashable IsEBB - --- use generic instance +instance Hashable IsEBB +instance Hashable TestHeader +instance Hashable TestBlock +instance Hashable (Block SlotNo TestHeaderHash) +instance Hashable (Point TestBlock) +instance Hashable PerasSeatIndex +instance Hashable (NESet PerasSeatIndex) +instance Hashable (MockPerasCert TestBlock) +instance (Hashable a, Hashable (WithOrigin a)) => Hashable (WithOrigin a) instance (StandardHash b, Hashable (HeaderHash b)) => Hashable (ChainHash b) --- use generic instance +-- ** ToExpr instance ToExpr EBB instance ToExpr IsEBB @@ -971,6 +1023,20 @@ deriving instance ToExpr (HeaderEnvelopeError TestBlock) deriving instance ToExpr BftValidationErr deriving instance ToExpr (ExtValidationError TestBlock) +deriving anyclass instance + ToExpr (VotingCommitteeError (MockPerasCrypto TestBlock) (MockPerasVotingCommitteeScheme TestBlock)) + deriving anyclass instance ToExpr FsPath deriving anyclass instance ToExpr BlocksPerFile deriving instance ToExpr BinaryBlockInfo + +-- ** Serialise for MockPerasCert via FromCBOR/ToCBOR +instance Serialise (MockPerasCert TestBlock) where + encode = toCBOR + decode = fromCBOR + +-- ** FromCBOR/ToCBOR for Point TestBlock via Serialise +instance FromCBOR (Point TestBlock) where + fromCBOR = decode +instance ToCBOR (Point TestBlock) where + toCBOR = encode diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs index d32be17fba..bc762e24ce 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -21,7 +21,6 @@ import Ouroboros.Consensus.HardFork.History.EraParams (eraEpochSize) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) import Ouroboros.Consensus.Ledger.SupportsProtocol -import Ouroboros.Consensus.Peras.Params (defaultPerasParams) import Ouroboros.Consensus.Storage.ChainDB hiding ( TraceFollowerEvent (..) ) @@ -140,7 +139,7 @@ fromMinimalChainDbArgs MinimalChainDbArgs{..} = , cdbPerasVoteDbArgs = PerasVoteDbArgs { pvdbaTracer = nullTracer - , pvdbaPerasParams = defaultPerasParams + , pvdbaPerasEpochContextResolverHandle = NoDefault } , cdbsArgs = ChainDbSpecificArgs diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs index 9ca11e1a40..03bafd389d 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs @@ -12,16 +12,29 @@ module Test.Util.Orphans.ToExpr () where import qualified Control.Monad.Class.MonadTime.SI as SI +import Data.Maybe.Strict (StrictMaybe) +import Data.Set.NonEmpty (NESet) import Data.TreeDiff import GHC.Generics (Generic) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime, WithArrivalTime) +import Ouroboros.Consensus.Committee.Class (VotingCommittee) +import Ouroboros.Consensus.Committee.WFA (SeatIndex) import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Mempool.API import Ouroboros.Consensus.Mempool.TxSeq +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert) +import Ouroboros.Consensus.Peras.Context + ( PerasEpochContextNotFoundForRound + , PerasEpochContextResolver + ) +import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasVotingCommitteeScheme) +import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) +import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote) +import Ouroboros.Consensus.Peras.Voting.Adapter (PerasConversionError) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API (LoE (..)) import Ouroboros.Consensus.Storage.ImmutableDB @@ -63,6 +76,7 @@ instance ( ToExpr (LedgerState blk EmptyMK) , ToExpr (ChainDepState (BlockProtocol blk)) , ToExpr (TipInfo blk) + , Show (PerasVotingCommittee blk) ) => ToExpr (ExtLedgerState blk EmptyMK) @@ -122,14 +136,42 @@ deriving instance ToExpr a => ToExpr (LoE a) deriving anyclass instance ToExpr PerasRoundNo +deriving instance ToExpr a => ToExpr (StrictMaybe a) + deriving anyclass instance ToExpr PerasWeight -deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (PerasCert' blk) +deriving anyclass instance ToExpr VoteWeight -deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (ValidatedPerasCert blk) +deriving anyclass instance ToExpr PerasVoteId deriving anyclass instance ToExpr a => ToExpr (WithArrivalTime a) +deriving anyclass instance ToExpr a => ToExpr (NESet a) + +instance ToExpr (HeaderHash blk) => ToExpr (MockPerasVote blk) +instance ToExpr (HeaderHash blk) => ToExpr (MockPerasCert blk) + +instance ToExpr (PerasVotingCommitteeError blk) => ToExpr (MockPerasError blk) + +instance + Show (PerasVotingCommittee blk) => + ToExpr (VotingCommittee crypto (MockPerasVotingCommitteeScheme blk)) + where + toExpr = defaultExprViaShow + +instance + Show (PerasVotingCommittee blk) => + ToExpr (PerasEpochContextResolver blk) + where + toExpr = defaultExprViaShow + +deriving anyclass instance ToExpr PerasEpochContextNotFoundForRound + +deriving anyclass instance ToExpr SeatIndex +deriving anyclass instance ToExpr PerasSeatIndex + +deriving anyclass instance ToExpr PerasConversionError + {------------------------------------------------------------------------------- si-timers --------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs index c37b0d11f4..2e0733637c 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs @@ -5,9 +5,12 @@ module Test.Util.Peras.Mock ( genMockPerasVotingCommitteeInput , genMockPerasVotingCommittee + , genMockPerasEpochContext , genMockPerasVote + , genMockValidatedPerasVote , genMockPerasCert , genMockPerasCertFullCommittee + , genMockValidatedPerasCert , genMockPerasVoterIndices , pickSeatIndexFromCommittee , genVotersSubset @@ -18,6 +21,14 @@ import Data.Either (fromRight) import qualified Data.List.NonEmpty as NonEmpty import Data.Set (Set) import qualified Data.Set.NonEmpty as NESet +import Ouroboros.Consensus.Block + ( PerasParams (..) + ) +import Ouroboros.Consensus.Block.SupportsPeras + ( PerasEpochContext (..) + , ValidatedPerasCert (..) + , ValidatedPerasVote (..) + ) import Ouroboros.Consensus.Committee.Class import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) import Ouroboros.Consensus.Peras.Crypto.Mock @@ -25,6 +36,7 @@ import Ouroboros.Consensus.Peras.Crypto.Mock , MockPerasVotingCommitteeScheme , VotingCommittee (..) , VotingCommitteeInput (..) + , getEligibilityWitness , unsafeIntToSeatIndex ) import Ouroboros.Consensus.Peras.Types (PerasSeatIndex (..)) @@ -34,6 +46,7 @@ import Test.Util.Peras.Common ( NonEmptyListWithUniqueIds (..) , genLedgerStake , genNonEmptyListWithUniqueIds + , genPerasParams , genPointTestBlock , genPoolId , genRoundNo @@ -62,6 +75,12 @@ genMockPerasVotingCommittee = . mkVotingCommittee <$> genMockPerasVotingCommitteeInput +genMockPerasEpochContext :: Gen (PerasEpochContext TestBlock) +genMockPerasEpochContext = + PerasEpochContext + <$> genMockPerasVotingCommittee + <*> genPerasParams + pickSeatIndexFromCommittee :: VotingCommittee (MockPerasCrypto TestBlock) @@ -106,6 +125,28 @@ genMockPerasVote committee = do , mockVoteBlock = block } +genMockValidatedPerasVote :: + PerasEpochContext TestBlock -> + Gen (ValidatedPerasVote TestBlock) +genMockValidatedPerasVote context = do + let committee = pecCommittee context + vote <- genMockPerasVote committee + let voteWeight = + case getEligibilityWitness committee (mockVoteSeatIndex vote) of + Just witness -> + eligiblePartyVoteWeight committee witness + Nothing -> + error $ + unlines + [ "genMockValidatedPerasVote: seat index of vote generated from" + , " the committee should be part of the committee" + ] + pure + ValidatedPerasVote + { vpvVote = vote + , vpvVoteWeight = voteWeight + } + genMockPerasCert :: VotingCommittee (MockPerasCrypto TestBlock) @@ -143,3 +184,16 @@ genMockPerasCertFullCommittee committee = do , mockCertRound = roundNo , mockCertBlock = block } + +genMockValidatedPerasCert :: + PerasEpochContext TestBlock -> + Gen (ValidatedPerasCert TestBlock) +genMockValidatedPerasCert context = do + let committee = pecCommittee context + let params = pecParams context + cert <- genMockPerasCertFullCommittee committee + pure $ + ValidatedPerasCert + { vpcCert = cert + , vpcCertBoost = perasWeight params + } diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs index b9e89ebbda..1313f23be6 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs @@ -87,6 +87,9 @@ import Ouroboros.Consensus.Node.Run , SerialiseNodeToNodeConstraints (..) ) import Ouroboros.Consensus.Node.Serialisation +import Ouroboros.Consensus.Peras.Context + ( PerasEpochContextResolver + ) import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) import Ouroboros.Consensus.Storage.ChainDB (SerialiseDiskConstraints) import Ouroboros.Consensus.Storage.Serialisation @@ -905,7 +908,13 @@ $( do ) examplesRoundtrip :: forall blk. - (SerialiseDiskConstraints blk, Eq blk, Show blk, LedgerSupportsProtocol blk) => + ( SerialiseDiskConstraints blk + , Eq blk + , Show blk + , LedgerSupportsProtocol blk + , Eq (PerasEpochContextResolver blk) + , Show (PerasEpochContextResolver blk) + ) => CodecConfig blk -> Examples blk -> [TestTree] 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 76b46ccc00..d1e7d4fd0d 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -90,7 +90,7 @@ module Test.Util.TestBlock , updateToNextNumeral ) where -import Cardano.Binary (DecoderError) +import Cardano.Binary (DecoderError, FromCBOR (..), ToCBOR (..)) import Cardano.Crypto.DSIGN import Cardano.Ledger.BaseTypes (knownNonZeroBounded, unNonZero) import qualified Codec.CBOR.Decoding as CBOR @@ -136,13 +136,26 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.Query -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) +import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Peras.Cert.Mock + ( MockPerasCert (..) + ) +import Ouroboros.Consensus.Peras.Context + ( StateSupportsPerasEpochContext (..) + , mkBoundedPerasEpochContextWith + ) +import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCrypto, MockPerasVotingCommitteeScheme) +import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) import Ouroboros.Consensus.Peras.SelectView (weightedSelectView) +import Ouroboros.Consensus.Peras.Vote.Mock + ( MockPerasVote (..) + ) +import Ouroboros.Consensus.Peras.Voting.Mock (mkMockPerasVotingCommitteeInput) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.BFT @@ -632,12 +645,25 @@ deriving anyclass instance NoThunks (Ticked LedgerState (TestBlockWith ptype) mk) testInitExtLedgerWithState :: + ( Typeable ptype + , HasLedgerTables LedgerState (TestBlockWith ptype) + ) => PayloadDependentState ptype mk -> ExtLedgerState (TestBlockWith ptype) mk testInitExtLedgerWithState st = - ExtLedgerState - { ledgerState = testInitLedgerWithState st - , headerState = genesisHeaderState () - } + let ledgerState = testInitLedgerWithState st + headerState = genesisHeaderState () + perasEpochContextResolver = + initPerasEpochContextResolver + (configLedger singleNodeTestConfig) + (forgetLedgerTables ledgerState) + headerState + latestPerasCertOnChainRound = SNothing + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } data TestBlockLedgerConfig = TestBlockLedgerConfig { tblcHardForkParams :: !HardFork.EraParams @@ -692,9 +718,36 @@ instance PayloadSemantics ptype => LedgerSupportsProtocol (TestBlockWith ptype) ledgerViewForecastAt cfg state = constantForecastInRange (strictMaybeToMaybe (tblcForecastRange cfg)) () (getTipSlot state) -instance LedgerSupportsPeras (TestBlockWith ptype) +instance LedgerStateSupportsPeras (LedgerState (TestBlockWith ptype)) + +instance LedgerStateSupportsPeras (Ticked LedgerState (TestBlockWith ptype)) + +instance Typeable ptype => StateSupportsPerasEpochContext (TestBlockWith ptype) where + mkBoundedPerasEpochContext = mkBoundedPerasEpochContextWith mkMockPerasVotingCommitteeInput + +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: this is a mocked up implementation without crypto! +instance + Typeable ptype => + BlockSupportsPeras (TestBlockWith ptype) + where + type PerasCrypto (TestBlockWith ptype) = MockPerasCrypto (TestBlockWith ptype) + type + PerasVotingCommitteeScheme (TestBlockWith ptype) = + MockPerasVotingCommitteeScheme (TestBlockWith ptype) + type PerasVote (TestBlockWith ptype) = MockPerasVote (TestBlockWith ptype) + type PerasCert (TestBlockWith ptype) = MockPerasCert (TestBlockWith ptype) + type PerasError (TestBlockWith ptype) = MockPerasError (TestBlockWith ptype) + +{------------------------------------------------------------------------------- + Test infrastructure: config +-------------------------------------------------------------------------------} singleNodeTestConfigWith :: + forall ptype. CodecConfig (TestBlockWith ptype) -> StorageConfig (TestBlockWith ptype) -> SecurityParam -> @@ -753,8 +806,8 @@ data instance CodecConfig TestBlock = TestBlockCodecConfig data instance StorageConfig TestBlock = TestBlockStorageConfig deriving (Show, Generic, NoThunks) -instance HasHardForkHistory TestBlock where - type HardForkIndices TestBlock = '[TestBlock] +instance HasHardForkHistory (TestBlockWith ptype) where + type HardForkIndices (TestBlockWith ptype) = '[TestBlockWith ptype] hardForkSummary = neverForksHardForkSummary tblcHardForkParams data instance BlockQuery TestBlock fp result where @@ -971,8 +1024,8 @@ instance Serialise (AnnTip (TestBlockWith ptype)) where decode = defaultDecodeAnnTip decode instance PayloadSemantics ptype => Serialise (ExtLedgerState (TestBlockWith ptype) EmptyMK) where - encode = encodeExtLedgerState encode encode encode - decode = decodeExtLedgerState decode decode decode + encode = encodeExtLedgerState encode encode encode toCBOR + decode = decodeExtLedgerState decode decode decode fromCBOR instance Serialise (RealPoint (TestBlockWith ptype)) where encode = encodeRealPoint encode 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 65067e6667..52c5d3a067 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 @@ -101,10 +101,7 @@ import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.SupportsPeerSelection -import Ouroboros.Consensus.Ledger.SupportsPeras - ( LedgerStateSupportsPeras - , LedgerSupportsPeras - ) +import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras) import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Mock.Ledger.Address import Ouroboros.Consensus.Mock.Ledger.State @@ -527,8 +524,6 @@ instance MockProtocolSpecific c ext => CommonProtocolParams (SimpleBlock c ext) instance LedgerSupportsPeerSelection (SimpleBlock c ext) where getPeers = const [] -instance LedgerSupportsPeras (SimpleBlock c ext) - instance LedgerStateSupportsPeras (LedgerState (SimpleBlock c ext)) instance LedgerStateSupportsPeras (Ticked LedgerState (SimpleBlock c ext)) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PBFT.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PBFT.hs index 91a0e51a1c..bf6884b833 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PBFT.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PBFT.hs @@ -38,6 +38,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Mock.Ledger.Block import Ouroboros.Consensus.Mock.Ledger.Forge import Ouroboros.Consensus.Mock.Node.Abstract +import Ouroboros.Consensus.Mock.Node.Peras () import Ouroboros.Consensus.Protocol.PBFT import qualified Ouroboros.Consensus.Protocol.PBFT.State as S import Ouroboros.Consensus.Protocol.Signed diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/Praos.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/Praos.hs index d9ed462ecb..2509b18fa9 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/Praos.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/Praos.hs @@ -37,6 +37,7 @@ import Ouroboros.Consensus.Mock.Ledger.Address import Ouroboros.Consensus.Mock.Ledger.Block import Ouroboros.Consensus.Mock.Ledger.Forge import Ouroboros.Consensus.Mock.Node.Abstract +import Ouroboros.Consensus.Mock.Node.Peras () import Ouroboros.Consensus.Mock.Protocol.Praos import Ouroboros.Consensus.Protocol.Signed import Ouroboros.Consensus.Storage.Serialisation diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs index 4dac7e982b..e181e4475f 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs @@ -31,6 +31,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Mock.Ledger.Block import Ouroboros.Consensus.Mock.Ledger.Forge import Ouroboros.Consensus.Mock.Node.Abstract +import Ouroboros.Consensus.Mock.Node.Peras () import Ouroboros.Consensus.Mock.Protocol.LeaderSchedule import Ouroboros.Consensus.Mock.Protocol.Praos import Ouroboros.Consensus.NodeId (CoreNodeId) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs index 7cb4b6623f..f3dfe29fdc 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs @@ -74,6 +74,9 @@ instance , Show (ForgeStateUpdateError (SimpleBlock SimpleMockCrypto ext)) , Serialise ext , RunMockBlock SimpleMockCrypto ext + , ChainDepStateSupportsPeras (ChainDepState (BlockProtocol (SimpleBlock SimpleMockCrypto ext))) + , ChainDepStateSupportsPeras + (Ticked (ChainDepState (BlockProtocol (SimpleBlock SimpleMockCrypto ext)))) ) => RunNode (SimpleBlock SimpleMockCrypto ext) @@ -99,7 +102,7 @@ simpleBlockForging aCanBeLeader aForgeExt = , canBeLeader = aCanBeLeader , updateForgeState = \_ _ _ -> return $ ForgeStateUpdated () , checkCanForge = \_ _ _ _ _ -> return () - , forgeBlock = \cfg bno slot lst txs proof -> + , forgeBlock = \cfg bno slot _mbPerasCert lst txs proof -> return $ forgeSimple aForgeExt diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs index 7892c13b75..b7729da155 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NamedFieldPuns #-} + module Ouroboros.Consensus.Mock.Node.BFT ( MockBftBlock , blockForgingBft @@ -5,12 +7,14 @@ module Ouroboros.Consensus.Mock.Node.BFT ) where import Cardano.Crypto.DSIGN +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import qualified Data.Map.Strict as Map import Ouroboros.Consensus.Block.Forging (BlockForging) import Ouroboros.Consensus.Config import qualified Ouroboros.Consensus.HardFork.History as HardFork import Ouroboros.Consensus.HeaderValidation -import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..), initPerasEpochContextResolver) +import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Mock.Ledger import Ouroboros.Consensus.Mock.Node import Ouroboros.Consensus.Node.ProtocolInfo @@ -26,34 +30,46 @@ protocolInfoBft :: HardFork.EraParams -> ProtocolInfo MockBftBlock protocolInfoBft numCoreNodes nid securityParam eraParams = - ProtocolInfo - { pInfoConfig = - TopLevelConfig - { topLevelConfigProtocol = - BftConfig - { bftParams = - BftParams - { bftNumNodes = numCoreNodes - , bftSecurityParam = securityParam - } - , bftSignKey = signKey nid - , bftVerKeys = - Map.fromList - [ (CoreId n, verKey n) - | n <- enumCoreNodes numCoreNodes - ] - } - , topLevelConfigLedger = SimpleLedgerConfig () eraParams defaultMockConfig - , topLevelConfigBlock = SimpleBlockConfig - , topLevelConfigCodec = SimpleCodecConfig - , topLevelConfigStorage = SimpleStorageConfig securityParam - , topLevelConfigCheckpoints = emptyCheckpointsMap - } - , pInfoInitLedger = - ExtLedgerState - (genesisSimpleLedgerState addrDist) - (genesisHeaderState ()) - } + let ledgerConfig = SimpleLedgerConfig () eraParams defaultMockConfig + in ProtocolInfo + { pInfoConfig = + TopLevelConfig + { topLevelConfigProtocol = + BftConfig + { bftParams = + BftParams + { bftNumNodes = numCoreNodes + , bftSecurityParam = securityParam + } + , bftSignKey = signKey nid + , bftVerKeys = + Map.fromList + [ (CoreId n, verKey n) + | n <- enumCoreNodes numCoreNodes + ] + } + , topLevelConfigLedger = ledgerConfig + , topLevelConfigBlock = SimpleBlockConfig + , topLevelConfigCodec = SimpleCodecConfig + , topLevelConfigStorage = SimpleStorageConfig securityParam + , topLevelConfigCheckpoints = emptyCheckpointsMap + } + , pInfoInitLedger = + let ledgerState = genesisSimpleLedgerState addrDist + headerState = genesisHeaderState () + perasEpochContextResolver = + initPerasEpochContextResolver + ledgerConfig + (forgetLedgerTables ledgerState) + headerState + latestPerasCertOnChainRound = SNothing + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } + } where signKey :: CoreNodeId -> SignKeyDSIGN MockDSIGN signKey (CoreNodeId n) = SignKeyMockDSIGN n diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs index b2a8b1eaec..21e11609eb 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs @@ -10,6 +10,7 @@ module Ouroboros.Consensus.Mock.Node.PBFT ) where import Cardano.Crypto.DSIGN +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import qualified Data.Bimap as Bimap import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config @@ -17,6 +18,7 @@ import qualified Ouroboros.Consensus.HardFork.History as HardFork import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool (txForgetValidated) +import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Mock.Ledger import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId (CoreNodeId (..)) @@ -30,24 +32,36 @@ protocolInfoMockPBFT :: HardFork.EraParams -> ProtocolInfo MockPBftBlock protocolInfoMockPBFT params eraParams = - ProtocolInfo - { pInfoConfig = - TopLevelConfig - { topLevelConfigProtocol = - PBftConfig - { pbftParams = params - } - , topLevelConfigLedger = SimpleLedgerConfig ledgerView eraParams defaultMockConfig - , topLevelConfigBlock = SimpleBlockConfig - , topLevelConfigCodec = SimpleCodecConfig - , topLevelConfigStorage = SimpleStorageConfig (pbftSecurityParam params) - , topLevelConfigCheckpoints = emptyCheckpointsMap - } - , pInfoInitLedger = - ExtLedgerState - (genesisSimpleLedgerState addrDist) - (genesisHeaderState S.empty) - } + let ledgerConfig = SimpleLedgerConfig ledgerView eraParams defaultMockConfig + in ProtocolInfo + { pInfoConfig = + TopLevelConfig + { topLevelConfigProtocol = + PBftConfig + { pbftParams = params + } + , topLevelConfigLedger = ledgerConfig + , topLevelConfigBlock = SimpleBlockConfig + , topLevelConfigCodec = SimpleCodecConfig + , topLevelConfigStorage = SimpleStorageConfig (pbftSecurityParam params) + , topLevelConfigCheckpoints = emptyCheckpointsMap + } + , pInfoInitLedger = + let ledgerState = genesisSimpleLedgerState addrDist + headerState = genesisHeaderState S.empty + perasEpochContextResolver = + initPerasEpochContextResolver + ledgerConfig + (forgetLedgerTables ledgerState) + headerState + latestPerasCertOnChainRound = SNothing + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } + } where ledgerView :: PBftLedgerView PBftMockCrypto ledgerView = @@ -106,7 +120,7 @@ pbftBlockForging canBeLeader = canBeLeader slot tickedPBftState - , forgeBlock = \cfg slot bno lst txs proof -> + , forgeBlock = \cfg slot bno _mbPerasCert lst txs proof -> return $ forgeSimple forgePBftExt diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Peras.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Peras.hs new file mode 100644 index 0000000000..a71758b1d8 --- /dev/null +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Peras.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Empty Peras support for the mock block. +-- +-- NOTE: this module exists solely because the orphan module +-- 'Ouroboros.Consensus.Mock.Node.Serialisation' needs these instances, but +-- defining it there would be too confusing. +module Ouroboros.Consensus.Mock.Node.Peras () where + +import Data.Typeable (Typeable) +import Ouroboros.Consensus.Block (BlockProtocol) +import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras (..)) +import Ouroboros.Consensus.Mock.Ledger.Block (SimpleBlock, SimpleCrypto) +import Ouroboros.Consensus.Peras.Context (StateSupportsPerasEpochContext (..)) +import Ouroboros.Consensus.Protocol.Abstract + ( ChainDepState + , ChainDepStateSupportsPeras + ) +import Ouroboros.Consensus.Ticked (Ticked) + +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: The mock block does not support Peras, so we can use the empty instance here. +instance + (SimpleCrypto c, Typeable ext) => + BlockSupportsPeras (SimpleBlock c ext) + +instance + ( SimpleCrypto c + , Typeable ext + , ChainDepStateSupportsPeras (ChainDepState (BlockProtocol (SimpleBlock c ext))) + , ChainDepStateSupportsPeras (Ticked (ChainDepState (BlockProtocol (SimpleBlock c ext)))) + ) => + StateSupportsPerasEpochContext (SimpleBlock c ext) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs index 5c5e7a869f..a374fed9ed 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -10,6 +11,7 @@ module Ouroboros.Consensus.Mock.Node.Praos import Cardano.Crypto.KES import Cardano.Crypto.VRF +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import Data.Bifunctor (second) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -20,6 +22,7 @@ import qualified Ouroboros.Consensus.HardFork.History as HardFork import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool (txForgetValidated) +import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Mock.Ledger import Ouroboros.Consensus.Mock.Protocol.Praos import Ouroboros.Consensus.Node.ProtocolInfo @@ -37,30 +40,41 @@ protocolInfoPraos :: PraosEvolvingStake -> ProtocolInfo MockPraosBlock protocolInfoPraos numCoreNodes nid params eraParams eta0 evolvingStakeDist = - ProtocolInfo - { pInfoConfig = - TopLevelConfig - { topLevelConfigProtocol = - PraosConfig - { praosParams = params - , praosSignKeyVRF = signKeyVRF nid - , praosInitialEta = eta0 - , praosInitialStake = genesisStakeDist addrDist - , praosEvolvingStake = evolvingStakeDist - , praosVerKeys = verKeys - } - , topLevelConfigLedger = SimpleLedgerConfig addrDist eraParams defaultMockConfig - , topLevelConfigBlock = SimpleBlockConfig - , topLevelConfigCodec = SimpleCodecConfig - , topLevelConfigStorage = SimpleStorageConfig (praosSecurityParam params) - , topLevelConfigCheckpoints = emptyCheckpointsMap - } - , pInfoInitLedger = - ExtLedgerState - { ledgerState = genesisSimpleLedgerState addrDist - , headerState = genesisHeaderState (PraosChainDepState []) - } - } + let ledgerConfig = SimpleLedgerConfig addrDist eraParams defaultMockConfig + in ProtocolInfo + { pInfoConfig = + TopLevelConfig + { topLevelConfigProtocol = + PraosConfig + { praosParams = params + , praosSignKeyVRF = signKeyVRF nid + , praosInitialEta = eta0 + , praosInitialStake = genesisStakeDist addrDist + , praosEvolvingStake = evolvingStakeDist + , praosVerKeys = verKeys + } + , topLevelConfigLedger = ledgerConfig + , topLevelConfigBlock = SimpleBlockConfig + , topLevelConfigCodec = SimpleCodecConfig + , topLevelConfigStorage = SimpleStorageConfig (praosSecurityParam params) + , topLevelConfigCheckpoints = emptyCheckpointsMap + } + , pInfoInitLedger = + let ledgerState = genesisSimpleLedgerState addrDist + headerState = genesisHeaderState (PraosChainDepState []) + perasEpochContextResolver = + initPerasEpochContextResolver + ledgerConfig + (forgetLedgerTables ledgerState) + headerState + latestPerasCertOnChainRound = SNothing + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } + } where signKeyVRF :: CoreNodeId -> SignKeyVRF MockVRF signKeyVRF (CoreNodeId n) = SignKeyMockVRF n @@ -133,7 +147,7 @@ praosBlockForging cid initHotKey = do . second forgeStateUpdateInfoFromUpdateInfo . evolveKey sno , checkCanForge = \_ _ _ _ _ -> return () - , forgeBlock = \cfg bno sno tickedLedgerSt txs isLeader -> do + , forgeBlock = \cfg bno sno _mbPerasCert tickedLedgerSt txs isLeader -> do hotKey <- readMVar varHotKey return $ forgeSimple diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs index 8a6eb15e34..184276286a 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NamedFieldPuns #-} + -- | Test the Praos chain selection rule but with explicit leader schedule module Ouroboros.Consensus.Mock.Node.PraosRule ( MockPraosRuleBlock @@ -7,6 +9,7 @@ module Ouroboros.Consensus.Mock.Node.PraosRule import Cardano.Crypto.KES import Cardano.Crypto.VRF +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Ouroboros.Consensus.Block.Forging (BlockForging) @@ -14,6 +17,7 @@ import Ouroboros.Consensus.Config import qualified Ouroboros.Consensus.HardFork.History as HardFork import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Mock.Ledger import Ouroboros.Consensus.Mock.Node import Ouroboros.Consensus.Mock.Protocol.LeaderSchedule @@ -38,35 +42,46 @@ protocolInfoPraosRule eraParams schedule evolvingStake = - ProtocolInfo - { pInfoConfig = - TopLevelConfig - { topLevelConfigProtocol = - WLSConfig - { wlsConfigSchedule = schedule - , wlsConfigP = - PraosConfig - { praosParams = params - , praosSignKeyVRF = NeverUsedSignKeyVRF - , praosInitialEta = 0 - , praosInitialStake = genesisStakeDist addrDist - , praosEvolvingStake = evolvingStake - , praosVerKeys = verKeys - } - , wlsConfigNodeId = nid - } - , topLevelConfigLedger = SimpleLedgerConfig () eraParams defaultMockConfig - , topLevelConfigBlock = SimpleBlockConfig - , topLevelConfigCodec = SimpleCodecConfig - , topLevelConfigStorage = SimpleStorageConfig (praosSecurityParam params) - , topLevelConfigCheckpoints = emptyCheckpointsMap - } - , pInfoInitLedger = - ExtLedgerState - { ledgerState = genesisSimpleLedgerState addrDist - , headerState = genesisHeaderState () - } - } + let ledgerConfig = SimpleLedgerConfig () eraParams defaultMockConfig + in ProtocolInfo + { pInfoConfig = + TopLevelConfig + { topLevelConfigProtocol = + WLSConfig + { wlsConfigSchedule = schedule + , wlsConfigP = + PraosConfig + { praosParams = params + , praosSignKeyVRF = NeverUsedSignKeyVRF + , praosInitialEta = 0 + , praosInitialStake = genesisStakeDist addrDist + , praosEvolvingStake = evolvingStake + , praosVerKeys = verKeys + } + , wlsConfigNodeId = nid + } + , topLevelConfigLedger = ledgerConfig + , topLevelConfigBlock = SimpleBlockConfig + , topLevelConfigCodec = SimpleCodecConfig + , topLevelConfigStorage = SimpleStorageConfig (praosSecurityParam params) + , topLevelConfigCheckpoints = emptyCheckpointsMap + } + , pInfoInitLedger = + let ledgerState = genesisSimpleLedgerState addrDist + headerState = genesisHeaderState () + perasEpochContextResolver = + initPerasEpochContextResolver + ledgerConfig + (forgetLedgerTables ledgerState) + headerState + latestPerasCertOnChainRound = SNothing + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + , latestPerasCertOnChainRound + } + } where addrDist :: AddrDist addrDist = mkAddrDist numCoreNodes diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Serialisation.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Serialisation.hs index f5a00a8964..6642141ec4 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Serialisation.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Serialisation.hs @@ -27,6 +27,7 @@ import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Mock.Ledger import Ouroboros.Consensus.Mock.Node.Abstract +import Ouroboros.Consensus.Mock.Node.Peras () import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Serialisation diff --git a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs index 20e0978bbb..b00b44a751 100644 --- a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs +++ b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs @@ -51,10 +51,10 @@ First, some imports we'll need: > Header, StorageConfig, ChainHash, HasHeader(..), HeaderFields(..), > HeaderHash, Point, StandardHash) > import Ouroboros.Consensus.Protocol.Abstract -> (SecurityParam(..), ConsensusConfig, ConsensusProtocol(..), NoTiebreaker(..)) +> (SecurityParam(..), ConsensusConfig, ConsensusProtocol(..), NoTiebreaker(..)) > import Ouroboros.Consensus.Ticked ( Ticked, Ticked(TickedTrivial) ) > import Ouroboros.Consensus.Block -> (BlockSupportsProtocol (tiebreakerView, validateView)) +> (BlockSupportsProtocol (tiebreakerView, validateView), BlockSupportsPeras) > import Ouroboros.Consensus.Ledger.Abstract > (AuxLedgerEvent, GetTip(..), IsLedger(..), LedgerCfg, > LedgerResult(LedgerResult, lrEvents, lrResult), @@ -396,7 +396,10 @@ will know nothing about the structure of the data - instead there are other typeclasses needed to build an interface to derive things that are needed from this value. We'll implement those typeclasses next. +We also need to instantiate `BlockSupportsPeras` for `BlockC`. For this, we can +use the default emtpy implementation. +> instance BlockSupportsPeras BlockC Interface to the Block Header ----------------------------- diff --git a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs index 35e96920b7..f9d710bc1c 100644 --- a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs +++ b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs @@ -71,6 +71,7 @@ And imports, of course: > BlockProtocol, castHeaderFields, BlockConfig, CodecConfig, > StorageConfig, Point, castPoint, WithOrigin (..), EpochNo (EpochNo), > pointSlot, blockPoint, BlockNo (..)) +> import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras) > import Ouroboros.Consensus.Block.SupportsProtocol > (BlockSupportsProtocol (..)) > import Ouroboros.Consensus.Protocol.Abstract @@ -208,6 +209,11 @@ defined earlier: > instance StandardHash BlockD +We also need to instantiate `BlockSupportsPeras` for `BlockC`. For this, we can +use the default emtpy implementation. + +> instance BlockSupportsPeras BlockD + Then we define a function `computeBlockHash` which computes a `Hash` for a `BlockD` - basically aggregating all the data in the block besides the hash itself: diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs index 14e9e92a7c..b23834552a 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} module Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke ( tests @@ -20,6 +17,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert +import Ouroboros.Consensus.Peras.Context (mockPerasEpochContextResolverHandle) import Ouroboros.Consensus.Storage.PerasCertDB.API ( AddPerasCertResult (..) , PerasCertDB @@ -28,7 +26,6 @@ import Ouroboros.Consensus.Storage.PerasCertDB.API import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB import qualified Ouroboros.Consensus.Storage.PerasCertDB.Impl as PerasCertDB import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Network.Block (StandardHash) import Ouroboros.Network.Protocol.ObjectDiffusion.Codec import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound ( objectDiffusionInboundPeerPipelined @@ -44,8 +41,8 @@ import Test.Tasty.QuickCheck (testProperty) import Test.Util.Peras ( ListWithUniqueIds (..) , genListWithUniqueIds - , genPointTestBlock - , genRoundNo + , genMockPerasEpochContext + , genMockValidatedPerasCert , genWithArrivalTime , mockSystemTime ) @@ -58,22 +55,12 @@ tests = [ testProperty "PerasCertDiffusion smoke test" prop_smoke ] -genValidatedPerasCert :: Gen (ValidatedPerasCert TestBlock) -genValidatedPerasCert = - ValidatedPerasCert - <$> genPerasCert - <*> genPerasWeight - where - genPerasCert = - PerasCert - <$> genRoundNo - <*> genPointTestBlock - genPerasWeight = - PerasWeight - <$> choose (1, 15) - newCertDB :: - (IOLike m, StandardHash blk) => [WithArrivalTime (ValidatedPerasCert blk)] -> m (PerasCertDB m blk) + ( IOLike m + , BlockSupportsPeras blk + ) => + [WithArrivalTime (ValidatedPerasCert blk)] -> + m (PerasCertDB m blk) newCertDB certs = do db <- PerasCertDB.createDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer) mapM_ @@ -89,38 +76,42 @@ newCertDB certs = do prop_smoke :: Property prop_smoke = forAll genProtocolConstants $ \protocolConstants -> - forAll (genListWithUniqueIds getPerasCertRound (genWithArrivalTime genValidatedPerasCert)) $ - \(ListWithUniqueIds watValidatedCerts) -> - let - mkPoolInterfaces :: - forall m. - IOLike m => - m - ( ObjectPoolReader PerasRoundNo (PerasCert TestBlock) PerasCertTicketNo m - , ObjectPoolWriter PerasRoundNo (PerasCert TestBlock) m - , m [PerasCert TestBlock] - ) - mkPoolInterfaces = do - outboundPool <- newCertDB watValidatedCerts - inboundPool <- newCertDB [] + forAll genMockPerasEpochContext $ \epochContext -> + forAll + (genListWithUniqueIds getPerasCertRound (genWithArrivalTime (genMockValidatedPerasCert epochContext))) + $ \(ListWithUniqueIds watValidatedCerts) -> + let + mkPoolInterfaces :: + forall m. + IOLike m => + m + ( ObjectPoolReader PerasRoundNo (PerasCert TestBlock) PerasCertTicketNo m + , ObjectPoolWriter PerasRoundNo (PerasCert TestBlock) m + , m [PerasCert TestBlock] + ) + mkPoolInterfaces = do + epochContextResolverHandle <- mockPerasEpochContextResolverHandle epochContext + + outboundPool <- newCertDB watValidatedCerts + inboundPool <- newCertDB [] - let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool - inboundPoolWriter = makePerasCertPoolWriterFromCertDB mockSystemTime inboundPool - getAllInboundPoolContent = do - certsMap <- - atomically $ - PerasCertDB.getCertsAfter inboundPool (PerasCertDB.zeroPerasCertTicketNo) - certs' <- sequence (Map.elems certsMap) - pure $ vpcCert . forgetArrivalTime <$> certs' + let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool + inboundPoolWriter = makePerasCertPoolWriterFromCertDB mockSystemTime inboundPool epochContextResolverHandle + getAllInboundPoolContent = do + certsMap <- + atomically $ + PerasCertDB.getCertsAfter inboundPool (PerasCertDB.zeroPerasCertTicketNo) + certs' <- sequence (Map.elems certsMap) + pure $ vpcCert . forgetArrivalTime <$> certs' - return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) - in - prop_smoke_object_diffusion - protocolConstants - (map (vpcCert . forgetArrivalTime) watValidatedCerts) - runOutboundPeer - runInboundPeer - mkPoolInterfaces + return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) + in + prop_smoke_object_diffusion + protocolConstants + (map (vpcCert . forgetArrivalTime) watValidatedCerts) + runOutboundPeer + runInboundPeer + mkPoolInterfaces where runOutboundPeer outbound outboundChannel tracer = runPeer diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs index d2ccdd4c20..c3bf6ca292 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs @@ -1,16 +1,10 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -Wno-orphans #-} - module Test.Consensus.MiniProtocol.ObjectDiffusion.PerasVote.Smoke ( tests ) where import Control.Monad (join) import Control.Tracer (contramap, nullTracer) -import Data.Data (Typeable) import qualified Data.Map as Map -import Data.Ratio ((%)) import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer) import Ouroboros.Consensus.Block.SupportsPeras import Ouroboros.Consensus.BlockchainTime.WallClock.Types @@ -19,6 +13,10 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote +import Ouroboros.Consensus.Peras.Context + ( PerasEpochContextResolverHandle + , mockPerasEpochContextResolverHandle + ) import Ouroboros.Consensus.Storage.PerasVoteDB ( AddPerasVoteResult (..) , PerasVoteDB @@ -27,7 +25,6 @@ import Ouroboros.Consensus.Storage.PerasVoteDB ) import qualified Ouroboros.Consensus.Storage.PerasVoteDB as PerasVoteDB import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Network.Block (StandardHash) import Ouroboros.Network.Protocol.ObjectDiffusion.Codec import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound ( objectDiffusionInboundPeerPipelined @@ -43,9 +40,8 @@ import Test.Tasty.QuickCheck (testProperty) import Test.Util.Peras ( ListWithUniqueIds (..) , genListWithUniqueIds - , genPointTestBlock - , genRoundNo - , genSeatIndex + , genMockPerasEpochContext + , genMockValidatedPerasVote , genWithArrivalTime , mockSystemTime ) @@ -58,26 +54,15 @@ tests = [ testProperty "PerasVoteDiffusion smoke test" prop_smoke ] -genValidatedPerasVote :: Gen (ValidatedPerasVote TestBlock) -genValidatedPerasVote = - ValidatedPerasVote - <$> genPerasVote - <*> genVoteWeight - where - genPerasVote = - PerasVote - <$> genRoundNo - <*> genPointTestBlock - <*> genSeatIndex - genVoteWeight = - VoteWeight . (1 %) - <$> choose (1, 100) - newVoteDB :: - (IOLike m, StandardHash blk, Typeable blk) => - [WithArrivalTime (ValidatedPerasVote blk)] -> m (PerasVoteDB m blk) -newVoteDB votes = do - db <- PerasVoteDB.createDB (PerasVoteDB.PerasVoteDbArgs nullTracer defaultPerasParams) + ( IOLike m + , BlockSupportsPeras blk + ) => + PerasEpochContextResolverHandle m blk -> + [WithArrivalTime (ValidatedPerasVote blk)] -> + m (PerasVoteDB m blk) +newVoteDB resolverHandle votes = do + db <- PerasVoteDB.createDB (PerasVoteDB.PerasVoteDbArgs nullTracer resolverHandle) mapM_ ( \vote -> do result <- join $ atomically $ PerasVoteDB.addVote db vote @@ -92,46 +77,40 @@ newVoteDB votes = do prop_smoke :: Property prop_smoke = forAll genProtocolConstants $ \protocolConstants -> - forAll (genListWithUniqueIds getPerasVoteRound (genWithArrivalTime genValidatedPerasVote)) $ - \(ListWithUniqueIds watValidatedVotes) -> - let - mkPoolInterfaces :: - IOLike m => - m - ( ObjectPoolReader PerasVoteId (PerasVote TestBlock) PerasVoteTicketNo m - , ObjectPoolWriter PerasVoteId (PerasVote TestBlock) m - , m [PerasVote TestBlock] - ) - mkPoolInterfaces = do - outboundPool <- newVoteDB watValidatedVotes - inboundPool <- newVoteDB [] + forAll genMockPerasEpochContext $ \epochContext -> + forAll + (genListWithUniqueIds getPerasVoteRound (genWithArrivalTime (genMockValidatedPerasVote epochContext))) + $ \(ListWithUniqueIds watValidatedVotes) -> + let + mkPoolInterfaces :: + IOLike m => + m + ( ObjectPoolReader PerasVoteId (PerasVote TestBlock) PerasVoteTicketNo m + , ObjectPoolWriter PerasVoteId (PerasVote TestBlock) m + , m [PerasVote TestBlock] + ) + mkPoolInterfaces = do + epochContextResolverHandle <- mockPerasEpochContextResolverHandle epochContext + + outboundPool <- newVoteDB epochContextResolverHandle watValidatedVotes + inboundPool <- newVoteDB epochContextResolverHandle [] - let outboundPoolReader = makePerasVotePoolReaderFromVoteDB outboundPool - stakeDistr = - PerasVoteStakeDistr $ - Map.fromList - [ (pvVoteVoterId (vpvVote v), vpvVoteWeight v) - | WithArrivalTime _ v <- watValidatedVotes - ] - inboundPoolWriter = - makePerasVotePoolWriterFromVoteDB - mockSystemTime - (pure stakeDistr) - inboundPool - getAllInboundPoolContent = do - votesMap <- - atomically $ - PerasVoteDB.getVotesAfter inboundPool zeroPerasVoteTicketNo - pure $ vpvVote . forgetArrivalTime <$> Map.elems votesMap + let outboundPoolReader = makePerasVotePoolReaderFromVoteDB outboundPool + inboundPoolWriter = makePerasVotePoolWriterFromVoteDB mockSystemTime inboundPool epochContextResolverHandle + getAllInboundPoolContent = do + votesMap <- + atomically $ + PerasVoteDB.getVotesAfter inboundPool zeroPerasVoteTicketNo + pure $ vpvVote . forgetArrivalTime <$> Map.elems votesMap - return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) - in - prop_smoke_object_diffusion - protocolConstants - (map (vpvVote . forgetArrivalTime) watValidatedVotes) - runOutboundPeer - runInboundPeer - mkPoolInterfaces + return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) + in + prop_smoke_object_diffusion + protocolConstants + (map (vpvVote . forgetArrivalTime) watValidatedVotes) + runOutboundPeer + runInboundPeer + mkPoolInterfaces where runOutboundPeer outbound outboundChannel tracer = runPeer diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Iterator.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Iterator.hs index 2bcb9af556..ae49ed149f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Iterator.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Iterator.hs @@ -115,11 +115,11 @@ tests = -- All blocks on the same chain a, b, c, d, e :: TestBlock -a = firstBlock 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} -b = mkNextBlock a 1 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} -c = mkNextBlock b 2 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} -d = mkNextBlock c 3 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} -e = mkNextBlock d 4 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} +a = firstBlock 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} +b = mkNextBlock a 1 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} +c = mkNextBlock b 2 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} +d = mkNextBlock c 3 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} +e = mkNextBlock d 4 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} -- | Requested stream = A -> C -- @@ -176,9 +176,9 @@ prop_1435_case1 = (Left (ForkTooOld (StreamFromInclusive (blockRealPoint b')))) where canContainEBB = const True - ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - b' = mkNextBlock ebb 0 TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCertRound = Nothing} + ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + b' = mkNextBlock ebb 0 TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCert = Nothing} -- | Requested stream = EBB' -> EBB' where EBB, B, and EBB' are all blocks in -- the same slot, and EBB' is not part of the current chain nor ChainDB. @@ -197,9 +197,9 @@ prop_1435_case2 = (Left (ForkTooOld (StreamFromInclusive (blockRealPoint ebb')))) where canContainEBB = const True - ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - ebb' = firstEBB canContainEBB TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCertRound = Nothing} + ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + ebb' = firstEBB canContainEBB TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCert = Nothing} -- | Requested stream = EBB -> EBB where EBB and B are all blocks in the same -- slot. @@ -218,8 +218,8 @@ prop_1435_case3 = (Right (map Right [ebb])) where canContainEBB = const True - ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} + ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} -- | Requested stream = EBB -> EBB where EBB and B are all blocks in the same -- slot. @@ -238,8 +238,8 @@ prop_1435_case4 = (Right (map Right [ebb])) where canContainEBB = const True - ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} + ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} -- | Requested stream = EBB -> EBB where EBB and B' are all blocks in the same -- slot, and B' is not part of the current chain nor ChainDB. @@ -258,8 +258,8 @@ prop_1435_case5 = (Left (ForkTooOld (StreamFromInclusive (blockRealPoint b')))) where canContainEBB = const True - ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - b' = mkNextBlock ebb 0 TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCertRound = Nothing} + ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + b' = mkNextBlock ebb 0 TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCert = Nothing} -- | Requested stream = EBB' -> EBB' where EBB and EBB' are all blocks in the -- same slot, and EBB' is not part of the current chain nor ChainDB. @@ -278,8 +278,8 @@ prop_1435_case6 = (Left (ForkTooOld (StreamFromInclusive (blockRealPoint ebb')))) where canContainEBB = const True - ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - ebb' = firstEBB canContainEBB TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCertRound = Nothing} + ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + ebb' = firstEBB canContainEBB TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCert = Nothing} -- | The general property test prop_general_test :: diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index 30ffb81d33..aa679dde5c 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -9,6 +9,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Model implementation of the chain DB @@ -87,7 +88,7 @@ module Test.Ouroboros.Storage.ChainDB.Model , wipeVolatileDB ) where -import Cardano.Ledger.BaseTypes (unNonZero) +import Cardano.Ledger.BaseTypes (strictMaybeToMaybe, unNonZero) import Codec.Serialise (Serialise, serialise) import Control.Monad (unless) import Control.Monad.Except (runExcept) @@ -106,14 +107,20 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.TreeDiff import GHC.Generics (Generic) +import Generics.SOP (All, Top) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) import Ouroboros.Consensus.Config +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..)) import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert) +import Ouroboros.Consensus.Peras.Context + ( PerasEpochContextResolver + , StateSupportsPerasEpochContext + ) import Ouroboros.Consensus.Peras.SelectView import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Protocol.Abstract @@ -185,12 +192,20 @@ deriving instance , ToExpr (Chain blk) , ToExpr (ChainProducerState blk) , ToExpr (ExtLedgerState blk EmptyMK) + , Show (PerasCert blk) + , Show (PerasVote blk) , StandardHash blk , Show blk ) => ToExpr (Model blk) -deriving instance (LedgerSupportsProtocol blk, Show blk) => Show (Model blk) +deriving instance + ( LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , Show (PerasEpochContextResolver blk) + , Show blk + ) => + Show (Model blk) {------------------------------------------------------------------------------- Queries @@ -233,11 +248,13 @@ getBlockComponentByPoint blockComponent pt m = (`getBlockComponent` blockComponent) <$> getBlockByPoint pt m getLatestPerasCertOnChainRound :: - LedgerSupportsPeras blk => Model blk -> Maybe PerasRoundNo getLatestPerasCertOnChainRound m = do - getLatestPerasCertRound (ledgerState (currentLedger m)) + strictMaybeToMaybe + . latestPerasCertOnChainRound + . currentLedger + $ m hasBlockByPoint :: HasHeader blk => @@ -262,7 +279,11 @@ getMaxSlotNo = foldMap (MaxSlotNo . blockSlot) . blocks -- * After VolatileDB corruption, the whole chain might have more than weight -- @k@, but the tip of the ImmutableDB might be buried under significantly -- less than weight @k@ worth of blocks. -maxActualRollback :: HasHeader blk => SecurityParam -> Model blk -> PerasWeight +maxActualRollback :: + ( HasHeader blk + , IsPerasCert (PerasCert blk) blk + ) => + SecurityParam -> Model blk -> PerasWeight maxActualRollback k m = foldMap' (weightBoostOfPoint weights) . takeWhile (/= immutableTipPoint) @@ -290,7 +311,9 @@ maxActualRollback k m = -- ImmutableDB to know the most recent \"immutable\" block. immutableChain :: forall blk. - HasHeader blk => + ( HasHeader blk + , IsPerasCert (PerasCert blk) blk + ) => SecurityParam -> Model blk -> Chain blk @@ -330,7 +353,10 @@ immutableChain k m = -- 2. The suffix of the current chain not part of the 'immutableDbChain', i.e., -- the \"ImmutableDB\". volatileChain :: - (HasHeader a, HasHeader blk) => + ( HasHeader a + , HasHeader blk + , IsPerasCert (PerasCert blk) blk + ) => SecurityParam -> -- | Provided since 'AnchoredFragment' is not a functor (blk -> a) -> @@ -355,7 +381,9 @@ volatileChain k f m = -- because the background thread copying blocks to the ImmutableDB might not -- have caught up. immutableBlockNo :: - HasHeader blk => + ( HasHeader blk + , IsPerasCert (PerasCert blk) blk + ) => SecurityParam -> Model blk -> WithOrigin BlockNo immutableBlockNo k = Chain.headBlockNo . immutableChain k @@ -365,7 +393,9 @@ immutableBlockNo k = Chain.headBlockNo . immutableChain k -- This is used for garbage collection of the VolatileDB, which is done in -- terms of slot numbers, not in terms of block numbers. immutableSlotNo :: - HasHeader blk => + ( HasHeader blk + , IsPerasCert (PerasCert blk) blk + ) => SecurityParam -> Model blk -> WithOrigin SlotNo @@ -398,10 +428,17 @@ isValid = flip getIsValid getLoEFragment :: Model blk -> LoE (AnchoredFragment blk) getLoEFragment = loeFragment -perasWeights :: StandardHash blk => Model blk -> PerasWeightSnapshot blk -perasWeights = PerasCertDBModel.getWeightSnapshot . perasCertModel +perasWeights :: + ( StandardHash blk + , IsPerasCert (PerasCert blk) blk + ) => + Model blk -> PerasWeightSnapshot blk +perasWeights = + PerasCertDBModel.getWeightSnapshot . perasCertModel -roundNoOfLatestCertSeen :: Model blk -> Maybe PerasRoundNo +roundNoOfLatestCertSeen :: + IsPerasCert (PerasCert blk) blk => + Model blk -> Maybe PerasRoundNo roundNoOfLatestCertSeen m = getPerasCertRound . forgetBoostedBlockStatus <$> PerasCertDBModel.getLatestCertSeen (perasCertModel m) @@ -433,7 +470,12 @@ empty loe initLedger = addBlock :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( All Top (HardForkIndices blk) + , LedgerSupportsProtocol blk + , StateSupportsPerasEpochContext blk + , LedgerTablesAreTrivial ExtLedgerState blk + , BlockSupportsPeras blk + ) => TopLevelConfig blk -> blk -> Model blk -> @@ -462,7 +504,13 @@ addBlock cfg blk m addPerasCert :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( All Top (HardForkIndices blk) + , LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk + , Ord (PerasCert blk) + ) => TopLevelConfig blk -> WithArrivalTime (ValidatedPerasCert blk) -> Model blk -> @@ -478,7 +526,15 @@ addPerasCert cfg cert m addPerasVote :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( All Top (HardForkIndices blk) + , LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk + , Ord (PerasVote blk) + , Ord (PerasCert blk) + , PerasCert blk ~ MockPerasCert blk + ) => TopLevelConfig blk -> WithArrivalTime (ValidatedPerasVote blk) -> Model blk -> @@ -495,8 +551,11 @@ addPerasVote cfg vote m = chainSelection :: forall blk. - ( LedgerTablesAreTrivial ExtLedgerState blk + ( All Top (HardForkIndices blk) + , LedgerTablesAreTrivial ExtLedgerState blk , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk ) => TopLevelConfig blk -> Model blk -> @@ -624,7 +683,12 @@ chainSelection cfg m = consideredCandidates addBlocks :: - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( All Top (HardForkIndices blk) + , LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk + ) => TopLevelConfig blk -> [blk] -> Model blk -> @@ -634,7 +698,13 @@ addBlocks cfg = repeatedly (addBlock cfg) -- | Wrapper around 'addBlock' that returns an 'AddBlockPromise'. addBlockPromise :: forall m blk. - (LedgerSupportsProtocol blk, MonadSTM m, LedgerTablesAreTrivial ExtLedgerState blk) => + ( All Top (HardForkIndices blk) + , LedgerSupportsProtocol blk + , MonadSTM m + , LedgerTablesAreTrivial ExtLedgerState blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk + ) => TopLevelConfig blk -> blk -> Model blk -> @@ -655,8 +725,11 @@ addBlockPromise cfg blk m = (result, m') -- point. updateLoE :: forall blk. - ( LedgerTablesAreTrivial ExtLedgerState blk + ( All Top (HardForkIndices blk) + , LedgerTablesAreTrivial ExtLedgerState blk , LedgerSupportsProtocol blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk ) => TopLevelConfig blk -> AnchoredFragment blk -> @@ -671,7 +744,7 @@ updateLoE cfg f m = (tipPoint m', m') -------------------------------------------------------------------------------} stream :: - GetPrevHash blk => + (GetPrevHash blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> StreamFrom blk -> StreamTo blk -> @@ -856,7 +929,12 @@ data ValidatedChain blk -- 'invalid' of the given 'Model'. validate :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( All Top (HardForkIndices blk) + , LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk + ) => TopLevelConfig blk -> Model blk -> Chain blk -> @@ -917,7 +995,12 @@ chains bs = go Chain.Genesis validChains :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( All Top (HardForkIndices blk) + , LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk + ) => TopLevelConfig blk -> Model blk -> Map (HeaderHash blk) blk -> @@ -973,7 +1056,7 @@ successors = Map.unionsWith Map.union . map single between :: forall blk. - GetPrevHash blk => + (GetPrevHash blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> StreamFrom blk -> StreamTo blk -> @@ -1075,7 +1158,7 @@ between k from to m = do -- tip). garbageCollectable :: forall blk. - HasHeader blk => + (HasHeader blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> Model blk -> blk -> Bool garbageCollectable secParam m b = -- Note: we don't use the block number but the slot number, as the @@ -1091,7 +1174,7 @@ garbageCollectable secParam m b = -- case from a block that was never added to the model in the first place. garbageCollectablePoint :: forall blk. - HasHeader blk => + (HasHeader blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> Model blk -> RealPoint blk -> Bool garbageCollectablePoint secParam m pt | Just blk <- getBlock (realPointHash pt) m = @@ -1104,7 +1187,7 @@ garbageCollectablePoint secParam m pt -- garbage collected it. garbageCollectableIteratorNext :: forall blk. - ModelSupportsBlock blk => + (ModelSupportsBlock blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> Model blk -> IteratorId -> Bool garbageCollectableIteratorNext secParam m itId = case fst (iteratorNext itId GetBlock m) of @@ -1122,7 +1205,7 @@ garbageCollectableIteratorNext secParam m itId = -- used in isolation and is not exported. garbageCollect :: forall blk. - HasHeader blk => + (HasHeader blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> Model blk -> Model blk garbageCollect secParam m@Model{..} = m @@ -1154,7 +1237,7 @@ data ShouldGarbageCollect = GarbageCollect | DoNotGarbageCollect -- Idempotent. copyToImmutableDB :: forall blk. - HasHeader blk => + (HasHeader blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> ShouldGarbageCollect -> Model blk -> Model blk copyToImmutableDB secParam shouldCollectGarbage m = garbageCollectIf shouldCollectGarbage $ @@ -1178,7 +1261,12 @@ reopen m = m{isOpen = True} -- see https://github.com/tweag/cardano-peras/issues/122 wipeVolatileDB :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( All Top (HardForkIndices blk) + , LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk + ) => TopLevelConfig blk -> Model blk -> (Point blk, Model blk) 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 0c1018f878..1c970c70f6 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 @@ -15,6 +15,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -107,6 +108,7 @@ import Data.Typeable import Data.Void (Void) import Data.Word (Word16, Word64) import GHC.Generics (Generic) +import Generics.SOP (All, Top) import qualified Generics.SOP as SOP import NoThunks.Class (AllowThunk (..)) import Ouroboros.Consensus.Block @@ -123,9 +125,14 @@ 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.Peras.Cert.Mock (MockPerasCert (..)) +import Ouroboros.Consensus.Peras.Context + ( StateSupportsPerasEpochContext + , perasEpochContextResolverBounds + ) +import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB hiding ( TraceFollowerEvent (..) @@ -158,6 +165,7 @@ import Test.Ouroboros.Storage.ChainDB.Model , IteratorId , ModelSupportsBlock , ShouldGarbageCollect (DoNotGarbageCollect, GarbageCollect) + , currentLedger ) import qualified Test.Ouroboros.Storage.ChainDB.Model as Model import Test.Ouroboros.Storage.Orphans () @@ -180,6 +188,7 @@ import Test.Util.ChunkInfo import Test.Util.Header (attachSlotTimeToFragment) import Test.Util.Orphans.Arbitrary () import Test.Util.Orphans.ToExpr () +import Test.Util.Peras (genMockPerasVoterIndices) import Test.Util.QuickCheck import Test.Util.RefEnv (RefEnv) import qualified Test.Util.RefEnv as RE @@ -255,7 +264,17 @@ data Cmd blk it flr UpdateLedgerSnapshots | -- Corruption WipeVolatileDB - deriving (Generic, Show, Functor, Foldable, Traversable) + deriving (Generic, Functor, Foldable, Traversable) + +deriving instance + ( StandardHash blk + , Show blk + , Show it + , Show flr + , Show (PerasCert blk) + , Show (PerasVote blk) + ) => + Show (Cmd blk it flr) -- = Invalid blocks -- @@ -355,9 +374,9 @@ type AllComponents blk = ) type TestConstraints blk = - ( ConsensusProtocol (BlockProtocol blk) + ( All Top (HardForkIndices blk) + , ConsensusProtocol (BlockProtocol blk) , LedgerSupportsProtocol blk - , LedgerSupportsPeras blk , BlockSupportsDiffusionPipelining blk , InspectLedger blk , Eq (ChainDepState (BlockProtocol blk)) @@ -377,6 +396,10 @@ type TestConstraints blk = , LedgerTablesAreTrivial LedgerState blk , CanUpgradeLedgerTables LedgerState blk , ImmutableEraParams blk + , BlockSupportsPeras blk + , StateSupportsPerasEpochContext blk + , PerasVote blk ~ MockPerasVote blk + , PerasCert blk ~ MockPerasCert blk ) deriving instance @@ -1075,6 +1098,13 @@ lockstep model@Model{..} cmd (At resp) = Generator -------------------------------------------------------------------------------} +-- | Whether the selected chain of the model is still at Origin. While it is, +-- the header state cannot resolve a valid Peras context, so Peras actions would +-- fail in the SUT. Note this is stronger than the DB being empty: the DB can +-- contain dangling fork blocks while the selected chain is still at Origin. +atOrigin :: HasHeader blk => DBModel blk -> Bool +atOrigin dbModel = Model.tipPoint dbModel == GenesisPoint + -- | Generate a 'Cmd' -- -- NOTE: the frequencies for generating blocks and Peras certificates are @@ -1106,17 +1136,21 @@ generator loe genBlock genPerasBlock m@Model{..} = -- The following frequencies achieve this in practice: let freq = case loe of LoEDisabled -> - -- We must reduce the probability of Peras events to trigger on - -- an empty DB since there are no interesting blocks to vote for - if empty then 1 else 25 + -- While the selected chain is still at Origin, we cannot + -- resolve a valid Peras context, so the SUT would reject Peras + -- actions. Only generate them once the header state has + -- advanced past Origin. + if atOrigin dbModel then 0 else 25 -- The LoE does not yet support Peras. LoEEnabled () -> 0 in (freq, genAddPerasCert) , let freq = case loe of LoEDisabled -> - -- We must reduce the probability of Peras events to trigger on - -- an empty DB since there are no interesting blocks to vote for - if empty then 20 else 500 + -- While the selected chain is still at Origin, we cannot + -- resolve a valid Peras context, so the SUT would reject Peras + -- actions. Only generate them once the header state has + -- advanced past Origin. + if atOrigin dbModel then 0 else 500 -- The LoE does not yet support Peras. LoEEnabled () -> 0 in (freq, genAddPerasVote) @@ -1277,15 +1311,18 @@ generator loe genBlock genPerasBlock m@Model{..} = ] -- Include the boosted block itself in the persisted seenBlocks let seenBlks = fmap (blk :) gapBlks + -- Generate some voters to populate the certificate + voters <- genMockPerasVoterIndices -- Build the certificate now <- genRelativeTime let certWithTime = WithArrivalTime now $ ValidatedPerasCert { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBoostedBlock = blockPoint blk + MockPerasCert + { mockCertRound = roundNo + , mockCertBlock = blockPoint blk + , mockCertVoters = voters } , vpcCertBoost = boost } @@ -1300,6 +1337,7 @@ generator loe genBlock genPerasBlock m@Model{..} = -- threshold for multiple different blocks in the same round, avoiding the -- MultipleWinnersInRound error. let voteModel = Model.perasVoteModel dbModel + weightFromVoteEntry = unVoteWeight . vpvVoteWeight . forgetArrivalTime . PerasVoteDBModel.veVote -- Compute total weight per round from the vote model weightPerRound :: Map.Map PerasRoundNo Rational weightPerRound = @@ -1307,7 +1345,7 @@ generator loe genBlock genPerasBlock m@Model{..} = (+) [ ( pvtRoundNo target , sum - [ unVoteWeight (vpvVoteWeight (forgetArrivalTime (PerasVoteDBModel.veVote ve))) + [ weightFromVoteEntry ve | ve <- Set.toList entries ] ) @@ -1370,10 +1408,10 @@ generator loe genBlock genPerasBlock m@Model{..} = WithArrivalTime now $ ValidatedPerasVote { vpvVote = - PerasVote - { pvVoteRound = roundNo - , pvVoteBlock = blockPoint blk - , pvVoteVoterId = seatIndex + MockPerasVote + { mockVoteRound = roundNo + , mockVoteBlock = blockPoint blk + , mockVoteSeatIndex = seatIndex } , vpvVoteWeight = weight } @@ -1457,6 +1495,13 @@ generator loe genBlock genPerasBlock m@Model{..} = chooseSlot :: SlotNo -> SlotNo -> Gen SlotNo chooseSlot (SlotNo start) (SlotNo end) = SlotNo <$> choose (start, end) +chooseSlotWithLimit :: SlotNo -> SlotNo -> SlotNo -> Gen (Maybe SlotNo) +chooseSlotWithLimit (SlotNo limit) (SlotNo start) (SlotNo end) = + let end' = min end limit + in if start > end' + then return Nothing + else Just . SlotNo <$> choose (start, end') + {------------------------------------------------------------------------------- Shrinking -------------------------------------------------------------------------------} @@ -1495,8 +1540,21 @@ precondition Model{..} (At cmd) = forAll (iters cmd) (`member` RE.keys knownIters) .&& forAll (flrs cmd) (`member` RE.keys knownFollowers) .&& case cmd of - -- Even though we ensure this in the generator, shrinking might change - -- it. + -- Even though we ensure that the chain is not at origin in the generator, + -- shrinking might change it. + -- While the selected chain is still at Origin, we cannot resolve a valid + -- Peras context, so the SUT would reject Peras actions. Shrinking can + -- remove the 'AddBlock's preceding a Peras command, so we must forbid + -- them here as well. + AddPerasCert{} -> Not (Boolean (atOrigin dbModel)) + -- Same thing here, we need to ensure that the chain is not at origin. + -- + -- In addition, we also make sure that the Peras round number is within + -- the supported bounds of the current context resolver because forging + -- a cert from validated votes requires access to a Peras epoch context. + AddPerasVote watValVote _ -> + (Not (Boolean (atOrigin dbModel))) + :&& (Boolean (withinContextBounds (getPerasVoteRound watValVote))) GetBlockComponent pt -> Not $ garbageCollectable pt GetGCedBlockComponent pt -> garbageCollectable pt IteratorNext it -> Not $ garbageCollectableIteratorNext it @@ -1541,6 +1599,13 @@ precondition Model{..} (At cmd) = Map.notMember (blockHash blk) $ Model.invalid dbModel + withinContextBounds :: PerasRoundNo -> Bool + withinContextBounds roundNo = + let resolver = + perasEpochContextResolver . currentLedger $ dbModel + (lo, hi) = perasEpochContextResolverBounds resolver + in lo <= roundNo && roundNo < hi + transition :: (TestConstraints blk, Show1 r, Eq1 r) => Model blk m r -> @@ -1661,8 +1726,12 @@ deriving instance , ToExpr (TipInfo blk) , ToExpr (LedgerState blk EmptyMK) , ToExpr (ExtValidationError blk) + , ToExpr (PerasVotingCommittee blk) , StandardHash blk , Show blk + , Show (PerasVote blk) + , Show (PerasCert blk) + , Show (PerasVotingCommittee blk) ) => ToExpr (Model blk IO Concrete) @@ -1899,53 +1968,55 @@ genBlkPair :: ) genBlkPair chunkInfo loe Model{..} = ( -- For block generation - frequency - [ -- We want to prioritise growing the tree connected to genesis, as it is - -- the most likely growth pattern. - -- - -- However, we want to produce more chainSel events than in real life, - -- so we prioritise growing /any/ branch, not just the current chain tip - genSuccOfCurrentChainTip_WithFreq 5 - , genSuccOfAlreadyInChainDBConnected_IfAnyWithFreq 20 - , -- We also highly prioritise the "gap blocks", i.e. blocks that are - -- needed to fill the gap between blocks that are already part of the - -- ChainDB. Gap blocks might or might not be connected to genesis at the - -- moment, but ultimately if all saved gap blocks get added, they will - -- all be connected to genesis. - genFromSavedGapBlocks_IfAnyWithFreq 20 - , -- Now we also want a small probability to generate blocks that are not - -- connected to genesis at all. We can either generate completely new - -- gaps (to model out-of-order block reception), or expand on an - -- existing one by adding the successor of a dangling block already part - -- of the ChainDB. - -- - -- Be careful, if the ChainDB ends up containing too many dangling - -- blocks, Peras targets will mostly be disconnected blocks and - -- consequently Peras action won't result in direct chain selection - -- events (instead the chain selection events will be delayed until the - -- gap gets filled). So we need to keep the following frequencies low. - genNewGap_WithFreq 2 - , genSuccOfAlreadyInChainDBDangling_IfAnyWithFreq 2 - , -- Finally we want a small probability to re-add an existing block of the - -- ChainDB - genAlreadyInChainDB_IfAnyWithFreq 1 - ] + loopUntilJust $ + frequency + [ -- We want to prioritise growing the tree connected to genesis, as it is + -- the most likely growth pattern. + -- + -- However, we want to produce more chainSel events than in real life, + -- so we prioritise growing /any/ branch, not just the current chain tip + (5, genSuccOfCurrentChainTip_withGapBlocks) + , (20, genSuccOfAlreadyInChainDBConnected_withGapBlocks) + , -- We also highly prioritise the "gap blocks", i.e. blocks that are + -- needed to fill the gap between blocks that are already part of the + -- ChainDB. Gap blocks might or might not be connected to genesis at the + -- moment, but ultimately if all saved gap blocks get added, they will + -- all be connected to genesis. + (20, genFromSavedGapBlocks_withGapBlocks) + , -- Now we also want a small probability to generate blocks that are not + -- connected to genesis at all. We can either generate completely new + -- gaps (to model out-of-order block reception), or expand on an + -- existing one by adding the successor of a dangling block already part + -- of the ChainDB. + -- + -- Be careful, if the ChainDB ends up containing too many dangling + -- blocks, Peras targets will mostly be disconnected blocks and + -- consequently Peras action won't result in direct chain selection + -- events (instead the chain selection events will be delayed until the + -- gap gets filled). So we need to keep the following frequencies low. + (2, genNewGap_withGapBlocks) + , (2, genSuccOfAlreadyInChainDBDangling_withGapBlocks) + , -- Finally we want a small probability to re-add an existing block of the + -- ChainDB + (1, genAlreadyInChainDB_withGapBlocks) + ] , -- For Peras vote and certs - frequency - [ -- Peras actions can theoretically only target rather old (and - -- connected) blocks, so there is a high chance that these blocks are - -- already part of the ChainDB. Consequently, we prioritise generating - -- Peras targets that are already part of the ChainDB and connected to - -- genesis - genAlreadyInChainDBConnected_IfAnyWithFreq 20 - , -- We also want a small probability of generating Peras targets that are - -- not yet part of the ChainDB or not connected, to model the case where - -- we receive a cert/vote for a block before we receive the block itself - genSuccOfAlreadyInChainDB_IfAnyWithFreq 2 - , genNewGap_WithFreq 1 - , genAlreadyInChainDBDangling_IfAnyWithFreq 1 - , genFromSavedGapBlocks_IfAnyWithFreq 1 - ] + loopUntilJust $ + frequency + [ -- Peras actions can theoretically only target rather old (and + -- connected) blocks, so there is a high chance that these blocks are + -- already part of the ChainDB. Consequently, we prioritise generating + -- Peras targets that are already part of the ChainDB and connected to + -- genesis + (20, genAlreadyInChainDBConnected_withGapBlocks) + , -- We also want a small probability of generating Peras targets that are + -- not yet part of the ChainDB or not connected, to model the case where + -- we receive a cert/vote for a block before we receive the block itself + (2, genSuccOfAlreadyInChainDB_withGapBlocks) + , (1, genNewGap_withGapBlocks) + , (1, genAlreadyInChainDBDangling_withGapBlocks) + , (1, genFromSavedGapBlocks_withGapBlocks) + ] ) where k = unNonZero (maxRollbacks (configSecurityParam (unOpaque modelConfig))) @@ -1975,19 +2046,27 @@ genBlkPair chunkInfo loe Model{..} = danglingBlocksMap :: Map.Map TestHeaderHash TestBlock danglingBlocksMap = Map.difference chainDBBlocksMap connectedBlocksMap - noBlocksAlreadyInChainDB = Map.null chainDBBlocksMap - noConnectedBlocksAlreadyInChainDB = Map.null connectedBlocksMap - noDanglingBlocksAlreadyInChainDB = Map.null danglingBlocksMap - savedGapBlocks = seenBlocks genState - noSavedGapBlocks = Map.null savedGapBlocks + + andThen :: Gen (Maybe a) -> (a -> Gen (Maybe b)) -> Gen (Maybe b) + andThen genA f = + genA >>= \case + Nothing -> pure Nothing + Just a -> f a + + loopUntilJust :: Gen (Maybe a) -> Gen a + loopUntilJust gen = do + mbA <- gen + case mbA of + Nothing -> loopUntilJust gen + Just a -> pure a -- This helper function is used to wrap generators when we know that the -- returned block is not going to create a new gap (i.e. there exist a path -- from an existing block of the ChainDB to this returned block that is either -- empty or made of blocks that are already in the saved gap blocks). - noNewSavedGapBlocks :: Gen TestBlock -> Gen (TestBlock, Persistent [TestBlock]) - noNewSavedGapBlocks = fmap (,Persistent []) + noNewSavedGapBlocks :: Gen (Maybe TestBlock) -> Gen (Maybe (TestBlock, Persistent [TestBlock])) + noNewSavedGapBlocks = fmap (fmap (,Persistent [])) -- Generate a block or EBB fitting on genesis genFirstBlock :: Gen TestBlock @@ -2003,19 +2082,43 @@ genBlkPair chunkInfo loe Model{..} = ) ] - -- Helper that generates a block that fits onto the given block. - genSuccOf :: TestBlock -> Gen TestBlock - genSuccOf b = + -- We don't want to generate blocks that are more than one epoch in the + -- future, relative to the slot of the current selected chain tip (i.e. the + -- current header/ledger state). + -- + -- The size of an epoch in slots is simply the 'numRegularBlocks' of the chunk config, + -- cf. eraParams definition in 'mkTestConfig' in Test.Ouroboros.Storage.TestBlock + maxSlotOfNextEpoch :: SlotNo + maxSlotOfNextEpoch = SlotNo ((nextEpoch + 1) * epochSize - 1) + where + -- When the tip is at Origin, we cap the max slot to the last slot of epoch + -- 0. Otherwise, we allow generating blocks up to the last slot of the epoch + -- following the one containing the current tip. + nextEpoch = case Model.tipBlock dbModel of + Nothing -> 0 + Just b -> (unSlotNo (blockSlot b) `div` epochSize) + 1 + -- The chunk size is uniform (see 'mkTestCfg'), so the epoch size is the + -- same for every slot; we can use slot 0 to compute it. + epochSize = + ImmutableDB.numRegularBlocks $ + ImmutableDB.getChunkSize chunkInfo $ + ImmutableDB.chunkIndexOfSlot chunkInfo 0 + + -- Helper that generates a block that fits onto the given block. The generated + -- block never occupies a slot larger than @maxSlot@ (see 'maxSlotOfNextEpoch') + -- except if it is an EBB block. + genSuccOf :: SlotNo -> TestBlock -> Gen (Maybe TestBlock) + genSuccOf maxSlot b = frequency [ ( 4 , do - slotNo <- + mbSlotNo <- if fromIsEBB (testBlockIsEBB b) - then chooseSlot (blockSlot b) (blockSlot b + 2) - else chooseSlot (blockSlot b + 1) (blockSlot b + 3) + then chooseSlotWithLimit maxSlot (blockSlot b) (blockSlot b + 2) + else chooseSlotWithLimit maxSlot (blockSlot b + 1) (blockSlot b + 3) body <- genBody - return $ mkNextBlock b slotNo body + return $ fmap (\slotNo -> mkNextBlock b slotNo body) mbSlotNo ) , -- An EBB is never followed directly by another EBB, otherwise they -- would have the same 'BlockNo', as the EBB has the same 'BlockNo' of @@ -2033,18 +2136,20 @@ genBlkPair chunkInfo loe Model{..} = ImmutableDB.chunkSlotForBoundaryBlock chunkInfo (prevEpoch + 1) - nextNextEBB = - ImmutableDB.chunkSlotForBoundaryBlock - chunkInfo - (prevEpoch + 2) + -- nextNextEBB = + -- ImmutableDB.chunkSlotForBoundaryBlock + -- chunkInfo + -- (prevEpoch + 2) (slotNo, epoch) <- first (ImmutableDB.chunkSlotToSlot chunkInfo) <$> frequency [ (7, return (nextEBB, prevEpoch + 1)) - , (1, return (nextNextEBB, prevEpoch + 2)) + -- We can no longer generate EBBs that are more than one epoch in the future, as + -- this would break ticking of the ExtLedgerState (specifically for the PerasEpochContextResolver) + -- , (1, return (nextNextEBB, prevEpoch + 2)) ] body <- genBody - return $ mkNextEBB canContainEBB b slotNo epoch body + return $ Just $ mkNextEBB canContainEBB b slotNo epoch body ) ] @@ -2054,97 +2159,100 @@ genBlkPair chunkInfo loe Model{..} = -- don't add just yet. These are in turn returned and stored as seen blocks -- in the generator state of the model. We can sample from these later on to -- (hopefully) fill the gaps. - genNewGap :: Gen (TestBlock, Persistent [TestBlock]) - genNewGap = do + genNewGap_withGapBlocks :: Gen (Maybe (TestBlock, Persistent [TestBlock])) + genNewGap_withGapBlocks = do gapSize <- choose (1, 3) start <- - if noBlocksAlreadyInChainDB - then genFirstBlock + if Map.null chainDBBlocksMap + then Just <$> genFirstBlock else genSuccOfAlreadyInChainDB - go gapSize start [] + case start of + Nothing -> return Nothing + Just tip -> Just <$> go maxSlotOfNextEpoch gapSize tip [] where - go :: Int -> TestBlock -> [TestBlock] -> Gen (TestBlock, Persistent [TestBlock]) - go 0 tip gapBlks = return (tip, Persistent gapBlks) - go n tip gapBlks = do - tip' <- genSuccOf tip - go (n - 1) tip' (tip : gapBlks) - genNewGap_WithFreq freq = - (freq, genNewGap) + go :: SlotNo -> Int -> TestBlock -> [TestBlock] -> Gen (TestBlock, Persistent [TestBlock]) + go _maxSlotNo 0 tip gapBlks = return (tip, Persistent gapBlks) + go maxSlotNo n tip gapBlks = do + mbTip' <- genSuccOf maxSlotNo tip + case mbTip' of + Nothing -> + -- We couldn't generate a successor block, so we return the current tip and the gap blocks we have so far. + return (tip, Persistent gapBlks) + Just tip' -> + go maxSlotNo (n - 1) tip' (tip : gapBlks) -- An intermediate gap block that was generated by 'genNewGap' but -- saved for later in the model's generator state. See 'GenState' for details. - genFromSavedGapBlocks :: Gen TestBlock - genFromSavedGapBlocks = elements (Map.elems savedGapBlocks) - genFromSavedGapBlocks_IfAnyWithFreq freq = + genFromSavedGapBlocks = + if Map.null savedGapBlocks + then pure Nothing + else Just <$> elements (Map.elems savedGapBlocks) + genFromSavedGapBlocks_withGapBlocks = -- we can use 'noNewSavedGapBlocks' since any gap block leading to the -- returned block should already be part of the saved gap blocks - (if noSavedGapBlocks then 0 else freq, noNewSavedGapBlocks genFromSavedGapBlocks) + noNewSavedGapBlocks genFromSavedGapBlocks - genAlreadyInChainDB :: Gen TestBlock - genAlreadyInChainDB = elements $ Map.elems chainDBBlocksMap - genAlreadyInChainDB_IfAnyWithFreq freq = + genAlreadyInChainDB = + if Map.null chainDBBlocksMap + then pure Nothing + else Just <$> elements (Map.elems chainDBBlocksMap) + genAlreadyInChainDB_withGapBlocks = -- we can use 'noNewSavedGapBlocks' since gap blocks should have been saved -- when the block was first added to the ChainDB - (if noBlocksAlreadyInChainDB then 0 else freq, noNewSavedGapBlocks genAlreadyInChainDB) + noNewSavedGapBlocks genAlreadyInChainDB -- A block that already exists in the ChainDB and is connected to genesis. - genAlreadyInChainDBConnected :: Gen TestBlock - genAlreadyInChainDBConnected = elements $ Map.elems connectedBlocksMap - genAlreadyInChainDBConnected_IfAnyWithFreq freq = + genAlreadyInChainDBConnected = + if Map.null connectedBlocksMap + then pure Nothing + else Just <$> elements (Map.elems connectedBlocksMap) + genAlreadyInChainDBConnected_withGapBlocks = -- we can use 'noNewSavedGapBlocks' since gap blocks should have been saved -- when the block was first added to the ChainDB - ( if noConnectedBlocksAlreadyInChainDB then 0 else freq - , noNewSavedGapBlocks genAlreadyInChainDBConnected - ) + noNewSavedGapBlocks genAlreadyInChainDBConnected -- A block that already exists in the ChainDB but is NOT connected to genesis -- (i.e. it is dangling/disconnected). - genAlreadyInChainDBDangling :: Gen TestBlock - genAlreadyInChainDBDangling = elements $ Map.elems danglingBlocksMap - genAlreadyInChainDBDangling_IfAnyWithFreq freq = + genAlreadyInChainDBDangling = + if Map.null danglingBlocksMap + then pure Nothing + else Just <$> elements (Map.elems danglingBlocksMap) + genAlreadyInChainDBDangling_withGapBlocks = -- we can use 'noNewSavedGapBlocks' since gap blocks should have been saved -- when the block was first added to the ChainDB - ( if noDanglingBlocksAlreadyInChainDB then 0 else freq - , noNewSavedGapBlocks genAlreadyInChainDBDangling - ) + noNewSavedGapBlocks genAlreadyInChainDBDangling -- A block that fits onto the current chain - genSuccOfCurrentChainTip :: Gen TestBlock genSuccOfCurrentChainTip = case Model.tipBlock dbModel of Nothing -> genFirstBlock - Just b -> genSuccOf b - genSuccOfCurrentChainTip_WithFreq freq = + Just b -> + fromMaybe (error "Generating successor of current chain tip should never fail") + <$> genSuccOf maxSlotOfNextEpoch b + genSuccOfCurrentChainTip_withGapBlocks = -- we can use 'noNewSavedGapBlocks' since there is no gap block leading to -- the immediate successor of a block on the current chain - (freq, noNewSavedGapBlocks genSuccOfCurrentChainTip) + noNewSavedGapBlocks (Just <$> genSuccOfCurrentChainTip) -- A block that fits onto any block in the ChainDB (connected or dangling) - genSuccOfAlreadyInChainDB :: Gen TestBlock - genSuccOfAlreadyInChainDB = genAlreadyInChainDB >>= genSuccOf - genSuccOfAlreadyInChainDB_IfAnyWithFreq freq = + genSuccOfAlreadyInChainDB = genAlreadyInChainDB `andThen` \b -> genSuccOf maxSlotOfNextEpoch b + genSuccOfAlreadyInChainDB_withGapBlocks = -- we can use 'noNewSavedGapBlocks' since there is no gap block leading to -- the immediate successor of a block in the ChainDB - (if noBlocksAlreadyInChainDB then 0 else freq, noNewSavedGapBlocks genSuccOfAlreadyInChainDB) + noNewSavedGapBlocks genSuccOfAlreadyInChainDB -- A block that fits onto some connected block @b@ in the ChainDB. - genSuccOfAlreadyInChainDBConnected :: Gen TestBlock - genSuccOfAlreadyInChainDBConnected = genAlreadyInChainDBConnected >>= genSuccOf - genSuccOfAlreadyInChainDBConnected_IfAnyWithFreq freq = + genSuccOfAlreadyInChainDBConnected = genAlreadyInChainDBConnected `andThen` \b -> genSuccOf maxSlotOfNextEpoch b + genSuccOfAlreadyInChainDBConnected_withGapBlocks = -- we can use 'noNewSavedGapBlocks' since there is no gap block leading to -- the immediate successor of a block in the ChainDB - ( if noConnectedBlocksAlreadyInChainDB then 0 else freq - , noNewSavedGapBlocks genSuccOfAlreadyInChainDBConnected - ) + noNewSavedGapBlocks genSuccOfAlreadyInChainDBConnected -- A block that fits onto some dangling (disconnected) block @b@ in the ChainDB. - genSuccOfAlreadyInChainDBDangling :: Gen TestBlock - genSuccOfAlreadyInChainDBDangling = genAlreadyInChainDBDangling >>= genSuccOf - genSuccOfAlreadyInChainDBDangling_IfAnyWithFreq freq = + genSuccOfAlreadyInChainDBDangling = genAlreadyInChainDBDangling `andThen` \b -> genSuccOf maxSlotOfNextEpoch b + genSuccOfAlreadyInChainDBDangling_withGapBlocks = -- we can use 'noNewSavedGapBlocks' since there is no gap block leading to -- the immediate successor of a block in the ChainDB - ( if noDanglingBlocksAlreadyInChainDB then 0 else freq - , noNewSavedGapBlocks genSuccOfAlreadyInChainDBDangling - ) + noNewSavedGapBlocks genSuccOfAlreadyInChainDBDangling canContainEBB = const modelSupportsEBBs -- TODO: we could be more precise genBody :: Gen TestBody @@ -2156,24 +2264,41 @@ genBlkPair chunkInfo loe Model{..} = [ (4, return True) , (1, return False) ] - perasCertRound <- do - let maxRoundNo = - case Model.roundNoOfLatestCertSeen dbModel of - Nothing -> 0 - Just (PerasRoundNo r) -> r + 1 + perasCert <- do frequency - [ (9, return Nothing) + [ (4, return Nothing) , let freq = case loe of LoEDisabled -> 1 -- The LoE does not yet support Peras. LoEEnabled () -> 0 - in (freq, Just . PerasRoundNo <$> choose (0, maxRoundNo)) + in (freq, Just <$> genPerasCert) ] return TestBody { tbForkNo = forkNo , tbIsValid = isValid - , tbPerasCertRound = perasCertRound + , tbPerasCert = perasCert + } + + genPerasCert :: Gen (PerasCert TestBlock) + genPerasCert = do + let maxRoundNo = + case Model.roundNoOfLatestCertSeen dbModel of + Nothing -> 0 + Just (PerasRoundNo r) -> r + 1 + roundNo <- + PerasRoundNo <$> choose (0, maxRoundNo) + boostedBlock <- + -- NOTE: we don't care about this boosted block, it could be @Genesis@ + blockPoint <$> genSuccOfCurrentChainTip + voters <- + genMockPerasVoterIndices + + pure + MockPerasCert + { mockCertRound = roundNo + , mockCertBlock = boostedBlock + , mockCertVoters = voters } -- | Generate a random security parameter (k) @@ -2251,8 +2376,10 @@ smUnused loe k chunkInfo = envUnused (genBlk chunkInfo loe) (genPerasBoostedBlk chunkInfo loe) - (mkTestCfg k chunkInfo) - testInitExtLedger + cfg + (testInitExtLedger (configLedger cfg)) + where + cfg = mkTestCfg k chunkInfo prop_sequential :: LoE () -> SmallChunkInfo -> Property prop_sequential loe smallChunkInfo@(SmallChunkInfo chunkInfo) = @@ -2304,7 +2431,7 @@ runCmdsLockstep loe k (SmallChunkInfo chunkInfo) cmds = mkArgs testCfg chunkInfo - (testInitExtLedger `withLedgerTables` emptyLedgerTables) + (testInitExtLedger (configLedger testCfg) `withLedgerTables` emptyLedgerTables) threadRegistry nodeDBs tracer @@ -2326,7 +2453,14 @@ runCmdsLockstep loe k (SmallChunkInfo chunkInfo) cmds = , varLoEFragment , args } - sm' = sm loe env (genBlk chunkInfo loe) (genPerasBoostedBlk chunkInfo loe) testCfg testInitExtLedger + sm' = + sm + loe + env + (genBlk chunkInfo loe) + (genPerasBoostedBlk chunkInfo loe) + testCfg + (testInitExtLedger (configLedger testCfg)) (hist, model, res) <- QSM.runCommands' sm' cmds' trace <- getTrace return (hist, model, res, trace) 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 9354c1768c..6f941a3f7c 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 @@ -34,7 +34,7 @@ import Ouroboros.Consensus.Block.RealPoint , blockRealPoint ) import Ouroboros.Consensus.Config - ( TopLevelConfig + ( TopLevelConfig (topLevelConfigLedger) ) import Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..)) import Ouroboros.Consensus.Ledger.Abstract @@ -381,7 +381,7 @@ runModelIO loe expr = toAssertion (runModel newModel topLevelConfig expr) where chunkInfo = ImmutableDB.simpleChunkInfo 100 k = SecurityParam (knownNonZeroBounded @2) - newModel = Model.empty loe testInitExtLedger + newModel = Model.empty loe (testInitExtLedger (topLevelConfigLedger topLevelConfig)) topLevelConfig = mkTestCfg k chunkInfo -- | Helper function to run the test against the actual chain database and @@ -392,7 +392,9 @@ runSystemIO expr = runSystem withChainDbEnv expr >>= toAssertion chunkInfo = ImmutableDB.simpleChunkInfo 100 k = SecurityParam (knownNonZeroBounded @2) topLevelConfig = mkTestCfg k chunkInfo - withChainDbEnv = withTestChainDbEnv topLevelConfig chunkInfo $ convertMapKind testInitExtLedger + withChainDbEnv = + withTestChainDbEnv topLevelConfig chunkInfo $ + convertMapKind (testInitExtLedger (topLevelConfigLedger topLevelConfig)) newtype TestFailure = TestFailure String deriving Show diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine/TestBlock.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine/TestBlock.hs index 4ca6d0f0c4..5ecb8065f1 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine/TestBlock.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine/TestBlock.hs @@ -36,7 +36,6 @@ import qualified Codec.Serialise as S import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe.Strict import Data.MemPack import Data.Set (Set) import qualified Data.Set as Set @@ -255,7 +254,6 @@ instance CanStowLedgerTables (LedgerState TestBlock) where stowErr :: String -> a stowErr fname = error $ "Function " <> fname <> " should not be used in these tests." -deriving anyclass instance ToExpr v => ToExpr (StrictMaybe v) deriving anyclass instance ToExpr (mk Token TValue) => ToExpr (LedgerTables TestBlock mk) deriving instance diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs index 486ac63142..d56a8bc2d9 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module Test.Ouroboros.Storage.PerasCertDB.Model ( Model (..) @@ -36,9 +38,9 @@ data Model blk = Model } deriving Generic -deriving instance StandardHash blk => Show (Model blk) +deriving instance Show (PerasCert blk) => Show (Model blk) -instance StandardHash blk => ToExpr (Model blk) where +instance Show (PerasCert blk) => ToExpr (Model blk) where toExpr = defaultExprViaShow initModel :: Model blk @@ -48,7 +50,9 @@ openDB :: Model blk -> Model blk openDB model = model{open = True} addCert :: - StandardHash blk => + ( Ord (PerasCert blk) + , IsPerasCert (PerasCert blk) blk + ) => Model blk -> WithArrivalTime (ValidatedPerasCert blk) -> (AddPerasCertResult, Model blk) addCert model@Model{certs, latestCertSeen} cert | certs `hasRoundNo` cert = (PerasCertAlreadyInDB, model) @@ -67,6 +71,7 @@ addCert model@Model{certs, latestCertSeen} cert Just prev hasRoundNo :: + IsPerasCert (PerasCert blk) blk => Set (WithArrivalTime (ValidatedPerasCert blk)) -> WithArrivalTime (ValidatedPerasCert blk) -> Bool @@ -74,7 +79,9 @@ hasRoundNo certs cert = (getPerasCertRound cert) `Set.member` (Set.map getPerasCertRound certs) getWeightSnapshot :: - StandardHash blk => + ( IsPerasCert (PerasCert blk) blk + , StandardHash blk + ) => Model blk -> PerasWeightSnapshot blk getWeightSnapshot Model{certs} = mkPerasWeightSnapshot @@ -88,7 +95,9 @@ getLatestCertSeen :: getLatestCertSeen Model{latestCertSeen} = latestCertSeen -garbageCollect :: SlotNo -> Model blk -> Model blk +garbageCollect :: + IsPerasCert (PerasCert blk) blk => + SlotNo -> Model blk -> Model blk garbageCollect slotNo model@Model{certs, latestCertSeen} = model { certs = Set.filter keepCert certs diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs index 6debbf9dae..17139a747b 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -19,15 +19,19 @@ module Test.Ouroboros.Storage.PerasCertDB.StateMachine (tests) where import Control.Monad (join) import Control.Monad.State import Control.Tracer (nullTracer) +import Data.Containers.NonEmpty (NE) import Data.Function ((&)) import qualified Data.List.NonEmpty as NE +import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Set.NonEmpty as NESet import Data.Word (Word64) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( RelativeTime (..) , WithArrivalTime (..) ) +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import Ouroboros.Consensus.Storage.PerasCertDB.API @@ -91,14 +95,16 @@ instance StateModel Model where genAddCert = do roundNo <- genRoundNo boostedBlock <- genPoint + voters <- genVoters now <- genRelativeTime let certWithTime = WithArrivalTime now $ ValidatedPerasCert { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBoostedBlock = boostedBlock + MockPerasCert + { mockCertRound = roundNo + , mockCertBlock = boostedBlock + , mockCertVoters = voters } , vpcCertBoost = perasWeight perasTestParams } @@ -119,6 +125,13 @@ instance StateModel Model where , (1, pure $ PerasRoundNo 2) , (8, PerasRoundNo <$> arbitrary) ] + + genVoters :: Gen (NE (Set PerasSeatIndex)) + genVoters = + NESet.fromList <$> (liftA2 (NE.:|) genSeatIndex (listOf genSeatIndex)) + + genSeatIndex = PerasSeatIndex <$> arbitrary + genHash = TestHash . NE.fromList . getNonEmpty <$> arbitrary initialState = Model Model.initModel diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs index 06956a8dd6..aa0921b9ad 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs @@ -1,4 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Test.Ouroboros.Storage.PerasVoteDB.Model ( PerasVoteDbModelError (..) @@ -19,27 +23,29 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Set.NonEmpty as NESet import Data.TreeDiff (ToExpr (..), defaultExprViaShow) import GHC.Generics (Generic) import Ouroboros.Consensus.Block (SlotNo, WithOrigin (..), pointSlot) import Ouroboros.Consensus.Block.Abstract (StandardHash) import Ouroboros.Consensus.Block.SupportsPeras - ( IsPerasVote (..) - , PerasCert' (..) - , PerasParams (..) + ( BlockSupportsPeras (..) + , IsPerasCert (..) + , IsPerasVote (..) + , PerasParams , PerasRoundNo + , PerasSeatIndex , PerasVoteId (..) , PerasVoteTarget (..) , ValidatedPerasCert (..) , ValidatedPerasVote (..) , VoteWeight (..) , getPerasCertPoint + , perasWeight , weightAboveThreshold ) -import Ouroboros.Consensus.BlockchainTime.WallClock.Types - ( WithArrivalTime (..) - ) -import Ouroboros.Consensus.Peras.Types (PerasSeatIndex) +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) import Ouroboros.Consensus.Storage.PerasVoteDB.API ( AddPerasVoteResult (..) , PerasVoteTicketNo @@ -50,11 +56,15 @@ data VoteEntry blk = VoteEntry { veTicketNo :: PerasVoteTicketNo -- ^ The ticket number assigned to this vote , veVoter :: PerasSeatIndex - -- ^ The voter ID + -- ^ The seat index of the voter , veVote :: WithArrivalTime (ValidatedPerasVote blk) -- ^ The vote itself } - deriving (Show, Eq, Ord, Generic) + +deriving instance Show (PerasVote blk) => Show (VoteEntry blk) +deriving instance Eq (PerasVote blk) => Eq (VoteEntry blk) +deriving instance Ord (PerasVote blk) => Ord (VoteEntry blk) +deriving instance Generic (VoteEntry blk) data PerasVoteDbModelError = MultipleWinnersInRound PerasRoundNo deriving (Show, Generic) @@ -71,9 +81,24 @@ data Model blk = Model , certs :: Map PerasRoundNo (ValidatedPerasCert blk) -- ^ Forged certificates indexed by round number } - deriving (Show, Generic) -instance StandardHash blk => ToExpr (Model blk) where +-- deriving (Show, Generic) + +deriving instance + ( StandardHash blk + , Show (PerasVote blk) + , Show (PerasCert blk) + ) => + Show (Model blk) +deriving instance Generic (Model blk) + +instance + ( StandardHash blk + , Show (PerasVote blk) + , Show (PerasCert blk) + ) => + ToExpr (Model blk) + where toExpr = defaultExprViaShow initModel :: PerasParams blk -> Model blk @@ -132,15 +157,20 @@ closeDB model = } addVote :: - StandardHash blk => + ( StandardHash blk + , Ord (PerasVote blk) + , PerasCert blk ~ MockPerasCert blk + , IsPerasVote (PerasVote blk) blk + , IsPerasCert (PerasCert blk) blk + ) => WithArrivalTime (ValidatedPerasVote blk) -> Model blk -> ( Either PerasVoteDbModelError (AddPerasVoteResult blk) , Model blk ) addVote vote model - -- The ID of a vote is a pair (voterId, roundNo). So checking if the voter has - -- already voted in this round means checking if the pair (voterId, roundNo) + -- The ID of a vote is a pair (seatIndex, roundNo). So checking if the voter has + -- already voted in this round means checking if the pair (seatIndex, roundNo) -- is already present in the model i.e. if the vote is already in the model. -- In which case, we can ignore it. -- @@ -165,7 +195,7 @@ addVote vote model | reachedQuorum , Nothing <- certAtRound = -- Also ensure that we didn't already have a quorum before adding this - -- vote in a more direct way: the stake represented by the existing votes + -- vote in a more direct way: the weight represented by the existing votes -- must be below the threshold. assert (not hadQuorum) $ ( Right $ @@ -195,7 +225,7 @@ addVote vote model roundNo = getPerasVoteRound vote votedBlock = - getPerasVoteBlock vote + getPerasVotePoint vote voter = getPerasVoteSeatIndex vote -- Compute the next ticket number associated to this vote. @@ -218,8 +248,14 @@ addVote vote model -- The extended set of votes including the new one extendedVotes = Set.insert voteEntry existingVotes - -- Get the total stake of a set of votes - getTotalStake = + -- The extended set of voters including the new one + extendedVoters = + NESet.unsafeFromSet -- Safe due to insert below + . Set.insert voter + . Set.map veVoter + $ existingVotes + -- Get the total weight of a set of votes + getTotalWeight = VoteWeight . sum . fmap @@ -229,18 +265,18 @@ addVote vote model . veVote ) . Set.toList - -- Total stake represented by the existing votes - existingVotesStake = - getTotalStake existingVotes - -- Total stake represented by the extended set of votes - extendedVotesStake = - getTotalStake extendedVotes + -- Total weight represented by the existing votes + existingVotesWeight = + getTotalWeight existingVotes + -- Total weight represented by the extended set of votes + extendedVotesWeight = + getTotalWeight extendedVotes -- Did we already have a quorum before adding this new vote? hadQuorum = - weightAboveThreshold (params model) existingVotesStake + weightAboveThreshold (params model) existingVotesWeight -- Did we reach the quorum threshold with this new vote? reachedQuorum = - weightAboveThreshold (params model) extendedVotesStake + weightAboveThreshold (params model) extendedVotesWeight -- The existing certificate (if any) for this round certAtRound = Map.lookup roundNo (certs model) @@ -248,9 +284,10 @@ addVote vote model freshCert = ValidatedPerasCert { vpcCert = - PerasCert - { pcCertRound = getPerasVoteRound vote - , pcCertBoostedBlock = getPerasVoteBlock vote + MockPerasCert + { mockCertRound = roundNo + , mockCertBlock = votedBlock + , mockCertVoters = extendedVoters } , vpcCertBoost = perasWeight (params model) } diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs index 5cf5beeb75..8b6a0293e0 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs @@ -37,10 +37,10 @@ import GHC.Generics (Generic) import Ouroboros.Consensus.Block.Abstract (Point (..), SlotNo (..)) import Ouroboros.Consensus.Block.SupportsPeras ( IsPerasVote (..) + , PerasEpochContext (..) , PerasParams , PerasRoundNo (..) , PerasSeatIndex (..) - , PerasVote' (..) , PerasVoteId , PerasVoteTarget (..) , ValidatedPerasCert @@ -52,6 +52,8 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( RelativeTime (..) , WithArrivalTime (..) ) +import Ouroboros.Consensus.Peras.Context (mockPerasEpochContextResolverHandle) +import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) import Ouroboros.Consensus.Storage.PerasVoteDB ( AddPerasVoteResult (..) , PerasVoteDB @@ -84,7 +86,11 @@ import Test.QuickCheck.StateModel ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) -import Test.Util.TestBlock (TestBlock, TestHash (..)) +import Test.Util.Peras (genMockPerasVotingCommittee) +import Test.Util.TestBlock + ( TestBlock + , TestHash (..) + ) import Test.Util.TestEnv (adjustQuickCheckMaxSize, adjustQuickCheckTests) tests :: TestTree @@ -128,6 +134,7 @@ newtype Model = Model (Model.Model TestBlock) instance StateModel Model where data Action Model a where CreateDB :: + PerasEpochContext TestBlock -> Action Model () AddVote :: WithArrivalTime (ValidatedPerasVote TestBlock) -> @@ -167,7 +174,14 @@ instance StateModel Model where ] where genCreateDB = do - pure CreateDB + committee <- genMockPerasVotingCommittee + let params = perasTestParams + pure $ + CreateDB $ + PerasEpochContext + { pecCommittee = committee + , pecParams = params + } genAddVote = do roundNo <- genRoundNo @@ -179,10 +193,10 @@ instance StateModel Model where WithArrivalTime now $ ValidatedPerasVote { vpvVote = - PerasVote - { pvVoteRound = roundNo - , pvVoteBlock = point - , pvVoteVoterId = seatIndex + MockPerasVote + { mockVoteRound = roundNo + , mockVoteBlock = point + , mockVoteSeatIndex = seatIndex } , vpvVoteWeight = weight } @@ -231,7 +245,7 @@ instance StateModel Model where nextState (Model m) action _ = case action of - CreateDB -> Model $ Model.openDB m + CreateDB _context -> Model $ Model.openDB m AddVote vote -> Model $ snd $ Model.addVote vote m GetVoteIds -> Model $ m GetVotesAfter _ -> Model $ m @@ -240,7 +254,7 @@ instance StateModel Model where precondition (Model m) action = case action of - CreateDB -> not (Model.open m) + CreateDB _context -> not (Model.open m) AddVote _ -> Model.open m GetVoteIds -> Model.open m GetVotesAfter _ -> Model.open m @@ -256,8 +270,9 @@ instance HasVariables (Action Model a) where instance RunModel Model (StateT (PerasVoteDB IO TestBlock) IO) where perform _ action _ = case action of - CreateDB -> do - let args = PerasVoteDB.PerasVoteDbArgs nullTracer perasTestParams + CreateDB context -> do + resolverHandle <- lift $ mockPerasEpochContextResolverHandle context + let args = PerasVoteDB.PerasVoteDbArgs nullTracer resolverHandle voteDB <- lift $ PerasVoteDB.createDB args put voteDB AddVote vote -> do @@ -371,6 +386,8 @@ perasVoteDBErrorTag err = "MultipleWinnersInRound" ForgingCertError{} -> "ForgingCertError" + EpochContextNotFoundForRound{} -> + "EpochContextNotFoundForRound" addVoteResultTag :: AddPerasVoteResult TestBlock -> String addVoteResultTag res = diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs index cf8f1ee921..3cbf41ae8f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs @@ -49,6 +49,7 @@ import GHC.Generics import GHC.Stack import qualified Generics.SOP as SOP import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Storage.VolatileDB import Ouroboros.Consensus.Storage.VolatileDB.Impl.Types (FileId) @@ -77,6 +78,7 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Test.Util.Orphans.Arbitrary () import Test.Util.Orphans.ToExpr () +import Test.Util.Peras.Mock (genMockPerasVoterIndices) import Test.Util.QuickCheck import Test.Util.SOP import Test.Util.ToExpr () @@ -392,7 +394,7 @@ generatorCmdImpl Model{..} = TestBody <$> arbitrary <*> arbitrary - <*> liftArbitrary (PerasRoundNo <$> arbitrary) + <*> liftArbitrary genPerasCert prevHash <- frequency [ (1, return GenesisHash) @@ -407,6 +409,18 @@ generatorCmdImpl Model{..} = let clen = ChainLength (fromIntegral (unBlockNo no)) return $ mkBlock canContainEBB body prevHash slot no clen ebb + genPerasCert :: Gen (PerasCert Block) + genPerasCert = do + mockCertRound <- PerasRoundNo <$> arbitrary + mockCertBlock <- blockPoint <$> genRandomBlock + mockCertVoters <- genMockPerasVoterIndices + pure $ + MockPerasCert + { mockCertRound + , mockCertBlock + , mockCertVoters + } + genHash :: Gen (HeaderHash Block) genHash = frequency