diff --git a/changelog.d/20260421_170000_agustin.mista_concrete_certs_and_votes.md b/changelog.d/20260421_170000_agustin.mista_concrete_certs_and_votes.md new file mode 100644 index 0000000000..0bce9065c2 --- /dev/null +++ b/changelog.d/20260421_170000_agustin.mista_concrete_certs_and_votes.md @@ -0,0 +1,28 @@ + + + + +### Non-Breaking + +- Introduce `Ouroboros.Consensus.Util.Bitmap` providing `ByteString`-based compact bitmaps. +- Define `PerasBLSCrypto` scheme with support for all the voting committee superclasses. +- Define concrete `PerasVote` and `PerasCert` types using BLS signatures. +- Define `PerasVoteCompatibleWithVotingCommittee` and `PerasCertCompatibleWithVotingCommittee` type classes with conversions between concrete Peras types and their abstract voting committee counterparts. +- Instantiate `VotingCommitteeSupportsPeras` for both `WFALS` and `EveryoneVotes`. + + diff --git a/changelog.d/20260507_102103_agustin.mista_bytes32realpoint.md b/changelog.d/20260507_102103_agustin.mista_bytes32realpoint.md new file mode 100644 index 0000000000..2434d73981 --- /dev/null +++ b/changelog.d/20260507_102103_agustin.mista_bytes32realpoint.md @@ -0,0 +1,23 @@ + + + +### Non-Breaking + +- Introduce `Bytes32RealPoint` for real points with 32byte header hashes. + + 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 a4398e4b1a..7cca08c3f5 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 @@ -88,6 +88,7 @@ import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsPeerSelection +import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Util (ShowProxy (..)) @@ -573,3 +574,10 @@ decodeByronResult query = case query of instance CanUpgradeLedgerTables LedgerState ByronBlock where upgradeTables _ _ = id + +{------------------------------------------------------------------------------- + LedgerSupportsPeras +-------------------------------------------------------------------------------} + +-- | Default instance with no Peras support +instance LedgerSupportsPeras ByronBlock 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..782bd8fd4d 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs @@ -42,6 +42,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 +50,6 @@ 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.Node.InitStorage import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run @@ -302,8 +302,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..7509b4f185 --- /dev/null +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Peras.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Empty Peras support for Byron. +-- +-- NOTE: this module exists solely because the orphan module +-- 'Ouroboros.Consensus.Byron.Node.Serialisation' needs this instance, 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/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs index def77f1549..13c73e14c8 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 @@ -123,6 +123,8 @@ class HasPartialConsensusConfig proto , DecCBOR (SL.PState era) , Crypto (ProtoCrypto proto) + , -- Peras constraints + BlockSupportsPeras (ShelleyBlock proto era) , -- Backwards compatibility Plain.FromCBOR (LegacyPParams era) , Plain.ToCBOR (LegacyPParams era) 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..73674823d1 --- /dev/null +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Mocked Peras support for Shelley. +-- +-- NOTE: this module exists solely because the orphan module +-- 'Ouroboros.Consensus.Shelley.Node.Serialisation' needs this instance, but +-- defining it there would be too confusing. +module Ouroboros.Consensus.Shelley.Node.Peras () where + +import Cardano.Ledger.Api +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (..) + , VoidPerasError + ) +import Ouroboros.Consensus.Peras.Cert.Mock + ( MockPerasCert (..) + , forgeMockPerasCert + , validateMockPerasCert + ) +import Ouroboros.Consensus.Peras.Vote.Mock + ( MockPerasVote (..) + , validateMockPerasVote + ) +import Ouroboros.Consensus.Shelley.Ledger.Block + ( ShelleyBlock + , ShelleyCompatible + ) + +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- Peras support starts with DijkstraEra, so earlier eras use the default void +-- implementation. + +instance ShelleyCompatible proto ShelleyEra => BlockSupportsPeras (ShelleyBlock proto ShelleyEra) +instance ShelleyCompatible proto AllegraEra => BlockSupportsPeras (ShelleyBlock proto AllegraEra) +instance ShelleyCompatible proto MaryEra => BlockSupportsPeras (ShelleyBlock proto MaryEra) +instance ShelleyCompatible proto AlonzoEra => BlockSupportsPeras (ShelleyBlock proto AlonzoEra) +instance ShelleyCompatible proto BabbageEra => BlockSupportsPeras (ShelleyBlock proto BabbageEra) +instance ShelleyCompatible proto ConwayEra => BlockSupportsPeras (ShelleyBlock proto ConwayEra) + +-- NOTE: this is a mocked up implementation without crypto! +-- TODO: replace this with a concrete implementation using 'Peras.Vote.V1' and +-- 'Peras.Cert.V1' for era >= DijkstraEra. +instance + ShelleyCompatible proto DijkstraEra => + BlockSupportsPeras (ShelleyBlock proto DijkstraEra) + where + type PerasVote (ShelleyBlock proto DijkstraEra) = MockPerasVote (ShelleyBlock proto DijkstraEra) + type PerasCert (ShelleyBlock proto DijkstraEra) = MockPerasCert (ShelleyBlock proto DijkstraEra) + type PerasError (ShelleyBlock proto DijkstraEra) = VoidPerasError (ShelleyBlock proto DijkstraEra) + + validatePerasVote = validateMockPerasVote + validatePerasCert = validateMockPerasCert + forgePerasCert = forgeMockPerasCert + + -- TODO: extract actual Peras certificates from blocks + getPerasCertInBlock _ = Nothing 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/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs index 4e045bfd84..07618ee158 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -163,21 +163,112 @@ 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) + , LedgerSupportsPeras (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) + , LedgerSupportsPeras (ShelleyBlock proto AllegraEra) + , TxLimits (ShelleyBlock proto AllegraEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto AllegraEra] +instance + ( ShelleyCompatible proto MaryEra + , LedgerSupportsProtocol (ShelleyBlock proto MaryEra) + , LedgerSupportsPeras (ShelleyBlock proto MaryEra) + , TxLimits (ShelleyBlock proto MaryEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto MaryEra] +instance + ( ShelleyCompatible proto AlonzoEra + , LedgerSupportsProtocol (ShelleyBlock proto AlonzoEra) + , LedgerSupportsPeras (ShelleyBlock proto AlonzoEra) + , TxLimits (ShelleyBlock proto AlonzoEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto AlonzoEra] +instance + ( ShelleyCompatible proto BabbageEra + , LedgerSupportsProtocol (ShelleyBlock proto BabbageEra) + , LedgerSupportsPeras (ShelleyBlock proto BabbageEra) + , TxLimits (ShelleyBlock proto BabbageEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto BabbageEra] +instance + ( ShelleyCompatible proto ConwayEra + , LedgerSupportsProtocol (ShelleyBlock proto ConwayEra) + , LedgerSupportsPeras (ShelleyBlock proto ConwayEra) + , TxLimits (ShelleyBlock proto ConwayEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto ConwayEra] +instance + ( ShelleyCompatible proto DijkstraEra + , LedgerSupportsProtocol (ShelleyBlock proto DijkstraEra) + , LedgerSupportsPeras (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 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..183dce4f95 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 @@ -27,6 +27,7 @@ import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Byron.Node import Ouroboros.Consensus.Byron.Protocol import Ouroboros.Consensus.ByronDual.Ledger +import Ouroboros.Consensus.ByronDual.Node.Peras () import Ouroboros.Consensus.ByronDual.Node.Serialisation () import Ouroboros.Consensus.ByronSpec.Ledger import qualified Ouroboros.Consensus.ByronSpec.Ledger.Genesis as Genesis diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Peras.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Peras.hs new file mode 100644 index 0000000000..5cf7407010 --- /dev/null +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Peras.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Empty Peras support for DualByron. +-- +-- NOTE: this module exists solely because the orphan module +-- 'Ouroboros.Consensus.ByronDual.Node.Serialisation' needs this instance, but +-- defining it there would be too confusing. +module Ouroboros.Consensus.ByronDual.Node.Peras () where + +import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras) +import Ouroboros.Consensus.ByronDual.Ledger (DualByronBlock) + +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: DualByron does not support Peras, so we can use the empty instance here. +instance BlockSupportsPeras DualByronBlock diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs index 946ec235bb..787cf7e4ab 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs @@ -16,6 +16,7 @@ import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Byron.Node.Serialisation () import Ouroboros.Consensus.Byron.Protocol import Ouroboros.Consensus.ByronDual.Ledger +import Ouroboros.Consensus.ByronDual.Node.Peras () import Ouroboros.Consensus.ByronSpec.Ledger import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Dual 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 8c50f1767a..b1486bd4cc 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 @@ -186,6 +186,8 @@ type ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 = , 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 (TxMeasure (ShelleyBlock proto1 era1)) (TxMeasure (ShelleyBlock proto2 era2)) 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 41c4cbe936..5102434ec1 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 @@ -276,8 +276,9 @@ mkHandlers :: ( IOLike m , MonadTime m , MonadTimer m - , LedgerSupportsMempool blk , HasTxId (GenTx blk) + , BlockSupportsPeras blk + , LedgerSupportsMempool blk , LedgerSupportsProtocol blk , Ord addrNTN , Hashable addrNTN @@ -621,6 +622,8 @@ showTracers :: , Show (Header blk) , Show (GenTx blk) , Show (GenTxId blk) + , Show (PerasVote blk) + , Show (PerasCert blk) , HasHeader blk , HasNestedContent Header blk ) => @@ -778,6 +781,8 @@ mkApps :: , 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/Tracers.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs index dc48b9d317..cffac87302 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 @@ -191,6 +191,8 @@ showTracers :: , Show (ForgeStateUpdateError blk) , Show (CannotForge blk) , Show (TxMeasure blk) + , Show (PerasVote blk) + , Show (PerasCert blk) , Show remotePeer , LedgerSupportsProtocol blk ) => 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 ee17e0a1fb..068684c9d4 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 @@ -1777,6 +1777,8 @@ type TracingConstraints blk = , Show (CannotForge blk) , Show (TxMeasure blk) , Show (ReasonForSwitch (TiebreakerView (BlockProtocol blk))) + , Show (PerasVote blk) + , Show (PerasCert blk) , HasNestedContent Header 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..7c0771d947 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 @@ -31,6 +31,7 @@ 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.Ledger.Basics (LedgerState) @@ -162,6 +163,7 @@ runGenesisTest :: , LedgerSupportsPeras blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk @@ -224,6 +226,7 @@ runConformanceTest :: , LedgerSupportsPeras blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash 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..17fafb54ae 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 @@ -35,6 +35,7 @@ import Data.Monoid (Endo (..)) import GHC.Generics (Generic, Generically (..)) import Ouroboros.Consensus.Block ( BlockSupportsDiffusionPipelining + , BlockSupportsPeras , ConvertRawHash , Header ) @@ -186,6 +187,7 @@ toTestTree :: , LedgerSupportsPeras blk , SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk 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 2f6d1f4dea..8a8a37abcf 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 @@ -4,6 +4,7 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -309,6 +310,9 @@ instance LedgerSupportsProtocol BlockA where instance LedgerSupportsPeras BlockA +-- NOTE: this block does not support Peras, so we can use the empty instance here. +instance BlockSupportsPeras BlockA + instance HasPartialConsensusConfig ProtocolA instance HasPartialLedgerConfig BlockA where 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 6e7401deca..b01cea1f33 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 @@ -4,6 +4,7 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -265,6 +266,9 @@ instance LedgerSupportsProtocol BlockB where instance LedgerSupportsPeras BlockB +-- NOTE: this block does not support Peras, so we can use the empty instance here. +instance BlockSupportsPeras BlockB + instance HasPartialConsensusConfig ProtocolB instance HasPartialLedgerConfig BlockB 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 20b4147bb7..8d91c0fe3e 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 @@ -137,6 +137,7 @@ mkChainDb :: , LedgerSupportsPeras blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk @@ -190,6 +191,7 @@ restoreNode :: , LedgerSupportsPeras blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk @@ -220,6 +222,7 @@ lifecycleStart :: , LedgerSupportsPeras blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash 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 bf9d106caa..b56308c9c8 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 @@ -553,6 +553,7 @@ nodeLifecycle :: , LedgerSupportsPeras blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk @@ -612,6 +613,7 @@ runPointSchedule :: , LedgerSupportsPeras blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 86af9b10c5..5bcfa4e8c5 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -236,12 +236,17 @@ library Ouroboros.Consensus.Node.Run Ouroboros.Consensus.Node.Serialisation Ouroboros.Consensus.NodeId - Ouroboros.Consensus.Peras.Cert Ouroboros.Consensus.Peras.Cert.Inclusion + Ouroboros.Consensus.Peras.Cert.Mock + Ouroboros.Consensus.Peras.Cert.V1 + Ouroboros.Consensus.Peras.Crypto.BLS Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView - Ouroboros.Consensus.Peras.Vote + Ouroboros.Consensus.Peras.Types Ouroboros.Consensus.Peras.Vote.Aggregation + Ouroboros.Consensus.Peras.Vote.Mock + Ouroboros.Consensus.Peras.Vote.V1 + Ouroboros.Consensus.Peras.Voting.Adapter Ouroboros.Consensus.Peras.Voting.Rules Ouroboros.Consensus.Peras.Voting.View Ouroboros.Consensus.Peras.Weight @@ -320,6 +325,7 @@ library Ouroboros.Consensus.Util.AnchoredSeq Ouroboros.Consensus.Util.Args Ouroboros.Consensus.Util.Assert + Ouroboros.Consensus.Util.Bitmap Ouroboros.Consensus.Util.CallStack Ouroboros.Consensus.Util.CBOR Ouroboros.Consensus.Util.Condense @@ -576,6 +582,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 @@ -673,8 +680,12 @@ test-suite consensus-test Test.Consensus.MiniProtocol.ObjectDiffusion.PerasVote.Smoke Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke Test.Consensus.Peras.Cert.Inclusion + Test.Consensus.Peras.Serialisation + Test.Consensus.Peras.Util + Test.Consensus.Peras.Voting.Adapter Test.Consensus.Peras.Voting.Rules Test.Consensus.Peras.WeightSnapshot + Test.Consensus.Util.Bitmap Test.Consensus.Util.MonadSTM.NormalForm Test.Consensus.Util.Pred Test.Consensus.Util.Versioned @@ -1307,6 +1318,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 @@ -1338,6 +1350,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 @@ -1435,6 +1448,7 @@ library unstable-byron-testlib exposed-modules: Ouroboros.Consensus.ByronDual.Ledger Ouroboros.Consensus.ByronDual.Node + Ouroboros.Consensus.ByronDual.Node.Peras Ouroboros.Consensus.ByronDual.Node.Serialisation Test.Consensus.Byron.Examples Test.Consensus.Byron.Generators 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/RealPoint.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs index 94e2b9515d..966cec0f81 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} @@ -22,12 +23,24 @@ module Ouroboros.Consensus.Block.RealPoint , realPointSlot , realPointToPoint , withOriginRealPointToPoint + + -- * Bytes32RealPoint + , Bytes32RealPoint + , bytes32RealPointHash + , bytes32RealPointSlot + , decodeBytes32RealPoint + , encodeBytes32RealPoint + , fromBytes32RealPoint + , toBytes32RealPoint ) where import Cardano.Binary (enforceSize) import Codec.CBOR.Decoding (Decoder) import Codec.CBOR.Encoding (Encoding, encodeListLen) import Codec.Serialise (decode, encode) +import Control.Exception (assert) +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as ByteString import Data.Coerce import Data.Proxy import Data.Typeable (Typeable, typeRep) @@ -120,3 +133,53 @@ castRealPoint :: RealPoint blk -> RealPoint blk' castRealPoint (RealPoint s h) = RealPoint s (coerce h) + +{------------------------------------------------------------------------------- + Bytes32RealPoint +-------------------------------------------------------------------------------} + +-- | A 'RealPoint' where the hash is always 32 bytes. +-- +-- The length of the hash is enforced during decoding. +data Bytes32RealPoint = Bytes32RealPoint !SlotNo !ShortByteString + deriving (Show, Eq, Generic, NoThunks) + +bytes32RealPointSlot :: Bytes32RealPoint -> SlotNo +bytes32RealPointSlot (Bytes32RealPoint s _) = s + +bytes32RealPointHash :: Bytes32RealPoint -> ShortByteString +bytes32RealPointHash (Bytes32RealPoint _ h) = h + +encodeBytes32RealPoint :: Bytes32RealPoint -> Encoding +encodeBytes32RealPoint (Bytes32RealPoint s h) = + mconcat + [ encodeListLen 2 + , encode s + , encode h + ] + +decodeBytes32RealPoint :: forall s. Decoder s Bytes32RealPoint +decodeBytes32RealPoint = do + enforceSize "Bytes32RealPoint" 2 + s <- decode + h <- decode + case ByteString.length h of + 32 -> pure (Bytes32RealPoint s h) + len -> fail $ "decodeBytes32RealPoint: expected 32 bytes, got " <> show len + +fromBytes32RealPoint :: + forall blk. + Coercible (HeaderHash blk) ShortByteString => + Bytes32RealPoint -> + RealPoint blk +fromBytes32RealPoint (Bytes32RealPoint s h) = + RealPoint s (coerce h) + +toBytes32RealPoint :: + forall blk. + Coercible (HeaderHash blk) ShortByteString => + RealPoint blk -> + Bytes32RealPoint +toBytes32RealPoint (RealPoint s h) = + assert (ByteString.length (coerce h) == 32) $ + Bytes32RealPoint s (coerce h) 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 adb80c5118..66c6a91b57 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} @@ -5,202 +7,221 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Block.SupportsPeras - ( PerasRoundNo (..) - , onPerasRoundNo - , PerasVoteId (..) - , PerasVoteTarget (..) - , PerasVoterId (..) - , PerasVoteStake (..) - , stakeAboveThreshold - , PerasVoteStakeDistr (..) - , lookupPerasVoteStake - , BlockSupportsPeras (..) - , PerasCert (..) - , PerasVote (..) + ( BlockSupportsPeras (..) + , VoidPerasVote (..) + , VoidPerasCert (..) + , VoidPerasError (..) , ValidatedPerasCert (..) , ValidatedPerasVote (..) , ValidatedPerasVotesWithQuorum ( vpvqTarget , vpvqVotes - , vpvqPerasCfg + , vpvqPerasParams ) , votesReachQuorum - , HasPerasCertRound (..) - , HasPerasCertBoostedBlock (..) - , HasPerasCertBoost (..) - , HasPerasVoteRound (..) - , HasPerasVoteBlock (..) - , HasPerasVoteVoterId (..) - , HasPerasVoteStake (..) - , HasPerasVoteTarget (..) - , HasPerasVoteId (..) + , IsPerasVote (..) + , getPerasVoteId + , getPerasVoteTarget + , IsPerasCert (..) -- * Convenience re-exports , module Ouroboros.Consensus.Peras.Params + , module Ouroboros.Consensus.Peras.Types ) where -import Cardano.Binary (FromCBOR, ToCBOR) -import qualified Cardano.Binary as KeyHash -import Cardano.Ledger.Hashes (KeyHash, KeyRole (..)) -import Codec.Serialise (Serialise (..)) -import Codec.Serialise.Decoding (decodeListLenOf) -import Codec.Serialise.Encoding (encodeListLen) -import Control.DeepSeq (NFData) -import Data.Coerce (coerce) +import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Map as Map -import Data.Map.Strict (Map) -import Data.Monoid (Sum (..)) -import Data.Proxy (Proxy (..)) -import Data.Word (Word64) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Typeable (Typeable) +import Data.Void (Void, absurd) import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) import Ouroboros.Consensus.Peras.Params -import Ouroboros.Consensus.Util -import Ouroboros.Consensus.Util.Condense -import Quiet (Quiet (..)) +import Ouroboros.Consensus.Peras.Types +import Ouroboros.Consensus.Util (ShowProxy) -{------------------------------------------------------------------------------- --- * Peras types --------------------------------------------------------------------------------} +-- * BlockSupportsPeras class --- ** Round numbers +class + ( StandardHash blk + , Typeable blk + , Typeable (PerasVote blk) + , Typeable (PerasCert blk) + , Typeable (PerasError blk) + , Show (PerasVote blk) + , Show (PerasCert blk) + , Show (PerasError blk) + , Eq (PerasVote blk) + , Eq (PerasCert blk) + , Eq (PerasError blk) + , NoThunks (PerasVote blk) + , NoThunks (PerasCert blk) + , NoThunks (PerasError blk) + , IsPerasVote (PerasVote blk) blk + , IsPerasCert (PerasCert blk) blk + ) => + BlockSupportsPeras blk + where + type PerasVote blk = (vote :: Type) | vote -> blk + type PerasVote blk = VoidPerasVote blk -newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} - deriving Show via Quiet PerasRoundNo - deriving stock Generic - deriving newtype (Enum, Eq, Ord, Num, Bounded, NoThunks, Serialise, NFData, ToCBOR, FromCBOR) + type PerasCert blk = (cert :: Type) | cert -> blk + type PerasCert blk = VoidPerasCert blk -instance Condense PerasRoundNo where - condense = show . unPerasRoundNo + type PerasError blk = (err :: Type) | err -> blk + type PerasError blk = VoidPerasError blk -instance ShowProxy PerasRoundNo where - showProxy _ = "PerasRoundNo" + validatePerasVote :: + PerasParams -> + PerasVoteStakeDistr -> + PerasVote blk -> + Either (PerasError blk) (ValidatedPerasVote blk) + default validatePerasVote :: + PerasVote blk ~ VoidPerasVote blk => + PerasParams -> + PerasVoteStakeDistr -> + PerasVote blk -> + Either (PerasError blk) (ValidatedPerasVote blk) + validatePerasVote _ _ vote = + absurd (unVoidPerasVote vote) + + validatePerasCert :: + PerasParams -> + PerasCert blk -> + Either (PerasError blk) (ValidatedPerasCert blk) + default validatePerasCert :: + PerasCert blk ~ VoidPerasCert blk => + PerasParams -> + PerasCert blk -> + Either (PerasError blk) (ValidatedPerasCert blk) + validatePerasCert _ cert = + absurd (unVoidPerasCert cert) + + forgePerasCert :: + PerasParams -> + ValidatedPerasVotesWithQuorum blk -> + Either (PerasError blk) (ValidatedPerasCert blk) + default forgePerasCert :: + PerasVote blk ~ VoidPerasVote blk => + PerasParams -> + ValidatedPerasVotesWithQuorum blk -> + Either (PerasError blk) (ValidatedPerasCert blk) + forgePerasCert _ votes = + absurd (unVoidPerasVote (vpvVote (NonEmpty.head (vpvqVotes votes)))) --- | Lift a binary operation on 'Word64' to 'PerasRoundNo' -onPerasRoundNo :: - (Word64 -> Word64 -> Word64) -> - (PerasRoundNo -> PerasRoundNo -> PerasRoundNo) -onPerasRoundNo = coerce + -- | Extract a Peras certificate optionally stored in a block. + -- + -- Returns 'Nothing' if the block does not contain a Peras certificate, or + -- if the block is from an era that does not support Peras certificates. + getPerasCertInBlock :: + blk -> + Maybe (PerasCert blk) + getPerasCertInBlock _ = + Nothing --- ** Stake pool distributions +-- * Helpers to derive @BlockSupportsPeras@ for block types without Peras support -newtype PerasVoterId = PerasVoterId - { unPerasVoterId :: KeyHash StakePool - } - deriving newtype NoThunks - deriving stock (Eq, Ord, Generic) - deriving Show via Quiet PerasVoterId - --- NOTE: At the moment there is no consensus from researchers/engineers on how --- we go from the absolute stake of a voter in the ledger to the relative stake --- of their vote in the voting commitee (given that the quorum is expressed as --- a relative value of the voting commitee total stake). +-- | Imposible Peras vote for @blk@. -- --- So, for now you can consider this 'Rational' as the best approximation we --- have at the moment of the concrete type for a relative vote stake that can be --- compared to the quorum threshold value (also currently a 'Rational'). -newtype PerasVoteStake = PerasVoteStake - { unPerasVoteStake :: Rational +-- NOTE: the phantom @blk@ is used to keep the 'PerasVote' type family injective. +newtype VoidPerasVote blk + = VoidPerasVote + { unVoidPerasVote :: Void } - deriving newtype (Eq, Ord, Num, Fractional, NoThunks, Serialise) - deriving stock Generic - deriving Show via Quiet PerasVoteStake - deriving Semigroup via Sum Rational - deriving Monoid via Sum Rational + deriving newtype (Show, Eq, NoThunks, ShowProxy) --- | Check whether a given vote stake is above the quorum threshold. +-- | Imposible Peras certificate for @blk@. -- --- TODO: this function assumes that the 'PerasVoteStake' and the quorum --- threshold used in 'PerasParams' are expressed in the same units. That is, --- both are either absolute or relative (normalized) values. Under the current --- current implementation of 'PerasParams', this function only makes sense when --- both values are relative (normalized) values, so we should either normalize --- the 'PerasVoteStake' before calling this function, or change this function to --- accept a stake distribution and perform the normalization internally. -stakeAboveThreshold :: PerasParams -> PerasVoteStake -> Bool -stakeAboveThreshold params voteStake = - stake >= quorumThreshold + safetyMargin - where - stake = - unPerasVoteStake voteStake - quorumThreshold = - unPerasQuorumStakeThreshold - (perasQuorumStakeThreshold params) - safetyMargin = - unPerasQuorumStakeThresholdSafetyMargin - (perasQuorumStakeThresholdSafetyMargin params) - -newtype PerasVoteStakeDistr = PerasVoteStakeDistr - { unPerasVoteStakeDistr :: Map PerasVoterId PerasVoteStake +-- NOTE: the phantom @blk@ is used to keep the 'PerasCert' type family injective. +newtype VoidPerasCert blk + = VoidPerasCert + { unVoidPerasCert :: Void } - deriving newtype NoThunks - deriving stock (Show, Eq, Generic) + deriving newtype (Show, Eq, NoThunks, ShowProxy) -data PerasVoteTarget blk = PerasVoteTarget - { pvtRoundNo :: !PerasRoundNo - , pvtBlock :: !(Point blk) - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass NoThunks +instance IsPerasVote (VoidPerasVote blk) blk where + getPerasVoteRound = absurd . unVoidPerasVote + getPerasVoteBlock = absurd . unVoidPerasVote + getPerasVoteVoterId = absurd . unVoidPerasVote -data PerasVoteId blk = PerasVoteId - { pviRoundNo :: !PerasRoundNo - , pviVoterId :: !PerasVoterId - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass NoThunks - --- | Lookup the stake of a vote cast by a member of a given stake distribution. -lookupPerasVoteStake :: - PerasVote blk -> - PerasVoteStakeDistr -> - Maybe PerasVoteStake -lookupPerasVoteStake vote distr = - Map.lookup - (pvVoteVoterId vote) - (unPerasVoteStakeDistr distr) - --- ** Validated types - -data ValidatedPerasCert blk = ValidatedPerasCert - { vpcCert :: !(PerasCert blk) - , vpcCertBoost :: !PerasWeight +instance IsPerasCert (VoidPerasCert blk) blk where + getPerasCertRound = absurd . unVoidPerasCert + getPerasCertBlock = absurd . unVoidPerasCert + +-- | Imposible Peras error for @blk@. +-- +-- NOTE: the phantom @blk@ is used to keep the 'PerasError' type family injective. +newtype VoidPerasError blk + = VoidPerasError + { unVoidPerasError :: Void } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass NoThunks + deriving newtype (Show, Eq, NoThunks, ShowProxy) -data ValidatedPerasVote blk = ValidatedPerasVote +-- * Validated types + +data ValidatedPerasVote blk + = ValidatedPerasVote { vpvVote :: !(PerasVote blk) , vpvVoteStake :: !PerasVoteStake } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass NoThunks --- ** Votes with enough stake to reach quorum for a given target +deriving instance Show (PerasVote blk) => Show (ValidatedPerasVote blk) +deriving instance Eq (PerasVote blk) => Eq (ValidatedPerasVote blk) +deriving instance Ord (PerasVote blk) => Ord (ValidatedPerasVote blk) +deriving instance NoThunks (PerasVote blk) => NoThunks (ValidatedPerasVote blk) +deriving instance Generic (ValidatedPerasVote blk) + +data ValidatedPerasCert blk + = ValidatedPerasCert + { vpcCert :: !(PerasCert blk) + , vpcCertBoost :: !PerasWeight + } + +deriving instance Show (PerasCert blk) => Show (ValidatedPerasCert blk) +deriving instance Eq (PerasCert blk) => Eq (ValidatedPerasCert blk) +deriving instance Ord (PerasCert blk) => Ord (ValidatedPerasCert blk) +deriving instance NoThunks (PerasCert blk) => NoThunks (ValidatedPerasCert blk) +deriving instance Generic (ValidatedPerasCert blk) -- | A collection of validated Peras votes that: -- 1. are all for the same target, and -- 2. have total stake above the quorum threshold for a given 'PerasCfg'. -data ValidatedPerasVotesWithQuorum blk = ValidatedPerasVotesWithQuorum +data ValidatedPerasVotesWithQuorum blk + = ValidatedPerasVotesWithQuorum { vpvqTarget :: !(PerasVoteTarget blk) -- ^ The target that all the votes are for , vpvqVotes :: !(NonEmpty (ValidatedPerasVote blk)) -- ^ The votes that reached quorum for the given target - , vpvqPerasCfg :: !(PerasCfg blk) - -- ^ The Peras configuration used to validate that the votes reach quorum + , vpvqPerasParams :: !PerasParams + -- ^ The Peras parameters used to validate that the votes reach quorum } - deriving stock (Show, Eq, Generic) - deriving anyclass NoThunks + +deriving instance + ( StandardHash blk + , Show (PerasVote blk) + ) => + Show (ValidatedPerasVotesWithQuorum blk) +deriving instance + ( StandardHash blk + , Eq (PerasVote blk) + ) => + Eq (ValidatedPerasVotesWithQuorum blk) +deriving instance + ( StandardHash blk + , NoThunks (PerasVote blk) + ) => + NoThunks (ValidatedPerasVotesWithQuorum blk) +deriving instance + Generic (ValidatedPerasVotesWithQuorum blk) -- | Smart constructor for 'ValidatedPerasVotesReachingQuorum'. -- @@ -208,11 +229,13 @@ data ValidatedPerasVotesWithQuorum blk = ValidatedPerasVotesWithQuorum -- total stake is above the quorum threshold defined in the given 'PerasCfg'. -- It returns 'Nothing' if either of these conditions is not met. votesReachQuorum :: - StandardHash blk => - PerasCfg blk -> + ( StandardHash blk + , IsPerasVote (PerasVote blk) blk + ) => + PerasParams -> [ValidatedPerasVote blk] -> Maybe (ValidatedPerasVotesWithQuorum blk) -votesReachQuorum cfg votes = +votesReachQuorum params votes = case votes of -- We need at least one vote to determine who these votes are for, so we -- can't vacuously reach a quorum, even if the quorum threshold is 0. @@ -229,319 +252,68 @@ votesReachQuorum cfg votes = ValidatedPerasVotesWithQuorum { vpvqTarget = getPerasVoteTarget v0 , vpvqVotes = v0 :| vs - , vpvqPerasCfg = cfg + , vpvqPerasParams = params } where totalVoteStake = mconcat (vpvVoteStake <$> votes) votesHaveEnoughStake = - stakeAboveThreshold cfg totalVoteStake + stakeAboveThreshold params totalVoteStake allVotesMatchTarget target = all ((== (getPerasVoteTarget target)) . getPerasVoteTarget) -{------------------------------------------------------------------------------- --- * BlockSupportsPeras class --------------------------------------------------------------------------------} - -class - ( Show (PerasCfg blk) - , NoThunks (PerasCert blk) - ) => - BlockSupportsPeras blk - where - type PerasCfg blk - - data PerasCert blk - - data PerasVote blk - - data PerasValidationErr blk - - data PerasForgeErr blk +-- * Convenience projection classes - validatePerasCert :: - PerasCfg blk -> - PerasCert blk -> - Either (PerasValidationErr blk) (ValidatedPerasCert blk) - - validatePerasVote :: - PerasCfg blk -> - PerasVoteStakeDistr -> - PerasVote blk -> - Either (PerasValidationErr blk) (ValidatedPerasVote blk) - - forgePerasCert :: - PerasCfg blk -> - ValidatedPerasVotesWithQuorum blk -> - Either (PerasForgeErr blk) (ValidatedPerasCert blk) - - -- | Extract a Peras certificate optionally stored in a block. - -- - -- Returns 'Nothing' if the block does not contain a Peras certificate, or - -- 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 PerasCfg blk = PerasParams +-- | Types that support being treated as Peras votes +class IsPerasVote vote blk | vote -> blk where + getPerasVoteRound :: vote -> PerasRoundNo + getPerasVoteBlock :: vote -> Point blk + getPerasVoteVoterId :: vote -> PerasVoterId - data PerasCert blk = PerasCert - { pcCertRound :: PerasRoundNo - , pcCertBoostedBlock :: Point blk +-- | Extract the vote ID from a Peras vote container +getPerasVoteId :: IsPerasVote vote blk => vote -> PerasVoteId blk +getPerasVoteId vote = + PerasVoteId + { pviRoundNo = getPerasVoteRound vote + , pviVoterId = getPerasVoteVoterId vote } - deriving stock (Generic, Eq, Ord, Show) - deriving anyclass NoThunks - data PerasVote blk = PerasVote - { pvVoteRound :: PerasRoundNo - , pvVoteBlock :: Point blk - , pvVoteVoterId :: PerasVoterId +-- | Extract the vote target from a Peras vote container +getPerasVoteTarget :: IsPerasVote vote blk => vote -> PerasVoteTarget blk +getPerasVoteTarget vote = + PerasVoteTarget + { pvtRoundNo = getPerasVoteRound vote + , pvtBlock = getPerasVoteBlock vote } - deriving stock (Generic, Eq, Ord, Show) - deriving anyclass NoThunks - - -- TODO: enrich with actual error types - -- see https://github.com/tweag/cardano-peras/issues/120 - data PerasValidationErr blk - = PerasValidationErr - deriving stock (Show, Eq) - - -- TODO: enrich with actual error types - -- see https://github.com/tweag/cardano-peras/issues/120 - data PerasForgeErr blk - = PerasForgeErr - deriving stock (Show, Eq) - - -- TODO: perform actual validation against all - -- possible 'PerasValidationErr' variants - -- see https://github.com/tweag/cardano-peras/issues/120 - validatePerasCert params cert = - Right - ValidatedPerasCert - { vpcCert = cert - , vpcCertBoost = perasWeight params - } - - -- TODO: perform actual validation against all - -- possible 'PerasValidationErr' variants - -- see https://github.com/tweag/cardano-peras/issues/120 - validatePerasVote _params stakeDistr vote - | Just stake <- lookupPerasVoteStake vote stakeDistr = - Right - ValidatedPerasVote - { vpvVote = vote - , vpvVoteStake = stake - } - | otherwise = - Left PerasValidationErr - - -- TODO: perform actual validation against all - -- possible 'PerasForgeErr' variants - -- see https://github.com/tweag/cardano-peras/issues/120 - forgePerasCert params votes = - return $ - ValidatedPerasCert - { vpcCert = - PerasCert - { pcCertRound = pvtRoundNo (vpvqTarget votes) - , pcCertBoostedBlock = pvtBlock (vpvqTarget votes) - } - , vpcCertBoost = perasWeight params - } - - -- TODO: extract actual Peras certificates from blocks when the HFC plumbing - -- is in place. - getPerasCertInBlock _ = Nothing - -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 ShowProxy blk => ShowProxy (PerasVoteId blk) where - showProxy _ = "PerasVoteId " <> 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 - <> KeyHash.toCBOR (unPerasVoterId pvVoteVoterId) - decode = do - decodeListLenOf 3 - pvVoteRound <- decode - pvVoteBlock <- decode - pvVoteVoterId <- PerasVoterId <$> KeyHash.fromCBOR - pure $ PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId} - -instance Serialise (PerasVoteId blk) where - encode PerasVoteId{pviRoundNo, pviVoterId} = - encodeListLen 2 - <> encode pviRoundNo - <> KeyHash.toCBOR (unPerasVoterId pviVoterId) - decode = do - decodeListLenOf 2 - pviRoundNo <- decode - pviVoterId <- PerasVoterId <$> KeyHash.fromCBOR - pure $ PerasVoteId{pviRoundNo, pviVoterId} - --- | Extract the certificate round from a Peras certificate container -class HasPerasCertRound cert where - getPerasCertRound :: cert -> PerasRoundNo - -instance HasPerasCertRound (PerasCert blk) where - getPerasCertRound = pcCertRound - -instance HasPerasCertRound (ValidatedPerasCert blk) where - getPerasCertRound = getPerasCertRound . vpcCert - -instance - HasPerasCertRound cert => - HasPerasCertRound (WithArrivalTime cert) - where - getPerasCertRound = getPerasCertRound . forgetArrivalTime - --- | Extract the boosted block point from a Peras certificate container -class HasPerasCertBoostedBlock cert blk | cert -> blk where - getPerasCertBoostedBlock :: cert -> Point blk - -instance HasPerasCertBoostedBlock (PerasCert blk) blk where - getPerasCertBoostedBlock = pcCertBoostedBlock - -instance HasPerasCertBoostedBlock (ValidatedPerasCert blk) blk where - getPerasCertBoostedBlock = getPerasCertBoostedBlock . vpcCert instance - HasPerasCertBoostedBlock cert blk => - HasPerasCertBoostedBlock (WithArrivalTime cert) blk + IsPerasVote (PerasVote blk) blk => + IsPerasVote (ValidatedPerasVote blk) blk where - getPerasCertBoostedBlock = getPerasCertBoostedBlock . forgetArrivalTime - --- | Extract the certificate boost from a Peras certificate container -class HasPerasCertBoost cert where - getPerasCertBoost :: cert -> PerasWeight - -instance HasPerasCertBoost (ValidatedPerasCert blk) where - getPerasCertBoost = vpcCertBoost - -instance - HasPerasCertBoost cert => - HasPerasCertBoost (WithArrivalTime cert) - where - getPerasCertBoost = getPerasCertBoost . forgetArrivalTime - --- | Extract the vote round from a Peras vote container -class HasPerasVoteRound vote where - getPerasVoteRound :: vote -> PerasRoundNo - -instance HasPerasVoteRound (PerasVote blk) where - getPerasVoteRound = pvVoteRound - -instance HasPerasVoteRound (ValidatedPerasVote blk) where getPerasVoteRound = getPerasVoteRound . vpvVote - -instance - HasPerasVoteRound vote => - HasPerasVoteRound (WithArrivalTime vote) - where - getPerasVoteRound = getPerasVoteRound . forgetArrivalTime - --- | Extract the vote block point from a Peras vote container -class HasPerasVoteBlock vote blk | vote -> blk where - getPerasVoteBlock :: vote -> Point blk - -instance HasPerasVoteBlock (PerasVote blk) blk where - getPerasVoteBlock = pvVoteBlock - -instance HasPerasVoteBlock (ValidatedPerasVote blk) blk where getPerasVoteBlock = getPerasVoteBlock . vpvVote - -instance - HasPerasVoteBlock vote blk => - HasPerasVoteBlock (WithArrivalTime vote) blk - where - getPerasVoteBlock = getPerasVoteBlock . forgetArrivalTime - --- | Extract the stake pool ID from a Peras vote container -class HasPerasVoteVoterId vote where - getPerasVoteVoterId :: vote -> PerasVoterId - -instance HasPerasVoteVoterId (PerasVote blk) where - getPerasVoteVoterId = pvVoteVoterId - -instance HasPerasVoteVoterId (ValidatedPerasVote blk) where getPerasVoteVoterId = getPerasVoteVoterId . vpvVote instance - HasPerasVoteVoterId vote => - HasPerasVoteVoterId (WithArrivalTime vote) + IsPerasVote vote blk => + IsPerasVote (WithArrivalTime vote) blk where + getPerasVoteRound = getPerasVoteRound . forgetArrivalTime + getPerasVoteBlock = getPerasVoteBlock . forgetArrivalTime getPerasVoteVoterId = getPerasVoteVoterId . forgetArrivalTime --- | Extract the vote stake from a validated Peras vote container -class HasPerasVoteStake vote where - getPerasVoteStake :: vote -> PerasVoteStake - -instance HasPerasVoteStake (ValidatedPerasVote blk) where - getPerasVoteStake = vpvVoteStake - -instance - HasPerasVoteStake vote => - HasPerasVoteStake (WithArrivalTime vote) - where - getPerasVoteStake = getPerasVoteStake . forgetArrivalTime - --- | Extract the vote target from a Peras vote container -class HasPerasVoteTarget vote blk | vote -> blk where - getPerasVoteTarget :: vote -> PerasVoteTarget blk - -instance HasPerasVoteTarget (PerasVote blk) blk where - getPerasVoteTarget vote = - PerasVoteTarget - { pvtRoundNo = pvVoteRound vote - , pvtBlock = pvVoteBlock vote - } - -instance HasPerasVoteTarget (ValidatedPerasVote blk) blk where - getPerasVoteTarget = getPerasVoteTarget . vpvVote +-- | Types that support being treated as Peras certificates +class IsPerasCert cert blk | cert -> blk where + getPerasCertRound :: cert -> PerasRoundNo + getPerasCertBlock :: cert -> Point blk instance - HasPerasVoteTarget vote blk => - HasPerasVoteTarget (WithArrivalTime vote) blk + IsPerasCert (PerasCert blk) blk => + IsPerasCert (ValidatedPerasCert blk) blk where - getPerasVoteTarget = getPerasVoteTarget . forgetArrivalTime - --- | Extract the vote ID from a Peras vote container -class HasPerasVoteId vote blk | vote -> blk where - getPerasVoteId :: vote -> PerasVoteId blk - -instance HasPerasVoteId (PerasVote blk) blk where - getPerasVoteId vote = - PerasVoteId - { pviRoundNo = pvVoteRound vote - , pviVoterId = pvVoteVoterId vote - } - -instance HasPerasVoteId (ValidatedPerasVote blk) blk where - getPerasVoteId = getPerasVoteId . vpvVote + getPerasCertRound = getPerasCertRound . vpcCert + getPerasCertBlock = getPerasCertBlock . vpcCert -instance - HasPerasVoteId vote blk => - HasPerasVoteId (WithArrivalTime vote) blk - where - getPerasVoteId = getPerasVoteId . forgetArrivalTime +instance IsPerasCert cert blk => IsPerasCert (WithArrivalTime cert) blk where + getPerasCertRound = getPerasCertRound . forgetArrivalTime + getPerasCertBlock = getPerasCertBlock . forgetArrivalTime 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 d2a0a69457..9024aba930 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 @@ -47,6 +47,7 @@ import Data.Typeable import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract +import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras (..), VoidPerasError) import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Combinator.Abstract import Ouroboros.Consensus.HardFork.Combinator.AcrossEras @@ -57,6 +58,15 @@ import Ouroboros.Consensus.HardFork.Combinator.State.Types import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) +import Ouroboros.Consensus.Peras.Cert.Mock + ( MockPerasCert (..) + , forgeMockPerasCert + , validateMockPerasCert + ) +import Ouroboros.Consensus.Peras.Vote.Mock + ( MockPerasVote (..) + , validateMockPerasVote + ) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (ShowProxy) @@ -258,3 +268,33 @@ instance CanHardFork xs => LedgerSupportsPeras (HardForkBlock xs) where . hcmap proxySingle (K . getLatestPerasCertRound . unFlip) . State.tip . hardForkLedgerStatePerEra + +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: this is a mocked up implementation without crypto! + +-- TODO: when replacing this with a real votes and certificates, we need to make +-- sure that their binary representation would be compatible with the one the +-- HFC would produce if it were in charge of dispatching them. Concretely, this +-- means adding an envelope around the actual votes and certificates indicating +-- which era they belong to. This is to allow for the possibility of having the +-- HFC dispatch different types of votes and certificates in the future. + +instance + ( StandardHash (HardForkBlock xs) + , CanHardFork xs + ) => + BlockSupportsPeras (HardForkBlock xs) + where + type PerasVote (HardForkBlock xs) = MockPerasVote (HardForkBlock xs) + type PerasCert (HardForkBlock xs) = MockPerasCert (HardForkBlock xs) + type PerasError (HardForkBlock xs) = VoidPerasError (HardForkBlock xs) + + validatePerasVote = validateMockPerasVote + validatePerasCert = validateMockPerasCert + forgePerasCert = forgeMockPerasCert + + -- TODO: extract actual Peras certificates from blocks + getPerasCertInBlock _ = Nothing 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 23839c8c9f..d2758d2c80 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) (PerasVote (HardForkBlock xs)) ) => SerialiseHFC xs where 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 5051818331..fe5e48340a 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,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-} @@ -44,7 +45,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 +68,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 +78,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,7 +96,9 @@ 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 -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m @@ -111,7 +120,9 @@ 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 @@ -137,7 +148,9 @@ makePerasCertPoolWriterFromChainDB systemTime chainDB = } data PerasCertInboundException - = forall blk. PerasCertValidationError [PerasValidationErr blk] + = forall blk. + Show (PerasError blk) => + PerasCertValidationError [PerasError blk] deriving instance Show PerasCertInboundException @@ -154,10 +167,13 @@ instance Exception PerasCertInboundException -- each valid certificate is timestamped with the current wall-clock time and -- added to the database via @addCert@. processCerts :: - MonadSTM m => + ( MonadSTM m + , Show (PerasError blk) + , IsPerasCert (PerasCert blk) blk + ) => SystemTime m -> STM m (Set PerasRoundNo) -> - (PerasCert blk -> Either (PerasValidationErr blk) (ValidatedPerasCert blk)) -> + (PerasCert blk -> Either (PerasError blk) (ValidatedPerasCert blk)) -> (WithArrivalTime (ValidatedPerasCert blk) -> m ()) -> [PerasCert blk] -> m () 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 b565cc3239..3dcbf4dbb5 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,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-} @@ -45,7 +46,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 +67,9 @@ makePerasVotePoolReader getVotesAfterSTM = } makePerasVotePoolReaderFromVoteDB :: - IOLike m => + ( IOLike m + , IsPerasVote (PerasVote blk) blk + ) => PerasVoteDB m blk -> ObjectPoolReader (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m makePerasVotePoolReaderFromVoteDB perasVoteDB = @@ -72,7 +77,9 @@ makePerasVotePoolReaderFromVoteDB perasVoteDB = (PerasVoteDB.getVotesAfter perasVoteDB) makePerasVotePoolReaderFromChainDB :: - IOLike m => + ( IOLike m + , IsPerasVote (PerasVote blk) blk + ) => ChainDB m blk -> ObjectPoolReader (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m makePerasVotePoolReaderFromChainDB chainDB = @@ -90,7 +97,9 @@ 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 @@ -120,7 +129,9 @@ 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 @@ -152,7 +163,9 @@ makePerasVotePoolWriterFromChainDB systemTime getStakeDistrSTM chainDB = } data PerasVoteInboundException - = forall blk. PerasVoteValidationError [PerasValidationErr blk] + = forall blk. + Show (PerasError blk) => + PerasVoteValidationError [PerasError blk] deriving instance Show PerasVoteInboundException @@ -168,10 +181,13 @@ instance Exception PerasVoteInboundException -- `ouroboros-network`). Otherwise, each valid vote is timestamped with the -- current wall-clock time and added to the database via @addVote@. processVotes :: - MonadSTM m => + ( MonadSTM m + , Show (PerasError blk) + , IsPerasVote (PerasVote blk) blk + ) => SystemTime m -> STM m (Set (PerasVoteId blk)) -> - (PerasVote blk -> STM m (Either (PerasValidationErr blk) (ValidatedPerasVote blk))) -> + (PerasVote blk -> STM m (Either (PerasError blk) (ValidatedPerasVote blk))) -> (WithArrivalTime (ValidatedPerasVote blk) -> m ()) -> [PerasVote blk] -> m () 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 bbe02cd7ad..d7b7c2f9bb 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs @@ -59,6 +59,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 @@ -109,6 +111,7 @@ class , NodeInitStorage blk , BlockSupportsMetrics blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , BlockSupportsSanityCheck blk , Show (CannotForge blk) , Show (ForgeStateInfo blk) @@ -119,6 +122,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 a218642e50..a266cadb53 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,7 @@ import Codec.CBOR.Encoding (Encoding, encodeListLen) import Codec.Serialise (Serialise (decode, encode)) import Data.Kind import Data.SOP.BasicFunctors +import Data.Void (absurd) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool @@ -197,32 +198,6 @@ instance SerialiseNodeToNode blk PerasRoundNo where encodeNodeToNode _ccfg _version = encode decodeNodeToNode _ccfg _version = decode -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 PerasVoterId where encodeNodeToNode _ccfg _version = KeyHash.toCBOR . unPerasVoterId decodeNodeToNode _ccfg _version = PerasVoterId <$> KeyHash.fromCBOR @@ -239,6 +214,14 @@ instance SerialiseNodeToNode blk (PerasVoteId blk) where pviVoterId <- decodeNodeToNode ccfg version pure $ PerasVoteId pviRoundNo pviVoterId +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" + deriving newtype instance SerialiseNodeToClient blk (GenTxId blk) => SerialiseNodeToClient blk (WrapGenTxId blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert.hs deleted file mode 100644 index 005f1323a6..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Ouroboros.Consensus.Peras.Cert (module X) where - -import Ouroboros.Consensus.Peras.Cert.Inclusion as X diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs index a0de635ec9..55cb5266fa 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} -- | This module defines the logic needed to evaluate when a Peras certificate -- must be included in a block. @@ -25,13 +26,14 @@ module Ouroboros.Consensus.Peras.Cert.Inclusion import Data.Set (Set) import qualified Data.Set as Set -import Ouroboros.Consensus.Block (WithOrigin (..), withOriginToMaybe) -import Ouroboros.Consensus.Block.SupportsPeras - ( HasPerasCertRound (..) - , PerasParams +import Ouroboros.Consensus.Block + ( IsPerasCert (..) + , PerasCertMaxRounds (..) + , PerasParams (..) , PerasRoundNo (..) + , WithOrigin (..) + , withOriginToMaybe ) -import Ouroboros.Consensus.Peras.Params (PerasCertMaxRounds (..), PerasParams (..)) import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.Pred ( Evidence (..) @@ -88,7 +90,7 @@ data PerasCertInclusionView cert blk = PerasCertInclusionView -- within the same STM transaction, or the results may be inconsistent. mkPerasCertInclusionView :: forall cert blk. - HasPerasCertRound cert => + IsPerasCert cert blk => -- | Peras protocol parameters PerasParams -> -- | Current Peras round number @@ -147,7 +149,7 @@ data PerasCertInclusionRulesDecision cert deriving Show instance - HasPerasCertRound cert => + IsPerasCert cert blk => Explainable (PerasCertInclusionRulesDecision cert) where explain mode = \case diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs new file mode 100644 index 0000000000..6401f06437 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Mocked Peras certificates without crypto. +module Ouroboros.Consensus.Peras.Cert.Mock + ( MockPerasCert (..) + , validateMockPerasCert + , forgeMockPerasCert + ) where + +import Cardano.Binary (decodeListLenOf, encodeListLen) +import Codec.Serialise (Serialise (..)) +import Control.DeepSeq (NFData) +import Data.Data (Proxy (..)) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.Abstract + ( ConvertRawHash + , HeaderHash + , Point + , StandardHash + ) +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (..) + , IsPerasCert (..) + , PerasParams (..) + , PerasRoundNo + , PerasVoteTarget (..) + , ValidatedPerasCert (..) + , ValidatedPerasVotesWithQuorum (..) + ) +import Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToNode (..)) +import Ouroboros.Consensus.Util (ShowProxy) +import Ouroboros.Network.Util (ShowProxy (..)) + +-- | Mocked Peras certificates without crypto. +-- +-- NOTE: this is parameterized around the concrete block type being certified. +data MockPerasCert blk + = MockPerasCert + { mockCertRound :: PerasRoundNo + , mockCertBlock :: Point blk + } + +deriving instance StandardHash blk => Show (MockPerasCert blk) +deriving instance StandardHash blk => Eq (MockPerasCert blk) +deriving instance StandardHash blk => Ord (MockPerasCert blk) +deriving instance StandardHash blk => NoThunks (MockPerasCert blk) +deriving instance StandardHash blk => NFData (MockPerasCert blk) +deriving instance Generic (MockPerasCert blk) + +instance IsPerasCert (MockPerasCert blk) blk where + getPerasCertRound = mockCertRound + getPerasCertBlock = mockCertBlock + +instance ShowProxy blk => ShowProxy (MockPerasCert blk) where + showProxy _ = "MockPerasCert(" <> showProxy (Proxy @blk) <> ")" + +instance + Serialise (HeaderHash blk) => + Serialise (MockPerasCert blk) + where + encode + MockPerasCert + { mockCertRound + , mockCertBlock + } = + encodeListLen 2 + <> encode mockCertRound + <> encode mockCertBlock + decode = do + decodeListLenOf 2 + mockCertRound <- decode + mockCertBlock <- decode + pure $ + MockPerasCert + { mockCertRound + , mockCertBlock + } + +instance + ConvertRawHash blk => + SerialiseNodeToNode blk (MockPerasCert blk) + where + encodeNodeToNode + ccfg + version + MockPerasCert + { mockCertRound + , mockCertBlock + } = + encodeListLen 2 + <> encodeNodeToNode ccfg version mockCertRound + <> encodeNodeToNode ccfg version mockCertBlock + decodeNodeToNode ccfg version = do + decodeListLenOf 2 + mockCertRound <- decodeNodeToNode ccfg version + mockCertBlock <- decodeNodeToNode ccfg version + pure + MockPerasCert + { mockCertRound + , mockCertBlock + } + +-- | Helper to write 'BlockSupportsPeras.validatePerasCert'. +-- +-- WARNING: we do not perform any validation whatsoever for mocked certificates. +validateMockPerasCert :: + forall blk. + PerasParams -> + PerasCert blk -> + Either (PerasError blk) (ValidatedPerasCert blk) +validateMockPerasCert params cert = + Right + ValidatedPerasCert + { vpcCert = cert + , vpcCertBoost = perasWeight params + } + +-- | Helper to write 'BlockSupportsPeras.forgePerasCert'. +forgeMockPerasCert :: + forall blk. + PerasCert blk ~ MockPerasCert blk => + PerasParams -> + ValidatedPerasVotesWithQuorum blk -> + Either (PerasError blk) (ValidatedPerasCert blk) +forgeMockPerasCert params votes = + return $ + ValidatedPerasCert + { vpcCert = + MockPerasCert + { mockCertRound = pvtRoundNo (vpvqTarget votes) + , mockCertBlock = pvtBlock (vpvqTarget votes) + } + , vpcCertBoost = perasWeight params + } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs new file mode 100644 index 0000000000..a9351c4ee9 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Concrete Peras certificate types using BLS signatures. +-- +-- NOTE: this module is meant to be imported qualified. +-- +-- NOTE: the validation performed during serialization is minimal, and does not +-- cover any of additional semantic and cryptographic checks that must be +-- performed on the certificate later on. +module Ouroboros.Consensus.Peras.Cert.V1 + ( PerasCert (..) + , PerasCertVoters (..) + ) where + +import Cardano.Binary + ( FromCBOR (..) + , ToCBOR (..) + , decodeListLenOf + , encodeListLen + ) +import Control.Monad (when) +import Control.Monad.Error.Class (MonadError (..)) +import Data.Containers.NonEmpty (HasNonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.NonEmpty as NEMap +import Data.Map.Strict (Map) +import Data.Maybe (catMaybes) +import Data.Typeable (Typeable) +import Data.Word (Word16) +import Ouroboros.Consensus.Block.SupportsPeras + ( PerasBoostedBlock + , PerasRoundNo + , PerasSeatIndex (..) + ) +import Ouroboros.Consensus.Committee.Crypto + ( CryptoSupportsAggregateVoteSigning (..) + ) +import Ouroboros.Consensus.Peras.Crypto.BLS + ( PerasBLSCrypto + , VRFOutput + ) +import Ouroboros.Consensus.Peras.Vote.V1 (PerasVoteEligibilityProof (..)) +import Ouroboros.Consensus.Util.Bitmap (Bitmap) +import qualified Ouroboros.Consensus.Util.Bitmap as Bitmap + +-- | Concrete Peras certificates using BLS signatures +-- +-- NOTE: the 'tag' parameter is a phantom type used to track the block type that +-- the certificate is associated with, to ensure injectivity when 'V1.PerasCert' +-- is used as a type instance for 'BlockSupportsPeras' class. +data PerasCert tag + = PerasCert + { pcRoundNo :: !PerasRoundNo + -- ^ Election identifier + , pcBoostedBlock :: !PerasBoostedBlock + -- ^ Certificate message, i.e., the hash of the block being boosted + , pcVoters :: !PerasCertVoters + -- ^ Voters who contributed to this certificate + , pcSignature :: !(AggregateVoteSignature PerasBLSCrypto) + -- ^ Aggregate BLS signature on the hash of the election identifier and + -- the certificate message + } + deriving (Show, Eq) + +instance Typeable tag => FromCBOR (PerasCert tag) where + fromCBOR = do + decodeListLenOf 4 + pcRoundNo <- fromCBOR + pcBoostedBlock <- fromCBOR + pcVoters <- fromCBOR + pcSignature <- fromCBOR + pure + PerasCert + { pcRoundNo + , pcBoostedBlock + , pcVoters + , pcSignature + } + +instance Typeable tag => ToCBOR (PerasCert tag) where + toCBOR cert = + encodeListLen 4 + <> toCBOR (pcRoundNo cert) + <> toCBOR (pcBoostedBlock cert) + <> toCBOR (pcVoters cert) + <> toCBOR (pcSignature cert) + +-- | Voters contained in a certificate with their appropriate eligibility proof +newtype PerasCertVoters + = PerasCertVoters + { unPerasCertVoters :: + NE (Map PerasSeatIndex PerasVoteEligibilityProof) + } + deriving (Eq, Show) + +instance FromCBOR PerasCertVoters where + fromCBOR = do + decodeListLenOf 2 + votersBitmap <- fromCBOR + nonPersistentSigs <- fromCBOR + + either fail pure + . fromCompactRepr + $ CompactPerasCertVoters + { votersBitmap + , nonPersistentSigs + } + +instance ToCBOR PerasCertVoters where + toCBOR voters = + encodeListLen 2 + <> toCBOR votersBitmap + <> toCBOR nonPersistentSigs + where + CompactPerasCertVoters + { votersBitmap + , nonPersistentSigs + } = + toCompactRepr voters + +-- | Compact representation of the voters in a Peras certificate. +-- +-- This compact representation consists of a bitmap of voter seat indices and a +-- list of non-persistent eligibility proofs (VRF outputs). In this setup, the +-- last @np@ indices in the bitmap that are flipped to 1 correspond to +-- non-persistent voters, where @np@ is the length of the list of non-persistent +-- eligibility proofs. The remaining flipped indices in the bitmap correspond +-- to persistent voters. +-- +-- @ +-- fromCompactRepr +-- CompactPerasCertVoters { +-- votersBitmap = <01101011>, +-- nonPersistentSigs = [np1, np2, np3] +-- } +-- == +-- PerasCertVoters { +-- 1 => persistent +-- 2 => persistent +-- 4 => non-persistent(np1) +-- 6 => non-persistent(np2) +-- 7 => non-persistent(np3) +-- } +-- @ +data CompactPerasCertVoters + = CompactPerasCertVoters + { votersBitmap :: !(Bitmap Word16) + , nonPersistentSigs :: ![VRFOutput PerasBLSCrypto] + } + deriving (Eq, Show) + +-- | Decode 'PerasCertVoters' from their compact representation. +-- +-- See 'CompactPerasCertVoters' for the encoding scheme used here. +fromCompactRepr :: + CompactPerasCertVoters -> + Either String PerasCertVoters +fromCompactRepr + CompactPerasCertVoters + { votersBitmap + , nonPersistentSigs + } = do + let voterSeatIndices = + PerasSeatIndex <$> Bitmap.toIndices votersBitmap + + when (null voterSeatIndices) $ + throwError "Invalid Peras certificate: empty voters bitmap" + + when (length nonPersistentSigs > length voterSeatIndices) $ + throwError $ + unlines + [ "Invalid Peras certificate:" + <> " more non-persistent voter eligibility proofs were provided" + <> " than the number of voters in the certificate" + , " * number of voters: " + <> show (length voterSeatIndices) + , " * number of proofs: " + <> show (length nonPersistentSigs) + ] + + let numPersistentVoters = + length voterSeatIndices - length nonPersistentSigs + let persistentProofs = + take numPersistentVoters (repeat PersistentPerasVoteEligibilityProof) + let nonPersistentProofs = + fmap NonPersistentPerasVoteEligibilityProof nonPersistentSigs + let voters = + NEMap.fromAscList + . NonEmpty.fromList + . zip voterSeatIndices + $ persistentProofs <> nonPersistentProofs + + pure (PerasCertVoters voters) + +-- | Encode 'PerasCertVoters' into their compact representation. +-- +-- See 'CompactPerasCertVoters' for the encoding scheme used here. +toCompactRepr :: + PerasCertVoters -> + CompactPerasCertVoters +toCompactRepr (PerasCertVoters voters) = + CompactPerasCertVoters + { votersBitmap + , nonPersistentSigs + } + where + logicalUpperBound = + unPerasSeatIndex (fst (NEMap.findMax voters)) + votersByAscSeatIndex = + NonEmpty.toList (NEMap.toAscList voters) + votersSeatIndices = + fmap (unPerasSeatIndex . fst) votersByAscSeatIndex + votersBitmap = + Bitmap.fromIndices logicalUpperBound votersSeatIndices + nonPersistentSigs = + catMaybes (fmap getNonPersistentSig votersByAscSeatIndex) + getNonPersistentSig = \case + (_, PersistentPerasVoteEligibilityProof) -> Nothing + (_, NonPersistentPerasVoteEligibilityProof p) -> Just p diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs new file mode 100644 index 0000000000..31903225ca --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | BLS-based crypto scheme used in Peras voting committees +module Ouroboros.Consensus.Peras.Crypto.BLS + ( PerasBLSCrypto + , ElectionId + , VoteCandidate + , PerasPrivateKey (..) + , PerasPublicKey (..) + , VoteSignature (..) + , VRFElectionInput (..) + , VRFOutput (..) + , AggregateVoteVerificationKey + , AggregateVoteSignature + + -- * For testing purposes + , PerasBLSCryptoAggregateVoteVerificationKey (..) + , PerasBLSCryptoAggregateVoteSignature (..) + ) where + +import Cardano.Binary (FromCBOR, ToCBOR (..)) +import Cardano.Crypto.DSIGN (BLS12381MinSigDSIGN, DSIGNAlgorithm (..)) +import Cardano.Crypto.Hash (Hash) +import qualified Cardano.Crypto.Hash as Hash +import Cardano.Ledger.BaseTypes (Nonce (..), SlotNo (..)) +import Cardano.Ledger.Binary (runByteBuilder) +import Cardano.Ledger.Hashes (HASH) +import qualified Data.ByteString.Builder as BS +import qualified Data.ByteString.Builder.Extra as BS +import qualified Data.ByteString.Short as BS +import Ouroboros.Consensus.Block.Abstract (WithOrigin (..)) +import Ouroboros.Consensus.Block.RealPoint + ( bytes32RealPointHash + , bytes32RealPointSlot + ) +import Ouroboros.Consensus.Block.SupportsPeras + ( PerasBoostedBlock (..) + , PerasRoundNo (..) + ) +import Ouroboros.Consensus.Committee.Crypto + ( CryptoSupportsAggregateVoteSigning (..) + , CryptoSupportsBatchVRFVerification (..) + , CryptoSupportsVRF (..) + , CryptoSupportsVoteSigning (..) + , ElectionId + , PrivateKey + , PublicKey + , VRFPoolContext (..) + , VoteCandidate + ) +import Ouroboros.Consensus.Committee.Crypto.BLS (KeyRole (..)) +import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS + +-- | BLS-based crypto scheme used in Peras voting committees +data PerasBLSCrypto + +type instance ElectionId PerasBLSCrypto = PerasRoundNo +type instance VoteCandidate PerasBLSCrypto = PerasBoostedBlock + +-- | Private key of a Peras committee member +data PerasPrivateKey + = PerasPrivateKey + { perasVoteSignKey :: BLS.PrivateKey SIGN + , perasVRFSignKey :: BLS.PrivateKey VRF + } + +type instance PrivateKey PerasBLSCrypto = PerasPrivateKey + +-- | Public key of a Peras committee member +data PerasPublicKey + = PerasPublicKey + { perasVoteVerKey :: BLS.PublicKey SIGN + , perasVRFVerKey :: BLS.PublicKey VRF + } + +type instance PublicKey PerasBLSCrypto = PerasPublicKey + +-- | Hash the message of a Peras vote +-- +-- NOTE: this is inspired by the implementation used by the Praos VRF check in +-- 'Ouroboros.Consensus.Protocol.Praos.VRF.mkInputVRF'. +hashVoteSignature :: + ElectionId PerasBLSCrypto -> + VoteCandidate PerasBLSCrypto -> + Hash HASH (SigDSIGN BLS12381MinSigDSIGN) +hashVoteSignature roundNo boostedBlock = + Hash.castHash + . Hash.hashWith id + . runByteBuilder (8 + 8 + 32) + $ roundNoBytes <> boostedBlockBytes + where + roundNoBytes = + BS.word64BE + . unPerasRoundNo + $ roundNo + boostedBlockBytes = + case unPerasBoostedBlock boostedBlock of + Origin -> + mempty + NotOrigin point -> + bytes32RealPointSlotBytes point + <> bytes32RealPointHashBytes point + + bytes32RealPointSlotBytes = + BS.word64BE + . unSlotNo + . bytes32RealPointSlot + bytes32RealPointHashBytes = + BS.byteStringCopy + . BS.fromShort + . bytes32RealPointHash + +-- | Hash the input for the VRF used in Peras elections +-- +-- NOTE: this is inspired by the implementation used by the Praos VRF check in +-- 'Ouroboros.Consensus.Protocol.Praos.VRF.mkInputVRF'. +hashVRFInput :: + ElectionId PerasBLSCrypto -> + Nonce -> + Hash HASH (SigDSIGN BLS12381MinSigDSIGN) +hashVRFInput roundNo epochNonce = + Hash.castHash + . Hash.hashWith id + . runByteBuilder (8 + 32) + $ roundNoBytes <> epochNonceBytes + where + roundNoBytes = + BS.word64BE (unPerasRoundNo roundNo) + epochNonceBytes = + case epochNonce of + NeutralNonce -> mempty + Nonce h -> BS.byteStringCopy (Hash.hashToBytes h) + +-- * Crypto instances + +instance CryptoSupportsVoteSigning PerasBLSCrypto where + type VoteSigningKey PerasBLSCrypto = BLS.PrivateKey SIGN + type VoteVerificationKey PerasBLSCrypto = BLS.PublicKey SIGN + + newtype VoteSignature PerasBLSCrypto + = PerasBLSCryptoVoteSignature + { unPerasBLSCryptoVoteSignature :: + BLS.Signature BLS.SIGN + } + deriving stock (Eq, Show) + deriving newtype (FromCBOR, ToCBOR) + + getVoteSigningKey _ = + perasVoteSignKey + getVoteVerificationKey _ = + perasVoteVerKey + + signVote sk roundNo boostedBlock = + PerasBLSCryptoVoteSignature + . BLS.signWithRole @SIGN sk + $ hashVoteSignature roundNo boostedBlock + + verifyVoteSignature + pk + roundNo + boostedBlock + (PerasBLSCryptoVoteSignature sig) = + BLS.verifyWithRole @SIGN + pk + (hashVoteSignature roundNo boostedBlock) + sig + +instance CryptoSupportsVRF PerasBLSCrypto where + type VRFSigningKey PerasBLSCrypto = BLS.PrivateKey VRF + type VRFVerificationKey PerasBLSCrypto = BLS.PublicKey VRF + + newtype VRFElectionInput PerasBLSCrypto + = PerasBLSCryptoVRFElectionInput + { unPerasBLSCryptoVRFElectionInput :: + Hash HASH (SigDSIGN BLS12381MinSigDSIGN) + } + deriving stock (Eq, Show) + + newtype VRFOutput PerasBLSCrypto + = PerasBLSCryptoVRFOutput + { unPerasBLSCryptoVRFOutput :: + BLS.Signature VRF + } + deriving stock (Eq, Show) + deriving newtype (FromCBOR, ToCBOR) + + getVRFSigningKey _ = + perasVRFSignKey + + getVRFVerificationKey _ = + perasVRFVerKey + + mkVRFElectionInput epochNonce roundNo = + PerasBLSCryptoVRFElectionInput $ + hashVRFInput roundNo epochNonce + + evalVRF context (PerasBLSCryptoVRFElectionInput input) = + case context of + VRFSignContext sk -> do + let sig = BLS.signWithRole @VRF (BLS.coercePrivateKey @VRF sk) input + pure $ PerasBLSCryptoVRFOutput sig + VRFVerifyContext pk (PerasBLSCryptoVRFOutput sig) -> do + BLS.verifyWithRole @VRF (BLS.coercePublicKey @VRF pk) input sig + pure $ PerasBLSCryptoVRFOutput sig + + normalizeVRFOutput (PerasBLSCryptoVRFOutput sig) = + BLS.toNormalizedVRFOutput sig + +-- * Support for aggregate signatures and VRF outputs + +-- | Wrapper around the aggregate vote signatures. +newtype PerasBLSCryptoAggregateVoteVerificationKey + = PerasBLSCryptoAggregateVoteVerificationKey + { unPerasBLSCryptoAggregateVoteVerificationKey :: + BLS.PublicKey SIGN + } + deriving stock (Eq, Show) + +-- | Wrapper around the aggregate vote verification keys. +newtype PerasBLSCryptoAggregateVoteSignature + = PerasBLSCryptoAggregateVoteSignature + { unPerasBLSCryptoAggregateVoteSignature :: + BLS.Signature SIGN + } + deriving stock (Eq, Show) + deriving newtype (FromCBOR, ToCBOR) + +instance CryptoSupportsAggregateVoteSigning PerasBLSCrypto where + type + AggregateVoteVerificationKey PerasBLSCrypto = + PerasBLSCryptoAggregateVoteVerificationKey + type + AggregateVoteSignature PerasBLSCrypto = + PerasBLSCryptoAggregateVoteSignature + + aggregateVoteVerificationKeys _ pks = do + aggPk <- BLS.aggregatePublicKeys @SIGN pks + pure (PerasBLSCryptoAggregateVoteVerificationKey aggPk) + + aggregateVoteSignatures _ sigs = do + aggSig <- + BLS.aggregateSignatures @SIGN + . fmap unPerasBLSCryptoVoteSignature + $ sigs + pure (PerasBLSCryptoAggregateVoteSignature aggSig) + + verifyAggregateVoteSignature + _ + aggPk + roundNo + boostedBlock + aggSig = do + BLS.verifyWithRole @SIGN + (unPerasBLSCryptoAggregateVoteVerificationKey aggPk) + (hashVoteSignature roundNo boostedBlock) + (unPerasBLSCryptoAggregateVoteSignature aggSig) + +instance CryptoSupportsBatchVRFVerification PerasBLSCrypto where + -- NOTE: in contrast to vote signatures, we cannot aggregate multiple VRF + -- outputs into a single one when forging a certificate (because we need to + -- derive non-persistent seat numbers from each individual one). This means + -- that, at verification time, @sigs@ will always contain one VRF output per + -- non-persistent voter in the certificate, even when verifying a certificate + -- forged by someone else that we received over the network. + -- + -- However, we still want to verify all the VRF outputs in a single batch for + -- efficiency reasons, and we can do that by first aggregating all the VRF + -- outputs in the list locally (using linearization to avoid swap-attacks), + -- and then verifying the resulting aggregate VRF output against the aggregate + -- VRF verification key. + batchVerifyVRFOutputs + pks + (PerasBLSCryptoVRFElectionInput input) + sigs = do + BLS.linearizeAndVerifyVRFs + pks + input + . fmap unPerasBLSCryptoVRFOutput + $ sigs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs new file mode 100644 index 0000000000..1327eb6045 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Base Peras types used throughout the implementation. +module Ouroboros.Consensus.Peras.Types + ( PerasRoundNo (..) + , onPerasRoundNo + , PerasBoostedBlock (..) + , PerasSeatIndex (..) + , PerasVoteStake (..) + , stakeAboveThreshold + , PerasVoteTarget (..) + , PerasVoteId (..) + , PerasVoterId (..) + , PerasVoteStakeDistr (..) + , lookupPerasVoteStake + ) +where + +import Cardano.Binary + ( FromCBOR (..) + , ToCBOR (..) + , decodeListLenOf + , encodeListLen + ) +import Cardano.Ledger.Hashes (KeyHash, KeyRole (..)) +import Codec.Serialise.Class (Serialise (..)) +import Control.DeepSeq (NFData) +import Data.Coerce (coerce) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) +import Data.Semigroup (Sum (..)) +import Data.Word (Word16, Word64) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.Abstract (Point, WithOrigin) +import Ouroboros.Consensus.Block.RealPoint + ( Bytes32RealPoint + , decodeBytes32RealPoint + , encodeBytes32RealPoint + ) +import Ouroboros.Consensus.Peras.Params + ( PerasParams (..) + , PerasQuorumStakeThreshold (..) + , PerasQuorumStakeThresholdSafetyMargin (..) + ) +import Ouroboros.Consensus.Util (ShowProxy (..)) +import Ouroboros.Consensus.Util.CBOR (decodeWithOrigin, encodeWithOrigin) +import Ouroboros.Consensus.Util.Condense (Condense (..)) +import Quiet (Quiet (..)) + +-- * Peras types + +-- ** Round numbers + +newtype PerasRoundNo + = PerasRoundNo + { unPerasRoundNo :: Word64 + } + deriving Show via Quiet PerasRoundNo + deriving stock Generic + deriving newtype (Enum, Eq, Ord, Num, Bounded, NoThunks, Serialise, NFData, ToCBOR, FromCBOR) + +instance Condense PerasRoundNo where + condense = show . unPerasRoundNo + +instance ShowProxy PerasRoundNo where + showProxy _ = "PerasRoundNo" + +-- | Lift a binary operation on 'Word64' to 'PerasRoundNo' +onPerasRoundNo :: + (Word64 -> Word64 -> Word64) -> + (PerasRoundNo -> PerasRoundNo -> PerasRoundNo) +onPerasRoundNo = coerce + +-- ** Boosted blocks + +-- | The slot number and 32-byte hash of the block being voted for. +-- +-- NOTE: this type is mostly used in production votes and certificates, while +-- mocked votes and certificates generally use the more abstract 'Point blk'. +newtype PerasBoostedBlock + = PerasBoostedBlock + { unPerasBoostedBlock :: WithOrigin Bytes32RealPoint + } + deriving stock (Eq, Show) + +instance FromCBOR PerasBoostedBlock where + fromCBOR = PerasBoostedBlock <$> decodeWithOrigin decodeBytes32RealPoint + +instance ToCBOR PerasBoostedBlock where + toCBOR = encodeWithOrigin encodeBytes32RealPoint . unPerasBoostedBlock + +-- ** Seat indices + +-- | Seat index in the voting committee used for Peras +newtype PerasSeatIndex + = PerasSeatIndex + { unPerasSeatIndex :: Word16 + } + deriving stock (Eq, Ord, Show) + deriving newtype (FromCBOR, ToCBOR, Enum, Bounded) + +-- ** Vote parameters + +-- | The target of a vote in a Peras election +data PerasVoteTarget blk + = PerasVoteTarget + { pvtRoundNo :: !PerasRoundNo + , pvtBlock :: !(Point blk) + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass NoThunks + +-- | The identifier of a vote in a Peras election +data PerasVoteId blk + = PerasVoteId + { pviRoundNo :: !PerasRoundNo + , pviVoterId :: !PerasVoterId + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass NoThunks + +instance ShowProxy blk => ShowProxy (PerasVoteId blk) where + showProxy _ = "PerasVoteId " <> showProxy (Proxy @blk) + +instance Serialise (PerasVoteId blk) where + encode PerasVoteId{pviRoundNo, pviVoterId} = + encodeListLen 2 + <> encode pviRoundNo + <> toCBOR (unPerasVoterId pviVoterId) + decode = do + decodeListLenOf 2 + pviRoundNo <- decode + pviVoterId <- PerasVoterId <$> fromCBOR + pure $ PerasVoteId{pviRoundNo, pviVoterId} + +-- NOTE: At the moment there is no consensus from researchers/engineers on how +-- we go from the absolute stake of a voter in the ledger to the relative stake +-- of their vote in the voting commitee (given that the quorum is expressed as +-- a relative value of the voting commitee total stake). +-- +-- So, for now you can consider this 'Rational' as the best approximation we +-- have at the moment of the concrete type for a relative vote stake that can be +-- compared to the quorum threshold value (also currently a 'Rational'). +newtype PerasVoteStake + = PerasVoteStake + { unPerasVoteStake :: Rational + } + deriving newtype (Eq, Ord, Num, Fractional, NoThunks, NFData, Serialise) + deriving stock Generic + deriving Show via Quiet PerasVoteStake + deriving Semigroup via Sum Rational + deriving Monoid via Sum Rational + +-- | Check whether a given vote stake is above the quorum threshold. +-- +-- TODO: this function assumes that the 'PerasVoteStake' and the quorum +-- threshold used in 'PerasParams' are expressed in the same units. That is, +-- both are either absolute or relative (normalized) values. Under the current +-- current implementation of 'PerasParams', this function only makes sense when +-- both values are relative (normalized) values, so we should either normalize +-- the 'PerasVoteStake' before calling this function, or change this function to +-- accept a stake distribution and perform the normalization internally. +stakeAboveThreshold :: PerasParams -> PerasVoteStake -> Bool +stakeAboveThreshold params voteStake = + stake >= quorumThreshold + safetyMargin + where + stake = + unPerasVoteStake voteStake + quorumThreshold = + unPerasQuorumStakeThreshold + (perasQuorumStakeThreshold params) + safetyMargin = + unPerasQuorumStakeThresholdSafetyMargin + (perasQuorumStakeThresholdSafetyMargin params) + +-- ** Voting stake distributions + +-- | The identifier of a voter in a Peras election +newtype PerasVoterId + = PerasVoterId + { unPerasVoterId :: KeyHash StakePool + } + deriving newtype (NoThunks, NFData, FromCBOR, ToCBOR) + deriving stock (Eq, Ord, Generic) + deriving Show via Quiet PerasVoterId + +instance Serialise PerasVoterId where + encode = toCBOR . unPerasVoterId + decode = PerasVoterId <$> fromCBOR + +-- | Voting stake distribution for a Peras election +newtype PerasVoteStakeDistr + = PerasVoteStakeDistr + { unPerasVoteStakeDistr :: Map PerasVoterId PerasVoteStake + } + deriving newtype NoThunks + deriving stock (Show, Eq, Generic) + +-- | Lookup the stake of a vote cast by a member of a given stake distribution. +lookupPerasVoteStake :: + PerasVoterId -> + PerasVoteStakeDistr -> + Maybe PerasVoteStake +lookupPerasVoteStake voterId distr = + Map.lookup + voterId + (unPerasVoteStakeDistr distr) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote.hs deleted file mode 100644 index 281de61cb5..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Ouroboros.Consensus.Peras.Vote (module X) where - -import Ouroboros.Consensus.Peras.Vote.Aggregation as X 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 45bd8fbca0..d9f82e7a71 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 @@ -12,6 +12,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -- | Peras vote aggregation and certificate forging @@ -46,7 +47,7 @@ -- -- = Quorum Threshold and Multiple Winners -- --- The quorum threshold is parameterized via 'PerasCfg'. Depending on this +-- The quorum threshold is parameterized via 'PerasParams'. Depending on this -- configuration and the stake distribution, it may be theoretically possible -- for multiple targets to exceed the threshold within the same round. -- @@ -79,13 +80,16 @@ -- freshly forged (as opposed to voting on an already-won target). module Ouroboros.Consensus.Peras.Vote.Aggregation ( PerasRoundVoteState - , ptvsTotalStake + , getPerasRoundVoteStateRound + , getPerasRoundVoteStateCertMaybe + , getPerasRoundVoteStateMaxTargetedSlot , pattern VoteGeneratedNewCert , pattern VoteDidntGenerateNewCert , updatePerasRoundVoteStates - , getPerasRoundVoteStateCertMaybe - , getPerasRoundVoteStateMaxTargetedSlot , UpdateRoundVoteStateError (..) + , PerasTargetVoteState + , getPerasTargetVoteStateTotalStake + , getPerasTargetVoteStateBlock ) where import Cardano.Prelude (fromMaybe) @@ -108,18 +112,53 @@ data PerasRoundVoteState blk = PerasRoundVoteState { prvsRoundNo :: !PerasRoundNo , prvsState :: !(Either (NoQuorum blk) (Quorum blk)) } - deriving stock (Generic, Eq, Show) - deriving anyclass NoThunks -instance HasPerasVoteRound (PerasRoundVoteState blk) where - getPerasVoteRound = prvsRoundNo +deriving instance + ( StandardHash blk + , Show (PerasVote blk) + , Show (PerasCert blk) + ) => + Show (PerasRoundVoteState blk) +deriving instance + ( StandardHash blk + , Eq (PerasVote blk) + , Eq (PerasCert blk) + ) => + Eq (PerasRoundVoteState blk) +deriving instance + ( StandardHash blk + , NoThunks (PerasVote blk) + , NoThunks (PerasCert blk) + ) => + NoThunks (PerasRoundVoteState blk) +deriving instance + Generic (PerasRoundVoteState blk) -- | Current vote state when a quorum has not yet been reached data NoQuorum blk = NoQuorum { candidateStates :: !(Map (Point blk) (PerasTargetVoteState blk 'Candidate)) } - deriving stock (Generic, Eq, Show) - deriving anyclass NoThunks + +deriving instance + ( StandardHash blk + , Show (PerasVote blk) + , Show (PerasCert blk) + ) => + Show (NoQuorum blk) +deriving instance + ( StandardHash blk + , Eq (PerasVote blk) + , Eq (PerasCert blk) + ) => + Eq (NoQuorum blk) +deriving instance + ( StandardHash blk + , NoThunks (PerasVote blk) + , NoThunks (PerasCert blk) + ) => + NoThunks (NoQuorum blk) +deriving instance + Generic (NoQuorum blk) -- | Current vote state when a quorum has been reached data Quorum blk = Quorum @@ -127,8 +166,31 @@ data Quorum blk = Quorum , loserStates :: !(Map (Point blk) (PerasTargetVoteState blk 'Loser)) , winnerState :: !(PerasTargetVoteState blk 'Winner) } - deriving stock (Generic, Eq, Show) - deriving anyclass NoThunks + +deriving instance + ( StandardHash blk + , Show (PerasVote blk) + , Show (PerasCert blk) + ) => + Show (Quorum blk) +deriving instance + ( StandardHash blk + , Eq (PerasVote blk) + , Eq (PerasCert blk) + ) => + Eq (Quorum blk) +deriving instance + ( StandardHash blk + , NoThunks (PerasVote blk) + , NoThunks (PerasCert blk) + ) => + NoThunks (Quorum blk) +deriving instance + Generic (Quorum blk) + +-- | Get the round number of a round vote state +getPerasRoundVoteStateRound :: PerasRoundVoteState blk -> PerasRoundNo +getPerasRoundVoteStateRound = prvsRoundNo -- | Get the certificate if quorum was reached for the given round getPerasRoundVoteStateCertMaybe :: @@ -161,7 +223,7 @@ getPerasRoundVoteStateMaxTargetedSlot PerasRoundVoteState{prvsState} = maximumOrOrigin $ map pointSlot $ Map.keys candidateStates Right Quorum{winnerState, loserStates} -> maximumOrOrigin $ - pointSlot (getPerasVoteBlock winnerState) + pointSlot (getPerasTargetVoteStateBlock winnerState) : (pointSlot <$> Map.keys loserStates) where maximumOrOrigin [] = Origin @@ -188,7 +250,7 @@ data UpdateRoundVoteStateError blk (PerasTargetVoteState blk 'Winner) (PerasTargetVoteState blk 'Loser) | RoundVoteStateForgingCertError - (PerasForgeErr blk) + (PerasError blk) -- | Add a vote to an existing round vote aggregate. -- @@ -198,13 +260,13 @@ data UpdateRoundVoteStateError blk -- quorum) or if forging the certificate fails. updatePerasRoundVoteState :: forall blk. - StandardHash blk => + BlockSupportsPeras blk => WithArrivalTime (ValidatedPerasVote blk) -> - PerasCfg blk -> + PerasParams -> PerasRoundVoteState blk -> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk) -updatePerasRoundVoteState vote cfg roundState = - assert (getPerasVoteRound vote == getPerasVoteRound roundState) $ do +updatePerasRoundVoteState vote params roundState = + assert (getPerasVoteRound vote == getPerasRoundVoteStateRound roundState) $ do case roundState of -- Quorum not yet reached state@PerasRoundVoteState @@ -220,7 +282,7 @@ updatePerasRoundVoteState vote cfg roundState = (getPerasVoteBlock vote) candidateStates candidateOrWinnerState <- - updateCandidateVoteState cfg vote oldCandidateState + updateCandidateVoteState params vote oldCandidateState `onErr` \err -> RoundVoteStateForgingCertError err case candidateOrWinnerState of @@ -294,7 +356,7 @@ updatePerasRoundVoteState vote cfg roundState = fromMaybe (freshLoserVoteState (getPerasVoteTarget vote)) updateMaybeLoserVoteState mState = fmap Just $ - updateLoserVoteState cfg vote (existingOrFreshLoserVoteState mState) + updateLoserVoteState params vote (existingOrFreshLoserVoteState mState) `onErr` \err -> RoundVoteStateLoserAboveQuorum winnerState err loserStates' <- Map.alterF updateMaybeLoserVoteState votePoint loserStates @@ -318,14 +380,14 @@ updatePerasRoundVoteState vote cfg roundState = -- quorum) or if forging the certificate fails. updatePerasRoundVoteStates :: forall blk. - StandardHash blk => + BlockSupportsPeras blk => WithArrivalTime (ValidatedPerasVote blk) -> - PerasCfg blk -> + PerasParams -> Map PerasRoundNo (PerasRoundVoteState blk) -> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk, Map PerasRoundNo (PerasRoundVoteState blk)) -updatePerasRoundVoteStates vote cfg = +updatePerasRoundVoteStates vote params = alterMapAndReturnUpdatedValue updateMaybePerasRoundVoteState (getPerasVoteRound vote) @@ -358,7 +420,7 @@ updatePerasRoundVoteStates vote cfg = (PerasRoundVoteState blk, PerasRoundVoteState blk) updateMaybePerasRoundVoteState mRoundState = do let roundState = existingOrFreshRoundVoteState mRoundState - newRoundState <- updatePerasRoundVoteState vote cfg roundState + newRoundState <- updatePerasRoundVoteState vote params roundState pure (newRoundState, newRoundState) {------------------------------------------------------------------------------- @@ -412,8 +474,27 @@ data PerasTargetVoteTally blk = PerasTargetVoteTally , ptvtTotalStake :: !PerasVoteStake -- ^ Total stake of the votes received for this target } - deriving stock (Generic, Eq, Show) - deriving anyclass NoThunks + +deriving instance + ( StandardHash blk + , Show (PerasVoteTarget blk) + , Show (ValidatedPerasVote blk) + ) => + Show (PerasTargetVoteTally blk) +deriving instance + ( StandardHash blk + , Eq (PerasVoteTarget blk) + , Eq (ValidatedPerasVote blk) + ) => + Eq (PerasTargetVoteTally blk) +deriving instance + ( StandardHash blk + , NoThunks (PerasVoteTarget blk) + , NoThunks (ValidatedPerasVote blk) + ) => + NoThunks (PerasTargetVoteTally blk) +deriving instance + Generic (PerasTargetVoteTally blk) freshTargetVoteTally :: PerasVoteTarget blk -> PerasTargetVoteTally blk freshTargetVoteTally target = @@ -428,7 +509,9 @@ freshTargetVoteTally target = -- -- PRECONDITION: the vote's target must match the tally's target. updateTargetVoteTally :: - StandardHash blk => + ( StandardHash blk + , IsPerasVote (PerasVote blk) blk + ) => WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteTally blk -> PerasTargetVoteTally blk @@ -522,11 +605,13 @@ instance noThunks ctx (PerasTargetVoteWinner tally cert) = noThunks ctx (tally, cert) -instance HasPerasVoteRound (PerasTargetVoteState blk status) where - getPerasVoteRound = pvtRoundNo . ptvtTarget . ptvsVoteTally +-- | Extract the total stake from a target vote state +getPerasTargetVoteStateTotalStake :: PerasTargetVoteState blk status -> PerasVoteStake +getPerasTargetVoteStateTotalStake = ptvtTotalStake . ptvsVoteTally -instance HasPerasVoteBlock (PerasTargetVoteState blk status) blk where - getPerasVoteBlock = pvtBlock . ptvtTarget . ptvsVoteTally +-- | Extract the block point from a target vote state +getPerasTargetVoteStateBlock :: PerasTargetVoteState blk status -> Point blk +getPerasTargetVoteStateBlock = pvtBlock . ptvtTarget . ptvsVoteTally -- | Extract the underlying vote tally from a target vote state ptvsVoteTally :: PerasTargetVoteState blk status -> PerasTargetVoteTally blk @@ -535,10 +620,6 @@ ptvsVoteTally = \case PerasTargetVoteLoser tally -> tally PerasTargetVoteWinner tally _ -> tally --- | Extract the total stake from a target vote state -ptvsTotalStake :: PerasTargetVoteState blk status -> PerasVoteStake -ptvsTotalStake = ptvtTotalStake . ptvsVoteTally - freshCandidateVoteState :: PerasVoteTarget blk -> PerasTargetVoteState blk 'Candidate freshCandidateVoteState target = PerasTargetVoteCandidate (freshTargetVoteTally target) @@ -567,21 +648,21 @@ data PerasVoteStateCandidateOrWinner blk -- -- May fail if the candidate is elected winner but forging the certificate fails. updateCandidateVoteState :: - StandardHash blk => - PerasCfg blk -> + BlockSupportsPeras blk => + PerasParams -> WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteState blk 'Candidate -> Either - (PerasForgeErr blk) + (PerasError blk) (PerasVoteStateCandidateOrWinner blk) -updateCandidateVoteState cfg vote oldState = +updateCandidateVoteState params vote oldState = let newVoteTally = updateTargetVoteTally vote (ptvsVoteTally oldState) voteList = forgetArrivalTime <$> Map.elems (ptvtVotes newVoteTally) in - case votesReachQuorum cfg voteList of + case votesReachQuorum params voteList of Just votesWithQuorum -> do - cert <- forgePerasCert cfg votesWithQuorum + cert <- forgePerasCert params votesWithQuorum pure $ BecameWinner (PerasTargetVoteWinner newVoteTally cert) Nothing -> do pure $ RemainedCandidate (PerasTargetVoteCandidate newVoteTally) @@ -592,15 +673,17 @@ updateCandidateVoteState cfg vote oldState = -- -- May fail if the loser goes above quorum by adding the vote. updateLoserVoteState :: - StandardHash blk => - PerasCfg blk -> + ( StandardHash blk + , IsPerasVote (PerasVote blk) blk + ) => + PerasParams -> WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteState blk 'Loser -> Either (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser) -updateLoserVoteState cfg vote oldState = +updateLoserVoteState params vote oldState = assert (getPerasVoteTarget vote == ptvtTarget (ptvsVoteTally oldState)) $ do let newVoteTally = updateTargetVoteTally vote (ptvsVoteTally oldState) - aboveQuorum = stakeAboveThreshold cfg (ptvtTotalStake newVoteTally) + aboveQuorum = stakeAboveThreshold params (ptvtTotalStake newVoteTally) in if aboveQuorum then Left $ PerasTargetVoteLoser newVoteTally else Right $ PerasTargetVoteLoser newVoteTally @@ -609,7 +692,9 @@ updateLoserVoteState cfg vote oldState = -- -- PRECONDITION: the vote's target must match the underlying tally's target. updateWinnerVoteState :: - StandardHash blk => + ( StandardHash blk + , IsPerasVote (PerasVote blk) blk + ) => WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteState blk 'Winner -> PerasTargetVoteState blk 'Winner diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs new file mode 100644 index 0000000000..7df3e19d73 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Mocked Peras votes without crypto. +module Ouroboros.Consensus.Peras.Vote.Mock + ( MockPerasVote (..) + , validateMockPerasVote + ) where + +import Cardano.Binary (decodeListLenOf, encodeListLen) +import Codec.Serialise (Serialise (..)) +import Control.DeepSeq (NFData) +import Data.Data (Proxy (..)) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.Abstract + ( ConvertRawHash + , HeaderHash + , Point + , StandardHash + ) +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (..) + , IsPerasVote (..) + , PerasRoundNo + , PerasVoteStake + , PerasVoteStakeDistr + , PerasVoterId (..) + , ValidatedPerasVote (..) + ) +import Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToNode (..)) +import Ouroboros.Consensus.Peras.Params (PerasParams) +import Ouroboros.Consensus.Util (ShowProxy) +import Ouroboros.Network.Util (ShowProxy (..)) + +-- | Mocked Peras votes without crypto. +-- +-- NOTE: this is parameterized around the concrete block type being voted for. +data MockPerasVote blk + = MockPerasVote + { mockVoteRound :: PerasRoundNo + , mockVoteBlock :: Point blk + , mockVoteVoterId :: PerasVoterId + , mockVoteStake :: PerasVoteStake + -- ^ This field is unique to the mocked vote, and allows us to bypass the + -- need for a 'PerasVoteStakeDistr' when creating validated votes in tests. + } + +deriving instance StandardHash blk => Show (MockPerasVote blk) +deriving instance StandardHash blk => Eq (MockPerasVote blk) +deriving instance StandardHash blk => Ord (MockPerasVote blk) +deriving instance StandardHash blk => NoThunks (MockPerasVote blk) +deriving instance StandardHash blk => NFData (MockPerasVote blk) +deriving instance Generic (MockPerasVote blk) + +instance IsPerasVote (MockPerasVote blk) blk where + getPerasVoteRound = mockVoteRound + getPerasVoteBlock = mockVoteBlock + getPerasVoteVoterId = mockVoteVoterId + +instance ShowProxy blk => ShowProxy (MockPerasVote blk) where + showProxy _ = "MockPerasVote(" <> showProxy (Proxy @blk) <> ")" + +instance + Serialise (HeaderHash blk) => + Serialise (MockPerasVote blk) + where + encode + MockPerasVote + { mockVoteRound + , mockVoteBlock + , mockVoteVoterId + } = + encodeListLen 3 + <> encode mockVoteRound + <> encode mockVoteBlock + <> encode mockVoteVoterId + decode = do + decodeListLenOf 3 + mockVoteRound <- decode + mockVoteBlock <- decode + mockVoteVoterId <- decode + pure $ + MockPerasVote + { mockVoteRound + , mockVoteBlock + , mockVoteVoterId + , mockVoteStake = 0 + -- NOTE: stakes are never sent over the wire, but computed locally from + -- the stake distribution. We might need to change this in the future if + -- we ever need roundtrip tests using mocked votes, but for now this is + -- sufficient for our needs. + } + +instance + ConvertRawHash blk => + SerialiseNodeToNode blk (MockPerasVote blk) + where + encodeNodeToNode + ccfg + version + MockPerasVote + { mockVoteRound + , mockVoteBlock + , mockVoteVoterId + } = + encodeListLen 3 + <> encodeNodeToNode ccfg version mockVoteRound + <> encodeNodeToNode ccfg version mockVoteBlock + <> encodeNodeToNode ccfg version mockVoteVoterId + decodeNodeToNode ccfg version = do + decodeListLenOf 3 + mockVoteRound <- decodeNodeToNode ccfg version + mockVoteBlock <- decodeNodeToNode ccfg version + mockVoteVoterId <- decodeNodeToNode ccfg version + pure + MockPerasVote + { mockVoteRound + , mockVoteBlock + , mockVoteVoterId + , mockVoteStake = 0 + -- NOTE: stakes are never sent over the wire, but computed locally from + -- the stake distribution. We might need to change this in the future if + -- we ever need roundtrip tests using mocked votes, but for now this is + -- sufficient for our needs. + } + +-- | Helper to write 'BlockSupportsPeras.validatePerasVote'. +-- +-- WARNING: we do not perform any validation whatsoever for mocked votes. +validateMockPerasVote :: + forall blk. + PerasVote blk ~ MockPerasVote blk => + PerasParams -> + PerasVoteStakeDistr -> + PerasVote blk -> + Either (PerasError blk) (ValidatedPerasVote blk) +validateMockPerasVote _params _stakeDistr vote = + Right + ValidatedPerasVote + { vpvVote = vote + , vpvVoteStake = mockVoteStake vote + } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs new file mode 100644 index 0000000000..de9b37f84d --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Concrete Peras vote types using BLS signatures. +-- +-- NOTE: this module is meant to be imported qualified. +module Ouroboros.Consensus.Peras.Vote.V1 + ( PerasVote (..) + , PerasVoteEligibilityProof (..) + ) where + +import Cardano.Binary + ( FromCBOR (..) + , ToCBOR (..) + , decodeListLen + , decodeListLenOf + , encodeListLen + ) +import Data.Typeable (Typeable) +import Data.Word (Word8) +import Ouroboros.Consensus.Block.SupportsPeras + ( PerasBoostedBlock + , PerasRoundNo + , PerasSeatIndex + ) +import Ouroboros.Consensus.Committee.Crypto (CryptoSupportsVoteSigning (..)) +import Ouroboros.Consensus.Peras.Crypto.BLS + ( PerasBLSCrypto + , VRFOutput + ) + +-- | Concrete Peras votes using BLS signatures +-- +-- NOTE: the 'tag' parameter is a phantom type used to track the block type that +-- the vote is associated with, to ensure injectivity when 'V1.PerasVote' is +-- used as a type instance for 'BlockSupportsPeras' class. +data PerasVote tag + = PerasVote + { pvRoundNo :: !PerasRoundNo + -- ^ Election identifier + , pvBoostedBlock :: !PerasBoostedBlock + -- ^ Vote message, i.e., the hash of the block being voted for + , pvSeatIndex :: !PerasSeatIndex + -- ^ Seat index assigned to the committee member (identifies the voter) + , pvEligibilityProof :: !PerasVoteEligibilityProof + -- ^ Proof of eligibility for voting, depending on the type of membership to + -- the committee (persistent vs non-persistent) + , pvSignature :: !(VoteSignature PerasBLSCrypto) + -- ^ BLS signature on the hash of the election identifier and vote message + } + deriving (Show, Eq) + +instance Typeable tag => FromCBOR (PerasVote tag) where + fromCBOR = do + decodeListLenOf 5 + pvRoundNo <- fromCBOR + pvBoostedBlock <- fromCBOR + pvSeatIndex <- fromCBOR + pvEligibilityProof <- fromCBOR + pvSignature <- fromCBOR + pure + PerasVote + { pvRoundNo + , pvBoostedBlock + , pvSeatIndex + , pvEligibilityProof + , pvSignature + } + +instance Typeable tag => ToCBOR (PerasVote tag) where + toCBOR vote = + encodeListLen 5 + <> toCBOR (pvRoundNo vote) + <> toCBOR (pvBoostedBlock vote) + <> toCBOR (pvSeatIndex vote) + <> toCBOR (pvEligibilityProof vote) + <> toCBOR (pvSignature vote) + +-- | Proof of eligibility for voting for committee members +data PerasVoteEligibilityProof + = -- | Persistent committee members require no additional proof of eligibility + PersistentPerasVoteEligibilityProof + | -- | Non-persistent committee members provide a VRF proof of eligibility + NonPersistentPerasVoteEligibilityProof !(VRFOutput PerasBLSCrypto) + deriving stock (Eq, Show) + +instance FromCBOR PerasVoteEligibilityProof where + fromCBOR = do + len <- decodeListLen + tag <- fromCBOR @Word8 + case (len, tag) of + (1, 0) -> pure PersistentPerasVoteEligibilityProof + (2, 1) -> NonPersistentPerasVoteEligibilityProof <$> fromCBOR + _ -> + fail $ + "Invalid PerasVoteEligibilityProof length/tag: " + <> show (len, tag) + +instance ToCBOR PerasVoteEligibilityProof where + toCBOR = \case + PersistentPerasVoteEligibilityProof -> + encodeListLen 1 + <> toCBOR (0 :: Word8) + NonPersistentPerasVoteEligibilityProof vrfOutput -> + encodeListLen 2 + <> toCBOR (1 :: Word8) + <> toCBOR vrfOutput diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs new file mode 100644 index 0000000000..86a0ee9bba --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Support for using concrete votes and certificates with multiple voting +-- committee implementations. +module Ouroboros.Consensus.Peras.Voting.Adapter + ( -- * Peras support for multiple voting committee implementations + PerasConversionError (..) + , PerasVoteCompatibleWithVotingCommittee (..) + , PerasCertCompatibleWithVotingCommittee (..) + ) where + +import Data.Containers.NonEmpty (HasNonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Map.NonEmpty as NEMap +import Data.Maybe (isJust) +import Data.Word (Word16, Word64) +import qualified Ouroboros.Consensus.Committee.Class as Committee +import Ouroboros.Consensus.Committee.Crypto (CryptoSupportsVRF (..)) +import Ouroboros.Consensus.Committee.EveryoneVotes + ( Cert (..) + , EveryoneVotes + , Vote (..) + ) +import Ouroboros.Consensus.Committee.WFA (SeatIndex (..)) +import Ouroboros.Consensus.Committee.WFALS (Cert (..), Vote (..), WFALS) +import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import Ouroboros.Consensus.Peras.Crypto.BLS (PerasBLSCrypto) +import Ouroboros.Consensus.Peras.Types (PerasSeatIndex (..)) +import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 + +-- * Peras support for multiple voting committee implementations + +-- | Errors that can occur when converting between Peras and committee types +data PerasConversionError + = EveryoneVotesButFoundNonPersistentVoterInVote SeatIndex + | EveryoneVotesButFoundNonPersistentVotersInCert (NE [SeatIndex]) + | SeatIndexOverflowError Word64 + | CryptoError String + deriving stock (Eq, Show) + +-- | Conversion between (concrete) Peras votes and (abstract) committee votes. +-- +-- NOTE: the functional dependency @vote -> crypto@ explicitly ties each +-- concrete Peras vote type to a specific crypto scheme. +class + PerasVoteCompatibleWithVotingCommittee vote crypto committee + | vote -> crypto + where + toPerasVote :: + Committee.Vote crypto committee -> + Either PerasConversionError vote + fromPerasVote :: + vote -> + Either PerasConversionError (Committee.Vote crypto committee) + +-- | Conversion between (concrete) Peras certificates and (abstract) committee +-- certificates. +-- +-- NOTE: the functional dependency @cert -> crypto@ explicitly ties each +-- concrete Peras certificate type to a specific crypto scheme. +class + PerasCertCompatibleWithVotingCommittee cert crypto committee + | cert -> crypto + where + toPerasCert :: + Committee.Cert crypto committee -> + Either PerasConversionError cert + fromPerasCert :: + cert -> + Either PerasConversionError (Committee.Cert crypto committee) + +-- 'V1.PerasVote's are compatible with 'WFALS' as long as we make sure to avoid +-- overflowing their `Word16` seat index. +instance + PerasVoteCompatibleWithVotingCommittee + (V1.PerasVote tag) + PerasBLSCrypto + WFALS + where + toPerasVote = \case + WFALSPersistentVote seatIndex electionId candidate sig -> do + perasSeatIndex <- toPerasSeatIndex seatIndex + pure $ + V1.PerasVote + { V1.pvRoundNo = electionId + , V1.pvBoostedBlock = candidate + , V1.pvSeatIndex = perasSeatIndex + , V1.pvEligibilityProof = V1.PersistentPerasVoteEligibilityProof + , V1.pvSignature = sig + } + WFALSNonPersistentVote seatIndex electionId candidate vrfOutput sig -> do + perasSeatIndex <- toPerasSeatIndex seatIndex + let proof = V1.NonPersistentPerasVoteEligibilityProof vrfOutput + pure $ + V1.PerasVote + { V1.pvRoundNo = electionId + , V1.pvBoostedBlock = candidate + , V1.pvSeatIndex = perasSeatIndex + , V1.pvEligibilityProof = proof + , V1.pvSignature = sig + } + + fromPerasVote = \case + V1.PerasVote electionId candidate seatIndex proof sig -> do + let seatIndex' = fromPerasSeatIndex seatIndex + case proof of + V1.PersistentPerasVoteEligibilityProof -> + pure $ + WFALSPersistentVote + seatIndex' + electionId + candidate + sig + V1.NonPersistentPerasVoteEligibilityProof vrfOutput -> + pure $ + WFALSNonPersistentVote + seatIndex' + electionId + candidate + vrfOutput + sig + +-- 'V1.PerasCert's are compatible with 'WFALS' as long as we make sure to avoid +-- overflowing the `Word16` seat index of each voter. +instance + PerasCertCompatibleWithVotingCommittee + (V1.PerasCert tag) + PerasBLSCrypto + WFALS + where + toPerasCert = \case + WFALSCert electionId candidate voters sig -> do + voters' <- toPerasCertVoters voters + pure $ + V1.PerasCert + { V1.pcRoundNo = electionId + , V1.pcBoostedBlock = candidate + , V1.pcVoters = voters' + , V1.pcSignature = sig + } + + fromPerasCert = \case + V1.PerasCert electionId candidate voters sig -> do + let voters' = fromPerasCertVoters voters + pure $ + WFALSCert + electionId + candidate + voters' + sig + +-- 'V1.PerasVote's are compatible with 'EveryoneVotes' as long as we make sure +-- to only accept votes with persistent eligibility proofs (in addition to +-- avoiding overflowing their `Word16` seat index). +instance + PerasVoteCompatibleWithVotingCommittee + (V1.PerasVote tag) + PerasBLSCrypto + EveryoneVotes + where + toPerasVote = \case + EveryoneVotesVote seatIndex electionId candidate sig -> do + perasSeatIndex <- toPerasSeatIndex seatIndex + pure $ + V1.PerasVote + { V1.pvRoundNo = electionId + , V1.pvBoostedBlock = candidate + , V1.pvSeatIndex = perasSeatIndex + , V1.pvEligibilityProof = V1.PersistentPerasVoteEligibilityProof + , V1.pvSignature = sig + } + + fromPerasVote = \case + V1.PerasVote electionId candidate seatIndex proof sig -> do + let seatIndex' = fromPerasSeatIndex seatIndex + case proof of + V1.PersistentPerasVoteEligibilityProof -> + pure $ + EveryoneVotesVote + seatIndex' + electionId + candidate + sig + V1.NonPersistentPerasVoteEligibilityProof _ -> + Left $ + EveryoneVotesButFoundNonPersistentVoterInVote seatIndex' + +-- 'V1.PerasCert's are compatible with 'EveryoneVotes' as long as we make sure +-- to only accept certificates containing only persistent eligibility proofs +-- (in addition to avoiding overflowing the `Word16` seat index of each voter). +instance + PerasCertCompatibleWithVotingCommittee + (V1.PerasCert tag) + PerasBLSCrypto + EveryoneVotes + where + toPerasCert = \case + EveryoneVotesCert electionId candidate voters sig -> do + voters' <- + toPerasCertVoters + . NEMap.fromSet (const Nothing) + $ voters + pure $ + V1.PerasCert + { V1.pcRoundNo = electionId + , V1.pcBoostedBlock = candidate + , V1.pcVoters = voters' + , V1.pcSignature = sig + } + + fromPerasCert = \case + V1.PerasCert electionId candidate voters sig -> do + let voters' = fromPerasCertVoters voters + case nonPersistentVoters voters' of + Nothing -> + pure $ + EveryoneVotesCert + electionId + candidate + (NEMap.keysSet voters') + sig + Just nonPersistentSeatIndices -> + Left $ + EveryoneVotesButFoundNonPersistentVotersInCert + nonPersistentSeatIndices + where + nonPersistentVoters voters' = + case Map.keys (NEMap.filter isJust voters') of + [] -> + Nothing + nonPersistentSeats -> + Just (NonEmpty.fromList nonPersistentSeats) + +-- * Helpers + +-- | Convert a Peras seat index to a committee seat index. +fromPerasSeatIndex :: + PerasSeatIndex -> + SeatIndex +fromPerasSeatIndex (PerasSeatIndex seatIndex) = + SeatIndex (fromIntegral @Word16 @Word64 seatIndex) + +-- | Convert a committee seat index to a Peras seat index +-- +-- NOTE: this can fail if the seat index in the committee vote or certificate +-- overflows the smaller 'Word16' type used by Peras votes and certificates. +-- In practice, this should never happen unless there is a bug in the voting +-- committee logic. +toPerasSeatIndex :: + SeatIndex -> + Either PerasConversionError PerasSeatIndex +toPerasSeatIndex (SeatIndex seatIndex) + | seatIndex <= fromIntegral @Word16 @Word64 maxBound = + Right (PerasSeatIndex (fromIntegral @Word64 @Word16 seatIndex)) + | otherwise = + Left (SeatIndexOverflowError seatIndex) + +-- | Convert concrete Peras certificate voters to abstract committee voters +fromPerasCertVoters :: + V1.PerasCertVoters -> + NE (Map SeatIndex (Maybe (VRFOutput PerasBLSCrypto))) +fromPerasCertVoters voters = + NEMap.fromAscList + . NonEmpty.map + ( \(seatIndex, proof) -> + ( fromPerasSeatIndex seatIndex + , fromPerasVoteEligibilityProof proof + ) + ) + . NEMap.toAscList + . V1.unPerasCertVoters + $ voters + where + fromPerasVoteEligibilityProof = \case + V1.PersistentPerasVoteEligibilityProof -> Nothing + V1.NonPersistentPerasVoteEligibilityProof vrfOutput -> Just vrfOutput + +-- | Convert abstract committee voters to concrete Peras certificate voters +toPerasCertVoters :: + NE (Map SeatIndex (Maybe (VRFOutput PerasBLSCrypto))) -> + Either PerasConversionError V1.PerasCertVoters +toPerasCertVoters voters = + fmap V1.PerasCertVoters + . fmap NEMap.fromAscList + . traverse + ( \(seatIndex, proof) -> do + seatIndex' <- toPerasSeatIndex seatIndex + let proof' = toPerasVoteEligibilityProof proof + pure (seatIndex', proof') + ) + . NEMap.toAscList + $ voters + where + toPerasVoteEligibilityProof = \case + Nothing -> V1.PersistentPerasVoteEligibilityProof + Just vrfOutput -> V1.NonPersistentPerasVoteEligibilityProof vrfOutput diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs index 58d727ba1b..d088bae441 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs @@ -33,16 +33,13 @@ import Ouroboros.Consensus.Block.Abstract ( SlotNo (..) ) import Ouroboros.Consensus.Block.SupportsPeras - ( HasPerasCertRound (..) - , PerasRoundNo (..) - , getPerasCertRound - , onPerasRoundNo - ) -import Ouroboros.Consensus.Peras.Params - ( PerasCertArrivalThreshold (..) + ( IsPerasCert (..) + , PerasCertArrivalThreshold (..) , PerasCooldownRounds (..) , PerasIgnoranceRounds (..) , PerasParams (..) + , PerasRoundNo (..) + , onPerasRoundNo ) import Ouroboros.Consensus.Peras.Voting.View ( LatestCertOnChainView (..) @@ -76,7 +73,7 @@ instance Explainable PerasVotingRulesDecision where -- | Evaluate whether voting is allowed or not according to the voting rules isPerasVotingAllowed :: - HasPerasCertRound cert => + IsPerasCert cert blk => PerasVotingView cert -> PerasVotingRulesDecision isPerasVotingAllowed pvv = @@ -127,7 +124,7 @@ instance Explainable PerasVotingRule where -- | VR-1A: the voter has seen the certificate for the previous round, and the -- certificate was received in the first X slots after the start of the round. perasVR1A :: - HasPerasCertRound cert => + IsPerasCert cert blk => PerasVotingView cert -> Pred PerasVotingRule perasVR1A @@ -190,7 +187,7 @@ perasVR1B -- This enforces the chain-healing period that must occur before leaving a -- cooldown period. perasVR2A :: - HasPerasCertRound cert => + IsPerasCert cert blk => PerasVotingView cert -> Pred PerasVotingRule perasVR2A @@ -223,7 +220,7 @@ perasVR2A -- This enforces chain quality and common prefix before leaving a cooldown -- period. perasVR2B :: - HasPerasCertRound cert => + IsPerasCert cert blk => PerasVotingView cert -> Pred PerasVotingRule perasVR2B @@ -267,7 +264,7 @@ perasVR2B -- | Both VR-1A and VR-1B hold, which is the situation typically occurring when -- the voting has regularly occurred in preceding rounds. perasVR1 :: - HasPerasCertRound cert => + IsPerasCert cert blk => PerasVotingView cert -> Pred PerasVotingRule perasVR1 pvv = @@ -276,7 +273,7 @@ perasVR1 pvv = -- | Both VR-2A and VR-2B hold, which is the situation typically occurring when -- the chain is about to exit a cooldown period. perasVR2 :: - HasPerasCertRound cert => + IsPerasCert cert blk => PerasVotingView cert -> Pred PerasVotingRule perasVR2 pvv = @@ -284,7 +281,7 @@ perasVR2 pvv = -- | Voting is allowed if either VR-1A and VR-1B hold, or VR-2A and VR-2B hold. perasVotingRules :: - HasPerasCertRound cert => + IsPerasCert cert blk => PerasVotingView cert -> Pred PerasVotingRule perasVotingRules pvv = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs index b9019690a1..9454cb46d8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} @@ -42,11 +43,9 @@ import Ouroboros.Consensus.Block.Abstract , castPoint ) import Ouroboros.Consensus.Block.SupportsPeras - ( HasPerasCertRound (..) - , PerasRoundNo (..) + ( BlockSupportsPeras (..) + , IsPerasCert (..) , ValidatedPerasCert - , getPerasCertBoostedBlock - , getPerasCertRound ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( WithArrivalTime (..) @@ -61,6 +60,7 @@ import Ouroboros.Consensus.Peras.Params ( PerasBlockMinSlots (..) , PerasParams (..) ) +import Ouroboros.Consensus.Peras.Types (PerasRoundNo) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF @@ -223,6 +223,7 @@ forgetBoostedBlockStatus = \case mkPerasVotingView :: ( cert ~ WithArrivalTime (ValidatedPerasCert blk) , GetHeader blk + , IsPerasCert (PerasCert blk) blk ) => -- | Peras protocol parameters PerasParams -> @@ -291,5 +292,5 @@ mkPerasVotingView -- Check whether the boosted block is within the volatile fragment leading -- to the candidate block. AF.withinFragmentBounds - (castPoint (getPerasCertBoostedBlock cert)) + (castPoint (getPerasCertBlock cert)) chainAtCandidateBlock 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/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index 1e86e9df06..0b04e7a088 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 @@ -103,6 +103,7 @@ withDB :: , LedgerSupportsProtocol blk , LedgerSupportsPeras blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk @@ -119,6 +120,7 @@ openDB :: , LedgerSupportsProtocol blk , LedgerSupportsPeras blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk @@ -134,6 +136,7 @@ openDBInternal :: , LedgerSupportsProtocol blk , LedgerSupportsPeras blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk 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 3828af1bf8..a595a690f3 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 @@ -229,7 +229,7 @@ completeChainDbArgs , cdbPerasVoteDbArgs = PerasVoteDB.PerasVoteDbArgs { PerasVoteDB.pvdbaTracer = PerasVoteDB.pvdbaTracer (cdbPerasVoteDbArgs defArgs) - , PerasVoteDB.pvdbaPerasCfg = mkPerasParams + , PerasVoteDB.pvdbaPerasParams = mkPerasParams } , 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 2118a9a06d..a25c1d8639 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 @@ -91,6 +91,7 @@ import System.Random launchBgTasks :: forall m blk. ( IOLike m + , IsPerasCert (PerasCert blk) blk , LedgerSupportsProtocol blk , BlockSupportsDiffusionPipelining blk , InspectLedger blk @@ -571,6 +572,7 @@ dumpGcSchedule (GcSchedule varQueue) = toList <$> readTVar varQueue -- ChainDB. addBlockRunner :: ( IOLike m + , IsPerasCert (PerasCert blk) blk , LedgerSupportsProtocol blk , BlockSupportsDiffusionPipelining blk , InspectLedger blk @@ -615,7 +617,7 @@ addBlockRunner fuse cdb@CDB{..} = forever $ do ChainSelAddPerasCert cert _varProcessed -> traceWith cdbTracer $ TraceAddPerasCertEvent $ - PoppedPerasCertFromQueue (getPerasCertRound cert) (getPerasCertBoostedBlock cert) + PoppedPerasCertFromQueue (getPerasCertRound cert) (getPerasCertBlock cert) chainSelSync cdb message lift $ atomically $ processedChainSelMessage cdbChainSelQueue message ) 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 0369cd7fec..a97509e061 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 (Maybe (AddPerasCertPromise m)) @@ -345,6 +349,7 @@ triggerChainSelectionAsync CDB{cdbTracer, cdbChainSelQueue} = chainSelSync :: forall m blk. ( IOLike m + , IsPerasCert (PerasCert blk) blk , LedgerSupportsProtocol blk , BlockSupportsDiffusionPipelining blk , InspectLedger blk @@ -535,7 +540,7 @@ chainSelSync cdb@CDB{..} (ChainSelAddPerasCert cert varProcessed) = do certRound = getPerasCertRound cert boostedBlock :: Point blk - boostedBlock = getPerasCertBoostedBlock cert + boostedBlock = getPerasCertBlock cert -- | Return 'True' when the given header should be ignored when adding it -- because it is too old, i.e., we wouldn't be able to switch to a chain 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 2f15c44679..ade24f0213 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 @@ -637,7 +637,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) -> @@ -654,7 +656,10 @@ addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do { waitPerasCertProcessed = atomically $ readTMVar varProcessed } where - addedToQueue = AddedPerasCertToQueue (getPerasCertRound cert) (getPerasCertBoostedBlock cert) + addedToQueue = + AddedPerasCertToQueue + (getPerasCertRound cert) + (getPerasCertBlock cert) -- | Try to add blocks again that were postponed due to the LoE. addReprocessLoEBlocks :: @@ -789,9 +794,11 @@ data TraceEvent blk deriving instance ( Show (Header blk) + , Show (TraceAddBlockEvent blk) + , Show (PerasVote blk) + , Show (PerasCert blk) , LedgerSupportsProtocol blk , InspectLedger blk - , Show (TraceAddBlockEvent blk) ) => Show (TraceEvent blk) 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 339190fda3..045a692fa6 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 @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Ouroboros.Consensus.Storage.PerasCertDB.API @@ -110,7 +111,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 @@ -125,7 +128,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 @@ -160,7 +165,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 @@ -169,14 +176,16 @@ prop_garbageCollectRemovesOldCerts db slotNo = do _ <- garbageCollect db slotNo getCertsAfter db zeroPerasCertTicketNo allCertValues <- sequence (Map.elems allCertActions) - let targetSlots = pointSlot . getPerasCertBoostedBlock . forgetArrivalTime <$> allCertValues + let targetSlots = pointSlot . getPerasCertBlock . forgetArrivalTime <$> allCertValues pure $ all (>= NotOrigin slotNo) targetSlots -- | 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 @@ -193,7 +202,9 @@ prop_addCertLatestCertSeenMonotonic db cert = -- | 'getLatestCertSeen' is not affected by garbage collection. prop_garbageCollectPreservesLatestCertSeen :: - (MonadSTM m, StandardHash blk) => + ( MonadSTM m + , Eq (PerasCert 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 2a859ffd57..aca2517b2f 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 @@ -2,9 +2,12 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Storage.PerasCertDB.Impl ( -- * Opening @@ -61,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 = @@ -77,6 +87,7 @@ initialPerasCertDbState = -- | Check that the fields of 'PerasCertDbState' are in sync. invariantForPerasCertDbState :: + IsPerasCert (PerasCert blk) blk => WithFingerprint (PerasCertDbState blk) -> Either String () invariantForPerasCertDbState pcds = do checkEqual @@ -112,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 @@ -132,7 +151,7 @@ defaultArgs = createDB :: forall m blk. ( IOLike m - , StandardHash blk + , BlockSupportsPeras blk ) => Complete PerasCertDbArgs m blk -> m (PerasCertDB m blk) @@ -167,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) @@ -201,14 +222,17 @@ implAddCert PerasCertDbEnv{pcdbTracer, pcdbState} cert = do pure addPerasCertRes implGetWeightSnapshot :: - (IOLike m, StandardHash blk) => + ( IOLike m + , StandardHash blk + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDbEnv m blk -> STM m (WithFingerprint (PerasWeightSnapshot blk)) implGetWeightSnapshot PerasCertDbEnv{pcdbState} = do WithFingerprint pcds fp <- readTVar pcdbState let weights = mkPerasWeightSnapshot - [ (getPerasCertBoostedBlock cert, getPerasCertBoost cert) + [ (getPerasCertBlock cert, vpcCertBoost (forgetArrivalTime cert)) | cert <- Map.elems (pcdsCertsByTicket pcds) ] pure (WithFingerprint weights fp) @@ -244,7 +268,9 @@ implGetLatestCertSeen PerasCertDbEnv{pcdbState} = do implGarbageCollect :: forall m blk. - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDbEnv m blk -> SlotNo -> STM m (m ()) @@ -263,7 +289,7 @@ implGarbageCollect PerasCertDbEnv{pcdbTracer, pcdbState} slotNo = do } = let pcdsCertsByTicket' = Map.filter - (\cert -> pointSlot (getPerasCertBoostedBlock cert) >= NotOrigin slotNo) + (\cert -> pointSlot (getPerasCertBlock cert) >= NotOrigin slotNo) pcdsCertsByTicket pcdsCertIds' = Set.fromList (getPerasCertRound <$> Map.elems pcdsCertsByTicket') 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 319c01a6a8..39cc4333cd 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 @@ -2,8 +2,12 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Storage.PerasVoteDB.API ( PerasVoteDB (..) @@ -31,6 +35,7 @@ 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 @@ -82,8 +87,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 @@ -97,17 +115,27 @@ newtype BlockedPerasRoundWinner blk = BlockedPerasRoundWinner (Point blk, PerasVoteStake) 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 (PerasForgeErr 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 + +deriving instance + StandardHash blk => + Show (PerasVoteDbError blk) +deriving instance + ( StandardHash blk + , Typeable blk + ) => + Exception (PerasVoteDbError blk) -- * Invariants @@ -115,7 +143,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 @@ -129,7 +159,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 = @@ -160,7 +192,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 @@ -175,7 +209,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 7f5fce1611..8ef8170af1 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 @@ -6,7 +6,10 @@ {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Storage.PerasVoteDB.Impl ( -- * Opening @@ -21,7 +24,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) @@ -61,8 +63,27 @@ 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 (PerasVoteDbState blk) +deriving instance + ( StandardHash blk + , Eq (PerasVote blk) + , Eq (PerasCert blk) + ) => + Eq (PerasVoteDbState blk) +deriving instance + ( StandardHash blk + , NoThunks (PerasVote blk) + , NoThunks (PerasCert blk) + ) => + NoThunks (PerasVoteDbState blk) +deriving instance + Generic (PerasVoteDbState blk) initialPerasVoteDbState :: WithFingerprint (PerasVoteDbState blk) initialPerasVoteDbState = @@ -77,10 +98,14 @@ 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) -> - checkEqual "pvcRoundVoteStates rounds" roundNo (getPerasVoteRound prvs) + checkEqual + "pvcRoundVoteStates rounds" + roundNo + (getPerasRoundVoteStateRound prvs) checkEqual "pvcsVotesByTicket" (Set.fromList (getPerasVoteRound <$> Map.elems pvdsVotesByTicket)) @@ -115,7 +140,27 @@ data TraceEvent blk (AddPerasVoteResult blk) | GarbageCollected SlotNo - deriving stock (Show, Eq, Generic) + +deriving instance + ( Show (PerasVoteId blk) + , Show (ValidatedPerasVote blk) + , Show (AddPerasVoteResult blk) + ) => + Show (TraceEvent blk) +deriving instance + ( Eq (PerasVoteId blk) + , Eq (ValidatedPerasVote blk) + , Eq (AddPerasVoteResult blk) + ) => + Eq (TraceEvent blk) +deriving instance + ( NoThunks (PerasVoteId blk) + , NoThunks (ValidatedPerasVote blk) + , NoThunks (AddPerasVoteResult blk) + ) => + NoThunks (TraceEvent blk) +deriving instance + Generic (TraceEvent blk) {------------------------------------------------------------------------------ Creating the database @@ -124,25 +169,24 @@ data TraceEvent blk type PerasVoteDbArgs :: (Type -> Type) -> (Type -> Type) -> Type -> Type data PerasVoteDbArgs f m blk = PerasVoteDbArgs { pvdbaTracer :: Tracer m (TraceEvent blk) - , pvdbaPerasCfg :: HKD f (PerasCfg blk) + , pvdbaPerasParams :: HKD f PerasParams } defaultArgs :: Applicative m => Incomplete PerasVoteDbArgs m blk defaultArgs = PerasVoteDbArgs { pvdbaTracer = nullTracer - , pvdbaPerasCfg = noDefault + , pvdbaPerasParams = noDefault } createDB :: forall m blk. ( IOLike m - , StandardHash blk - , Typeable blk + , BlockSupportsPeras blk ) => Complete PerasVoteDbArgs m blk -> m (PerasVoteDB m blk) -createDB args@PerasVoteDbArgs{pvdbaPerasCfg} = do +createDB args@PerasVoteDbArgs{pvdbaPerasParams} = do pvdeState <- newTVarWithInvariantIO (either Just (const Nothing) . invariantForPerasVoteDbState) @@ -154,7 +198,7 @@ createDB args@PerasVoteDbArgs{pvdbaPerasCfg} = do } pure PerasVoteDB - { addVote = implAddVote pvdbaPerasCfg env + { addVote = implAddVote pvdbaPerasParams env , getVoteIds = implGetVoteIds env , getVotesAfter = implGetVotesAfter env , getForgedCertForRound = implGetForgedCertForRound env @@ -173,14 +217,13 @@ createDB args@PerasVoteDbArgs{pvdbaPerasCfg} = do -- see https://github.com/tweag/cardano-peras/issues/120 implAddVote :: ( IOLike m - , StandardHash blk - , Typeable blk + , BlockSupportsPeras blk ) => - PerasCfg blk -> + PerasParams -> PerasVoteDbEnv m blk -> WithArrivalTime (ValidatedPerasVote blk) -> STM m (m (AddPerasVoteResult blk)) -implAddVote perasCfg PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do +implAddVote params PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do let voteId = getPerasVoteId vote addPerasVoteRes <- do WithFingerprint pvds fp <- readTVar pvdeState @@ -205,7 +248,7 @@ implAddVote perasCfg PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do pvsVotesByTicket' = Map.insert pvsLastTicketNo' vote (pvdsVotesByTicket pvds) (addPerasVoteRes, pvsRoundVoteStates') <- - case updatePerasRoundVoteStates vote perasCfg (pvdsRoundVoteStates pvds) of + case updatePerasRoundVoteStates vote params (pvdsRoundVoteStates pvds) of -- Added vote and reached a quorum, forging a new certificate Right (VoteGeneratedNewCert cert, pvsRoundVoteStates') -> pure (AddedPerasVoteAndGeneratedNewCert cert, pvsRoundVoteStates') @@ -221,13 +264,13 @@ implAddVote perasCfg PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do MultipleWinnersInRound (getPerasVoteRound vote) ( ExistingPerasRoundWinner - ( getPerasVoteBlock winnerState - , ptvsTotalStake winnerState + ( getPerasTargetVoteStateBlock winnerState + , getPerasTargetVoteStateTotalStake winnerState ) ) ( BlockedPerasRoundWinner - ( getPerasVoteBlock loserState - , ptvsTotalStake loserState + ( getPerasTargetVoteStateBlock loserState + , getPerasTargetVoteStateTotalStake loserState ) ) -- Reached quorum but failed to forge a certificate @@ -278,7 +321,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/ouroboros-consensus/Ouroboros/Consensus/Util/Bitmap.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Bitmap.hs new file mode 100644 index 0000000000..ae6a8c656e --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Bitmap.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | A compact bitmap representation using serialisation-ready ByteStrings. +-- +-- Adapted from @Cardano.Leios.BitMapPV@ in the @leios-wfa-ls-demo@ package. +-- +-- NOTE: this module is meant to be imported qualified. +module Ouroboros.Consensus.Util.Bitmap + ( Bitmap + , fromIndices + , toIndices + , logicalUpperBound + , rawSerialise + , rawDeserialise + ) where + +import Cardano.Binary (FromCBOR (..), ToCBOR (..)) +import qualified Codec.CBOR.Decoding as CBOR +import qualified Codec.CBOR.Encoding as CBOR +import Control.Monad (forM_, when) +import Data.Bits + ( countTrailingZeros + , popCount + , unsafeShiftL + , (.&.) + , (.|.) + ) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Internal as ByteString +import Data.Word (Word8) +import Foreign.Marshal.Utils (fillBytes) +import Foreign.Storable (peekByteOff, pokeByteOff) + +-- | A compact bitmap representation over an index type. +-- +-- NOTE: the logical upper bound is stored explicitly so serialisation +-- round-trips exactly. +data Bitmap a + = Bitmap + -- | Logical upper bound + !a + -- | Payload + !ByteString + deriving Eq + +instance Show a => Show (Bitmap a) where + show (Bitmap maxIx bs) = + "Bitmap{maxIx=" + <> show maxIx + <> ",bytes=" + <> show (ByteString.length bs) + <> ",set=" + <> show (countSetBits bs) + <> "}" + where + countSetBits arr = + sum + [ popCount (ByteString.index arr i) + | i <- [0 .. ByteString.length arr - 1] + ] + +-- | Construct a 'Bitmap' from a list of indexes that should be set (flipped to +-- 1) and a maximum index (inclusive logical upper bound). +fromIndices :: Integral a => a -> [a] -> Bitmap a +fromIndices maxIx flipped = + Bitmap maxIx $ + ByteString.unsafeCreate nBytes $ \ptr -> do + fillBytes ptr 0 nBytes + forM_ flipped $ \ix -> do + let !i = fromIntegral ix :: Int + when (i >= 0 && i <= maxI) $ do + let !byteIx = i `quot` 8 + let !bitIx = i `rem` 8 + let !mask = bitMask bitIx + w <- peekByteOff ptr byteIx :: IO Word8 + pokeByteOff ptr byteIx (w .|. mask) + where + !maxI = fromIntegral maxIx :: Int + !nBytes = (maxI `quot` 8) + 1 + + bitMask k = fromIntegral ((1 :: Int) `unsafeShiftL` k) + +-- | Retrieve all indexes that are set (flipped to 1) in the bitmap, in +-- ascending order. +toIndices :: Integral a => Bitmap a -> [a] +toIndices (Bitmap maxIx bitmap) = + goBytes 0 + where + !maxI = fromIntegral maxIx :: Int + !nBytes = ByteString.length bitmap + + goBytes !byteIx + | byteIx >= nBytes = [] + | otherwise = + let !w = ByteString.index bitmap byteIx + in goBits (byteIx * 8) w <> goBytes (byteIx + 1) + + goBits !_ 0 = [] + goBits !base !w = + let !bitIx = countTrailingZeros w + !i = base + bitIx + !w' = w .&. (w - 1) + in if i <= maxI + then fromIntegral i : goBits base w' + else [] + +-- | Get the logical upper bound of a bitmap +logicalUpperBound :: Bitmap a -> a +logicalUpperBound (Bitmap a _) = a + +-- | Raw serialisation of the bitmap (just the underlying bytes, without the +-- logical upper bound). +rawSerialise :: Bitmap a -> ByteString +rawSerialise (Bitmap _ bs) = bs + +-- | Raw deserialisation of a bitmap from a logical upper bound and a ByteString +-- +-- Returns 'Nothing' if the byte string length does not match the expected size +-- for the given upper bound. +rawDeserialise :: Integral a => a -> ByteString -> Maybe (Bitmap a) +rawDeserialise maxIx bs + | ByteString.length bs /= expectedBytes = Nothing + | otherwise = Just (Bitmap maxIx bs) + where + expectedBytes = (fromIntegral maxIx `quot` 8) + 1 + +instance ToCBOR a => ToCBOR (Bitmap a) where + toCBOR (Bitmap maxIx bs) = + CBOR.encodeListLen 2 + <> toCBOR maxIx + <> CBOR.encodeBytes bs + +instance (Integral a, FromCBOR a) => FromCBOR (Bitmap a) where + fromCBOR = do + CBOR.decodeListLenOf 2 + maxIx <- fromCBOR + bs <- CBOR.decodeBytes + case rawDeserialise maxIx bs of + Nothing -> + fail "Bitmap: invalid bitmap data or size mismatch" + Just bitmap -> + pure bitmap diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index 6dcef59082..ec3e8a6259 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -23,6 +23,7 @@ import Data.MultiSet (MultiSet) import qualified Data.MultiSet as MultiSet import Data.SOP.BasicFunctors import Data.Typeable (Typeable) +import Data.Void (Void) import NoThunks.Class ( InspectHeap (..) , InspectHeapNamed (..) @@ -107,3 +108,9 @@ deriving via OnlyCheckWhnfNamed "SomeHasFS" (SomeHasFS m) instance NoThunks (SomeHasFS m) + +{------------------------------------------------------------------------------- + ShowProxy +-------------------------------------------------------------------------------} + +instance ShowProxy Void 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 792acb5580..39c97c33a4 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 @@ -114,6 +114,15 @@ 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 (..) + , forgeMockPerasCert + , validateMockPerasCert + ) +import Ouroboros.Consensus.Peras.Vote.Mock + ( MockPerasVote (..) + , validateMockPerasVote + ) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.BFT import Ouroboros.Consensus.Protocol.ModChainSel @@ -126,6 +135,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 () @@ -198,13 +208,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) @@ -621,22 +631,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 = + 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 = @@ -724,6 +730,22 @@ instance LedgerSupportsProtocol TestBlock where instance LedgerSupportsPeras TestBlock where getLatestPerasCertRound = latestPerasCertRound +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: this is a mocked up implementation without crypto! + +instance BlockSupportsPeras TestBlock where + type PerasVote TestBlock = MockPerasVote TestBlock + type PerasCert TestBlock = MockPerasCert TestBlock + type PerasError TestBlock = VoidPerasError TestBlock + + validatePerasVote = validateMockPerasVote + validatePerasCert = validateMockPerasCert + forgePerasCert = forgeMockPerasCert + getPerasCertInBlock = tbPerasCert . testBody + instance HasHardForkHistory TestBlock where type HardForkIndices TestBlock = '[TestBlock] hardForkSummary = neverForksHardForkSummary id @@ -932,16 +954,22 @@ 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 (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 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 da655ce9c8..e64d3de4fb 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -141,7 +141,7 @@ fromMinimalChainDbArgs MinimalChainDbArgs{..} = , cdbPerasVoteDbArgs = PerasVoteDbArgs { pvdbaTracer = nullTracer - , pvdbaPerasCfg = mkPerasParams + , pvdbaPerasParams = mkPerasParams } , 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 385382e69a..34a7aee03d 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 @@ -22,6 +22,8 @@ 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.Vote.Mock (MockPerasVote) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API (LoE (..)) import Ouroboros.Consensus.Storage.ImmutableDB @@ -124,12 +126,17 @@ deriving anyclass instance ToExpr PerasRoundNo deriving anyclass instance ToExpr PerasWeight -deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (PerasCert blk) +deriving anyclass instance ToExpr PerasVoteStake -deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (ValidatedPerasCert blk) +deriving anyclass instance ToExpr (PerasVoteId blk) deriving anyclass instance ToExpr a => ToExpr (WithArrivalTime a) +instance ToExpr PerasVoterId where toExpr = defaultExprViaShow + +instance ToExpr (HeaderHash blk) => ToExpr (MockPerasVote blk) +instance ToExpr (HeaderHash blk) => ToExpr (MockPerasCert blk) + {------------------------------------------------------------------------------- si-timers --------------------------------------------------------------------------------} 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 ab7c7d4682..63e0f721e7 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -142,7 +142,16 @@ 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 (..) + , forgeMockPerasCert + , validateMockPerasCert + ) import Ouroboros.Consensus.Peras.SelectView (weightedSelectView) +import Ouroboros.Consensus.Peras.Vote.Mock + ( MockPerasVote (..) + , validateMockPerasVote + ) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.BFT @@ -694,6 +703,31 @@ instance PayloadSemantics ptype => LedgerSupportsProtocol (TestBlockWith ptype) instance LedgerSupportsPeras (TestBlockWith ptype) +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: this is a mocked up implementation without crypto! + +instance + Typeable ptype => + BlockSupportsPeras (TestBlockWith ptype) + where + type PerasVote (TestBlockWith ptype) = MockPerasVote (TestBlockWith ptype) + type PerasCert (TestBlockWith ptype) = MockPerasCert (TestBlockWith ptype) + type PerasError (TestBlockWith ptype) = VoidPerasError (TestBlockWith ptype) + + validatePerasVote = validateMockPerasVote + validatePerasCert = validateMockPerasCert + forgePerasCert = forgeMockPerasCert + + -- TODO: extract actual Peras certificates from blocks + getPerasCertInBlock _ = Nothing + +{------------------------------------------------------------------------------- + Test infrastructure: config +-------------------------------------------------------------------------------} + singleNodeTestConfigWith :: CodecConfig (TestBlockWith ptype) -> StorageConfig (TestBlockWith ptype) -> 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..1452104da8 --- /dev/null +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Peras.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# 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 this instance, but +-- defining it there would be too confusing. +module Ouroboros.Consensus.Mock.Node.Peras () where + +import Data.Typeable (Typeable) +import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras (..)) +import Ouroboros.Consensus.Mock.Ledger.Block (SimpleBlock, SimpleCrypto) + +{------------------------------------------------------------------------------- + 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) 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/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index f0b10c40f6..cb4181c933 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -23,8 +23,11 @@ import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke (te import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.PerasVote.Smoke (tests) import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke (tests) import qualified Test.Consensus.Peras.Cert.Inclusion (tests) +import qualified Test.Consensus.Peras.Serialisation (tests) +import qualified Test.Consensus.Peras.Voting.Adapter (tests) import qualified Test.Consensus.Peras.Voting.Rules (tests) import qualified Test.Consensus.Peras.WeightSnapshot (tests) +import qualified Test.Consensus.Util.Bitmap (tests) import qualified Test.Consensus.Util.MonadSTM.NormalForm (tests) import qualified Test.Consensus.Util.Pred (tests) import qualified Test.Consensus.Util.Versioned (tests) @@ -66,9 +69,12 @@ tests = , testGroup "Peras" [ Test.Consensus.Peras.Cert.Inclusion.tests + , Test.Consensus.Peras.Voting.Adapter.tests , Test.Consensus.Peras.Voting.Rules.tests , Test.Consensus.Peras.WeightSnapshot.tests + , Test.Consensus.Peras.Serialisation.tests ] + , Test.Consensus.Util.Bitmap.tests , Test.Consensus.Util.MonadSTM.NormalForm.tests , Test.Consensus.Util.Versioned.tests , Test.Consensus.Util.Pred.tests 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 3bd7376cc3..15cc9a5d92 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,10 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke @@ -23,6 +25,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.Cert.Mock (MockPerasCert (..)) import Ouroboros.Consensus.Storage.PerasCertDB.API ( AddPerasCertResult (..) , PerasCertDB @@ -31,7 +34,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 @@ -62,15 +64,22 @@ tests = genPerasCert :: Gen (PerasCert TestBlock) genPerasCert = do - pcCertRound <- PerasRoundNo <$> arbitrary - pcCertBoostedBlock <- genPointTestBlock - pure $ PerasCert{pcCertRound, pcCertBoostedBlock} + mockCertRound <- PerasRoundNo <$> arbitrary + mockCertBlock <- genPointTestBlock + pure $ + MockPerasCert + { mockCertRound + , mockCertBlock + } -instance WithId (PerasCert blk) PerasRoundNo where - getId = pcCertRound +instance WithId (MockPerasCert blk) PerasRoundNo where + getId = getPerasCertRound -instance WithId (WithArrivalTime (ValidatedPerasCert blk)) PerasRoundNo where - getId = pcCertRound . vpcCert . forgetArrivalTime +instance + IsPerasCert (PerasCert blk) blk => + WithId (WithArrivalTime (ValidatedPerasCert blk)) PerasRoundNo + where + getId = getPerasCertRound . vpcCert . forgetArrivalTime genValidatedPerasCert :: Gen (ValidatedPerasCert TestBlock) genValidatedPerasCert = @@ -79,7 +88,10 @@ genValidatedPerasCert = <*> pure (perasWeight mkPerasParams) 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_ 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 9f50967421..058fa9fca9 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,6 +1,8 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.Consensus.MiniProtocol.ObjectDiffusion.PerasVote.Smoke @@ -16,7 +18,6 @@ import qualified Cardano.Crypto.Seed as SL import qualified Cardano.Ledger.Keys as SL import Control.Monad (join) import Control.Tracer (contramap, nullTracer) -import Data.Data (Typeable) import qualified Data.Map as Map import Data.Ratio ((%)) import Data.String (IsString (..)) @@ -28,6 +29,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote +import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) import Ouroboros.Consensus.Storage.PerasVoteDB ( AddPerasVoteResult (..) , PerasVoteDB @@ -36,7 +38,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 @@ -80,25 +81,40 @@ genPerasVoteStake = do genPerasVote :: Gen (PerasVote TestBlock) genPerasVote = do - pvVoteRound <- PerasRoundNo <$> arbitrary - pvVoteBlock <- genPointTestBlock - pvVoteVoterId <- genPerasVoterId - pure $ PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId} + mockVoteRound <- PerasRoundNo <$> arbitrary + mockVoteBlock <- genPointTestBlock + mockVoteVoterId <- genPerasVoterId + mockVoteStake <- genPerasVoteStake + pure $ + MockPerasVote + { mockVoteRound + , mockVoteBlock + , mockVoteVoterId + , mockVoteStake + } -instance WithId (PerasVote blk) (PerasVoteId blk) where +instance WithId (MockPerasVote blk) (PerasVoteId blk) where getId = getPerasVoteId -instance WithId (WithArrivalTime (ValidatedPerasVote blk)) (PerasVoteId blk) where +instance + IsPerasVote (PerasVote blk) blk => + WithId (WithArrivalTime (ValidatedPerasVote blk)) (PerasVoteId blk) + where getId = getPerasVoteId . vpvVote . forgetArrivalTime genValidatedPerasVote :: Gen (ValidatedPerasVote TestBlock) -genValidatedPerasVote = - ValidatedPerasVote - <$> genPerasVote - <*> genPerasVoteStake +genValidatedPerasVote = do + mockVote <- genPerasVote + pure + ValidatedPerasVote + { vpvVote = mockVote + , vpvVoteStake = mockVoteStake mockVote + } newVoteDB :: - (IOLike m, StandardHash blk, Typeable blk) => + ( IOLike m + , BlockSupportsPeras blk + ) => [WithArrivalTime (ValidatedPerasVote blk)] -> m (PerasVoteDB m blk) newVoteDB votes = do db <- PerasVoteDB.createDB (PerasVoteDB.PerasVoteDbArgs nullTracer mkPerasParams) @@ -131,16 +147,10 @@ prop_smoke = inboundPool <- newVoteDB [] let outboundPoolReader = makePerasVotePoolReaderFromVoteDB outboundPool - stakeDistr = - PerasVoteStakeDistr $ - Map.fromList - [ (pvVoteVoterId (vpvVote v), vpvVoteStake v) - | WithArrivalTime _ v <- watValidatedVotes - ] inboundPoolWriter = makePerasVotePoolWriterFromVoteDB mockSystemTime - (pure stakeDistr) + (pure (PerasVoteStakeDistr mempty)) -- mocked votes are self-validating inboundPool getAllInboundPoolContent = do votesMap <- diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs index 7c7a4f8525..27c088ac1f 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -17,11 +19,13 @@ module Test.Consensus.Peras.Cert.Inclusion (tests) where import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic) -import Ouroboros.Consensus.Block (WithOrigin (..)) +import Ouroboros.Consensus.Block (Point (..), WithOrigin (..)) import Ouroboros.Consensus.Block.SupportsPeras - ( HasPerasCertRound (..) + ( IsPerasCert (..) + , PerasCertMaxRounds (..) + , PerasParams (..) , PerasRoundNo (..) - , getPerasCertRound + , mkPerasParams ) import Ouroboros.Consensus.Peras.Cert.Inclusion ( LatestCertOnChainView (..) @@ -30,11 +34,6 @@ import Ouroboros.Consensus.Peras.Cert.Inclusion , PerasCertInclusionView (..) , needCert ) -import Ouroboros.Consensus.Peras.Params - ( PerasCertMaxRounds (..) - , PerasParams (..) - , mkPerasParams - ) import Ouroboros.Consensus.Util.Pred (Evidence (..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck @@ -50,6 +49,7 @@ import Test.Tasty.QuickCheck , testProperty ) import Test.Util.QuickCheck (geometric) +import Test.Util.TestBlock (TestBlock) import Test.Util.TestEnv (adjustQuickCheckTests) {------------------------------------------------------------------------------- @@ -83,7 +83,7 @@ data PerasCertInclusionRulesDecisionModel -- -- NOTE: this predicate could be lifted directly from the agda specification. needCertModel :: - PerasCertInclusionView TestCert TestBlk -> + PerasCertInclusionView TestCert TestBlock -> PerasCertInclusionRulesDecisionModel needCertModel PerasCertInclusionView @@ -235,9 +235,12 @@ data TestCert } deriving (Show, Eq, Generic) -instance HasPerasCertRound TestCert where +instance IsPerasCert TestCert TestBlock where getPerasCertRound = tcRoundNo + -- We don't really care about the block being boosted for the inclusion rules + getPerasCertBlock = const GenesisPoint + -- | Generate a test certificate -- -- NOTE: to improve the probabilities of covering all the paths in the code, @@ -256,13 +259,6 @@ genTestCert roundNo = do { tcRoundNo = roundNo' } --- * Mocked block type - --- | A mocked block type for testing -data TestBlk - = TestBlk - deriving (Show, Eq, Generic) - -- * Certificate and inclusion views genLatestCertSeen :: PerasRoundNo -> Gen (LatestCertSeenView TestCert) @@ -292,7 +288,7 @@ genPerasCertIds currRoundNo = do then Set.singleton (currRoundNo - 2) else Set.empty -genPerasCertInclusionView :: Gen (PerasCertInclusionView TestCert TestBlk) +genPerasCertInclusionView :: Gen (PerasCertInclusionView TestCert TestBlock) genPerasCertInclusionView = do perasParams <- genPerasParams currRoundNo <- genPerasRoundNo diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs new file mode 100644 index 0000000000..02a9c8b0b9 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Serialisation roundtrip tests for Peras types +module Test.Consensus.Peras.Serialisation + ( tests + ) where + +import Cardano.Binary (FromCBOR (..), ToCBOR (..), decodeFull, serialize) +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 +import Test.Consensus.Peras.Util + ( genPerasCert + , genPerasVote + , mkBucket + , tabulatePerasCert + , tabulatePerasVote + ) +import Test.QuickCheck + ( Gen + , Property + , counterexample + , forAll + , tabulate + , (===) + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Test.Util.TestEnv (adjustQuickCheckTests) + +tests :: TestTree +tests = + testGroup + "Serialization roundtrip for Peras types" + [ adjustQuickCheckTests (* 10) $ + testProperty "Roundtrip for PerasVote" $ + prop_roundtrip @(V1.PerasVote ()) + -- Generate both persistent and non-persistent votes + (genPerasVote True) + tabulatePerasVote + , adjustQuickCheckTests (* 10) $ + testProperty "Roundtrip for PerasCert" $ + prop_roundtrip @(V1.PerasCert ()) + -- Generate certs with both persistent and non-persistent votes + (genPerasCert True) + tabulatePerasCert + ] + +-- * Properties + +prop_roundtrip :: + forall a. + ( Eq a + , Show a + , ToCBOR a + , FromCBOR a + ) => + Gen a -> + (a -> Property -> Property) -> + Property +prop_roundtrip gen tabulateValue = + forAll gen $ \a -> do + let encoded = serialize a + let decoded = decodeFull encoded + tabulateValue a + . tabulateEncodedSize encoded + . counterexample + ( unlines + [ "Original value:" + , show a + , "Decoded value:" + , show decoded + ] + ) + $ Right a === decoded + +-- * Tabulators + +tabulateEncodedSize :: LazyByteString.ByteString -> Property -> Property +tabulateEncodedSize bytes = + tabulate + "Encoded size" + [mkBucket 1000 (fromIntegral (LazyByteString.length bytes)) " bytes"] diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs new file mode 100644 index 0000000000..cabea97e26 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Common utilities for writing tests for Peras types. +module Test.Consensus.Peras.Util + ( -- * Predicates + perasVoteIsPersistent + , perasCertContainsOnlyPersistentVotes + + -- * Generators + , genPerasVote + , genPerasCert + + -- * Tabulators + , mkBucket + , tabulatePerasCert + , tabulatePerasVote + ) where + +import Cardano.Crypto.Hash (ByteString) +import Cardano.Ledger.BaseTypes (SlotNo (..)) +import Control.Monad (forM) +import qualified Data.ByteString as ByteString +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as ShortByteString +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.NonEmpty as NEMap +import Data.Maybe (catMaybes, fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.String (IsString (..)) +import Data.Traversable (mapAccumM) +import Data.Word (Word8) +import GHC.Word (Word16) +import Ouroboros.Consensus.Block (HeaderHash) +import Ouroboros.Consensus.Block.Abstract (WithOrigin (..)) +import Ouroboros.Consensus.Block.RealPoint (RealPoint (..), toBytes32RealPoint) +import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS +import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import Ouroboros.Consensus.Peras.Crypto.BLS + ( PerasBLSCryptoAggregateVoteSignature (..) + , VRFOutput (..) + , VoteSignature (..) + ) +import Ouroboros.Consensus.Peras.Types + ( PerasBoostedBlock (..) + , PerasRoundNo (..) + , PerasSeatIndex (..) + ) +import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 +import Test.QuickCheck + ( Arbitrary (..) + , Gen + , Property + , choose + , frequency + , sized + , tabulate + , vectorOf + ) + +-- * Predicates + +-- | Whether a Peras vote is a persistent one +perasVoteIsPersistent :: V1.PerasVote tag -> Bool +perasVoteIsPersistent vote + | V1.PersistentPerasVoteEligibilityProof{} <- V1.pvEligibilityProof vote = True + | otherwise = False + +-- | Whether a Peras certifcate only contains persistent votes +perasCertContainsOnlyPersistentVotes :: V1.PerasCert tag -> Bool +perasCertContainsOnlyPersistentVotes cert = + all + ( \case + V1.PersistentPerasVoteEligibilityProof -> True + V1.NonPersistentPerasVoteEligibilityProof{} -> False + ) + ( NEMap.elems + . V1.unPerasCertVoters + . V1.pcVoters + $ cert + ) + +-- * Generators + +genRoundNo :: Gen PerasRoundNo +genRoundNo = PerasRoundNo <$> arbitrary + +data BlockWith32BytesHeaderHash +type instance HeaderHash BlockWith32BytesHeaderHash = ShortByteString + +genBoostedBlock :: Gen PerasBoostedBlock +genBoostedBlock = PerasBoostedBlock <$> genWithOrigin genBytes32RealPoint + where + genWithOrigin gen = + frequency + [ (1, pure Origin) + , (9, NotOrigin <$> gen) + ] + genBytes32RealPoint = do + slotNo <- SlotNo <$> arbitrary + hash <- ShortByteString.pack <$> vectorOf 32 arbitrary + pure $ + toBytes32RealPoint @BlockWith32BytesHeaderHash $ + RealPoint slotNo hash + +genSeatIndex :: Gen PerasSeatIndex +genSeatIndex = PerasSeatIndex <$> arbitrary + +genPrivateKey :: Proxy r -> Gen (BLS.PrivateKey r) +genPrivateKey _ = + fromMaybe (error "genPrivateKey: invalid key bytes") + . BLS.rawDeserialisePrivateKey "ROUNDTRIP" + . ByteString.pack + <$> vectorOf 32 (arbitrary @Word8) + +genSignature :: + forall r. + BLS.HasBLSContext r => + Proxy r -> + Gen (BLS.Signature r) +genSignature _ = do + key <- genPrivateKey (Proxy @r) + msg <- fromString @ByteString <$> arbitrary + pure $ BLS.signWithRole key msg + +genVoteEligibilityProof :: Bool -> Gen V1.PerasVoteEligibilityProof +genVoteEligibilityProof shouldGenNonPersistent = do + frequency + [ + ( 4 + , pure V1.PersistentPerasVoteEligibilityProof + ) + , + ( if shouldGenNonPersistent then 1 else 0 + , V1.NonPersistentPerasVoteEligibilityProof + . PerasBLSCryptoVRFOutput + <$> genSignature (Proxy @BLS.VRF) + ) + ] + +genVoters :: Bool -> Gen V1.PerasCertVoters +genVoters shouldGenNonPersistent = do + numVoters <- + sized $ \size -> + fmap (+ 1) $ + choose @Word16 (0, fromIntegral size * 10) + numPersistentVoters <- + case shouldGenNonPersistent of + True -> choose (0, numVoters) + False -> pure numVoters + persistentVoters <- + if numPersistentVoters == 0 + then pure [] + else forM [0 .. numPersistentVoters - 1] $ \i -> do + let proof = V1.PersistentPerasVoteEligibilityProof + pure (PerasSeatIndex i, proof) + nonPersistentVoters <- + if numPersistentVoters == numVoters + then pure [] + else forM [numPersistentVoters .. numVoters - 1] $ \i -> do + proof <- + V1.NonPersistentPerasVoteEligibilityProof + . PerasBLSCryptoVRFOutput + <$> genSignature (Proxy @BLS.VRF) + pure (PerasSeatIndex i, proof) + voters <- + fmap (snd . fmap catMaybes) + . mapAccumM + ( \canDrop (i, proof) -> do + voter <- + frequency + [ (75, pure (Just (i, proof))) + , (if canDrop then 25 else 0, pure Nothing) + ] + pure + ( canDrop || voter == Nothing + , voter + ) + ) + False + $ persistentVoters <> nonPersistentVoters + pure $ + V1.PerasCertVoters (NEMap.fromList (NonEmpty.fromList voters)) + +genPerasVote :: Bool -> Gen (V1.PerasVote tag) +genPerasVote shouldGenNonPersistent = do + pvRoundNo <- genRoundNo + pvBoostedBlock <- genBoostedBlock + pvSeatIndex <- genSeatIndex + pvEligibilityProof <- genVoteEligibilityProof shouldGenNonPersistent + pvSignature <- + PerasBLSCryptoVoteSignature + <$> genSignature (Proxy @BLS.SIGN) + pure + V1.PerasVote + { V1.pvRoundNo + , V1.pvBoostedBlock + , V1.pvSeatIndex + , V1.pvEligibilityProof + , V1.pvSignature + } + +genPerasCert :: Bool -> Gen (V1.PerasCert tag) +genPerasCert shouldGenNonPersistent = do + pcRoundNo <- genRoundNo + pcBoostedBlock <- genBoostedBlock + pcVoters <- genVoters shouldGenNonPersistent + pcSignature <- + PerasBLSCryptoAggregateVoteSignature + <$> genSignature (Proxy @BLS.SIGN) + pure + V1.PerasCert + { V1.pcRoundNo + , V1.pcBoostedBlock + , V1.pcVoters + , V1.pcSignature + } + +-- * Tabulators + +mkBucket :: Int -> Int -> String -> String +mkBucket bucketSize x suffix + | lower == upper = show lower <> suffix + | otherwise = show lower <> "-" <> show upper <> suffix + where + lower = (x `div` bucketSize) * bucketSize + upper = lower + bucketSize + +tabulatePerasCert :: V1.PerasCert tag -> Property -> Property +tabulatePerasCert cert = + foldr (flip (.)) id $ + [ tabulate + "Number of voters" + [mkBucket 100 numVoters " voters"] + , tabulate + "Proportion of persistent voters" + [mkBucket 10 persistentVotersRatio "%"] + ] + where + numVoters = + length + . V1.unPerasCertVoters + . V1.pcVoters + $ cert + numPersistentVoters = + length + . filter (== V1.PersistentPerasVoteEligibilityProof) + . NonEmpty.toList + . NEMap.elems + . V1.unPerasCertVoters + . V1.pcVoters + $ cert + + persistentVotersRatio + | numVoters == 0 = 0 + | otherwise = numPersistentVoters * 100 `div` numVoters + +tabulatePerasVote :: V1.PerasVote tag -> Property -> Property +tabulatePerasVote vote = + foldr (flip (.)) id $ + [ tabulate + "Voter type" + [voterType] + ] + where + voterType = + case V1.pvEligibilityProof vote of + V1.PersistentPerasVoteEligibilityProof -> "persistent" + V1.NonPersistentPerasVoteEligibilityProof _ -> "non-persistent" diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs new file mode 100644 index 0000000000..3cd82dd231 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Test properties of the adapters between Peras and voting committee types. +module Test.Consensus.Peras.Voting.Adapter (tests) where + +import Data.Proxy (Proxy (..)) +import qualified Ouroboros.Consensus.Committee.Class as Committee +import Ouroboros.Consensus.Committee.EveryoneVotes (EveryoneVotes) +import Ouroboros.Consensus.Committee.WFALS (WFALS) +import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 +import Ouroboros.Consensus.Peras.Voting.Adapter + ( PerasCertCompatibleWithVotingCommittee (..) + , PerasVoteCompatibleWithVotingCommittee (..) + ) +import Test.Consensus.Peras.Util + ( genPerasCert + , genPerasVote + , perasCertContainsOnlyPersistentVotes + , perasVoteIsPersistent + , tabulatePerasCert + , tabulatePerasVote + ) +import Test.QuickCheck + ( Gen + , Property + , Testable (..) + , counterexample + , forAll + , frequency + , tabulate + , (===) + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Test.Util.TestEnv (adjustQuickCheckTests) + +tests :: TestTree +tests = + testGroup + "Roundtrip for Peras types via abstract committee types" + [ adjustQuickCheckTests (* 10) $ + testProperty "Roundtrip for PerasVote via WFALS" $ + prop_roundtrip_vote + (Proxy @(V1.PerasVote ())) + (Proxy @WFALS) + -- WFALS supports both persistent and non-persistent of votes + (const True) + -- Generate both persistent and non-persistent votes + (genPerasVote True) + tabulatePerasVote + , adjustQuickCheckTests (* 10) $ + testProperty "Roundtrip for PerasVote via EveryoneVotes" $ + prop_roundtrip_vote + (Proxy @(V1.PerasVote ())) + (Proxy @EveryoneVotes) + -- EveryoneVotes only supports non-persistent votes + perasVoteIsPersistent + -- Generate both persistent and non-persistent votes to trigger + -- conversion errors in a reasonable amount of tests + (genPerasVote =<< frequency [(2, pure True), (1, pure False)]) + tabulatePerasVote + , adjustQuickCheckTests (* 10) $ + testProperty "Roundtrip for PerasCert via WFALS" $ + prop_roundtrip_cert + (Proxy @(V1.PerasCert ())) + (Proxy @WFALS) + -- WFALS supports certs with both persistent and non-persistent votes + (const True) + -- Generate certs with both persistent and non-persistent votes + (genPerasCert True) + tabulatePerasCert + , adjustQuickCheckTests (* 10) $ + testProperty "Roundtrip for PerasCert via EveryoneVotes" $ + prop_roundtrip_cert + (Proxy @(V1.PerasCert ())) + (Proxy @EveryoneVotes) + -- EveryoneVotes only supports certs with persistent votes + perasCertContainsOnlyPersistentVotes + -- Only sometimes generate certs with non-persistent votes to + -- trigger conversion errors in a reasonable amount of tests + (genPerasCert =<< frequency [(2, pure False), (1, pure True)]) + tabulatePerasCert + ] + +-- * Properties + +-- | Test that converting a concrete Peras vote to an committee vote and back +-- again results in the original Peras vote. +-- +-- NOTE: this takes a predicate to determine whether triggering an exception is +-- a test failure or an expected outcome for the given voting committee scheme. +prop_roundtrip_vote :: + forall vote crypto committee. + ( Show vote + , Eq vote + , PerasVoteCompatibleWithVotingCommittee vote crypto committee + ) => + Proxy vote -> + Proxy committee -> + (vote -> Bool) -> + Gen vote -> + (vote -> Property -> Property) -> + Property +prop_roundtrip_vote _ _ shouldPass gen tabulateValue = + forAll gen $ \vote -> do + tabulateValue vote $ + case fromPerasVote vote of + Left err + | shouldPass vote -> + counterexample + ( unlines + [ "fromPerasVote failed with:" + , show err + , "Original vote:" + , show vote + ] + ) + False + | otherwise -> + tabulateOutcome "Fails as expected" $ + property True + Right (committeeVote :: Committee.Vote crypto committee) -> + case toPerasVote committeeVote of + Left err -> + counterexample + ( unlines + [ "toPerasVote failed with:" + , show err + ] + ) + $ property False + Right vote' -> + tabulateOutcome "Roundtrips successfully" + . counterexample + ( unlines + [ "Original vote:" + , show vote + , "Roundtripped vote:" + , show vote' + ] + ) + $ vote === vote' + +-- | Test that converting a concrete Peras cert to an committee cert and back +-- again results in the original Peras cert. +-- +-- NOTE: this takes a predicate to determine whether triggering an exception is +-- a test failure or an expected outcome for the given voting committee scheme. +prop_roundtrip_cert :: + forall cert crypto committee. + ( Show cert + , Eq cert + , PerasCertCompatibleWithVotingCommittee cert crypto committee + ) => + Proxy cert -> + Proxy committee -> + (cert -> Bool) -> + Gen cert -> + (cert -> Property -> Property) -> + Property +prop_roundtrip_cert _ _ shouldPass gen tabulateValue = + forAll gen $ \cert -> do + tabulateValue cert $ + case fromPerasCert cert of + Left err + | shouldPass cert -> + counterexample + ( unlines + [ "fromPerasCert failed with:" + , show err + , "Original cert:" + , show cert + ] + ) + $ property False + | otherwise -> + tabulateOutcome "Fails as expected" $ + property True + Right (committeeCert :: Committee.Cert crypto committee) -> + case toPerasCert committeeCert of + Left err -> + counterexample + ( unlines + [ "toPerasCert failed with:" + , show err + ] + ) + False + Right cert' -> + tabulateOutcome "Roundtrips successfully" + . counterexample + ( unlines + [ "Original cert:" + , show cert + , "Roundtripped cert:" + , show cert' + ] + ) + $ cert === cert' + +tabulateOutcome :: String -> Property -> Property +tabulateOutcome outcome = tabulate "Outcome" [outcome] diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs index d47497cfde..aeb7c50086 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -13,26 +15,24 @@ module Test.Consensus.Peras.Voting.Rules (tests) where import GHC.Generics (Generic) +import Ouroboros.Consensus.Block (Point (..)) import Ouroboros.Consensus.Block.Abstract ( SlotNo (..) , WithOrigin (..) ) import Ouroboros.Consensus.Block.SupportsPeras - ( HasPerasCertRound (..) - , PerasRoundNo (..) - , getPerasCertRound - , onPerasRoundNo - ) -import Ouroboros.Consensus.BlockchainTime - ( RelativeTime (..) - ) -import Ouroboros.Consensus.Peras.Params - ( PerasBlockMinSlots (..) + ( IsPerasCert (..) + , PerasBlockMinSlots (..) , PerasCertArrivalThreshold (..) , PerasCooldownRounds (..) , PerasIgnoranceRounds (..) , PerasParams (..) + , PerasRoundNo (..) , mkPerasParams + , onPerasRoundNo + ) +import Ouroboros.Consensus.BlockchainTime + ( RelativeTime (..) ) import Ouroboros.Consensus.Peras.Voting.Rules ( PerasVotingRulesDecision (..) @@ -59,6 +59,7 @@ import Test.Tasty.QuickCheck ) import Test.Util.Orphans.Arbitrary (genNominalDiffTime50Years) import Test.Util.QuickCheck (geometric) +import Test.Util.TestBlock (TestBlock) import Test.Util.TestEnv (adjustQuickCheckTests) {------------------------------------------------------------------------------- @@ -255,9 +256,12 @@ data TestCert } deriving (Show, Eq, Generic) -instance HasPerasCertRound TestCert where +instance IsPerasCert TestCert TestBlock where getPerasCertRound = tcRoundNo + -- We don't really care about the block being boosted for the voting rules + getPerasCertBlock = const GenesisPoint + -- | Generate a test certificate -- -- NOTE: to improve the probabilities of covering all the paths in the code, diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/Bitmap.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/Bitmap.hs new file mode 100644 index 0000000000..b059d497e6 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/Bitmap.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Property-based tests for 'Bitmap' +module Test.Consensus.Util.Bitmap (tests) where + +import Cardano.Binary (decodeFull, serialize) +import qualified Data.Set as Set +import qualified Ouroboros.Consensus.Util.Bitmap as Bitmap +import Test.QuickCheck (Testable (..), counterexample, vectorOf) +import Test.Tasty +import Test.Tasty.QuickCheck + ( Gen + , Property + , choose + , forAll + , testProperty + , (===) + ) +import Test.Util.TestEnv (adjustQuickCheckTests) + +tests :: TestTree +tests = + adjustQuickCheckTests (* 100) $ + testGroup + "Bitmap" + [ testProperty + "prop_roundtrip_toIndices" + prop_roundtrip_toIndices + , testProperty + "prop_roundtrip_serialisation" + prop_roundtrip_serialisation + ] + +-- * Properties + +-- | Converting from indices to bitmap and back preserves the indices. +prop_roundtrip_toIndices :: Property +prop_roundtrip_toIndices = + forAll genMaxIndex $ \maxIndex -> + forAll genNumIndices $ \numIndices -> do + forAll (genIndices numIndices maxIndex) $ \indices -> do + let bitmap = Bitmap.fromIndices maxIndex indices + let indices' = Bitmap.toIndices bitmap + Set.fromList indices === Set.fromList indices' + +-- | Serialisation roundtrip preserves the bitmap. +prop_roundtrip_serialisation :: Property +prop_roundtrip_serialisation = + forAll genMaxIndex $ \maxIndex -> + forAll genNumIndices $ \numIndices -> do + forAll (genIndices numIndices maxIndex) $ \indices -> do + let bitmap = Bitmap.fromIndices maxIndex indices + let encoded = serialize bitmap + case decodeFull encoded of + Left err -> + counterexample ("Deserialization failed: " <> show err) $ + property False + Right bitmap' -> + bitmap === bitmap' + +-- * Generators + +genMaxIndex :: Gen Int +genMaxIndex = + choose (0, 10000) + +genNumIndices :: Gen Int +genNumIndices = + choose (0, 100) + +genIndices :: Int -> Int -> Gen [Int] +genIndices numIndices maxIndex = + vectorOf numIndices (choose (0, maxIndex)) 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 155df7f6d8..678aa5155f 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 @@ -113,6 +114,7 @@ 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.SelectView import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Protocol.Abstract @@ -182,12 +184,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 + , Show (PerasVote blk) + , Show (PerasCert blk) + , Show blk + ) => + Show (Model blk) {------------------------------------------------------------------------------- Queries @@ -259,7 +269,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) @@ -287,7 +301,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 @@ -327,7 +343,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) -> @@ -352,7 +371,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 @@ -362,7 +383,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 @@ -395,11 +418,20 @@ 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 m = getPerasCertRound <$> PerasCertDBModel.getLatestCertSeen (perasCertModel m) +roundNoOfLatestCertSeen :: + IsPerasCert (PerasCert blk) blk => + Model blk -> Maybe PerasRoundNo +roundNoOfLatestCertSeen m = + getPerasCertRound + <$> PerasCertDBModel.getLatestCertSeen (perasCertModel m) {------------------------------------------------------------------------------- Construction @@ -428,7 +460,10 @@ empty loe initLedger = addBlock :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , IsPerasCert (PerasCert blk) blk + ) => TopLevelConfig blk -> blk -> Model blk -> @@ -457,7 +492,11 @@ addBlock cfg blk m addPerasCert :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , Ord (PerasCert blk) + , IsPerasCert (PerasCert blk) blk + ) => TopLevelConfig blk -> WithArrivalTime (ValidatedPerasCert blk) -> Model blk -> @@ -467,7 +506,14 @@ addPerasCert cfg cert m = addPerasVote :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , Ord (PerasVote blk) + , Ord (PerasCert blk) + , PerasCert blk ~ MockPerasCert blk + , IsPerasVote (PerasVote blk) blk + , IsPerasCert (PerasCert blk) blk + ) => TopLevelConfig blk -> WithArrivalTime (ValidatedPerasVote blk) -> Model blk -> @@ -485,6 +531,7 @@ chainSelection :: forall blk. ( LedgerTablesAreTrivial ExtLedgerState blk , LedgerSupportsProtocol blk + , IsPerasCert (PerasCert blk) blk ) => TopLevelConfig blk -> Model blk -> @@ -612,7 +659,10 @@ chainSelection cfg m = consideredCandidates addBlocks :: - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , IsPerasCert (PerasCert blk) blk + ) => TopLevelConfig blk -> [blk] -> Model blk -> @@ -622,7 +672,11 @@ addBlocks cfg = repeatedly (addBlock cfg) -- | Wrapper around 'addBlock' that returns an 'AddBlockPromise'. addBlockPromise :: forall m blk. - (LedgerSupportsProtocol blk, MonadSTM m, LedgerTablesAreTrivial ExtLedgerState blk) => + ( LedgerSupportsProtocol blk + , MonadSTM m + , LedgerTablesAreTrivial ExtLedgerState blk + , IsPerasCert (PerasCert blk) blk + ) => TopLevelConfig blk -> blk -> Model blk -> @@ -645,6 +699,7 @@ updateLoE :: forall blk. ( LedgerTablesAreTrivial ExtLedgerState blk , LedgerSupportsProtocol blk + , IsPerasCert (PerasCert blk) blk ) => TopLevelConfig blk -> AnchoredFragment blk -> @@ -659,7 +714,7 @@ updateLoE cfg f m = (tipPoint m', m') -------------------------------------------------------------------------------} stream :: - GetPrevHash blk => + (GetPrevHash blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> StreamFrom blk -> StreamTo blk -> @@ -905,7 +960,10 @@ chains bs = go Chain.Genesis validChains :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , IsPerasCert (PerasCert blk) blk + ) => TopLevelConfig blk -> Model blk -> Map (HeaderHash blk) blk -> @@ -961,7 +1019,7 @@ successors = Map.unionsWith Map.union . map single between :: forall blk. - GetPrevHash blk => + (GetPrevHash blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> StreamFrom blk -> StreamTo blk -> @@ -1063,7 +1121,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 @@ -1079,7 +1137,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 = @@ -1092,7 +1150,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 @@ -1110,7 +1168,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 @@ -1136,7 +1194,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 $ @@ -1160,7 +1218,10 @@ reopen m = m{isOpen = True} -- see https://github.com/tweag/cardano-peras/issues/122 wipeVolatileDB :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , IsPerasCert (PerasCert blk) 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 cbfa12a690..599c1580a2 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,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -125,6 +127,8 @@ 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.Vote.Mock (MockPerasVote (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB hiding ( TraceFollowerEvent (..) @@ -253,7 +257,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 -- @@ -373,6 +387,9 @@ type TestConstraints blk = , LedgerTablesAreTrivial LedgerState blk , CanUpgradeLedgerTables LedgerState blk , ImmutableEraParams blk + , BlockSupportsPeras blk + , PerasVote blk ~ MockPerasVote blk + , PerasCert blk ~ MockPerasCert blk ) deriving instance @@ -1279,9 +1296,9 @@ generator loe genBlock genPerasBlock m@Model{..} = WithArrivalTime now $ ValidatedPerasCert { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBoostedBlock = blockPoint blk + MockPerasCert + { mockCertRound = roundNo + , mockCertBlock = blockPoint blk } , vpcCertBoost = boost } @@ -1313,10 +1330,11 @@ generator loe genBlock genPerasBlock m@Model{..} = WithArrivalTime now $ ValidatedPerasVote { vpvVote = - PerasVote - { pvVoteRound = roundNo - , pvVoteBlock = blockPoint blk - , pvVoteVoterId = voterId + MockPerasVote + { mockVoteRound = roundNo + , mockVoteBlock = blockPoint blk + , mockVoteVoterId = voterId + , mockVoteStake = stake } , vpvVoteStake = stake } @@ -1606,6 +1624,8 @@ deriving instance , ToExpr (ExtValidationError blk) , StandardHash blk , Show blk + , Show (PerasVote blk) + , Show (PerasCert blk) ) => ToExpr (Model blk IO Concrete) @@ -1755,7 +1775,7 @@ addPerasCertOutcomes = concatMap classifyEvent classifyEvent :: Event Blk m Symbolic -> [String] classifyEvent ev = case unAt (eventCmd ev) of AddPerasCert certWithTime _ -> - let targetPt = pcCertBoostedBlock (vpcCert (forgetArrivalTime certWithTime)) + let targetPt = getPerasCertBlock (vpcCert (forgetArrivalTime certWithTime)) in case (isBlockConnected targetPt (dbModel (eventBefore ev))) of False -> assert (chainSelOutcome ev == "no chain selection change") $ @@ -1773,7 +1793,7 @@ addPerasVoteOutcomes = concatMap classifyEvent classifyEvent :: Event Blk m Symbolic -> [String] classifyEvent ev = case unAt (eventCmd ev) of AddPerasVote voteWithTime _ -> - let targetPt = pvVoteBlock (vpvVote (forgetArrivalTime voteWithTime)) + let targetPt = getPerasVoteBlock (vpvVote (forgetArrivalTime voteWithTime)) certsBefore = numCerts (eventBefore ev) certsAfter = numCerts (eventAfter ev) certProduced = certsAfter > certsBefore @@ -2099,24 +2119,37 @@ 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 + pure + MockPerasCert + { mockCertRound = roundNo + , mockCertBlock = boostedBlock } -- | Generate a random security parameter (k) 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 3b44055bd6..7487edf5ef 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 (..) @@ -18,7 +20,7 @@ import qualified Data.Set as Set import Data.TreeDiff (ToExpr (..), defaultExprViaShow) import GHC.Generics (Generic) import Ouroboros.Consensus.Block -import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) import Ouroboros.Consensus.Peras.Weight ( PerasWeightSnapshot , mkPerasWeightSnapshot @@ -31,9 +33,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 @@ -43,7 +45,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) -> Model blk addCert model@Model{certs, latestCertSeen} cert | certs `hasRoundNo` cert = model @@ -57,6 +61,7 @@ addCert model@Model{certs, latestCertSeen} cert | otherwise -> Just prev hasRoundNo :: + IsPerasCert (PerasCert blk) blk => Set (WithArrivalTime (ValidatedPerasCert blk)) -> WithArrivalTime (ValidatedPerasCert blk) -> Bool @@ -64,11 +69,13 @@ 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 - [ (getPerasCertBoostedBlock cert, getPerasCertBoost cert) + [ (getPerasCertBlock cert, vpcCertBoost (forgetArrivalTime cert)) | cert <- Set.toList certs ] @@ -77,8 +84,10 @@ 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} = model{certs = Set.filter keepCert certs} where - keepCert cert = pointSlot (getPerasCertBoostedBlock cert) >= NotOrigin slotNo + keepCert cert = pointSlot (getPerasCertBlock cert) >= NotOrigin slotNo 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 25277db826..5833d57ad0 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 @@ -28,6 +28,7 @@ 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 (AddPerasCertResult (..), PerasCertDB) @@ -51,8 +52,8 @@ tests = [ adjustQuickCheckTests (* 100) $ testProperty "q-d" $ prop_qd ] -perasTestCfg :: PerasCfg TestBlock -perasTestCfg = mkPerasParams +perasTestParams :: PerasParams +perasTestParams = mkPerasParams prop_qd :: Actions Model -> Property prop_qd actions = QC.monadic f $ property () <$ runActions actions @@ -91,11 +92,11 @@ instance StateModel Model where WithArrivalTime now $ ValidatedPerasCert { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBoostedBlock = boostedBlock + MockPerasCert + { mockCertRound = roundNo + , mockCertBlock = boostedBlock } - , vpcCertBoost = perasWeight perasTestCfg + , vpcCertBoost = perasWeight perasTestParams } pure (AddCert certWithTime) @@ -137,7 +138,7 @@ instance StateModel Model where -- So we should enforce: round = round' => boostedBlock = boostedBlock' p cert' = getPerasCertRound cert /= getPerasCertRound cert' - || getPerasCertBoostedBlock cert == getPerasCertBoostedBlock cert' + || getPerasCertBlock cert == getPerasCertBlock cert' GetWeightSnapshot -> True GetLatestCertSeen -> True GarbageCollect _slotNo -> True @@ -194,7 +195,7 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where "Certificate block collision" [ show $ Set.member - (getPerasCertBoostedBlock cert) - (Set.map getPerasCertBoostedBlock model.certs) + (getPerasCertBlock cert) + (Set.map getPerasCertBlock model.certs) ] monitoring _ _ _ _ prop = prop 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 04a9e56193..5f03f35a03 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 (..) @@ -23,26 +27,22 @@ import GHC.Generics (Generic) import Ouroboros.Consensus.Block (SlotNo, WithOrigin (..), pointSlot) import Ouroboros.Consensus.Block.Abstract (StandardHash) import Ouroboros.Consensus.Block.SupportsPeras - ( HasPerasVoteBlock (..) - , HasPerasVoteRound (..) - , PerasCert (..) - , PerasCfg - , PerasParams (..) + ( BlockSupportsPeras (..) + , IsPerasCert (..) + , IsPerasVote (..) + , PerasParams , PerasRoundNo , PerasVoteId (..) , PerasVoteStake (..) , PerasVoteTarget (..) , PerasVoterId , ValidatedPerasCert (..) - , ValidatedPerasVote - , getPerasCertBoostedBlock - , getPerasVoteStake - , getPerasVoteVoterId + , ValidatedPerasVote (..) + , perasWeight , stakeAboveThreshold ) -import Ouroboros.Consensus.BlockchainTime.WallClock.Types - ( WithArrivalTime (..) - ) +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) import Ouroboros.Consensus.Storage.PerasVoteDB.API ( AddPerasVoteResult (..) , PerasVoteTicketNo @@ -57,7 +57,11 @@ data VoteEntry blk = VoteEntry , 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) @@ -74,12 +78,27 @@ 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 :: PerasCfg blk -> Model blk +initModel :: PerasParams -> Model blk initModel cfg = Model { open = False @@ -135,7 +154,12 @@ 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) @@ -158,7 +182,7 @@ addVote vote model -- block in this round => integrity violation (shouldn't happen in practice) | reachedQuorum , Just existingCert <- certAtRound - , getPerasCertBoostedBlock freshCert /= getPerasCertBoostedBlock existingCert = + , getPerasCertBlock freshCert /= getPerasCertBlock existingCert = ( Left $ MultipleWinnersInRound roundNo , model @@ -227,7 +251,7 @@ addVote vote model . sum . fmap ( unPerasVoteStake - . getPerasVoteStake + . vpvVoteStake . forgetArrivalTime . veVote ) @@ -251,9 +275,9 @@ addVote vote model freshCert = ValidatedPerasCert { vpcCert = - PerasCert - { pcCertRound = getPerasVoteRound vote - , pcCertBoostedBlock = getPerasVoteBlock vote + MockPerasCert + { mockCertRound = roundNo + , mockCertBlock = votedBlock } , 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 fe5905eb95..2dae37aa84 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 @@ -41,11 +41,9 @@ import Data.Word (Word64) import GHC.Generics (Generic) import Ouroboros.Consensus.Block.Abstract (Point (..), SlotNo (..)) import Ouroboros.Consensus.Block.SupportsPeras - ( BlockSupportsPeras (..) - , HasPerasVoteBlock (..) - , HasPerasVoteRound (..) + ( IsPerasVote (..) + , PerasParams , PerasRoundNo (..) - , PerasVote (..) , PerasVoteId , PerasVoteStake (..) , PerasVoteTarget (..) @@ -58,6 +56,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( RelativeTime (..) , WithArrivalTime (..) ) +import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) import Ouroboros.Consensus.Storage.PerasVoteDB ( AddPerasVoteResult (..) , PerasVoteDB @@ -91,7 +90,10 @@ import Test.QuickCheck.StateModel ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) -import Test.Util.TestBlock (TestBlock, TestHash (..)) +import Test.Util.TestBlock + ( TestBlock + , TestHash (..) + ) import Test.Util.TestEnv (adjustQuickCheckMaxSize, adjustQuickCheckTests) tests :: TestTree @@ -104,8 +106,8 @@ tests = prop_qd ] -perasTestCfg :: PerasCfg TestBlock -perasTestCfg = mkPerasParams +perasTestParams :: PerasParams +perasTestParams = mkPerasParams prop_qd :: Actions Model -> Property prop_qd actions = monadic runActualImplemMonad resultAsPropertyM @@ -186,10 +188,11 @@ instance StateModel Model where WithArrivalTime now $ ValidatedPerasVote { vpvVote = - PerasVote - { pvVoteRound = roundNo - , pvVoteBlock = point - , pvVoteVoterId = voterId + MockPerasVote + { mockVoteRound = roundNo + , mockVoteBlock = point + , mockVoteVoterId = voterId + , mockVoteStake = stake } , vpvVoteStake = stake } @@ -234,7 +237,7 @@ instance StateModel Model where pure (RelativeTime time) initialState = - Model (Model.initModel perasTestCfg) + Model (Model.initModel perasTestParams) nextState (Model m) action _ = case action of @@ -264,7 +267,7 @@ instance RunModel Model (StateT (PerasVoteDB IO TestBlock) IO) where perform _ action _ = case action of CreateDB -> do - let args = PerasVoteDB.PerasVoteDbArgs nullTracer perasTestCfg + let args = PerasVoteDB.PerasVoteDbArgs nullTracer perasTestParams voteDB <- lift $ PerasVoteDB.createDB args put voteDB AddVote vote -> do 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..5884ee08a1 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) @@ -392,7 +393,7 @@ generatorCmdImpl Model{..} = TestBody <$> arbitrary <*> arbitrary - <*> liftArbitrary (PerasRoundNo <$> arbitrary) + <*> liftArbitrary genPerasCert prevHash <- frequency [ (1, return GenesisHash) @@ -407,6 +408,16 @@ 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 + pure $ + MockPerasCert + { mockCertRound + , mockCertBlock + } + genHash :: Gen (HeaderHash Block) genHash = frequency