diff --git a/cabal.project b/cabal.project index 2162410163..17c612c568 100644 --- a/cabal.project +++ b/cabal.project @@ -16,7 +16,7 @@ index-state: -- Bump this if you need newer packages from Hackage , hackage.haskell.org 2025-07-22T09:13:54Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2025-08-21T09:41:03Z + , cardano-haskell-packages 2025-10-07T11:20:00Z packages: ouroboros-consensus @@ -56,6 +56,17 @@ allow-newer: , fin:QuickCheck , bin:QuickCheck +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network + tag: peras-staging/pr-5202 + --sha256: sha256-nTbjunQaqt6/syzSKw24Lne50083dI2SZFirG2/1T9U= + subdir: + ouroboros-network + ouroboros-network-protocols + ouroboros-network-api + ouroboros-network + source-repository-package type: git location: https://github.com/IntersectMBO/cardano-ledger diff --git a/docs/website/contents/howtos/benchmarks.md b/docs/website/contents/howtos/benchmarks.md new file mode 100644 index 0000000000..94ce7fc0c7 --- /dev/null +++ b/docs/website/contents/howtos/benchmarks.md @@ -0,0 +1,32 @@ +# Consensus benchmarks + +We are in the process of adding component level microbenchmarks for Consensus. + +We check for regressions in performance on CI. + +## Mempool Benchmark + +We started with microbenchmarks for adding transactions to the mempool. The +mempool benchmarks can be run using the following command. + +```sh +cabal new-run ouroboros-consensus:mempool-bench +``` + +## ChainSync Client Benchmark + +To aid the refactoring of the ChainSync client, we added a benchmark for it in [PR#823](https://github.com/IntersectMBO/ouroboros-consensus/pull/823). The benchmark could be invoked as follows: + +```sh +cabal new-run ouroboros-consensus:ChainSync-client-bench -- 10 10 +``` + +## PerasCertDB Benchmark + +We have a microbenchmark for the boosted chain fragment weight calculation, which could be run as follows: + +```sh +cabal run ouroboros-consensus:PerasCertDB-bench -- +RTS -T -A32m -RTS +``` + +We request GHC runtime system statistics with `-T` to get a memory usage estimate, and also request a large nursery with `-A32m` to minimise garbage collection. See `tasty-bench` [documentation](https://github.com/Bodigrim/tasty-bench?tab=readme-ov-file#troubleshooting) for more tips. diff --git a/docs/website/contents/references/glossary.md b/docs/website/contents/references/glossary.md index 3035ccae69..f547be3d1f 100644 --- a/docs/website/contents/references/glossary.md +++ b/docs/website/contents/references/glossary.md @@ -472,6 +472,19 @@ These kinds are maintained by the Networking layer: - [Public root peers](#public-root-peers). - [Shared peers](#shared-peers). +## ;Peras ;weight ;boost + +Peras is an extension of Praos enabling faster settlement under optimistic conditions. +To this end, Peras can result in a block `B` receiving a *boost*, which means that any chain containing `B` gets additional weight when being compared to other chains. + +Consider a chain fragment `F`: + +- Its ;*weight boost* is the sum of all boosts received by points on this fragment (excluding the anchor). Note that the same point can be boosted multiple times. + +- Its ;*total weight* is its tip block number plus its weight boost. + +Note that these notions are always relative to a particular anchor, so different chain fragments must have the same anchor when their total weight is to be compared. + ## ;Phases Byron, Shelley, Goguen (current one as of August 2023), Basho, Voltaire. diff --git a/flake.lock b/flake.lock index 70f4df31ec..3ced387e4d 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1755770112, - "narHash": "sha256-BE9+swBBPBi9iRQNqsUNUjS02nyRF+OwfCkhIjted6I=", + "lastModified": 1759837865, + "narHash": "sha256-g8SMcVN1v51Muz6a+xJkB92mPx1jsg+sjHKvQ3Wj/jY=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "7af503772adf627cd23be5431440a0ffae74de52", + "rev": "9a46cacd941c108492cd4cee5d29735e8cd8ee65", "type": "github" }, "original": { 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 f57756fe0f..c1b7ebbf39 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 @@ -333,6 +333,7 @@ byronEraParams genesis = , eraSlotLength = fromByronSlotLength $ genesisSlotLength genesis , eraSafeZone = HardFork.StandardSafeZone (2 * k) , eraGenesisWin = GenesisWindow (2 * k) + , eraPerasRoundLength = HardFork.NoPerasEnabled } where k = unNonZero $ maxRollbacks $ genesisSecurityParam genesis @@ -345,6 +346,7 @@ byronEraParamsNeverHardForks genesis = , eraSlotLength = fromByronSlotLength $ genesisSlotLength genesis , eraSafeZone = HardFork.UnsafeIndefiniteSafeZone , eraGenesisWin = GenesisWindow (2 * Gen.unBlockCount (Gen.configK genesis)) + , eraPerasRoundLength = HardFork.NoPerasEnabled } instance HasHardForkHistory ByronBlock where diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index 0edeb83eb6..e77eb7c114 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs @@ -432,6 +432,7 @@ instance Map.fromList $ [ (NodeToNodeV_14, CardanoNodeToNodeVersion2) , (NodeToNodeV_15, CardanoNodeToNodeVersion2) + , (NodeToNodeV_16, CardanoNodeToNodeVersion2) ] supportedNodeToClientVersions _ = diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index c096ab5d87..4dbc168cef 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -113,6 +113,7 @@ import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.HardFork.Combinator.PartialConfig import qualified Ouroboros.Consensus.HardFork.History as HardFork +import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (..)) import Ouroboros.Consensus.HardFork.History.Util import Ouroboros.Consensus.HardFork.Simple import Ouroboros.Consensus.HeaderValidation @@ -168,6 +169,8 @@ shelleyEraParams genesis = , eraSlotLength = mkSlotLength $ SL.fromNominalDiffTimeMicro $ SL.sgSlotLength genesis , eraSafeZone = HardFork.StandardSafeZone stabilityWindow , eraGenesisWin = GenesisWindow stabilityWindow + , -- TODO(geo2a): enabled Peras conditionally in the Dijkstra era + eraPerasRoundLength = HardFork.NoPerasEnabled } where stabilityWindow = @@ -183,6 +186,7 @@ shelleyEraParamsNeverHardForks genesis = , eraSlotLength = mkSlotLength $ SL.fromNominalDiffTimeMicro $ SL.sgSlotLength genesis , eraSafeZone = HardFork.UnsafeIndefiniteSafeZone , eraGenesisWin = GenesisWindow stabilityWindow + , eraPerasRoundLength = HardFork.NoPerasEnabled } where stabilityWindow = diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs index c03e0e5179..7003a5ce8a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs @@ -48,6 +48,7 @@ instance SupportedNetworkProtocolVersion (ShelleyBlock proto era) where Map.fromList [ (NodeToNodeV_14, ShelleyNodeToNodeVersion1) , (NodeToNodeV_15, ShelleyNodeToNodeVersion1) + , (NodeToNodeV_16, ShelleyNodeToNodeVersion1) ] supportedNodeToClientVersions _ = Map.fromList diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Generators.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Generators.hs index e613b0c0f3..66d077a344 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Generators.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Generators.hs @@ -993,11 +993,11 @@ instance Arbitrary History.EraEnd where ] instance Arbitrary History.EraSummary where - arbitrary = - History.EraSummary - <$> arbitrary - <*> arbitrary - <*> arbitrary + -- Note: this generator may produce EraSummary with nonsensical bounds, + -- i.e. with existing PerasRoundNo at era start and Nothing for it at the end. + -- However, we only use this generator to check that the serialisation roundtrips, + -- and the internal structure of EraSummary is irrelevant for that. + arbitrary = History.EraSummary <$> arbitrary <*> arbitrary <*> arbitrary instance (Arbitrary a, SListI xs) => Arbitrary (NonEmpty xs a) where arbitrary = do diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index 1ffccbe235..8f4159e77e 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -63,6 +63,7 @@ library Ouroboros.Consensus.Node.Exit Ouroboros.Consensus.Node.ExitPolicy Ouroboros.Consensus.Node.GSM + Ouroboros.Consensus.Node.GSM.PeerState Ouroboros.Consensus.Node.Genesis Ouroboros.Consensus.Node.Recovery Ouroboros.Consensus.Node.RethrowPolicy @@ -77,6 +78,7 @@ library build-depends: base >=4.14 && <4.22, bytestring >=0.10 && <0.13, + cardano-base, cardano-slotting, cborg ^>=0.2.2, containers >=0.5 && <0.8, @@ -96,8 +98,10 @@ library random, resource-registry ^>=0.1, safe-wild-cards ^>=1.0, + semialign, serialise ^>=0.2, text, + these, time, transformers, typed-protocols:{stateful, typed-protocols}, 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 85c4109a52..57956f5537 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 @@ -39,6 +39,7 @@ module Ouroboros.Consensus.Network.NodeToNode , initiatorAndResponder ) where +import Cardano.Base.FeatureFlags (CardanoFeatureFlag) import Codec.CBOR.Decoding (Decoder) import qualified Codec.CBOR.Decoding as CBOR import Codec.CBOR.Encoding (Encoding) @@ -54,6 +55,7 @@ import qualified Data.ByteString.Lazy as BSL import Data.Hashable (Hashable) import Data.Int (Int64) import Data.Map.Strict (Map) +import Data.Set (Set) import Data.Void (Void) import qualified Network.Mux as Mux import Network.TypedProtocol.Codec @@ -68,6 +70,14 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client ) import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CsClient import Ouroboros.Consensus.MiniProtocol.ChainSync.Server +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound (objectDiffusionInbound) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State + ( ObjectDiffusionInboundStateView + , bracketObjectDiffusionInbound + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound (objectDiffusionOutbound) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert import Ouroboros.Consensus.Node.ExitPolicy import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run @@ -81,10 +91,6 @@ import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Network.Block ( Serialised (..) - , decodePoint - , decodeTip - , encodePoint - , encodeTip ) import Ouroboros.Network.BlockFetch import Ouroboros.Network.BlockFetch.Client @@ -124,6 +130,18 @@ import Ouroboros.Network.Protocol.KeepAlive.Client import Ouroboros.Network.Protocol.KeepAlive.Codec import Ouroboros.Network.Protocol.KeepAlive.Server import Ouroboros.Network.Protocol.KeepAlive.Type +import Ouroboros.Network.Protocol.ObjectDiffusion.Codec + ( byteLimitsObjectDiffusion + , codecObjectDiffusion + , codecObjectDiffusionId + , timeLimitsObjectDiffusion + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound + ( objectDiffusionInboundPeerPipelined + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound + ( objectDiffusionOutboundPeer + ) import Ouroboros.Network.Protocol.PeerSharing.Client ( PeerSharingClient , peerSharingClientPeer @@ -197,6 +215,16 @@ data Handlers m addr blk = Handlers NodeToNodeVersion -> ConnectionId addr -> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m () + , hPerasCertDiffusionClient :: + NodeToNodeVersion -> + ControlMessageSTM m -> + ObjectDiffusionInboundStateView m -> + ConnectionId addr -> + PerasCertDiffusionInboundPipelined blk m () + , hPerasCertDiffusionServer :: + NodeToNodeVersion -> + ConnectionId addr -> + PerasCertDiffusionOutbound blk m () , hKeepAliveClient :: NodeToNodeVersion -> ControlMessageSTM m -> @@ -241,6 +269,7 @@ mkHandlers , keepAliveRng , miniProtocolParameters , getDiffusionPipeliningSupport + , systemTime } NodeKernel { getChainDB @@ -293,6 +322,23 @@ mkHandlers (mapTxSubmissionMempoolReader txForgetValidated $ getMempoolReader getMempool) (getMempoolWriter getMempool) version + , hPerasCertDiffusionClient = \version controlMessageSTM state peer -> + objectDiffusionInbound + (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionInboundTracer tracers)) + ( perasCertDiffusionMaxFifoLength miniProtocolParameters + , 10 -- TODO https://github.com/tweag/cardano-peras/issues/97 + , 10 -- TODO https://github.com/tweag/cardano-peras/issues/97 + ) + (makePerasCertPoolWriterFromChainDB systemTime getChainDB) + version + controlMessageSTM + state + , hPerasCertDiffusionServer = \version peer -> + objectDiffusionOutbound + (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionOutboundTracer tracers)) + (perasCertDiffusionMaxFifoLength miniProtocolParameters) + (makePerasCertPoolReaderFromChainDB $ getChainDB) + version , hKeepAliveClient = \_version -> keepAliveClient (Node.keepAliveClientTracer tracers) keepAliveRng , hKeepAliveServer = \_version _peer -> keepAliveServer , hPeerSharingClient = \_version controlMessageSTM _peer -> peerSharingClient controlMessageSTM @@ -304,7 +350,7 @@ mkHandlers -------------------------------------------------------------------------------} -- | Node-to-node protocol codecs needed to run 'Handlers'. -data Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS = Codecs +data Codecs blk addr e m bCS bSCS bBF bSBF bTX bPCD bKA bPS = Codecs { cChainSyncCodec :: Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS , cChainSyncCodecSerialised :: Codec (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bSCS @@ -312,6 +358,7 @@ data Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS = Codecs , cBlockFetchCodecSerialised :: Codec (BlockFetch (Serialised blk) (Point blk)) e m bSBF , cTxSubmission2Codec :: Codec (TxSubmission2 (GenTxId blk) (GenTx blk)) e m bTX + , cPerasCertDiffusionCodec :: Codec (PerasCertDiffusion blk) e m bPCD , cKeepAliveCodec :: Codec KeepAlive e m bKA , cPeerSharingCodec :: Codec (PeerSharing addr) e m bPS } @@ -339,49 +386,53 @@ defaultCodecs :: ByteString ByteString ByteString + ByteString defaultCodecs ccfg version encAddr decAddr nodeToNodeVersion = Codecs { cChainSyncCodec = codecChainSync enc dec - (encodePoint (encodeRawHash p)) - (decodePoint (decodeRawHash p)) - (encodeTip (encodeRawHash p)) - (decodeTip (decodeRawHash p)) + enc + dec + enc + dec , cChainSyncCodecSerialised = codecChainSync enc dec - (encodePoint (encodeRawHash p)) - (decodePoint (decodeRawHash p)) - (encodeTip (encodeRawHash p)) - (decodeTip (decodeRawHash p)) + enc + dec + enc + dec , cBlockFetchCodec = codecBlockFetch enc dec - (encodePoint (encodeRawHash p)) - (decodePoint (decodeRawHash p)) + enc + dec , cBlockFetchCodecSerialised = codecBlockFetch enc dec - (encodePoint (encodeRawHash p)) - (decodePoint (decodeRawHash p)) + enc + dec , cTxSubmission2Codec = codecTxSubmission2 enc dec enc dec + , cPerasCertDiffusionCodec = + codecObjectDiffusion + enc + dec + enc + dec , cKeepAliveCodec = codecKeepAlive_v2 , cPeerSharingCodec = codecPeerSharing (encAddr nodeToNodeVersion) (decAddr nodeToNodeVersion) } where - p :: Proxy blk - p = Proxy - enc :: SerialiseNodeToNode blk a => a -> Encoding enc = encodeNodeToNode ccfg version @@ -401,6 +452,7 @@ identityCodecs :: (AnyMessage (BlockFetch blk (Point blk))) (AnyMessage (BlockFetch (Serialised blk) (Point blk))) (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))) + (AnyMessage (PerasCertDiffusion blk)) (AnyMessage KeepAlive) (AnyMessage (PeerSharing addr)) identityCodecs = @@ -410,6 +462,7 @@ identityCodecs = , cBlockFetchCodec = codecBlockFetchId , cBlockFetchCodecSerialised = codecBlockFetchId , cTxSubmission2Codec = codecTxSubmission2Id + , cPerasCertDiffusionCodec = codecObjectDiffusionId , cKeepAliveCodec = codecKeepAliveId , cPeerSharingCodec = codecPeerSharingId } @@ -432,6 +485,7 @@ data Tracers' peer ntnAddr blk e f = Tracers f (TraceLabelPeer peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk)))) , tTxSubmission2Tracer :: f (TraceLabelPeer peer (TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk)))) + , tPerasCertDiffusionTracer :: f (TraceLabelPeer peer (TraceSendRecv (PerasCertDiffusion blk))) , tKeepAliveTracer :: f (TraceLabelPeer peer (TraceSendRecv KeepAlive)) , tPeerSharingTracer :: f (TraceLabelPeer peer (TraceSendRecv (PeerSharing ntnAddr))) } @@ -444,6 +498,7 @@ instance (forall a. Semigroup (f a)) => Semigroup (Tracers' peer ntnAddr blk e f , tBlockFetchTracer = f tBlockFetchTracer , tBlockFetchSerialisedTracer = f tBlockFetchSerialisedTracer , tTxSubmission2Tracer = f tTxSubmission2Tracer + , tPerasCertDiffusionTracer = f tPerasCertDiffusionTracer , tKeepAliveTracer = f tKeepAliveTracer , tPeerSharingTracer = f tPeerSharingTracer } @@ -464,6 +519,7 @@ nullTracers = , tBlockFetchTracer = nullTracer , tBlockFetchSerialisedTracer = nullTracer , tTxSubmission2Tracer = nullTracer + , tPerasCertDiffusionTracer = nullTracer , tKeepAliveTracer = nullTracer , tPeerSharingTracer = nullTracer } @@ -485,6 +541,7 @@ showTracers tr = , tBlockFetchTracer = showTracing tr , tBlockFetchSerialisedTracer = showTracing tr , tTxSubmission2Tracer = showTracing tr + , tPerasCertDiffusionTracer = showTracing tr , tKeepAliveTracer = showTracing tr , tPeerSharingTracer = showTracing tr } @@ -509,7 +566,7 @@ type ServerApp m addr bytes a = -- | Applications for the node-to-node protocols -- -- See 'Network.Mux.Types.MuxApplication' -data Apps m addr bCS bBF bTX bKA bPS a b = Apps +data Apps m addr bCS bBF bTX bPCD bKA bPS a b = Apps { aChainSyncClient :: ClientApp m addr bCS a -- ^ Start a chain sync client that communicates with the given upstream -- node. @@ -525,6 +582,10 @@ data Apps m addr bCS bBF bTX bKA bPS a b = Apps -- given upstream node. , aTxSubmission2Server :: ServerApp m addr bTX b -- ^ Start a transaction submission v2 server. + , aPerasCertDiffusionClient :: ClientApp m addr bPCD a + -- ^ Start a Peras cert diffusion client. + , aPerasCertDiffusionServer :: ServerApp m addr bPCD b + -- ^ Start a Peras cert diffusion server. , aKeepAliveClient :: ClientApp m addr bKA a -- ^ Start a keep-alive client. , aKeepAliveServer :: ServerApp m addr bKA b @@ -540,7 +601,7 @@ data Apps m addr bCS bBF bTX bKA bPS a b = Apps -- -- They don't depend on the instantiation of the protocol parameters (which -- block type is used, etc.), hence the use of 'RankNTypes'. -data ByteLimits bCS bBF bTX bKA = ByteLimits +data ByteLimits bCS bBF bTX bPCD bKA = ByteLimits { blChainSync :: forall header point tip. ProtocolSizeLimits @@ -556,27 +617,34 @@ data ByteLimits bCS bBF bTX bKA = ByteLimits ProtocolSizeLimits (TxSubmission2 txid tx) bTX + , blPerasCertDiffusion :: + forall blk. + ProtocolSizeLimits + (PerasCertDiffusion blk) + bPCD , blKeepAlive :: ProtocolSizeLimits KeepAlive bKA } -noByteLimits :: ByteLimits bCS bBF bTX bKA +noByteLimits :: ByteLimits bCS bBF bTX bPCD bKA noByteLimits = ByteLimits { blChainSync = byteLimitsChainSync (const 0) , blBlockFetch = byteLimitsBlockFetch (const 0) , blTxSubmission2 = byteLimitsTxSubmission2 (const 0) + , blPerasCertDiffusion = byteLimitsObjectDiffusion (const 0) , blKeepAlive = byteLimitsKeepAlive (const 0) } -byteLimits :: ByteLimits ByteString ByteString ByteString ByteString +byteLimits :: ByteLimits ByteString ByteString ByteString ByteString ByteString byteLimits = ByteLimits { blChainSync = byteLimitsChainSync size , blBlockFetch = byteLimitsBlockFetch size , blTxSubmission2 = byteLimitsTxSubmission2 size + , blPerasCertDiffusion = byteLimitsObjectDiffusion size , blKeepAlive = byteLimitsKeepAlive size } where @@ -587,7 +655,7 @@ byteLimits = -- | Construct the 'NetworkApplication' for the node-to-node protocols mkApps :: - forall m addrNTN addrNTC blk e bCS bBF bTX bKA bPS. + forall m addrNTN addrNTC blk e bCS bBF bTX bPCD bKA bPS. ( IOLike m , MonadTimer m , Ord addrNTN @@ -602,8 +670,8 @@ mkApps :: NodeKernel m addrNTN addrNTC blk -> StdGen -> Tracers m addrNTN blk e -> - (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bKA bPS) -> - ByteLimits bCS bBF bTX bKA -> + (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bPCD bKA bPS) -> + ByteLimits bCS bBF bTX bPCD bKA -> -- Chain-Sync timeouts for chain-sync client (using `Header blk`) as well as -- the server (`SerialisedHeader blk`). (forall header. ProtocolTimeLimitsWithRnd (ChainSync header (Point blk) (Tip blk))) -> @@ -611,7 +679,7 @@ mkApps :: CsClient.CSJConfig -> ReportPeerMetrics m (ConnectionId addrNTN) -> Handlers m addrNTN blk -> - Apps m addrNTN bCS bBF bTX bKA bPS NodeToNodeInitiatorResult () + Apps m addrNTN bCS bBF bTX bPCD bKA bPS NodeToNodeInitiatorResult () mkApps kernel rng Tracers{..} mkCodecs ByteLimits{..} chainSyncTimeouts lopBucketConfig csjConfig ReportPeerMetrics{..} Handlers{..} = Apps{..} where @@ -790,6 +858,56 @@ mkApps kernel rng Tracers{..} mkCodecs ByteLimits{..} chainSyncTimeouts lopBucke channel (txSubmissionServerPeerPipelined (hTxSubmissionServer version them)) + aPerasCertDiffusionClient :: + NodeToNodeVersion -> + ExpandedInitiatorContext addrNTN m -> + Channel m bPCD -> + m (NodeToNodeInitiatorResult, Maybe bPCD) + aPerasCertDiffusionClient + version + ExpandedInitiatorContext + { eicConnectionId = them + , eicControlMessage = controlMessageSTM + } + channel = do + labelThisThread "PerasCertDiffusionClient" + bracketObjectDiffusionInbound + version + (getPerasCertDiffusionHandles kernel) + them + $ \state -> do + ((), trailing) <- + runPipelinedPeerWithLimits + (TraceLabelPeer them `contramap` tPerasCertDiffusionTracer) + (cPerasCertDiffusionCodec (mkCodecs version)) + blPerasCertDiffusion + timeLimitsObjectDiffusion + channel + ( objectDiffusionInboundPeerPipelined + (hPerasCertDiffusionClient version controlMessageSTM state them) + ) + return (NoInitiatorResult, trailing) + + aPerasCertDiffusionServer :: + NodeToNodeVersion -> + ResponderContext addrNTN -> + Channel m bPCD -> + m ((), Maybe bPCD) + aPerasCertDiffusionServer + version + ResponderContext{rcConnectionId = them} + channel = do + labelThisThread "PerasCertDiffusionServer" + runPeerWithLimits + (TraceLabelPeer them `contramap` tPerasCertDiffusionTracer) + (cPerasCertDiffusionCodec (mkCodecs version)) + blPerasCertDiffusion + timeLimitsObjectDiffusion + channel + ( objectDiffusionOutboundPeer + (hPerasCertDiffusionServer version them) + ) + aKeepAliveClient :: NodeToNodeVersion -> ExpandedInitiatorContext addrNTN m -> @@ -890,13 +1008,15 @@ mkApps kernel rng Tracers{..} mkCodecs ByteLimits{..} chainSyncTimeouts lopBucke -- on the protocol version, but it eventually may; this is why @_version@ is -- currently unused. initiator :: + Set CardanoFeatureFlag -> MiniProtocolParameters -> NodeToNodeVersion -> NodeToNodeVersionData -> - Apps m addr b b b b b a c -> + Apps m addr b b b b b b a c -> OuroborosBundleWithExpandedCtx 'Mux.InitiatorMode addr b m a Void -initiator miniProtocolParameters version versionData Apps{..} = +initiator featureFlags miniProtocolParameters version versionData Apps{..} = nodeToNodeProtocols + featureFlags miniProtocolParameters -- TODO: currently consensus is using 'ConnectionId' for its 'peer' type. -- This is currently ok, as we might accept multiple connections from the @@ -911,6 +1031,10 @@ initiator miniProtocolParameters version versionData Apps{..} = (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aBlockFetchClient version ctx))) , txSubmissionProtocol = (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aTxSubmission2Client version ctx))) + , perasCertDiffusionProtocol = + (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aPerasCertDiffusionClient version ctx))) + , perasVoteDiffusionProtocol = + error "perasVoteDiffusionProtocol: not implemented" , keepAliveProtocol = (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aKeepAliveClient version ctx))) , peerSharingProtocol = @@ -926,13 +1050,15 @@ initiator miniProtocolParameters version versionData Apps{..} = -- on the protocol version, but it eventually may; this is why @_version@ is -- currently unused. initiatorAndResponder :: + Set CardanoFeatureFlag -> MiniProtocolParameters -> NodeToNodeVersion -> NodeToNodeVersionData -> - Apps m addr b b b b b a c -> + Apps m addr b b b b b b a c -> OuroborosBundleWithExpandedCtx 'Mux.InitiatorResponderMode addr b m a c -initiatorAndResponder miniProtocolParameters version versionData Apps{..} = +initiatorAndResponder featureFlags miniProtocolParameters version versionData Apps{..} = nodeToNodeProtocols + featureFlags miniProtocolParameters ( NodeToNodeProtocols { chainSyncProtocol = @@ -950,6 +1076,13 @@ initiatorAndResponder miniProtocolParameters version versionData Apps{..} = (MiniProtocolCb (\initiatorCtx -> aTxSubmission2Client version initiatorCtx)) (MiniProtocolCb (\responderCtx -> aTxSubmission2Server version responderCtx)) ) + , perasCertDiffusionProtocol = + ( InitiatorAndResponderProtocol + (MiniProtocolCb (\initiatorCtx -> aPerasCertDiffusionClient version initiatorCtx)) + (MiniProtocolCb (\responderCtx -> aPerasCertDiffusionServer version responderCtx)) + ) + , perasVoteDiffusionProtocol = + error "perasVoteDiffusionProtocol: not implemented" , keepAliveProtocol = ( InitiatorAndResponderProtocol (MiniProtocolCb (\initiatorCtx -> aKeepAliveClient version initiatorCtx)) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index 7c0535c1bd..a868b6724a 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs @@ -60,6 +60,7 @@ module Ouroboros.Consensus.Node , openChainDB ) where +import Cardano.Base.FeatureFlags (CardanoFeatureFlag) import qualified Cardano.Network.Diffusion as Cardano.Diffusion import Cardano.Network.Diffusion.Configuration (ChainSyncIdleTimeout (..)) import qualified Cardano.Network.Diffusion.Policies as Cardano.Diffusion @@ -84,6 +85,7 @@ import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isNothing) +import Data.Set (Set) import Data.Time (NominalDiffTime) import Data.Typeable (Typeable) import Ouroboros.Consensus.Block @@ -232,6 +234,8 @@ data RunNodeArgs m addrNTN addrNTC blk = RunNodeArgs -- ^ Network PeerSharing miniprotocol willingness flag , rnGetUseBootstrapPeers :: STM m UseBootstrapPeers , rnGenesisConfig :: GenesisConfig + , rnFeatureFlags :: Set CardanoFeatureFlag + -- ^ Enabled experimental features } -- | Arguments that usually only tests /directly/ specify. @@ -319,6 +323,8 @@ data LowLevelRunNodeArgs m addrNTN addrNTC blk , llrnPublicPeerSelectionStateVar :: StrictSTM.StrictTVar m (PublicPeerSelectionState addrNTN) , llrnLdbFlavorArgs :: Complete LedgerDbFlavorArgs m -- ^ The flavor arguments + , llrnFeatureFlags :: Set CardanoFeatureFlag + -- ^ Enabled experimental features } data NodeDatabasePaths @@ -570,8 +576,10 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = gsmAntiThunderingHerd keepAliveRng cfg + llrnFeatureFlags rnTraceConsensus btime + systemTime (InFutureCheck.realHeaderInFutureCheck llrnMaxClockSkew systemTime) historicityCheck chainDB @@ -649,6 +657,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = ByteString ByteString ByteString + ByteString NodeToNodeInitiatorResult () mkNodeToNodeApps nodeKernelArgs nodeKernel peerMetrics encAddrNTN decAddrNTN version = @@ -690,6 +699,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = ByteString ByteString ByteString + ByteString NodeToNodeInitiatorResult () ) -> @@ -731,7 +741,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = version llrnVersionDataNTN ( \versionData -> - NTN.initiator miniProtocolParams version versionData + NTN.initiator llrnFeatureFlags miniProtocolParams version versionData -- Initiator side won't start responder side of Peer -- Sharing protocol so we give a dummy implementation -- here. @@ -746,7 +756,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = version llrnVersionDataNTN ( \versionData -> - NTN.initiatorAndResponder miniProtocolParams version versionData $ + NTN.initiatorAndResponder llrnFeatureFlags miniProtocolParams version versionData $ ntnApps blockVersion ) | (version, blockVersion) <- Map.toList llrnNodeToNodeVersions @@ -845,8 +855,10 @@ mkNodeKernelArgs :: StdGen -> StdGen -> TopLevelConfig blk -> + Set CardanoFeatureFlag -> Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk -> BlockchainTime m -> + SystemTime m -> InFutureCheck.SomeHeaderInFutureCheck m blk -> (m GSM.GsmState -> HistoricityCheck m blk) -> ChainDB m blk -> @@ -864,8 +876,10 @@ mkNodeKernelArgs gsmAntiThunderingHerd rng cfg + featureFlags tracers btime + systemTime chainSyncFutureCheck chainSyncHistoricityCheck chainDB @@ -883,7 +897,9 @@ mkNodeKernelArgs { tracers , registry , cfg + , featureFlags , btime + , systemTime , chainDB , initChainDB = nodeInitChainDB , chainSyncFutureCheck @@ -1001,6 +1017,7 @@ stdLowLevelRunNodeArgsIO { rnProtocolInfo , rnPeerSharing , rnGenesisConfig + , rnFeatureFlags } $(SafeWildCards.fields 'StdRunNodeArgs) = do llrnBfcSalt <- stdBfcSaltIO @@ -1051,6 +1068,8 @@ stdLowLevelRunNodeArgsIO Diffusion.dcPublicPeerSelectionVar srnDiffusionConfiguration , llrnLdbFlavorArgs = srnLdbFlavorArgs + , llrnFeatureFlags = + rnFeatureFlags } where networkMagic :: NetworkMagic diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs index aa9733d360..6608ade58c 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs @@ -56,8 +56,6 @@ import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry import qualified Ouroboros.Consensus.Ledger.Basics as L import Ouroboros.Consensus.Node.GsmState import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) -import Ouroboros.Consensus.Util.NormalForm.StrictTVar (StrictTVar) -import qualified Ouroboros.Consensus.Util.NormalForm.StrictTVar as StrictSTM import System.FS.API ( HasFS , createDirectoryIfMissing @@ -97,18 +95,24 @@ data CandidateVersusSelection WhetherCandidateIsBetter !Bool deriving (Eq, Show) -data GsmView m upstreamPeer selection chainSyncState = GsmView +data GsmView m upstreamPeer selection peerState = GsmView { antiThunderingHerd :: Maybe StdGen -- ^ An initial seed used to randomly increase 'minCaughtUpDuration' by up -- to 15% every transition from Syncing to CaughtUp, in order to avoid a -- thundering herd phenomenon. -- -- 'Nothing' should only be used for testing. - , candidateOverSelection :: - selection -> - chainSyncState -> - CandidateVersusSelection - , peerIsIdle :: chainSyncState -> Bool + , getCandidateOverSelection :: + STM + m + ( selection -> + peerState -> + CandidateVersusSelection + ) + -- ^ Whether the candidate from the @chainSyncState@ is preferable to the + -- selection. This can depend on external state (Peras certificates boosting + -- blocks). + , peerIsIdle :: peerState -> Bool , durationUntilTooOld :: Maybe (selection -> m DurationFromNow) -- ^ How long from now until the selection will be so old that the node -- should exit the @CaughtUp@ state @@ -117,10 +121,8 @@ data GsmView m upstreamPeer selection chainSyncState = GsmView , equivalent :: selection -> selection -> Bool -- ^ Whether the two selections are equivalent for the purpose of the -- Genesis State Machine - , getChainSyncStates :: - STM m (Map.Map upstreamPeer (StrictTVar m chainSyncState)) - -- ^ The current ChainSync state with the latest candidates from the - -- upstream peers + , getPeerStates :: STM m (Map.Map upstreamPeer peerState) + -- ^ The current peer state with the latest candidates from the upstream peers , getCurrentSelection :: STM m selection -- ^ The node's current selection , minCaughtUpDuration :: NominalDiffTime @@ -234,11 +236,11 @@ realGsmEntryPoints tracerArgs gsmView = GsmView { antiThunderingHerd - , candidateOverSelection + , getCandidateOverSelection , peerIsIdle , durationUntilTooOld , equivalent - , getChainSyncStates + , getPeerStates , getCurrentSelection , minCaughtUpDuration , setCaughtUpPersistentMark @@ -364,12 +366,13 @@ realGsmEntryPoints tracerArgs gsmView = blockUntilCaughtUp :: STM m (TraceGsmEvent tracedSelection) blockUntilCaughtUp = do - -- STAGE 1: all ChainSync clients report no subsequent headers - varsState <- getChainSyncStates - states <- traverse StrictSTM.readTVar varsState + -- STAGE 1: all peers are idle, which means that + -- * all ChainSync clients report no subsequent headers, and + -- * all PerasCertDiffusion clients report no subsequent certificates + peerStates <- getPeerStates check $ - not (Map.null states) - && all peerIsIdle states + not (Map.null peerStates) + && all peerIsIdle peerStates -- STAGE 2: no candidate is better than the node's current -- selection @@ -382,15 +385,15 @@ realGsmEntryPoints tracerArgs gsmView = -- block; general Praos reasoning ensures that won't take particularly -- long. selection <- getCurrentSelection - candidates <- traverse StrictSTM.readTVar varsState + candidateOverSelection <- getCandidateOverSelection let ok candidate = WhetherCandidateIsBetter False == candidateOverSelection selection candidate - check $ all ok candidates + check $ all ok peerStates pure $ GsmEventEnterCaughtUp - (Map.size states) + (Map.size peerStates) (cnvSelection selection) -- STAGE 3: the previous stages weren't so slow that the idler diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM/PeerState.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM/PeerState.hs new file mode 100644 index 0000000000..defc3abe33 --- /dev/null +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM/PeerState.hs @@ -0,0 +1,78 @@ +module Ouroboros.Consensus.Node.GSM.PeerState + ( GsmPeerState (..) + , maybeChainSyncState + , maybePerasCertDiffusionState + , mkGsmPeerStates + , gsmPeerIsIdle + ) +where + +import Cardano.Base.FeatureFlags (CardanoFeatureFlag (..)) +import Data.Align (Semialign (..)) +import Data.Map.Strict (Map) +import Data.Set (Set) +import Data.These (These (..)) +import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State + ( ChainSyncClientHandle (..) + , ChainSyncClientHandleCollection (..) + , ChainSyncState (..) + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State + ( ObjectDiffusionInboundHandle (..) + , ObjectDiffusionInboundHandleCollection (..) + , ObjectDiffusionInboundState (..) + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert (PerasCertDiffusionInboundState) +import Ouroboros.Consensus.Util.IOLike (MonadSTM (..), readTVar) +import Ouroboros.Network.NodeToNode.Version (isPerasEnabled) + +-- | State about peers we are connected to during initialization. +newtype GsmPeerState blk = GsmPeerState + { unGsmPeerState :: + These + (ChainSyncState blk) + (PerasCertDiffusionInboundState blk) + } + +-- | Retrieve the 'ChainSync' state of this peer, if such a connection is established. +maybeChainSyncState :: GsmPeerState blk -> Maybe (ChainSyncState blk) +maybeChainSyncState (GsmPeerState these) = + case these of + This csState -> Just csState + That _ -> Nothing + These csState _ -> Just csState + +-- | Retrieve the 'PerasCertDiffusion' state of this peer, if such a connection is established. +maybePerasCertDiffusionState :: GsmPeerState blk -> Maybe (PerasCertDiffusionInboundState blk) +maybePerasCertDiffusionState (GsmPeerState these) = + case these of + This _ -> Nothing + That pcdState -> Just pcdState + These _ pcdState -> Just pcdState + +-- | Construct a 'GsmPeerState' for all peers we are connected to. +mkGsmPeerStates :: + (Ord peer, MonadSTM m) => + ChainSyncClientHandleCollection peer m blk -> + ObjectDiffusionInboundHandleCollection peer m blk -> + STM m (Map peer (GsmPeerState blk)) +mkGsmPeerStates csHandles pcdHandles = do + csPeerStates <- traverse (readTVar . cschState) =<< cschcMap csHandles + pcdPeerStates <- traverse (readTVar . odihState) =<< odihcMap pcdHandles + pure (GsmPeerState <$> align csPeerStates pcdPeerStates) + +-- | Determine whether our connections to this peer are idle. +gsmPeerIsIdle :: Set CardanoFeatureFlag -> GsmPeerState blk -> Bool +gsmPeerIsIdle featureFlags (GsmPeerState these) = + case these of + -- We have both ChainSync and PerasCertDiffusion connections => idle if both are idling + These csState pcdState -> csIdling csState && odisIdling pcdState + -- Only a ChainSync connection is available => idle if the ChainSync connection is idling + This csState | not (perasIsEnabled csState) -> csIdling csState + -- We will soon establish a PerasCertDiffusion connection => not idling + This _ -> False + -- We will soon establish a ChainSync connection => not idling + That _ -> False + where + -- Is the Peras feature flag enabled and the peer is compatible with it? + perasIsEnabled csState = isPerasEnabled featureFlags (csNodeToNodeVersion csState) 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 24b82c331d..7cee89fa52 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 @@ -42,6 +42,7 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Server import Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server ( TraceLocalTxSubmissionServerEvent (..) ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert import Ouroboros.Consensus.Node.GSM (TraceGsmEvent) import Ouroboros.Network.Block (Tip) import Ouroboros.Network.BlockFetch @@ -87,6 +88,10 @@ data Tracers' remotePeer localPeer blk f = Tracers , csjTracer :: f (TraceLabelPeer remotePeer (CSJumping.TraceEventCsj remotePeer blk)) , dbfTracer :: f (CSJumping.TraceEventDbf remotePeer) + , perasCertDiffusionInboundTracer :: + f (TraceLabelPeer remotePeer (TracePerasCertDiffusionInbound blk)) + , perasCertDiffusionOutboundTracer :: + f (TraceLabelPeer remotePeer (TracePerasCertDiffusionOutbound blk)) } instance @@ -115,6 +120,8 @@ instance , gddTracer = f gddTracer , csjTracer = f csjTracer , dbfTracer = f dbfTracer + , perasCertDiffusionInboundTracer = f perasCertDiffusionInboundTracer + , perasCertDiffusionOutboundTracer = f perasCertDiffusionOutboundTracer } where f :: @@ -151,6 +158,8 @@ nullTracers = , gddTracer = nullTracer , csjTracer = nullTracer , dbfTracer = nullTracer + , perasCertDiffusionInboundTracer = nullTracer + , perasCertDiffusionOutboundTracer = nullTracer } showTracers :: @@ -189,6 +198,8 @@ showTracers tr = , gddTracer = showTracing tr , csjTracer = showTracing tr , dbfTracer = showTracing tr + , perasCertDiffusionInboundTracer = showTracing tr + , perasCertDiffusionOutboundTracer = showTracing tr } {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index b9c53da498..29533108c6 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -27,6 +27,7 @@ module Ouroboros.Consensus.NodeKernel , toConsensusMode ) where +import Cardano.Base.FeatureFlags (CardanoFeatureFlag (..)) import Cardano.Network.ConsensusMode (ConsensusMode (..)) import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers) import Cardano.Network.PeerSelection.LocalRootPeers @@ -49,8 +50,9 @@ import Data.Functor ((<&>)) import Data.Hashable (Hashable) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Maybe (isJust, mapMaybe) +import Data.Maybe (isJust, isNothing, mapMaybe) import Data.Proxy +import Data.Set (Set) import qualified Data.Text as Text import Data.Void (Void) import Ouroboros.Consensus.Block hiding (blockMatchesHeader) @@ -80,8 +82,16 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck ( SomeHeaderInFutureCheck ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State + ( ObjectDiffusionInboundHandleCollection (..) + , newObjectDiffusionInboundHandleCollection + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert + ( PerasCertDiffusionInboundHandleCollection + ) import Ouroboros.Consensus.Node.GSM (GsmNodeKernelArgs (..)) import qualified Ouroboros.Consensus.Node.GSM as GSM +import Ouroboros.Consensus.Node.GSM.PeerState (gsmPeerIsIdle, maybeChainSyncState, mkGsmPeerStates) import Ouroboros.Consensus.Node.Genesis ( GenesisNodeKernelArgs (..) , LoEAndGDDConfig (..) @@ -173,6 +183,9 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel -- from it with 'GSM.gsmStateToLedgerJudgement'. , getChainSyncHandles :: ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk -- ^ The kill handle and exposed state for each ChainSync client. + , getPerasCertDiffusionHandles :: + ObjectDiffusionInboundHandleCollection (ConnectionId addrNTN) m blk + -- ^ The exposed state for each Peras CertDiffusion client. , getPeerSharingRegistry :: PeerSharingRegistry addrNTN m -- ^ Read the current peer sharing registry, used for interacting with -- the PeerSharing protocol @@ -195,7 +208,9 @@ data NodeKernelArgs m addrNTN addrNTC blk = NodeKernelArgs { tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk , registry :: ResourceRegistry m , cfg :: TopLevelConfig blk + , featureFlags :: Set CardanoFeatureFlag , btime :: BlockchainTime m + , systemTime :: SystemTime m , chainDB :: ChainDB m blk , initChainDB :: StorageConfig blk -> InitChainDB m blk -> m () , chainSyncFutureCheck :: SomeHeaderInFutureCheck m blk @@ -232,6 +247,7 @@ initNodeKernel args@NodeKernelArgs { registry , cfg + , featureFlags , tracers , chainDB , initChainDB @@ -254,6 +270,7 @@ initNodeKernel , mempool , peerSharingRegistry , varChainSyncHandles + , varPerasCertDiffusionHandles , varGsmState } = st @@ -271,22 +288,35 @@ initNodeKernel gsmTracerArgs GSM.GsmView { GSM.antiThunderingHerd = Just gsmAntiThunderingHerd - , GSM.candidateOverSelection = \(headers, _lst) state -> - case AF.intersectionPoint headers (csCandidate state) of - Nothing -> GSM.CandidateDoesNotIntersect - Just{} -> - GSM.WhetherCandidateIsBetter $ -- precondition requires intersection - preferAnchoredCandidate - (configBlock cfg) - headers - (csCandidate state) - , GSM.peerIsIdle = csIdling + , GSM.getCandidateOverSelection = do + weights <- forgetFingerprint <$> ChainDB.getPerasWeightSnapshot chainDB + pure $ \(headers, _lst) peerState -> do + case csCandidate <$> maybeChainSyncState peerState of + Just candidate + -- The candidate does not intersect with our current chain. + -- This is a precondition for 'WhetherCandidateIsBetter'. + | isNothing (AF.intersectionPoint headers candidate) -> + GSM.CandidateDoesNotIntersect + -- The candidate is better than our current chain. + | preferAnchoredCandidate (configBlock cfg) weights headers candidate -> + GSM.WhetherCandidateIsBetter True + -- The candidate is not better than our current chain. + | otherwise -> + GSM.WhetherCandidateIsBetter False + Nothing -> + -- We don't have an established ChainSync connection with this peer. + -- We conservatively assume that its candidate is not better than ours. + GSM.WhetherCandidateIsBetter False + , GSM.peerIsIdle = gsmPeerIsIdle featureFlags , GSM.durationUntilTooOld = gsmDurationUntilTooOld <&> \wd (_headers, lst) -> GSM.getDurationUntilTooOld wd (getTipSlot lst) , GSM.equivalent = (==) `on` (AF.headPoint . fst) - , GSM.getChainSyncStates = fmap cschState <$> cschcMap varChainSyncHandles + , GSM.getPeerStates = + mkGsmPeerStates + varChainSyncHandles + varPerasCertDiffusionHandles , GSM.getCurrentSelection = do headers <- ChainDB.getCurrentChainWithTime chainDB extLedgerState <- ChainDB.getCurrentLedger chainDB @@ -363,6 +393,7 @@ initNodeKernel , getFetchMode = readFetchMode blockFetchInterface , getGsmState = readTVar varGsmState , getChainSyncHandles = varChainSyncHandles + , getPerasCertDiffusionHandles = varPerasCertDiffusionHandles , getPeerSharingRegistry = peerSharingRegistry , getTracers = tracers , setBlockForging = \a -> atomically . LazySTM.putTMVar blockForgingVar $! a @@ -413,6 +444,8 @@ data InternalState m addrNTN addrNTC blk = IS BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk m , fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk m , varChainSyncHandles :: ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk + , varPerasCertDiffusionHandles :: + PerasCertDiffusionInboundHandleCollection (ConnectionId addrNTN) m blk , varGsmState :: StrictTVar m GSM.GsmState , mempool :: Mempool m blk , peerSharingRegistry :: PeerSharingRegistry addrNTN m @@ -451,6 +484,8 @@ initInternalState newTVarIO gsmState varChainSyncHandles <- atomically newChainSyncClientHandleCollection + varPerasCertDiffusionHandles <- atomically newObjectDiffusionInboundHandleCollection + mempool <- openMempool registry 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 d34e717e76..937f705109 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 @@ -83,6 +83,7 @@ import Ouroboros.Consensus.Mempool import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert (PerasCertDiffusion) import qualified Ouroboros.Consensus.Network.NodeToNode as NTN import Ouroboros.Consensus.Node.ExitPolicy import qualified Ouroboros.Consensus.Node.GSM as GSM @@ -123,8 +124,8 @@ import Ouroboros.Network.NodeToNode ( ConnectionId (..) , ExpandedInitiatorContext (..) , IsBigLedgerPeer (..) - , MiniProtocolParameters (..) , ResponderContext (..) + , defaultMiniProtocolParameters ) import Ouroboros.Network.PeerSelection.Governor ( makePublicPeerSelectionStateVar @@ -1044,7 +1045,9 @@ runThreadNetwork { tracers , registry , cfg = pInfoConfig + , featureFlags = mempty , btime + , systemTime , chainDB , initChainDB = nodeInitChainDB , chainSyncFutureCheck = @@ -1056,13 +1059,7 @@ runThreadNetwork , mempoolCapacityOverride = NoMempoolCapacityBytesOverride , keepAliveRng = kaRng , peerSharingRng = psRng - , miniProtocolParameters = - MiniProtocolParameters - { chainSyncPipeliningHighMark = 4 - , chainSyncPipeliningLowMark = 2 - , blockFetchPipeliningMax = 10 - , txSubmissionMaxUnacked = 1000 -- TODO ? - } + , miniProtocolParameters = defaultMiniProtocolParameters , blockFetchConfiguration = BlockFetchConfiguration { bfcMaxConcurrencyBulkSync = 1 @@ -1186,6 +1183,7 @@ runThreadNetwork Lazy.ByteString Lazy.ByteString (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))) + (AnyMessage (PerasCertDiffusion blk)) (AnyMessage KeepAlive) (AnyMessage (PeerSharing NodeId)) customNodeToNodeCodecs cfg ntnVersion = @@ -1205,6 +1203,9 @@ runThreadNetwork , cTxSubmission2Codec = mapFailureCodec CodecIdFailure $ NTN.cTxSubmission2Codec NTN.identityCodecs + , cPerasCertDiffusionCodec = + mapFailureCodec CodecIdFailure $ + NTN.cPerasCertDiffusionCodec NTN.identityCodecs , cKeepAliveCodec = mapFailureCodec CodecIdFailure $ NTN.cKeepAliveCodec NTN.identityCodecs @@ -1795,6 +1796,7 @@ type LimitedApp' m addr blk = Lazy.ByteString Lazy.ByteString (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))) + (AnyMessage (PerasCertDiffusion blk)) (AnyMessage KeepAlive) (AnyMessage (PeerSharing addr)) NodeToNodeInitiatorResult diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs index 4f223c42e1..8941958814 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs @@ -137,11 +137,12 @@ setupGsm isHaaSatisfied vars = do (id, tracer) GSM.GsmView { GSM.antiThunderingHerd = Nothing - , GSM.candidateOverSelection = \s (PeerState c _) -> candidateOverSelection s c + , GSM.getCandidateOverSelection = pure $ \s (PeerState c _) -> + candidateOverSelection s c , GSM.peerIsIdle = isIdling , GSM.durationUntilTooOld = Just durationUntilTooOld , GSM.equivalent = (==) -- unsound, but harmless in this test - , GSM.getChainSyncStates = readTVar varStates + , GSM.getPeerStates = traverse readTVar =<< readTVar varStates , GSM.getCurrentSelection = readTVar varSelection , GSM.minCaughtUpDuration = thrashLimit , GSM.setCaughtUpPersistentMark = \b -> diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs index bacebe644f..eeb39af6f7 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs @@ -192,6 +192,7 @@ prop_densityDisconnectStatic = { csCandidate = frag , csLatestSlot = SJust (AF.headSlot frag) , csIdling = False + , csNodeToNodeVersion = maxBound } gen = do gt <- genChains (QC.choose (1, 4)) @@ -431,6 +432,7 @@ evolveBranches EvolvingPeers{k, sgen, peers = initialPeers, fullTree} = { csCandidate = attachTimeUsingTestConfig csCandidate , csIdling = False , csLatestSlot = SJust (AF.headSlot csCandidate) + , csNodeToNodeVersion = maxBound } -- Run GDD. (loeFrag, suffixes) = diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs index fe7383c0f4..e87ca885ec 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs @@ -58,6 +58,7 @@ import qualified Ouroboros.Consensus.Node.GSM as GSM import Ouroboros.Consensus.Node.Genesis (setGetLoEFragment) import Ouroboros.Consensus.Node.GsmState import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Peras.Weight (emptyPerasWeightSnapshot) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as Punishment @@ -141,16 +142,15 @@ run = withRegistry \registry -> do -- Then, send C. atomically $ modifyTVar (cschState hdl) $ \s -> - ChainSyncState + s { csCandidate = csCandidate s AF.:> attachSlotTime cfg (getHeader blkC) , csLatestSlot = pure $ NotOrigin $ blockSlot blkC - , csIdling = csIdling s } addBlk blkC -- Finally, roll back to the initial fragment and idle. - atomically $ modifyTVar (cschState hdl) $ \_s -> - ChainSyncState + atomically $ modifyTVar (cschState hdl) $ \s -> + s { csCandidate = initialFrag , csLatestSlot = pure $ AF.headSlot initialFrag , csIdling = True @@ -168,7 +168,7 @@ run = withRegistry \registry -> do -- Finally, idle. atomically $ modifyTVar (cschState hdl) $ \s -> - ChainSyncState + s { csCandidate = csCandidate s , csLatestSlot = csLatestSlot s , csIdling = True @@ -222,6 +222,7 @@ mkTestChainSyncClientHandle frag = do { csCandidate = frag , csIdling = False , csLatestSlot = pure $ AF.headSlot frag + , csNodeToNodeVersion = maxBound } varJumping <- newTVar $ Disengaged DisengagedDone varJumpInfo <- newTVar Nothing @@ -279,10 +280,10 @@ mkGsmEntryPoints varChainSyncHandles chainDB writeGsmState = GSM.realGsmEntryPoints (id, nullTracer) GSM.GsmView - { GSM.candidateOverSelection + { GSM.getCandidateOverSelection = pure candidateOverSelection , GSM.peerIsIdle = csIdling , GSM.equivalent = (==) `on` AF.headPoint - , GSM.getChainSyncStates = fmap cschState <$> cschcMap varChainSyncHandles + , GSM.getPeerStates = traverse readTVar =<< fmap cschState <$> cschcMap varChainSyncHandles , GSM.getCurrentSelection = ChainDB.getCurrentChain chainDB , -- Make sure that we stay in CaughtUp for the duration of the test once we -- have entered it. @@ -301,10 +302,13 @@ mkGsmEntryPoints varChainSyncHandles chainDB writeGsmState = Just{} -> -- precondition requires intersection GSM.WhetherCandidateIsBetter $ - preferAnchoredCandidate (configBlock cfg) selection candFrag + preferAnchoredCandidate (configBlock cfg) weights selection candFrag where candFrag = csCandidate candidateState + -- TODO https://github.com/tweag/cardano-peras/issues/67 + weights = emptyPerasWeightSnapshot + forkGDD :: forall m. IOLike m => diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs index 549de0f352..5821c0a534 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs @@ -164,6 +164,7 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = (History.StandardSafeZone (safeFromTipA k)) (safeZoneB k) <*> pure (GenesisWindow ((unNonZero $ maxRollbacks k) * 2)) + <*> pure (History.PerasEnabled defaultPerasRoundLength) shape :: History.Shape '[BlockA, BlockB] shape = History.Shape $ exactlyTwo eraParamsA eraParamsB diff --git a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs index 3f82ec83e3..80b1eff97d 100644 --- a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs +++ b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs @@ -103,6 +103,7 @@ prop_simple_bft_convergence , version = newestVersion (Proxy @MockBftBlock) } + testOutput :: TestOutput MockBftBlock testOutput = runTestNetwork testConfig diff --git a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs index 70854581a8..9d983608d2 100644 --- a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs +++ b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs @@ -37,6 +37,7 @@ import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck import Ouroboros.Consensus.MiniProtocol.ChainSync.Server ( chainSyncServerForFollower ) +import qualified Ouroboros.Consensus.MiniProtocol.Util.Idling as Idling import Ouroboros.Consensus.Node.NetworkProtocolVersion ( NodeToNodeVersion ) @@ -158,7 +159,7 @@ oneBenchRun , CSClient.headerMetricsTracer = nullTracer , CSClient.setCandidate = writeTVar varCandidate , CSClient.setLatestSlot = \_ -> pure () - , CSClient.idling = CSClient.noIdling + , CSClient.idling = Idling.noIdling , CSClient.loPBucket = CSClient.noLoPBucket , CSClient.jumping = CSClient.noJumping } diff --git a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs new file mode 100644 index 0000000000..40642021d4 --- /dev/null +++ b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} + +-- | This module contains benchmarks for Peras chain weight calculation as +-- implemented by the by the +-- 'Ouroboros.Consensus.Peras.Weight.weightBoostOfFragment' function. +-- +-- We benchmark the calculation on a static sequence of chain fragments of increasing +-- length, ranging from 0 to around 8640, with a sampling rate of 100. The chain fragments +-- are instantiated with 'TestBlock', and every 5 blocks there is a booster block with +-- weight 15. All parameters are set in 'benchmarkParams'. +module Main (main) where + +import Data.List (iterate') +import Numeric.Natural (Natural) +import Ouroboros.Consensus.Block (PerasWeight (PerasWeight), SlotNo (..)) +import Ouroboros.Consensus.Peras.Weight + ( PerasWeightSnapshot + , mkPerasWeightSnapshot + , weightBoostOfFragment + ) +import Ouroboros.Network.AnchoredFragment qualified as AF +import Test.Ouroboros.Storage.TestBlock (TestBlock (..), TestBody (..), TestHeader (..)) +import Test.Ouroboros.Storage.TestBlock qualified as TestBlock +import Test.Tasty.Bench + +data BenchmarkParams = BenchmarkParams + { blockRate :: SlotNo + -- ^ How often the fragments will contain blocks, in slots + , fragmentLenghtSamplingRate :: Natural + -- ^ The rate of length increase for generate chain fragments + , fragmentMaxLenght :: Natural + -- ^ the maximum length of a fragment + , boostedBlockRate :: Natural + -- ^ How often boosted blocks occur, in blocks + , boostWeight :: PerasWeight + -- ^ The weight of the boost + } + +benchmarkParams :: BenchmarkParams +benchmarkParams = + BenchmarkParams + { blockRate = 20 + , fragmentLenghtSamplingRate = 100 + , fragmentMaxLenght = 2160 + 3 * 2160 + , boostedBlockRate = 5 + , boostWeight = PerasWeight 15 + } + +main :: IO () +main = + Test.Tasty.Bench.defaultMain $ map benchWeightBoostOfFragment inputs + where + -- NOTE: we do not use the 'env' combinator to set up the test data since + -- it requires 'NFData' for 'AF.AnchoredFragment'. While the necessary + -- instances could be provided, we do not think is necessary for this + -- benchmark, as the input data is rather small. + inputs :: [(Natural, (PerasWeightSnapshot TestBlock, AF.AnchoredFragment TestBlock))] + inputs = + getEveryN (fragmentLenghtSamplingRate benchmarkParams) $ + take (fromIntegral $ fragmentMaxLenght benchmarkParams) $ + zip [0 ..] $ + zip (map uniformWeightSnapshot fragments) fragments + +benchWeightBoostOfFragment :: + (Natural, (PerasWeightSnapshot TestBlock, AF.AnchoredFragment TestBlock)) -> Benchmark +benchWeightBoostOfFragment (i, (weightSnapshot, fragment)) = + bench ("weightBoostOfFragment of length " <> show i) $ + whnf (weightBoostOfFragment weightSnapshot) fragment + +-- | An infinite list of chain fragments +fragments :: [AF.AnchoredFragment TestBlock] +fragments = iterate' addSuccessorBlock genesisFragment + where + genesisFragment :: AF.AnchoredFragment TestBlock + genesisFragment = AF.Empty AF.AnchorGenesis + + addSuccessorBlock :: AF.AnchoredFragment TestBlock -> AF.AnchoredFragment TestBlock + addSuccessorBlock = \case + AF.Empty _ -> (AF.Empty AF.AnchorGenesis) AF.:> (TestBlock.firstBlock 0 dummyBody) + (xs AF.:> x) -> + let nextBlockSlot = blockRate benchmarkParams + (thSlotNo . testHeader $ x) + in (xs AF.:> x) AF.:> TestBlock.mkNextBlock x nextBlockSlot dummyBody + + dummyBody :: TestBody + dummyBody = TestBody{tbForkNo = 0, tbIsValid = True} + +-- | Given a chain fragment, construct a weight snapshot where there's a boosted block every 90 slots +uniformWeightSnapshot :: AF.AnchoredFragment TestBlock -> PerasWeightSnapshot TestBlock +uniformWeightSnapshot fragment = + let pointsToBoost = + map snd + . getEveryN (boostedBlockRate benchmarkParams) + . zip [0 ..] + . map AF.blockPoint + . AF.toOldestFirst + $ fragment + weights = repeat (boostWeight benchmarkParams) + in mkPerasWeightSnapshot $ pointsToBoost `zip` weights + +getEveryN :: Natural -> [(Natural, a)] -> [(Natural, a)] +getEveryN n = filter (\(i, _) -> (i `mod` n) == 0) diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 1c93bb8f26..acbca582c1 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -83,6 +83,7 @@ library Ouroboros.Consensus.Block.RealPoint Ouroboros.Consensus.Block.SupportsDiffusionPipelining Ouroboros.Consensus.Block.SupportsMetrics + Ouroboros.Consensus.Block.SupportsPeras Ouroboros.Consensus.Block.SupportsProtocol Ouroboros.Consensus.Block.SupportsSanityCheck Ouroboros.Consensus.BlockchainTime @@ -190,6 +191,14 @@ library Ouroboros.Consensus.MiniProtocol.LocalStateQuery.Server Ouroboros.Consensus.MiniProtocol.LocalTxMonitor.Server Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert + Ouroboros.Consensus.MiniProtocol.Util + Ouroboros.Consensus.MiniProtocol.Util.Idling Ouroboros.Consensus.Node.GsmState Ouroboros.Consensus.Node.InitStorage Ouroboros.Consensus.Node.NetworkProtocolVersion @@ -197,6 +206,8 @@ library Ouroboros.Consensus.Node.Run Ouroboros.Consensus.Node.Serialisation Ouroboros.Consensus.NodeId + Ouroboros.Consensus.Peras.SelectView + Ouroboros.Consensus.Peras.Weight Ouroboros.Consensus.Protocol.Abstract Ouroboros.Consensus.Protocol.BFT Ouroboros.Consensus.Protocol.LeaderSchedule @@ -262,6 +273,9 @@ library Ouroboros.Consensus.Storage.LedgerDB.V2.Forker Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq + Ouroboros.Consensus.Storage.PerasCertDB + Ouroboros.Consensus.Storage.PerasCertDB.API + Ouroboros.Consensus.Storage.PerasCertDB.Impl Ouroboros.Consensus.Storage.Serialisation Ouroboros.Consensus.Storage.VolatileDB Ouroboros.Consensus.Storage.VolatileDB.API @@ -596,6 +610,9 @@ test-suite consensus-test Test.Consensus.MiniProtocol.ChainSync.CSJ Test.Consensus.MiniProtocol.ChainSync.Client Test.Consensus.MiniProtocol.LocalStateQuery.Server + Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke + Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke + Test.Consensus.Peras.WeightSnapshot Test.Consensus.Util.MonadSTM.NormalForm Test.Consensus.Util.Versioned @@ -717,6 +734,9 @@ test-suite storage-test Test.Ouroboros.Storage.LedgerDB.V1.DbChangelog Test.Ouroboros.Storage.LedgerDB.V1.LMDB Test.Ouroboros.Storage.Orphans + Test.Ouroboros.Storage.PerasCertDB + Test.Ouroboros.Storage.PerasCertDB.Model + Test.Ouroboros.Storage.PerasCertDB.StateMachine Test.Ouroboros.Storage.VolatileDB Test.Ouroboros.Storage.VolatileDB.Mock Test.Ouroboros.Storage.VolatileDB.Model @@ -827,6 +847,19 @@ benchmark ChainSync-client-bench unstable-consensus-testlib, with-utf8, +benchmark PerasCertDB-bench + import: common-bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench/PerasCertDB-bench + main-is: Main.hs + other-modules: + build-depends: + base, + ouroboros-consensus, + ouroboros-network-api, + tasty-bench, + unstable-consensus-testlib, + test-suite doctest import: common-test main-is: doctest.hs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs index 0ee718be4a..7c8b020e33 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs @@ -8,5 +8,6 @@ import Ouroboros.Consensus.Block.NestedContent as X import Ouroboros.Consensus.Block.RealPoint as X import Ouroboros.Consensus.Block.SupportsDiffusionPipelining as X import Ouroboros.Consensus.Block.SupportsMetrics as X +import Ouroboros.Consensus.Block.SupportsPeras as X import Ouroboros.Consensus.Block.SupportsProtocol as X import Ouroboros.Consensus.Block.SupportsSanityCheck as X diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs new file mode 100644 index 0000000000..41adcb03fa --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Ouroboros.Consensus.Block.SupportsPeras + ( PerasRoundNo (..) + , PerasWeight (..) + , BlockSupportsPeras (..) + , PerasCert (..) + , PerasCfg (..) + , ValidatedPerasCert (..) + , makePerasCfg + , HasPerasCert (..) + , getPerasCertRound + , getPerasCertBoostedBlock + , getPerasCertBoost + + -- * Ouroboros Peras round length + , PerasRoundLength (..) + , defaultPerasRoundLength + ) where + +import Codec.Serialise (Serialise (..)) +import Codec.Serialise.Decoding (decodeListLenOf) +import Codec.Serialise.Encoding (encodeListLen) +import Data.Monoid (Sum (..)) +import Data.Proxy (Proxy (..)) +import Data.Word (Word64) +import GHC.Generics (Generic) +import NoThunks.Class +import Ouroboros.Consensus.Block.Abstract +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) +import Ouroboros.Consensus.Util +import Ouroboros.Consensus.Util.Condense +import Quiet (Quiet (..)) + +newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} + deriving Show via Quiet PerasRoundNo + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks, Serialise) + +instance Condense PerasRoundNo where + condense = show . unPerasRoundNo + +instance ShowProxy PerasRoundNo where + showProxy _ = "PerasRoundNo" + +newtype PerasWeight = PerasWeight {unPerasWeight :: Word64} + deriving Show via Quiet PerasWeight + deriving stock Generic + deriving newtype (Eq, Ord, NoThunks) + deriving (Semigroup, Monoid) via Sum Word64 + +instance Condense PerasWeight where + condense = show . unPerasWeight + +-- | TODO this will become a Ledger protocol parameter +boostPerCert :: PerasWeight +boostPerCert = PerasWeight 15 + +-- TODO using 'Validated' for extra safety? Or some @.Unsafe@ module? +data ValidatedPerasCert blk = ValidatedPerasCert + { vpcCert :: !(PerasCert blk) + , vpcCertBoost :: !PerasWeight + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass NoThunks + +{------------------------------------------------------------------------------- + Ouroboros Peras round length +-------------------------------------------------------------------------------} + +newtype PerasRoundLength = PerasRoundLength {unPerasRoundLength :: Word64} + deriving stock (Show, Eq, Ord) + deriving newtype (NoThunks, Num) + +-- | See the Protocol parameters section of the Peras design report: +-- https://tweag.github.io/cardano-peras/peras-design.pdf#section.2.1 +-- TODO this will become a Ledger protocol parameter +defaultPerasRoundLength :: PerasRoundLength +defaultPerasRoundLength = 90 + +class + ( Show (PerasCfg blk) + , NoThunks (PerasCert blk) + ) => + BlockSupportsPeras blk + where + data PerasCfg blk + + data PerasCert blk + + data PerasValidationErr blk + + validatePerasCert :: + PerasCfg blk -> + PerasCert blk -> + Either (PerasValidationErr blk) (ValidatedPerasCert blk) + +-- TODO degenerate instance for all blks to get things to compile +instance StandardHash blk => BlockSupportsPeras blk where + newtype PerasCfg blk = PerasCfg + { -- TODO eventually, this will come from the + -- protocol parameters from the ledger state + perasCfgWeightBoost :: PerasWeight + } + deriving stock (Show, Eq) + + data PerasCert blk = PerasCert + { pcCertRound :: PerasRoundNo + , pcCertBoostedBlock :: Point blk + } + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass NoThunks + + -- TODO enrich with actual error types + data PerasValidationErr blk + = PerasValidationErr + deriving stock (Show, Eq) + + -- TODO perform actual validation against all + -- possible 'PerasValidationErr' variants + validatePerasCert cfg cert = + Right + ValidatedPerasCert + { vpcCert = cert + , vpcCertBoost = perasCfgWeightBoost cfg + } + +instance ShowProxy blk => ShowProxy (PerasCert blk) where + showProxy _ = "PerasCert " <> 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} + +-- | Derive a 'PerasCfg' from a 'BlockConfig' +-- TODO this currently doesn't depend on 'BlockConfig' at all, but likely will +makePerasCfg :: Maybe (BlockConfig blk) -> PerasCfg blk +makePerasCfg _ = + PerasCfg + { perasCfgWeightBoost = boostPerCert + } + +class StandardHash blk => HasPerasCert cert blk | cert -> blk where + getPerasCert :: cert -> PerasCert blk + +getPerasCertRound :: HasPerasCert cert blk => cert -> PerasRoundNo +getPerasCertRound = pcCertRound . getPerasCert + +getPerasCertBoostedBlock :: HasPerasCert cert blk => cert -> Point blk +getPerasCertBoostedBlock = pcCertBoostedBlock . getPerasCert + +instance StandardHash blk => HasPerasCert (PerasCert blk) blk where + getPerasCert = id + +instance StandardHash blk => HasPerasCert (ValidatedPerasCert blk) blk where + getPerasCert = vpcCert + +instance HasPerasCert cert blk => HasPerasCert (WithArrivalTime cert) blk where + getPerasCert = getPerasCert . forgetArrivalTime + +class HasPerasCertBoost cert blk | cert -> blk where + getPerasCertBoost :: cert -> PerasWeight + +instance HasPerasCertBoost (ValidatedPerasCert blk) blk where + getPerasCertBoost = vpcCertBoost + +instance HasPerasCertBoost cert blk => HasPerasCertBoost (WithArrivalTime cert) blk where + getPerasCertBoost = getPerasCertBoost . forgetArrivalTime diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs index 28105dd672..16277ad4ec 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} module Ouroboros.Consensus.BlockchainTime.WallClock.Types @@ -15,6 +17,10 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.Types -- * Get current time (as 'RelativeTime') , SystemTime (..) + -- * Attach an arrival time (as 'RelativeTime') to an object + , WithArrivalTime (..) + , addArrivalTime + -- * Slot length , getSlotLength , mkSlotLength @@ -31,6 +37,7 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.Types import Cardano.Slotting.Time import Data.Time.Clock (NominalDiffTime) +import GHC.Generics (Generic) import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) addRelTime :: NominalDiffTime -> RelativeTime -> RelativeTime @@ -60,3 +67,22 @@ data SystemTime m = SystemTime -- to reach 'SystemStart'. In tests this does nothing. } deriving NoThunks via OnlyCheckWhnfNamed "SystemTime" (SystemTime m) + +{------------------------------------------------------------------------------- + Attach an arrival time (as RelativeTime) to an object +-------------------------------------------------------------------------------} + +-- | WithArrivalTime +data WithArrivalTime a = WithArrivalTime + { getArrivalTime :: !RelativeTime + -- ^ The time at which the object arrived + , forgetArrivalTime :: !a + -- ^ The object without its arrival time + } + deriving (Show, Eq, Ord, Generic, NoThunks) + +-- | Add an arrival time to an object +addArrivalTime :: Monad m => SystemTime m -> a -> m (WithArrivalTime a) +addArrivalTime systemTime a = do + t <- systemTimeCurrent systemTime + return (WithArrivalTime t a) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config/SecurityParam.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config/SecurityParam.hs index bebe022e8d..2aade1eeb9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config/SecurityParam.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config/SecurityParam.hs @@ -3,24 +3,39 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..)) where +module Ouroboros.Consensus.Config.SecurityParam + ( SecurityParam (..) + , maxRollbackWeight + ) where import Cardano.Binary import Cardano.Ledger.BaseTypes.NonZero import Data.Word import GHC.Generics (Generic) import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.SupportsPeras (PerasWeight (..)) import Quiet -- | Protocol security parameter -- --- We interpret this as the number of rollbacks we support. +-- In longest-chain protocols, we interpret this as the number of rollbacks we +-- support. -- -- i.e., k == 1: we can roll back at most one block -- k == 2: we can roll back at most two blocks, etc -- -- NOTE: This talks about the number of /blocks/ we can roll back, not -- the number of /slots/. +-- +-- In weightiest-chain protocols (Ouroboros Peras), we interpret this as the +-- maximum amount of weight we can roll back. +-- +-- i.e. k == 30: we can roll back at most 30 unweighted blocks, or two blocks +-- each having additional weight 14. newtype SecurityParam = SecurityParam {maxRollbacks :: NonZero Word64} deriving (Eq, Generic, NoThunks, ToCBOR, FromCBOR) deriving Show via Quiet SecurityParam + +-- | The maximum amount of weight we can roll back. +maxRollbackWeight :: SecurityParam -> PerasWeight +maxRollbackWeight = PerasWeight . unNonZero . maxRollbacks diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs index 1521969d44..1cd42db9de 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs @@ -35,6 +35,7 @@ module Ouroboros.Consensus.Fragment.Diff import Data.Word (Word64) import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Peras.Weight import Ouroboros.Network.AnchoredFragment ( AnchoredFragment , AnchoredSeq (..) @@ -73,12 +74,31 @@ getTip = castPoint . AF.headPoint . getSuffix getAnchorPoint :: ChainDiff b -> Point b getAnchorPoint = castPoint . AF.anchorPoint . getSuffix --- | Return 'True' iff applying the 'ChainDiff' to a chain @C@ will result in --- a chain shorter than @C@, i.e., the number of blocks to roll back is --- greater than the length of the new elements in the suffix to add. -rollbackExceedsSuffix :: HasHeader b => ChainDiff b -> Bool -rollbackExceedsSuffix (ChainDiff nbRollback suffix) = - nbRollback > fromIntegral (AF.length suffix) +-- | Return 'True' iff applying the 'ChainDiff' to the given chain @C@ will +-- result in a chain with less weight than @C@, i.e., the suffix of @C@ to roll +-- back has more weight than suffix is adding. +rollbackExceedsSuffix :: + forall b0 b1 b2. + ( HasHeader b0 + , HasHeader b1 + , HasHeader b2 + , HeaderHash b0 ~ HeaderHash b1 + , HeaderHash b0 ~ HeaderHash b2 + ) => + PerasWeightSnapshot b0 -> + -- | The chain @C@ the diff is applied to. + AnchoredFragment b1 -> + ChainDiff b2 -> + Bool +rollbackExceedsSuffix weights curChain (ChainDiff nbRollback suffix) = + weightOf suffixToRollBack > weightOf suffix + where + suffixToRollBack = AF.anchorNewest nbRollback curChain + + weightOf :: + (HasHeader b, HeaderHash b ~ HeaderHash b0) => + AnchoredFragment b -> PerasWeight + weightOf = totalWeightOfFragment weights {------------------------------------------------------------------------------- Constructors diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/ValidatedDiff.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/ValidatedDiff.hs index 0d31d8f3fe..0a18a54308 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/ValidatedDiff.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/ValidatedDiff.hs @@ -13,7 +13,6 @@ module Ouroboros.Consensus.Fragment.ValidatedDiff , getChainDiff , getLedger , new - , rollbackExceedsSuffix , toValidatedFragment -- * Monadic @@ -96,9 +95,6 @@ toValidatedFragment :: toValidatedFragment (UnsafeValidatedChainDiff cs l) = VF.ValidatedFragment (Diff.getSuffix cs) l -rollbackExceedsSuffix :: HasHeader b => ValidatedChainDiff b l -> Bool -rollbackExceedsSuffix = Diff.rollbackExceedsSuffix . getChainDiff - {------------------------------------------------------------------------------- Monadic -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Abstract.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Abstract.hs index 7498024f6a..b2a07369df 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Abstract.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Abstract.hs @@ -67,6 +67,6 @@ neverForksHardForkSummary :: LedgerState blk mk -> HardFork.Summary '[blk] neverForksHardForkSummary getParams cfg _st = - HardFork.neverForksSummary eraEpochSize eraSlotLength eraGenesisWin + HardFork.neverForksSummary eraEpochSize eraSlotLength eraGenesisWin eraPerasRoundLength where HardFork.EraParams{..} = getParams cfg diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/EraParams.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/EraParams.hs index e0784c8d34..4bcbc77786 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/EraParams.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/EraParams.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} @@ -12,17 +16,23 @@ module Ouroboros.Consensus.HardFork.History.EraParams ( -- * API EraParams (..) , SafeZone (..) + , PerasEnabled + , pattern PerasEnabled + , pattern NoPerasEnabled + , PerasEnabledT (..) + , fromPerasEnabled -- * Defaults , defaultEraParams ) where -import Cardano.Binary (enforceSize) +import Cardano.Binary (DecoderError (DecoderErrorCustom), cborError) import Cardano.Ledger.BaseTypes (unNonZero) import Codec.CBOR.Decoding (Decoder, decodeListLen, decodeWord8) import Codec.CBOR.Encoding (Encoding, encodeListLen, encodeWord8) import Codec.Serialise (Serialise (..)) -import Control.Monad (void) +import Control.Monad (ap, liftM, void) +import Control.Monad.Trans.Class import Data.Word import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -136,10 +146,57 @@ data EraParams = EraParams , eraSlotLength :: !SlotLength , eraSafeZone :: !SafeZone , eraGenesisWin :: !GenesisWindow + , eraPerasRoundLength :: !(PerasEnabled PerasRoundLength) + -- ^ Optional, as not every era will be Peras-enabled } deriving stock (Show, Eq, Generic) deriving anyclass NoThunks +-- | A marker for era parameters that are Peras-specific +-- and are not present in pre-Peras eras +newtype PerasEnabled a = MkPerasEnabled (Maybe a) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass NoThunks + deriving newtype (Functor, Applicative, Monad) + +pattern PerasEnabled :: a -> PerasEnabled a +pattern PerasEnabled x <- MkPerasEnabled (Just !x) + where + PerasEnabled !x = MkPerasEnabled (Just x) + +pattern NoPerasEnabled :: PerasEnabled a +pattern NoPerasEnabled = MkPerasEnabled Nothing + +{-# COMPLETE PerasEnabled, NoPerasEnabled #-} + +-- | A 'fromMaybe'-like eliminator for 'PerasEnabled' +fromPerasEnabled :: a -> PerasEnabled a -> a +fromPerasEnabled defaultValue = + \case + NoPerasEnabled -> defaultValue + PerasEnabled value -> value + +-- | A 'MaybeT'-line monad transformer. +-- +-- Used solely for the Peras-related hard fork combinator queries, +-- see 'Ouroboros.Consensus.HardFork.History.Qry'. +newtype PerasEnabledT m a = PerasEnabledT {runPerasEnabledT :: m (PerasEnabled a)} + deriving stock Functor + +instance (Functor m, Monad m) => Applicative (PerasEnabledT m) where + pure = PerasEnabledT . pure . PerasEnabled + (<*>) = ap + +instance Monad m => Monad (PerasEnabledT m) where + x >>= f = PerasEnabledT $ do + v <- runPerasEnabledT x + case v of + NoPerasEnabled -> pure NoPerasEnabled + PerasEnabled y -> runPerasEnabledT (f y) + +instance MonadTrans PerasEnabledT where + lift = PerasEnabledT . liftM PerasEnabled + -- | Default 'EraParams' -- -- We set @@ -147,6 +204,7 @@ data EraParams = EraParams -- * epoch size to @10k@ slots -- * the safe zone to @2k@ slots -- * the upper bound to 'NoLowerBound' +-- * the Peras Round Length is unset -- -- This is primarily useful for tests. defaultEraParams :: SecurityParam -> SlotLength -> EraParams @@ -156,6 +214,8 @@ defaultEraParams (SecurityParam k) slotLength = , eraSlotLength = slotLength , eraSafeZone = StandardSafeZone (unNonZero k * 2) , eraGenesisWin = GenesisWindow (unNonZero k * 2) + , -- Peras is disabled by default + eraPerasRoundLength = NoPerasEnabled } -- | Zone in which it is guaranteed that no hard fork can take place @@ -235,17 +295,27 @@ decodeSafeBeforeEpoch = do instance Serialise EraParams where encode EraParams{..} = mconcat $ - [ encodeListLen 4 + [ encodeListLen $ case eraPerasRoundLength of + NoPerasEnabled -> 4 + PerasEnabled{} -> 5 , encode (unEpochSize eraEpochSize) , encode eraSlotLength , encode eraSafeZone , encode (unGenesisWindow eraGenesisWin) ] + <> case eraPerasRoundLength of + NoPerasEnabled -> [] + PerasEnabled rl -> [encode (unPerasRoundLength rl)] decode = do - enforceSize "EraParams" 4 + len <- decodeListLen eraEpochSize <- EpochSize <$> decode eraSlotLength <- decode eraSafeZone <- decode eraGenesisWin <- GenesisWindow <$> decode + eraPerasRoundLength <- + case len of + 4 -> pure NoPerasEnabled + 5 -> PerasEnabled . PerasRoundLength <$> decode + _ -> cborError (DecoderErrorCustom "EraParams" "unexpected list length") return EraParams{..} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs index 9c4844c752..786c269433 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs @@ -42,12 +42,15 @@ module Ouroboros.Consensus.HardFork.History.Qry , slotToSlotLength , slotToWallclock , wallclockToSlot + , perasRoundNoToSlot + , slotToPerasRoundNo ) where import Codec.Serialise (Serialise (..)) import Control.Exception (throw) import Control.Monad (ap, guard, liftM, (>=>)) import Control.Monad.Except () +import Control.Monad.Trans.Class import Data.Bifunctor import Data.Fixed (divMod') import Data.Foldable (toList) @@ -126,6 +129,8 @@ import Quiet These are equal by (INV-2a). + 5. Slot to Peras round translation. + This means that for values at that boundary, it does not matter if we use this era or the next era for the translation. However, this is only true for these 4 translations. If we are returning the era parameters directly, then @@ -182,12 +187,16 @@ newtype TimeInSlot = TimeInSlot {getTimeInSlot :: NominalDiffTime} deriving Gene newtype SlotInEra = SlotInEra {getSlotInEra :: Word64} deriving Generic newtype SlotInEpoch = SlotInEpoch {getSlotInEpoch :: Word64} deriving Generic newtype EpochInEra = EpochInEra {getEpochInEra :: Word64} deriving Generic +newtype PerasRoundNoInEra = PerasRoundNoInEra {getPerasRoundNoInEra :: Word64} deriving Generic +newtype SlotInPerasRound = SlotInPerasRound {getSlotInPerasRound :: Word64} deriving Generic deriving via Quiet TimeInEra instance Show TimeInEra deriving via Quiet TimeInSlot instance Show TimeInSlot deriving via Quiet SlotInEra instance Show SlotInEra deriving via Quiet SlotInEpoch instance Show SlotInEpoch deriving via Quiet EpochInEra instance Show EpochInEra +deriving via Quiet PerasRoundNoInEra instance Show PerasRoundNoInEra +deriving via Quiet SlotInPerasRound instance Show SlotInPerasRound {------------------------------------------------------------------------------- Expressions @@ -212,23 +221,30 @@ data Expr (f :: Type -> Type) :: Type -> Type where EAbsToRelTime :: Expr f RelativeTime -> Expr f TimeInEra EAbsToRelSlot :: Expr f SlotNo -> Expr f SlotInEra EAbsToRelEpoch :: Expr f EpochNo -> Expr f EpochInEra + EAbsToRelPerasRoundNo :: Expr f PerasRoundNo -> Expr f (PerasEnabled PerasRoundNoInEra) -- Convert from era-relative to absolute ERelToAbsTime :: Expr f TimeInEra -> Expr f RelativeTime ERelToAbsSlot :: Expr f (SlotInEra, TimeInSlot) -> Expr f SlotNo ERelToAbsEpoch :: Expr f (EpochInEra, SlotInEpoch) -> Expr f EpochNo + ERelToAbsPerasRoundNo :: + Expr f (PerasEnabled PerasRoundNoInEra) -> Expr f (PerasEnabled PerasRoundNo) -- Convert between relative values ERelTimeToSlot :: Expr f TimeInEra -> Expr f (SlotInEra, TimeInSlot) ERelSlotToTime :: Expr f SlotInEra -> Expr f TimeInEra ERelSlotToEpoch :: Expr f SlotInEra -> Expr f (EpochInEra, SlotInEpoch) ERelEpochToSlot :: Expr f EpochInEra -> Expr f SlotInEra + ERelPerasRoundNoToSlot :: Expr f (PerasEnabled PerasRoundNoInEra) -> Expr f (PerasEnabled SlotInEra) + ERelSlotToPerasRoundNo :: + Expr f SlotInEra -> Expr f (PerasEnabled (PerasRoundNoInEra, SlotInPerasRound)) -- Get era parameters -- The arguments are used for bound checks ESlotLength :: Expr f SlotNo -> Expr f SlotLength EEpochSize :: Expr f EpochNo -> Expr f EpochSize EGenesisWindow :: Expr f SlotNo -> Expr f GenesisWindow + EPerasRoundLength :: Expr f PerasRoundNo -> Expr f (PerasEnabled PerasRoundLength) {------------------------------------------------------------------------------- Interpreter @@ -247,6 +263,11 @@ evalExprInEra EraSummary{..} = \(ClosedExpr e) -> go e EraUnbounded -> return () EraEnd b -> guard $ p b + guardEndPeras :: (Bound -> PerasEnabledT Maybe Bool) -> PerasEnabledT Maybe () + guardEndPeras p = case eraEnd of + EraUnbounded -> pure () + EraEnd end -> lift . guard =<< p end + go :: Expr Identity a -> Maybe a go (EVar a) = return $ runIdentity a @@ -279,6 +300,13 @@ evalExprInEra EraSummary{..} = \(ClosedExpr e) -> go e e <- go expr guard (e >= boundEpoch eraStart) return $ EpochInEra (countEpochs e (boundEpoch eraStart)) + go (EAbsToRelPerasRoundNo expr) = + runPerasEnabledT $ do + eraStartPerasRound <- PerasEnabledT . Just $ boundPerasRound eraStart + absPerasRoundNo <- lift $ go expr + lift . guard $ absPerasRoundNo >= eraStartPerasRound + let roundInEra = countPerasRounds absPerasRoundNo eraStartPerasRound + pure . PerasRoundNoInEra $ roundInEra -- Convert relative to absolute -- @@ -304,6 +332,15 @@ evalExprInEra EraSummary{..} = \(ClosedExpr e) -> go e absEpoch < boundEpoch end || absEpoch == boundEpoch end && getSlotInEpoch s == 0 return absEpoch + go (ERelToAbsPerasRoundNo expr) = runPerasEnabledT $ do + eraStartPerasRound <- PerasEnabledT . Just $ boundPerasRound eraStart + relPerasRound <- PerasEnabledT $ go expr + let absPerasRound = addPerasRounds (getPerasRoundNoInEra relPerasRound) eraStartPerasRound + + guardEndPeras $ \end -> do + eraEndPerasRound <- PerasEnabledT . Just $ boundPerasRound end + pure $ absPerasRound <= eraEndPerasRound + pure absPerasRound -- Convert between relative values -- @@ -321,6 +358,14 @@ evalExprInEra EraSummary{..} = \(ClosedExpr e) -> go e go (ERelEpochToSlot expr) = do e <- go expr return $ SlotInEra (getEpochInEra e * epochSize) + go (ERelPerasRoundNoToSlot expr) = runPerasEnabledT $ do + PerasRoundNoInEra relPerasRoundNo <- PerasEnabledT $ go expr + PerasRoundLength perasRoundLength <- PerasEnabledT . Just $ eraPerasRoundLength + pure $ SlotInEra (relPerasRoundNo * perasRoundLength) + go (ERelSlotToPerasRoundNo expr) = runPerasEnabledT $ do + SlotInEra relSlot <- lift $ go expr + PerasRoundLength perasRoundLength <- PerasEnabledT . Just $ eraPerasRoundLength + pure . bimap PerasRoundNoInEra SlotInPerasRound $ relSlot `divMod` perasRoundLength -- Get era parameters -- @@ -342,6 +387,14 @@ evalExprInEra EraSummary{..} = \(ClosedExpr e) -> go e guard $ s >= boundSlot eraStart guardEnd $ \end -> s < boundSlot end return eraGenesisWin + go (EPerasRoundLength expr) = runPerasEnabledT $ do + eraStartPerasRound <- PerasEnabledT . Just $ boundPerasRound eraStart + absPerasRound <- lift $ go expr + lift . guard $ absPerasRound >= eraStartPerasRound + guardEndPeras $ \end -> do + eraEndPerasRound <- PerasEnabledT . Just $ boundPerasRound end + pure $ absPerasRound < eraEndPerasRound + PerasEnabledT . Just $ eraPerasRoundLength {------------------------------------------------------------------------------- PastHorizonException @@ -499,7 +552,7 @@ slotToEpoch' absSlot = -- | Translate 'SlotNo' to its corresponding 'EpochNo' -- -- Additionally returns the relative slot within this epoch and how many --- slots are left in this slot. +-- slots are left in this epoch. slotToEpoch :: SlotNo -> Qry (EpochNo, Word64, Word64) slotToEpoch absSlot = aux <$> qryFromExpr (slotToEpochExpr absSlot) @@ -528,6 +581,38 @@ epochToSize :: EpochNo -> Qry EpochSize epochToSize absEpoch = qryFromExpr (epochToSizeExpr absEpoch) +-- | Translate 'PerasRoundNo' to the 'SlotNo' of the first slot in that Peras round +-- +-- Additionally returns the length of the round. +perasRoundNoToSlot :: PerasRoundNo -> Qry (PerasEnabled (SlotNo, PerasRoundLength)) +perasRoundNoToSlot perasRoundNo = runPerasEnabledT $ do + relSlot <- + PerasEnabledT $ qryFromExpr (ERelPerasRoundNoToSlot (EAbsToRelPerasRoundNo (ELit perasRoundNo))) + absSlot <- lift $ qryFromExpr (ERelToAbsSlot (EPair (ELit relSlot) (ELit (TimeInSlot 0)))) + roundLength <- PerasEnabledT $ qryFromExpr (perasRoundNoPerasRoundLengthExpr perasRoundNo) + pure (absSlot, roundLength) + +-- | Translate 'SlotNo' to its corresponding 'PerasRoundNo' +-- +-- Additionally returns the relative slot within this round and how many +-- slots are left in this round. +slotToPerasRoundNo :: SlotNo -> Qry (PerasEnabled (PerasRoundNo, Word64, Word64)) +slotToPerasRoundNo absSlot = runPerasEnabledT $ do + (relPerasRoundNo, slotInPerasRound) <- + PerasEnabledT $ + qryFromExpr (ERelSlotToPerasRoundNo (EAbsToRelSlot (ELit absSlot))) + absPerasRoundNo <- + PerasEnabledT $ + qryFromExpr (ERelToAbsPerasRoundNo (ELit (PerasEnabled relPerasRoundNo))) + roundLength <- + PerasEnabledT $ + qryFromExpr (perasRoundNoPerasRoundLengthExpr absPerasRoundNo) + pure $ + ( absPerasRoundNo + , getSlotInPerasRound slotInPerasRound + , unPerasRoundLength roundLength - getSlotInPerasRound slotInPerasRound + ) + {------------------------------------------------------------------------------- Supporting expressions for the queries above -------------------------------------------------------------------------------} @@ -581,6 +666,10 @@ slotToGenesisWindow :: SlotNo -> Expr f GenesisWindow slotToGenesisWindow absSlot = EGenesisWindow (ELit absSlot) +perasRoundNoPerasRoundLengthExpr :: PerasRoundNo -> Expr f (PerasEnabled PerasRoundLength) +perasRoundNoPerasRoundLengthExpr absPerasRoundNo = + EPerasRoundLength (ELit absPerasRoundNo) + {------------------------------------------------------------------------------- 'Show' instances -------------------------------------------------------------------------------} @@ -629,13 +718,18 @@ instance Show (ClosedExpr a) where EAbsToRelTime e -> showString "EAbsToRelTime " . go n 11 e EAbsToRelSlot e -> showString "EAbsToRelSlot " . go n 11 e EAbsToRelEpoch e -> showString "EAbsToRelEpoch " . go n 11 e + EAbsToRelPerasRoundNo e -> showString "EAbsToRelPerasRoundNo " . go n 11 e ERelToAbsTime e -> showString "ERelToAbsTime " . go n 11 e ERelToAbsSlot e -> showString "ERelToAbsSlot " . go n 11 e ERelToAbsEpoch e -> showString "ERelToAbsEpoch " . go n 11 e + ERelToAbsPerasRoundNo e -> showString "ERelToAbsPerasRoundNo " . go n 11 e ERelTimeToSlot e -> showString "ERelTimeToSlot " . go n 11 e ERelSlotToTime e -> showString "ERelSlotToTime " . go n 11 e ERelSlotToEpoch e -> showString "ERelSlotToEpoch " . go n 11 e ERelEpochToSlot e -> showString "ERelEpochToSlot " . go n 11 e + ERelPerasRoundNoToSlot e -> showString "ERelPerasRoundNoToSlot " . go n 11 e + ERelSlotToPerasRoundNo e -> showString "ERelSlotToPerasRoundNo " . go n 11 e ESlotLength e -> showString "ESlotLength " . go n 11 e EEpochSize e -> showString "EEpochSize " . go n 11 e EGenesisWindow e -> showString "EGenesisWindow " . go n 11 e + EPerasRoundLength e -> showString "EPerasRoundLength " . go n 11 e diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs index 0ef241f4a5..03b71562e1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs @@ -47,7 +47,7 @@ module Ouroboros.Consensus.HardFork.History.Summary , summaryInit ) where -import Cardano.Binary (enforceSize) +import Cardano.Binary (DecoderError (DecoderErrorCustom), cborError, decodeListLen, enforceSize) import Codec.CBOR.Decoding ( TokenType (TypeNull) , decodeNull @@ -83,6 +83,8 @@ data Bound = Bound { boundTime :: !RelativeTime , boundSlot :: !SlotNo , boundEpoch :: !EpochNo + , boundPerasRound :: !(PerasEnabled PerasRoundNo) + -- ^ Optional, as not every era will be Peras-enabled } deriving stock (Show, Eq, Generic) deriving anyclass NoThunks @@ -93,6 +95,9 @@ initBound = { boundTime = RelativeTime 0 , boundSlot = SlotNo 0 , boundEpoch = EpochNo 0 + , -- TODO(geo2a): we may want to make this configurable, + -- see https://github.com/tweag/cardano-peras/issues/112 + boundPerasRound = NoPerasEnabled } -- | Version of 'mkUpperBound' when the upper bound may not be known @@ -122,12 +127,16 @@ mkUpperBound EraParams{..} lo hiEpoch = { boundTime = addRelTime inEraTime $ boundTime lo , boundSlot = addSlots inEraSlots $ boundSlot lo , boundEpoch = hiEpoch + , boundPerasRound = addPerasRounds <$> inEraPerasRounds <*> boundPerasRound lo } where inEraEpochs, inEraSlots :: Word64 inEraEpochs = countEpochs hiEpoch (boundEpoch lo) inEraSlots = inEraEpochs * unEpochSize eraEpochSize + inEraPerasRounds :: PerasEnabled Word64 + inEraPerasRounds = div <$> PerasEnabled inEraSlots <*> (unPerasRoundLength <$> eraPerasRoundLength) + inEraTime :: NominalDiffTime inEraTime = fromIntegral inEraSlots * getSlotLength eraSlotLength @@ -182,6 +191,10 @@ slotToEpochBound EraParams{eraEpochSize = EpochSize epochSize} lo hiSlot = -- > t' - t == ((s' - s) * slotLen) -- > (t' - t) / slotLen == s' - s -- > s + ((t' - t) / slotLen) == s' +-- +-- Ouroboros Peras adds an invariant relating epoch size and Peras voting round lengths: +-- > epochSize % perasRoundLength == 0 +-- i.e. the round length should divide the epoch size data EraSummary = EraSummary { eraStart :: !Bound -- ^ Inclusive lower bound @@ -219,8 +232,9 @@ newtype Summary xs = Summary {getSummary :: NonEmpty xs EraSummary} -------------------------------------------------------------------------------} -- | 'Summary' for a ledger that never forks -neverForksSummary :: EpochSize -> SlotLength -> GenesisWindow -> Summary '[x] -neverForksSummary epochSize slotLen genesisWindow = +neverForksSummary :: + EpochSize -> SlotLength -> GenesisWindow -> PerasEnabled PerasRoundLength -> Summary '[x] +neverForksSummary epochSize slotLen genesisWindow perasRoundLength = Summary $ NonEmptyOne $ EraSummary @@ -232,6 +246,7 @@ neverForksSummary epochSize slotLen genesisWindow = , eraSlotLength = slotLen , eraSafeZone = UnsafeIndefiniteSafeZone , eraGenesisWin = genesisWindow + , eraPerasRoundLength = perasRoundLength } } @@ -331,8 +346,19 @@ summarize :: Transitions xs -> Summary xs summarize ledgerTip = \(Shape shape) (Transitions transitions) -> - Summary $ go initBound shape transitions + Summary $ go initBoundWithPeras shape transitions where + -- as noted in the haddock, this function is only used for testing purposes, + -- therefore we make the initial era is Peras-enabled, which means + -- we only test Peras-enabled eras. It is rather difficult + -- to parameterise the test suite, as it requires also parameterise many non-test functions, like + -- 'HF.initBound'. + -- + -- TODO(geo2a): revisit this hard-coding of enabling Peras when + -- we're further into the integration process + -- see https://github.com/tweag/cardano-peras/issues/112 + initBoundWithPeras = initBound{boundPerasRound = PerasEnabled . PerasRoundNo $ 0} + go :: Bound -> -- Lower bound for current era Exactly (x ': xs) EraParams -> -- params for all eras @@ -471,6 +497,21 @@ invariantSummary = \(Summary summary) -> , " (INV-2b)" ] + case eraPerasRoundLength curParams of + NoPerasEnabled -> pure () + PerasEnabled perasRoundLength -> + unless + ( (unEpochSize $ eraEpochSize curParams) + `mod` (unPerasRoundLength perasRoundLength) + == 0 + ) + $ throwError + $ mconcat + [ "Invalid Peras round length " + , show curSummary + , " (Peras round length does not divide epoch size)" + ] + go curEnd next where curStart :: Bound @@ -484,18 +525,27 @@ invariantSummary = \(Summary summary) -> instance Serialise Bound where encode Bound{..} = - mconcat - [ encodeListLen 3 + mconcat $ + [ encodeListLen $ case boundPerasRound of + NoPerasEnabled -> 3 + PerasEnabled{} -> 4 , encode boundTime , encode boundSlot , encode boundEpoch ] + <> case boundPerasRound of + NoPerasEnabled -> [] + PerasEnabled bound -> [encode bound] decode = do - enforceSize "Bound" 3 + len <- decodeListLen boundTime <- decode boundSlot <- decode boundEpoch <- decode + boundPerasRound <- case len of + 3 -> pure NoPerasEnabled + 4 -> PerasEnabled <$> decode + _ -> cborError (DecoderErrorCustom "Bound" "unexpected list length") return Bound{..} instance Serialise EraEnd where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Util.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Util.hs index daf8fd443e..7cdebd4ea0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Util.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Util.hs @@ -2,8 +2,10 @@ module Ouroboros.Consensus.HardFork.History.Util ( -- * Adding and subtracting slots/epochs addEpochs , addSlots + , addPerasRounds , countEpochs , countSlots + , countPerasRounds , subSlots ) where @@ -26,6 +28,9 @@ subSlots n (SlotNo x) = assert (x >= n) $ SlotNo (x - n) addEpochs :: Word64 -> EpochNo -> EpochNo addEpochs n (EpochNo x) = EpochNo (x + n) +addPerasRounds :: Word64 -> PerasRoundNo -> PerasRoundNo +addPerasRounds n (PerasRoundNo x) = PerasRoundNo (x + n) + -- | @countSlots to fr@ counts the slots from @fr@ to @to@ (@to >= fr@) countSlots :: HasCallStack => SlotNo -> SlotNo -> Word64 countSlots (SlotNo to) (SlotNo fr) = assert (to >= fr) $ to - fr @@ -37,3 +42,8 @@ countEpochs :: HasCallStack => EpochNo -> EpochNo -> Word64 countEpochs (EpochNo to) (EpochNo fr) = assert (to >= fr) $ to - fr where _ = keepRedundantConstraint (Proxy :: Proxy HasCallStack) + +countPerasRounds :: HasCallStack => PerasRoundNo -> PerasRoundNo -> Word64 +countPerasRounds (PerasRoundNo to) (PerasRoundNo fr) = assert (to >= fr) $ to - fr + where + _ = keepRedundantConstraint (Proxy :: Proxy HasCallStack) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs index bdf45723e0..a630e3d104 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs @@ -33,6 +33,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol ) import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as CSJumping +import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import Ouroboros.Consensus.Storage.ChainDB.API ( AddBlockPromise , ChainDB @@ -45,14 +46,15 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunis import Ouroboros.Consensus.Util.AnchoredFragment import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () +import Ouroboros.Consensus.Util.STM import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (MaxSlotNo) import Ouroboros.Network.BlockFetch.ConsensusInterface ( BlockFetchConsensusInterface (..) + , ChainComparison (..) , ChainSelStarvation , FetchMode (..) - , FromConsensus (..) , PraosFetchMode (..) , mkReadFetchMode ) @@ -66,6 +68,7 @@ data ChainDbView m blk = ChainDbView , getMaxSlotNo :: STM m MaxSlotNo , addBlockAsync :: InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk) , getChainSelStarvation :: STM m ChainSelStarvation + , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) } defaultChainDbView :: ChainDB m blk -> ChainDbView m blk @@ -77,6 +80,7 @@ defaultChainDbView chainDB = , getMaxSlotNo = ChainDB.getMaxSlotNo chainDB , addBlockAsync = ChainDB.addBlockAsync chainDB , getChainSelStarvation = ChainDB.getChainSelStarvation chainDB + , getPerasWeightSnapshot = ChainDB.getPerasWeightSnapshot chainDB } readFetchModeDefault :: @@ -226,6 +230,16 @@ mkBlockFetchConsensusInterface readFetchedMaxSlotNo :: STM m MaxSlotNo readFetchedMaxSlotNo = getMaxSlotNo chainDB + readChainComparison :: STM m (WithFingerprint (ChainComparison (HeaderWithTime blk))) + readChainComparison = + fmap mkChainComparison <$> getPerasWeightSnapshot chainDB + where + mkChainComparison weights = + ChainComparison + { plausibleCandidateChain = plausibleCandidateChain weights + , compareCandidateChains = compareCandidateChains weights + } + -- Note that @ours@ comes from the ChainDB and @cand@ from the ChainSync -- client. -- @@ -241,10 +255,11 @@ mkBlockFetchConsensusInterface -- fragment, our current chain might have changed. plausibleCandidateChain :: HasCallStack => + PerasWeightSnapshot blk -> AnchoredFragment (HeaderWithTime blk) -> AnchoredFragment (HeaderWithTime blk) -> Bool - plausibleCandidateChain ours cand + plausibleCandidateChain weights ours cand = -- 1. The ChainDB maintains the invariant that the anchor of our fragment -- corresponds to the immutable tip. -- @@ -258,52 +273,27 @@ mkBlockFetchConsensusInterface -- point. This means that we are no longer guaranteed that the -- precondition holds. -- - -- 4. Our chain's anchor can only move forward. We can detect this by - -- looking at the block/slot numbers of the anchors: When the anchor - -- advances, either the block number increases (usual case), or the - -- block number stays the same, but the slot number increases (EBB - -- case). - -- - | anchorBlockNoAndSlot cand < anchorBlockNoAndSlot ours -- (4) - = - case (AF.null ours, AF.null cand) of - -- Both are non-empty, the precondition trivially holds. - (False, False) -> preferAnchoredCandidate bcfg ours cand - -- The candidate is shorter than our chain and, worse, we'd have to - -- roll back past our immutable tip (the anchor of @cand@). - (_, True) -> False - -- As argued above we can only reach this case when our chain's anchor - -- has changed (4). - -- - -- It is impossible for our chain to change /and/ still be empty: the - -- anchor of our chain only changes when a new block becomes - -- immutable. For a new block to become immutable, we must have - -- extended our chain with at least @k + 1@ blocks. Which means our - -- fragment can't be empty. - (True, _) -> error "impossible" - | otherwise = - preferAnchoredCandidate bcfg ours cand - where - anchorBlockNoAndSlot :: - AnchoredFragment (HeaderWithTime blk) -> - (WithOrigin BlockNo, WithOrigin SlotNo) - anchorBlockNoAndSlot frag = - (AF.anchorToBlockNo a, AF.anchorToSlotNo a) - where - a = AF.anchor frag + -- 4. Therefore, we check whether the candidate fragments still intersects + -- with our fragment; if not, then it is only a matter of time until the + -- ChainSync client disconnects from that peer. + case AF.intersectionPoint ours cand of + -- REVIEW: Hmm, maybe we want to change 'preferAnchoredCandidates' to + -- also just return 'False' in this case (and we remove the + -- precondition). + Nothing -> False + Just _ -> preferAnchoredCandidate bcfg weights ours cand compareCandidateChains :: + PerasWeightSnapshot blk -> AnchoredFragment (HeaderWithTime blk) -> AnchoredFragment (HeaderWithTime blk) -> Ordering compareCandidateChains = compareAnchoredFragments bcfg - headerForgeUTCTime :: FromConsensus (HeaderWithTime blk) -> STM m UTCTime + headerForgeUTCTime :: HeaderWithTime blk -> UTCTime headerForgeUTCTime = - pure - . fromRelativeTime (SupportsNode.getSystemStart bcfg) + fromRelativeTime (SupportsNode.getSystemStart bcfg) . hwtSlotRelativeTime - . unFromConsensus readChainSelStarvation = getChainSelStarvation chainDB diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs index ec16c91eca..85b0b1a487 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs @@ -73,7 +73,6 @@ module Ouroboros.Consensus.MiniProtocol.ChainSync.Client , Jumping.noJumping , chainSyncStateFor , newChainSyncClientHandleCollection - , noIdling , noLoPBucket , viewChainSyncState ) where @@ -122,8 +121,10 @@ import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCh import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as Jumping import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State +import Ouroboros.Consensus.MiniProtocol.Util.Idling (Idling (..)) import Ouroboros.Consensus.Node.GsmState (GsmState (..)) import Ouroboros.Consensus.Node.NetworkProtocolVersion +import Ouroboros.Consensus.Peras.Weight (emptyPerasWeightSnapshot) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB @@ -271,26 +272,6 @@ chainSyncStateFor :: chainSyncStateFor varHandles peer = readTVar . cschState . (Map.! peer) =<< readTVar varHandles --- | Interface for the ChainSync client to manipulate the idling flag in --- 'ChainSyncState'. -data Idling m = Idling - { idlingStart :: !(m ()) - -- ^ Mark the peer as being idle. - , idlingStop :: !(m ()) - -- ^ Mark the peer as not being idle. - } - deriving stock Generic - -deriving anyclass instance IOLike m => NoThunks (Idling m) - --- | No-op implementation, for tests. -noIdling :: Applicative m => Idling m -noIdling = - Idling - { idlingStart = pure () - , idlingStop = pure () - } - -- | Interface to the LoP implementation for the ChainSync client. data LoPBucket m = LoPBucket { lbPause :: !(m ()) @@ -404,6 +385,7 @@ bracketChainSyncClient { csCandidate = AF.Empty AF.AnchorGenesis , csLatestSlot = SNothing , csIdling = False + , csNodeToNodeVersion = version } withCSJCallbacks :: @@ -1833,7 +1815,12 @@ checkTime cfgEnv dynEnv intEnv = checkPreferTheirsOverOurs kis | -- Precondition is fulfilled as ourFrag and theirFrag intersect by -- construction. - preferAnchoredCandidate (configBlock cfg) ourFrag theirFrag = + preferAnchoredCandidate + (configBlock cfg) + -- TODO: remove this entire check, see https://github.com/tweag/cardano-peras/issues/64 + emptyPerasWeightSnapshot + ourFrag + theirFrag = pure () | otherwise = throwSTM $ diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs index d7dd82db7b..7077aba1b4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs @@ -37,6 +37,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol ) import Ouroboros.Consensus.Node.GsmState (GsmState) +import Ouroboros.Consensus.Node.NetworkProtocolVersion (NodeToNodeVersion) import Ouroboros.Consensus.Util.IOLike ( IOLike , NoThunks (..) @@ -74,6 +75,11 @@ data ChainSyncState blk = ChainSyncState -- processing it further, and the latest slot may refer to a header beyond -- the forecast horizon while the candidate fragment isn't extended yet, to -- signal to GDD that the density is known up to this slot. + , csNodeToNodeVersion :: !NodeToNodeVersion + -- ^ Negotiated version of the protocol with the peer. + -- + -- This is used to determine later on whether other mini-protocols are + -- expected to run in parallel with this one. } deriving stock Generic diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs new file mode 100644 index 0000000000..a368682c40 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs @@ -0,0 +1,505 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound + ( objectDiffusionInbound + , TraceObjectDiffusionInbound (..) + , ObjectDiffusionInboundError (..) + , NumObjectsProcessed (..) + ) where + +import Cardano.Prelude (catMaybes) +import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked +import Control.Exception (assert) +import Control.Monad (when) +import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadThrow +import Control.Tracer (Tracer, traceWith) +import Data.Foldable as Foldable (foldl', toList) +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict qualified as Seq +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Word (Word64) +import GHC.Generics (Generic) +import Network.TypedProtocol.Core (N (Z), Nat (..), natToInt) +import NoThunks.Class (NoThunks (..), unsafeNoThunks) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State + ( ObjectDiffusionInboundStateView (..) + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Consensus.MiniProtocol.Util.Idling qualified as Idling +import Ouroboros.Network.ControlMessage +import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion) +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound +import Ouroboros.Network.Protocol.ObjectDiffusion.Type + +-- Note: This module is inspired from TxSubmission inbound side. + +newtype NumObjectsProcessed + = NumObjectsProcessed + { getNumObjectsProcessed :: Word64 + } + deriving (Eq, Show) + +data TraceObjectDiffusionInbound objectId object + = -- | Number of objects just about to be inserted. + TraceObjectDiffusionCollected Int + | -- | Just processed object pass/fail breakdown. + TraceObjectDiffusionProcessed NumObjectsProcessed + | -- | Received a 'ControlMessage' from the outbound peer governor, and about + -- to act on it. + TraceObjectDiffusionControlMessage ControlMessage + | TraceObjectInboundCanRequestMoreObjects Int + | TraceObjectInboundCannotRequestMoreObjects Int + | TraceObjectInboundStartedIdling + | TraceObjectInboundStoppedIdling + deriving (Eq, Show) + +data ObjectDiffusionInboundError + = ProtocolErrorObjectNotRequested + | ProtocolErrorObjectIdsNotRequested + | ProtocolErrorObjectIdAlreadyKnown + | ProtocolErrorObjectIdsDuplicate + deriving Show + +instance Exception ObjectDiffusionInboundError where + displayException ProtocolErrorObjectNotRequested = + "The peer replied with a object we did not ask for." + displayException ProtocolErrorObjectIdsNotRequested = + "The peer replied with more objectIds than we asked for." + displayException ProtocolErrorObjectIdAlreadyKnown = + "The peer replied with an objectId that it has already sent us previously." + displayException ProtocolErrorObjectIdsDuplicate = + "The peer replied with a batch of objectIds containing a duplicate." + +-- | Information maintained internally in the 'objectDiffusionInbound' +-- implementation. +data InboundSt objectId object = InboundSt + { numIdsInFlight :: !NumObjectIdsReq + -- ^ The number of object identifiers that we have requested but + -- which have not yet been replied to. We need to track this to keep + -- our requests within the limit on the 'outstandingFifo' size. + , outstandingFifo :: !(StrictSeq objectId) + -- ^ This mirrors the queue of objects that the outbound peer has available + -- for us. Objects are kept in the order in which the outbound peer + -- advertised them to us. This is the same order in which we submit them to + -- the objectPool. It is also the order we acknowledge them. + , canRequestNext :: !(Set objectId) + -- ^ The objectIds that we can request. These are a subset of the + -- 'outstandingFifo' that we have not yet requested or not have in the pool + -- already. This is not ordered to illustrate the fact that we can + -- request objects out of order. + , pendingObjects :: !(Map objectId (Maybe object)) + -- ^ Objects we have successfully downloaded (or decided intentionally to + -- skip download) but have not yet added to the objectPool or acknowledged. + -- + -- Object IDs in this 'Map' are mapped to 'Nothing' if we notice that + -- they are already in the objectPool. That way we can skip requesting them + -- from the outbound peer, but still acknowledge them when the time comes. + , numToAckOnNextReq :: !NumObjectIdsAck + -- ^ The number of objects we can acknowledge on our next request + -- for more object IDs. Their corresponding IDs have already been removed + -- from 'outstandingFifo'. + } + deriving stock (Show, Generic) + deriving anyclass NoThunks + +initialInboundSt :: InboundSt objectId object +initialInboundSt = InboundSt 0 Seq.empty Set.empty Map.empty 0 + +objectDiffusionInbound :: + forall objectId object m. + ( Ord objectId + , NoThunks objectId + , NoThunks object + , MonadSTM m + , MonadThrow m + ) => + Tracer m (TraceObjectDiffusionInbound objectId object) -> + -- | Maximum values for outstanding FIFO length, number of IDs to request, + -- and number of objects to request + (NumObjectsOutstanding, NumObjectIdsReq, NumObjectsReq) -> + ObjectPoolWriter objectId object m -> + NodeToNodeVersion -> + ControlMessageSTM m -> + ObjectDiffusionInboundStateView m -> + ObjectDiffusionInboundPipelined objectId object m () +objectDiffusionInbound + tracer + (maxFifoLength, maxNumIdsToReq, maxNumObjectsToReq) + ObjectPoolWriter{..} + _version + controlMessageSTM + state = + ObjectDiffusionInboundPipelined $ do + continueWithStateM (go Zero) initialInboundSt + where + canRequestMoreObjects :: InboundSt k object -> Bool + canRequestMoreObjects st = + not (Set.null (canRequestNext st)) + + -- Computes how many new IDs we can request so that receiving all of them + -- won't make 'outstandingFifo' exceed 'maxFifoLength'. + numIdsToReq :: InboundSt objectId object -> NumObjectIdsReq + numIdsToReq st = + maxNumIdsToReq + `min` ( fromIntegral maxFifoLength + - (fromIntegral $ Seq.length $ outstandingFifo st) + - numIdsInFlight st + ) + + -- Updates 'InboundSt' with new object IDs and return the updated 'InboundSt'. + -- + -- Collected object IDs that are already in the objectPool are pre-emptively + -- acknowledged so that we don't need to bother requesting them from the + -- outbound peer. + preAcknowledge :: + InboundSt objectId object -> + (objectId -> Bool) -> + [objectId] -> + InboundSt objectId object + preAcknowledge st _ collectedIds | null collectedIds = st + preAcknowledge st poolHasObject collectedIds = + let + -- Divide the collected IDs in two parts: those that are already in the + -- objectPool and those that are not. + (alreadyObtained, notYetObtained) = + List.partition + (\objectId -> poolHasObject objectId) + collectedIds + + -- The objects that we intentionally don't request, because they are + -- already in the objectPool, will need to be acknowledged. + -- So we extend 'pendingObjects' with those objects (so of course they + -- have no corresponding reply). + pendingObjects' = + pendingObjects st + <> Map.fromList [(objectId, Nothing) | objectId <- alreadyObtained] + + -- We initially extend 'outstandingFifo' with the all the collected IDs + -- (to properly mirror the server state). + outstandingFifo' = outstandingFifo st <> Seq.fromList collectedIds + + -- Now check if the update of 'pendingObjects' let us acknowledge a prefix + -- of the 'outstandingFifo', as we do in 'goCollect' -> 'CollectObjects'. + (objectIdsToAck, outstandingFifo'') = + Seq.spanl (`Map.member` pendingObjects') outstandingFifo' + + -- If so we can remove them from the 'pendingObjects' structure. + -- + -- Note that unlike in TX-Submission, we made sure the outstanding FIFO + -- couldn't have duplicate IDs, so we don't have to worry about re-adding + -- the duplicate IDs to 'pendingObjects' for future acknowledgment. + pendingObjects'' = + Foldable.foldl' + (flip Map.delete) + pendingObjects' + objectIdsToAck + in + st + { canRequestNext = canRequestNext st <> (Set.fromList notYetObtained) + , pendingObjects = pendingObjects'' + , outstandingFifo = outstandingFifo'' + , numToAckOnNextReq = + numToAckOnNextReq st + + fromIntegral (Seq.length objectIdsToAck) + } + + go :: + forall (n :: N). + Nat n -> + StatefulM (InboundSt objectId object) n objectId object m + go n = StatefulM $ \st -> do + -- Check whether we should continue engaging in the protocol. + ctrlMsg <- atomically controlMessageSTM + traceWith tracer $ TraceObjectDiffusionControlMessage ctrlMsg + case ctrlMsg of + -- The peer selection governor is asking us to terminate the connection. + Terminate -> + pure $ terminateAfterDrain n + -- Otherwise, we can continue the protocol normally. + _continue -> case n of + -- We didn't pipeline any requests, so there are no replies in flight + -- (nothing to collect) + Zero -> do + if canRequestMoreObjects st + then do + -- There are no replies in flight, but we do know some more objects + -- we can ask for, so lets ask for them and more objectIds in a + -- pipelined way. + traceWith tracer (TraceObjectInboundCanRequestMoreObjects (natToInt n)) + pure $ continueWithState (goReqObjectsAndObjectIdsPipelined Zero) st + else do + -- There's no replies in flight, and we have no more objects we can + -- ask for so the only remaining thing to do is to ask for more + -- objectIds. Since this is the only thing to do now, we make this a + -- blocking call. + traceWith tracer (TraceObjectInboundCannotRequestMoreObjects (natToInt n)) + -- Before blocking, signal to the protocol client that we are idling + -- + -- NOTE this change of state should be made explicit: + -- https://github.com/tweag/cardano-peras/issues/144 + Idling.idlingStart (odisvIdling state) + traceWith tracer TraceObjectInboundStartedIdling + pure $ continueWithState goReqObjectIdsBlocking st + + -- We have pipelined some requests, so there are some replies in flight. + Succ n' -> + if canRequestMoreObjects st + then do + -- We have replies in flight and we should eagerly collect them if + -- available, but there are objects to request too so we + -- should *not* block waiting for replies. + -- So we ask for new objects and objectIds in a pipelined way. + traceWith tracer (TraceObjectInboundCanRequestMoreObjects (natToInt n)) + pure $ + CollectPipelined + (Just (continueWithState (goReqObjectsAndObjectIdsPipelined (Succ n')) st)) + (collectAndContinueWithState (goCollect n') st) + else do + traceWith tracer (TraceObjectInboundCannotRequestMoreObjects (natToInt n)) + -- In this case we can theoretically only collect replies or request + -- new object IDs. + -- + -- But it's important not to pipeline more requests for objectIds now + -- because if we did, then immediately after sending the request (but + -- having not yet received a response to either this or the other + -- pipelined requests), we would directly re-enter this code path, + -- resulting us in filling the pipeline with an unbounded number of + -- requests. + -- + -- So we instead block until we collect a reply. + pure $ + CollectPipelined + Nothing + (collectAndContinueWithState (goCollect n') st) + + goCollect :: + forall (n :: N). + Nat n -> + StatefulCollect (InboundSt objectId object) n objectId object m + goCollect n = StatefulCollect $ \st collect -> case collect of + CollectObjectIds numIdsRequested collectedIds -> do + let numCollectedIds = length collectedIds + collectedIdsSet = Set.fromList collectedIds + + -- Check they didn't send more than we asked for. We don't need to + -- check for a minimum: the blocking case checks for non-zero + -- elsewhere, and for the non-blocking case it is quite normal for + -- them to send us none. + when (numCollectedIds > fromIntegral numIdsRequested) $ + throwIO ProtocolErrorObjectIdsNotRequested + + -- Check that the server didn't send IDs that were already in the + -- outstanding FIFO + when (any (`Set.member` collectedIdsSet) (outstandingFifo st)) $ + throwIO ProtocolErrorObjectIdAlreadyKnown + + -- Check that the server didn't send duplicate IDs in its response + when (Set.size collectedIdsSet /= numCollectedIds) $ + throwIO ProtocolErrorObjectIdsDuplicate + + -- We extend our outstanding FIFO with the newly received objectIds by + -- calling 'preAcknowledge' which will also pre-emptively acknowledge the + -- objectIds that we already have in the pool and thus don't need to + -- request. + let st' = st{numIdsInFlight = numIdsInFlight st - numIdsRequested} + poolHasObject <- atomically $ opwHasObject + continueWithStateM + (go n) + (preAcknowledge st' poolHasObject collectedIds) + CollectObjects requestedIds collectedObjects -> do + let requestedIdsSet = Set.fromList requestedIds + obtainedIdsSet = Set.fromList (opwObjectId <$> collectedObjects) + + -- To start with we have to verify that the objects they have sent us are + -- exactly the objects we asked for, not more, not less. + when (requestedIdsSet /= obtainedIdsSet) $ + throwIO ProtocolErrorObjectNotRequested + + traceWith tracer $ + TraceObjectDiffusionCollected (length collectedObjects) + + -- We update 'pendingObjects' with the newly obtained objects + let newPendingObjects :: Map objectId (Maybe object) + newPendingObjects = Map.fromList [(opwObjectId obj, Just obj) | obj <- collectedObjects] + pendingObjects' = pendingObjects st <> newPendingObjects + + -- We then find the longest prefix of 'outstandingFifo' for which we have + -- all the corresponding IDs in 'pendingObjects'. + -- We remove this prefix from 'outstandingFifo'. + (objectIdsToAck, outstandingFifo') = + Seq.spanl (`Map.member` pendingObjects') (outstandingFifo st) + + -- And also remove these entries from 'pendingObjects'. + -- + -- Note that unlike in TX-Submission, we made sure the outstanding FIFO + -- couldn't have duplicate IDs, so we don't have to worry about re-adding + -- the duplicate IDs to 'pendingObjects' for future acknowledgment. + pendingObjects'' = + Foldable.foldl' + (flip Map.delete) + pendingObjects' + objectIdsToAck + + -- These are the objects we need to submit to the object pool + objectsToAck = + catMaybes $ + (((Map.!) pendingObjects') <$> toList objectIdsToAck) + + -- TODO: Certificate / Vote validation + + opwAddObjects objectsToAck + traceWith tracer $ + TraceObjectDiffusionProcessed + (NumObjectsProcessed (fromIntegral $ length objectsToAck)) + continueWithStateM + (go n) + st + { pendingObjects = pendingObjects'' + , outstandingFifo = outstandingFifo' + , numToAckOnNextReq = + numToAckOnNextReq st + + fromIntegral (Seq.length objectIdsToAck) + } + + goReqObjectIdsBlocking :: Stateful (InboundSt objectId object) 'Z objectId object m + goReqObjectIdsBlocking = Stateful $ \st -> do + let numIdsToRequest = numIdsToReq st + -- We should only request new object IDs in a blocking way if we have + -- absolutely nothing else we can do. + assert + ( numIdsInFlight st == 0 + && Seq.null (outstandingFifo st) + && Set.null (canRequestNext st) + && Map.null (pendingObjects st) + ) + $ SendMsgRequestObjectIdsBlocking + (numToAckOnNextReq st) + numIdsToRequest + ( \neCollectedIds -> do + -- We just got some new object id's, so we are no longer idling + -- + -- NOTE this change of state should be made explicit: + -- https://github.com/tweag/cardano-peras/issues/144 + Idling.idlingStop (odisvIdling state) + traceWith tracer TraceObjectInboundStoppedIdling + collectAndContinueWithState + (goCollect Zero) + st + { numToAckOnNextReq = 0 + , numIdsInFlight = numIdsToRequest + } + (CollectObjectIds numIdsToRequest (NonEmpty.toList neCollectedIds)) + ) + + goReqObjectsAndObjectIdsPipelined :: + forall (n :: N). + Nat n -> + Stateful (InboundSt objectId object) n objectId object m + goReqObjectsAndObjectIdsPipelined n = Stateful $ \st -> do + -- TODO: This implementation is deliberately naive, we pick in an + -- arbitrary order. We may want to revisit this later. + let (toRequest, canRequestNext') = + Set.splitAt (fromIntegral maxNumObjectsToReq) (canRequestNext st) + + SendMsgRequestObjectsPipelined + (toList toRequest) + ( continueWithStateM + (goReqObjectIdsPipelined (Succ n)) + st{canRequestNext = canRequestNext'} + ) + + goReqObjectIdsPipelined :: + forall (n :: N). + Nat n -> + StatefulM (InboundSt objectId object) n objectId object m + goReqObjectIdsPipelined n = StatefulM $ \st -> do + let numIdsToRequest = numIdsToReq st + + if numIdsToRequest <= 0 + then continueWithStateM (go n) st + else + pure $ + SendMsgRequestObjectIdsPipelined + (numToAckOnNextReq st) + numIdsToRequest + ( continueWithStateM + (go (Succ n)) + st + { numIdsInFlight = + numIdsInFlight st + + numIdsToRequest + , numToAckOnNextReq = 0 + } + ) + + -- Ignore all outstanding replies to messages we pipelined ("drain"), and then + -- terminate. + terminateAfterDrain :: + Nat n -> InboundStIdle n objectId object m () + terminateAfterDrain = \case + Zero -> SendMsgDone (pure ()) + Succ n -> CollectPipelined Nothing $ \_ignoredMsg -> pure $ terminateAfterDrain n + +------------------------------------------------------------------------------- +-- Utilities to deal with stateful continuations (copied from TX-submission) +------------------------------------------------------------------------------- + +newtype Stateful s n objectId object m = Stateful (s -> InboundStIdle n objectId object m ()) + +newtype StatefulM s n objectId object m + = StatefulM (s -> m (InboundStIdle n objectId object m ())) + +newtype StatefulCollect s n objectId object m + = StatefulCollect (s -> Collect objectId object -> m (InboundStIdle n objectId object m ())) + +-- | After checking that there are no unexpected thunks in the provided state, +-- pass it to the provided function. +-- +-- See 'checkInvariant' and 'unsafeNoThunks'. +continueWithState :: + NoThunks s => + Stateful s n objectId object m -> + s -> + InboundStIdle n objectId object m () +continueWithState (Stateful f) !st = + checkInvariant (show <$> unsafeNoThunks st) (f st) + +-- | A variant of 'continueWithState' to be more easily utilized with +-- 'inboundIdle' and 'inboundReqObjectIds'. +continueWithStateM :: + NoThunks s => + StatefulM s n objectId object m -> + s -> + m (InboundStIdle n objectId object m ()) +continueWithStateM (StatefulM f) !st = + checkInvariant (show <$> unsafeNoThunks st) (f st) +{-# NOINLINE continueWithStateM #-} + +-- | A variant of 'continueWithState' to be more easily utilized with +-- 'handleReply'. +collectAndContinueWithState :: + NoThunks s => + StatefulCollect s n objectId object m -> + s -> + Collect objectId object -> + m (InboundStIdle n objectId object m ()) +collectAndContinueWithState (StatefulCollect f) !st c = + checkInvariant (show <$> unsafeNoThunks st) (f st c) +{-# NOINLINE collectAndContinueWithState #-} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs new file mode 100644 index 0000000000..58402da64f --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State + ( ObjectDiffusionInboundState (..) + , initObjectDiffusionInboundState + , ObjectDiffusionInboundHandle (..) + , ObjectDiffusionInboundHandleCollection (..) + , ObjectDiffusionInboundStateView (..) + , newObjectDiffusionInboundHandleCollection + , bracketObjectDiffusionInbound + ) +where + +import Control.Monad.Class.MonadThrow (bracket) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block (BlockSupportsProtocol, HasHeader, Header) +import Ouroboros.Consensus.MiniProtocol.Util.Idling (Idling (..)) +import Ouroboros.Consensus.Node.NetworkProtocolVersion (NodeToNodeVersion) +import Ouroboros.Consensus.Util.IOLike + ( IOLike (..) + , MonadSTM (..) + , StrictTVar + , modifyTVar + , newTVar + , newTVarIO + , readTVar + ) + +-- | An ObjectDiffusion inbound client state that's used by other components. +-- +-- NOTE: 'blk' is not needed for now, but we keep it for future use. +data ObjectDiffusionInboundState blk = ObjectDiffusionInboundState + { odisIdling :: !Bool + -- ^ Whether the client is currently idling + , odisNodeToNodeVersion :: !NodeToNodeVersion + -- ^ Negotiated version of the protocol with the peer. + -- + -- This is used to determine later on whether other mini-protocols are + -- expected to run in parallel with this one. + } + deriving stock Generic + +deriving anyclass instance + ( HasHeader blk + , NoThunks (Header blk) + ) => + NoThunks (ObjectDiffusionInboundState blk) + +initObjectDiffusionInboundState :: NodeToNodeVersion -> ObjectDiffusionInboundState blk +initObjectDiffusionInboundState version = + ObjectDiffusionInboundState + { odisIdling = True + , odisNodeToNodeVersion = version + } + +-- | An interface to an ObjectDiffusion inbound client that's used by other components. +data ObjectDiffusionInboundHandle m blk = ObjectDiffusionInboundHandle + { odihState :: !(StrictTVar m (ObjectDiffusionInboundState blk)) + -- ^ Data shared between the client and external components. + } + deriving stock Generic + +deriving anyclass instance + ( IOLike m + , HasHeader blk + , NoThunks (Header blk) + ) => + NoThunks (ObjectDiffusionInboundHandle m blk) + +-- | A collection of ObjectDiffusion inbound client handles for the peers of this node. +data ObjectDiffusionInboundHandleCollection peer m blk = ObjectDiffusionInboundHandleCollection + { odihcMap :: !(STM m (Map peer (ObjectDiffusionInboundHandle m blk))) + -- ^ A map containing the handles for the peers in the collection + , odihcAddHandle :: !(peer -> ObjectDiffusionInboundHandle m blk -> STM m ()) + -- ^ Add the handle for the given peer to the collection + , odihcRemoveHandle :: !(peer -> STM m ()) + -- ^ Remove the handle for the given peer from the collection + } + deriving stock Generic + +newObjectDiffusionInboundHandleCollection :: + (Ord peer, IOLike m, NoThunks peer, BlockSupportsProtocol blk) => + STM m (ObjectDiffusionInboundHandleCollection peer m blk) +newObjectDiffusionInboundHandleCollection = do + handlesMap <- newTVar mempty + return + ObjectDiffusionInboundHandleCollection + { odihcMap = readTVar handlesMap + , odihcAddHandle = \peer handle -> + modifyTVar handlesMap (Map.insert peer handle) + , odihcRemoveHandle = \peer -> + modifyTVar handlesMap (Map.delete peer) + } + +-- | Interface for the ObjectDiffusion client to its state allocated by +-- 'bracketObjectDiffusionInbound'. +data ObjectDiffusionInboundStateView m = ObjectDiffusionInboundStateView + { odisvIdling :: !(Idling m) + } + deriving stock Generic + +bracketObjectDiffusionInbound :: + forall m peer blk a. + (IOLike m, HasHeader blk, NoThunks (Header blk)) => + NodeToNodeVersion -> + ObjectDiffusionInboundHandleCollection peer m blk -> + peer -> + (ObjectDiffusionInboundStateView m -> m a) -> + m a +bracketObjectDiffusionInbound version handles peer body = do + odiState <- newTVarIO (initObjectDiffusionInboundState version) + bracket (acquireContext odiState) releaseContext body + where + acquireContext odiState = atomically $ do + odihcAddHandle handles peer $ + ObjectDiffusionInboundHandle + { odihState = odiState + } + return + ObjectDiffusionInboundStateView + { odisvIdling = + Idling + { idlingStart = atomically $ modifyTVar odiState $ \s -> s{odisIdling = True} + , idlingStop = atomically $ modifyTVar odiState $ \s -> s{odisIdling = False} + } + } + + releaseContext _ = atomically $ do + odihcRemoveHandle handles peer diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs new file mode 100644 index 0000000000..2f949d8b3b --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs @@ -0,0 +1,59 @@ +-- | API for reading from and writing to object pools in the ObjectDiffusion +-- miniprotocol. +-- +-- The underlying object pool can be any database, such as a 'PerasCertDb' in +-- Peras certificate diffusion. +-- +-- 'ObjectPoolReader' is used on the outbound side of the protocol. Objects in +-- the pool are ordered by a strictly increasing ticket number ('ticketNo'), +-- which represents their time of arrival. Ticket numbers are local to each +-- node, unlike object IDs, which are global. Object IDs are not used for +-- ordering, since objects may arrive slightly out of order from peers. +-- +-- To read from the pool, one requests objects with a ticket number strictly +-- greater than the last known one. 'oprZeroTicketNo' provides an initial ticket +-- number for the first request. +-- +-- 'ObjectPoolWriter' is used on the inbound side of the protocol. It allows +-- checking whether an object is already present (to avoid re-requesting it) and +-- appending new objects. Ticket numbers are not part of the inbound interface, +-- but are used internally: newly added objects always receive a ticket number +-- strictly greater than those of older ones. +-- +-- This API design is inspired by 'MempoolSnapshot' from the TX-submission +-- miniprotocol, see: +-- +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API + ( ObjectPoolReader (..) + , ObjectPoolWriter (..) + ) where + +import Control.Concurrent.Class.MonadSTM.Strict (STM) +import Data.Word (Word64) + +-- | Interface used by the outbound side of object diffusion as its source of +-- objects to give to the remote side. +data ObjectPoolReader objectId object ticketNo m + = ObjectPoolReader + { oprObjectId :: object -> objectId + -- ^ Return the id of the specified object + , oprZeroTicketNo :: ticketNo + -- ^ Ticket number before the first item in the pool. + , oprObjectsAfter :: ticketNo -> Word64 -> STM m [(ticketNo, objectId, m object)] + -- ^ Get the list of objects available in the pool with a ticketNo greater + -- than the specified one. The number of returned objects is capped by the + -- given Word64. Only the IDs and ticketNos of the objects are directly + -- accessible; each actual object must be loaded through a monadic action. + } + +-- | Interface used by the inbound side of object diffusion when receiving +-- objects. +data ObjectPoolWriter objectId object m + = ObjectPoolWriter + { opwObjectId :: object -> objectId + -- ^ Return the id of the specified object + , opwAddObjects :: [object] -> m () + -- ^ Add a batch of objects to the objectPool. + , opwHasObject :: STM m (objectId -> Bool) + -- ^ Check if the object pool contains an object with the given id + } 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 new file mode 100644 index 0000000000..f4f0cb5562 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | Instantiate 'ObjectPoolReader' and 'ObjectPoolWriter' using Peras +-- certificates from the 'PerasCertDB' (or the 'ChainDB' which is wrapping the +-- 'PerasCertDB'). +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert + ( makePerasCertPoolReaderFromCertDB + , makePerasCertPoolWriterFromCertDB + , makePerasCertPoolReaderFromChainDB + , makePerasCertPoolWriterFromChainDB + ) where + +import Control.Monad ((>=>)) +import GHC.Exception (throw) +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime (WithArrivalTime) +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (SystemTime (..), addArrivalTime) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) +import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB +import Ouroboros.Consensus.Storage.PerasCertDB.API + ( PerasCertDB + , PerasCertSnapshot + , PerasCertTicketNo + ) +import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB +import Ouroboros.Consensus.Util.IOLike + +makePerasCertPoolReaderFromSnapshot :: + (IOLike m, StandardHash blk) => + STM m (PerasCertSnapshot blk) -> + ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m +makePerasCertPoolReaderFromSnapshot getCertSnapshot = + ObjectPoolReader + { oprObjectId = getPerasCertRound + , oprZeroTicketNo = PerasCertDB.zeroPerasCertTicketNo + , oprObjectsAfter = \lastKnown limit -> do + certSnapshot <- getCertSnapshot + pure $ + take (fromIntegral limit) $ + [ (ticketNo, getPerasCertRound cert, pure (getPerasCert cert)) + | (cert, ticketNo) <- PerasCertDB.getCertsAfter certSnapshot lastKnown + ] + } + +makePerasCertPoolReaderFromCertDB :: + (IOLike m, StandardHash blk) => + PerasCertDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m +makePerasCertPoolReaderFromCertDB perasCertDB = + makePerasCertPoolReaderFromSnapshot (PerasCertDB.getCertSnapshot perasCertDB) + +makePerasCertPoolWriterFromCertDB :: + (StandardHash blk, IOLike m) => + SystemTime m -> + PerasCertDB m blk -> + ObjectPoolWriter PerasRoundNo (PerasCert blk) m +makePerasCertPoolWriterFromCertDB systemTime perasCertDB = + ObjectPoolWriter + { opwObjectId = getPerasCertRound + , opwAddObjects = addPerasCerts systemTime (PerasCertDB.addCert perasCertDB) + , opwHasObject = do + certSnapshot <- PerasCertDB.getCertSnapshot perasCertDB + pure $ PerasCertDB.containsCert certSnapshot + } + +makePerasCertPoolReaderFromChainDB :: + (IOLike m, StandardHash blk) => + ChainDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m +makePerasCertPoolReaderFromChainDB chainDB = + makePerasCertPoolReaderFromSnapshot (ChainDB.getPerasCertSnapshot chainDB) + +makePerasCertPoolWriterFromChainDB :: + (StandardHash blk, IOLike m) => + SystemTime m -> + ChainDB m blk -> + ObjectPoolWriter PerasRoundNo (PerasCert blk) m +makePerasCertPoolWriterFromChainDB systemTime chainDB = + ObjectPoolWriter + { opwObjectId = getPerasCertRound + , opwAddObjects = addPerasCerts systemTime (ChainDB.addPerasCertAsync chainDB) + , opwHasObject = do + certSnapshot <- ChainDB.getPerasCertSnapshot chainDB + pure $ PerasCertDB.containsCert certSnapshot + } + +data PerasCertInboundException + = forall blk. PerasCertValidationError (PerasValidationErr blk) + +deriving instance Show PerasCertInboundException + +instance Exception PerasCertInboundException + +-- | Validate a list of 'PerasCert's, throwing a 'PerasCertInboundException' if +-- any of them are invalid. +validatePerasCerts :: + (StandardHash blk, MonadThrow m) => + [PerasCert blk] -> + m [ValidatedPerasCert blk] +validatePerasCerts certs = do + let perasCfg = makePerasCfg Nothing + -- TODO replace the mocked-up Nothing with a real + -- 'BlockConfig' when all the plumbing is in place + case traverse (validatePerasCert perasCfg) certs of + Left validationErr -> throw (PerasCertValidationError validationErr) + Right validatedCerts -> return validatedCerts + +-- | Add a list of 'PerasCert's into an object pool. +-- +-- NOTE: we first validate the certificates, throwing an exception if any of +-- them are invalid. We then wrap them with their arrival time, and finally add +-- them to the pool using the provided adder function. +-- +-- The order of the first two operations (i.e., validation and timestamping) are +-- rather arbitrary, and the abstract Peras protocol just assumes it can happen +-- "within" a slot. +addPerasCerts :: + (StandardHash blk, MonadThrow m) => + SystemTime m -> + (WithArrivalTime (ValidatedPerasCert blk) -> m a) -> + [PerasCert blk] -> + m () +addPerasCerts systemTime adder = do + validatePerasCerts + >=> mapM (addArrivalTime systemTime) + >=> mapM_ adder diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs new file mode 100644 index 0000000000..34c90b9836 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound + ( objectDiffusionOutbound + , TraceObjectDiffusionOutbound (..) + , ObjectDiffusionOutboundError (..) + ) where + +import Control.Exception (assert) +import Control.Monad (forM, unless, when) +import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadThrow +import Control.Tracer (Tracer, traceWith) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict qualified as Seq +import Data.Set qualified as Set +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound +import Ouroboros.Network.Protocol.ObjectDiffusion.Type + +-- Note: This module is inspired from TxSubmission outbound side. + +data TraceObjectDiffusionOutbound objectId object + = TraceObjectDiffusionOutboundRecvMsgRequestObjectIds NumObjectIdsReq + | -- | The IDs to be sent in the response + TraceObjectDiffusionOutboundSendMsgReplyObjectIds [objectId] + | -- | The IDs of the objects requested. + TraceObjectDiffusionOutboundRecvMsgRequestObjects + [objectId] + | -- | The objects to be sent in the response. + TraceObjectDiffusionOutboundSendMsgReplyObjects + [object] + | -- | Received 'MsgDone' + TraceObjectDiffusionOutboundTerminated + deriving Show + +data ObjectDiffusionOutboundError + = ProtocolErrorAckedTooManyObjectIds + | ProtocolErrorRequestedNothing + | ProtocolErrorRequestedTooManyObjectIds NumObjectIdsReq NumObjectsOutstanding + | ProtocolErrorRequestBlocking + | ProtocolErrorRequestNonBlocking + | ProtocolErrorRequestedUnavailableObject + | ProtocolErrorRequestedDuplicateObject + deriving Show + +instance Exception ObjectDiffusionOutboundError where + displayException ProtocolErrorAckedTooManyObjectIds = + "The peer tried to acknowledged more objectIds than are available to do so." + displayException (ProtocolErrorRequestedTooManyObjectIds reqNo maxUnacked) = + "The peer requested " + ++ show reqNo + ++ " objectIds which would put the " + ++ "total in flight over the limit of " + ++ show maxUnacked + displayException ProtocolErrorRequestedNothing = + "The peer requested zero objectIds." + displayException ProtocolErrorRequestBlocking = + "The peer made a blocking request for more objectIds when there are still " + ++ "unacknowledged objectIds. It should have used a non-blocking request." + displayException ProtocolErrorRequestNonBlocking = + "The peer made a non-blocking request for more objectIds when there are " + ++ "no unacknowledged objectIds. It should have used a blocking request." + displayException ProtocolErrorRequestedUnavailableObject = + "The peer requested an object which is not available, either " + ++ "because it was never available or because it was previously requested." + displayException ProtocolErrorRequestedDuplicateObject = + "The peer requested the same object twice." + +data OutboundSt objectId object ticketNo = OutboundSt + { outstandingFifo :: !(StrictSeq object) + , lastTicketNo :: !ticketNo + } + +objectDiffusionOutbound :: + forall objectId object ticketNo m. + (Ord objectId, Ord ticketNo, MonadSTM m, MonadThrow m) => + Tracer m (TraceObjectDiffusionOutbound objectId object) -> + -- | Maximum number of unacknowledged objectIds allowed + NumObjectsOutstanding -> + ObjectPoolReader objectId object ticketNo m -> + NodeToNodeVersion -> + ObjectDiffusionOutbound objectId object m () +objectDiffusionOutbound tracer maxFifoLength ObjectPoolReader{..} _version = + ObjectDiffusionOutbound (pure (makeBundle $ OutboundSt Seq.empty oprZeroTicketNo)) + where + makeBundle :: OutboundSt objectId object ticketNo -> OutboundStIdle objectId object m () + makeBundle !st = + OutboundStIdle + { recvMsgRequestObjectIds = recvMsgRequestObjectIds st + , recvMsgRequestObjects = recvMsgRequestObjects st + , recvMsgDone = traceWith tracer TraceObjectDiffusionOutboundTerminated + } + + updateStNewObjects :: + OutboundSt objectId object ticketNo -> + [(object, ticketNo)] -> + OutboundSt objectId object ticketNo + updateStNewObjects !OutboundSt{..} newObjectsWithTicketNos = + -- These objects should all be fresh + assert (all (\(_, ticketNo) -> ticketNo > lastTicketNo) newObjectsWithTicketNos) $ + let !outstandingFifo' = + outstandingFifo + <> (Seq.fromList $ fst <$> newObjectsWithTicketNos) + !lastTicketNo' + | null newObjectsWithTicketNos = lastTicketNo + | otherwise = snd $ last newObjectsWithTicketNos + in OutboundSt + { outstandingFifo = outstandingFifo' + , lastTicketNo = lastTicketNo' + } + + recvMsgRequestObjectIds :: + forall blocking. + OutboundSt objectId object ticketNo -> + SingBlockingStyle blocking -> + NumObjectIdsAck -> + NumObjectIdsReq -> + m (OutboundStObjectIds blocking objectId object m ()) + recvMsgRequestObjectIds !st@OutboundSt{..} blocking numIdsToAck numIdsToReq = do + traceWith tracer (TraceObjectDiffusionOutboundRecvMsgRequestObjectIds numIdsToReq) + + when (numIdsToAck > fromIntegral (Seq.length outstandingFifo)) $ + throwIO ProtocolErrorAckedTooManyObjectIds + + when + ( Seq.length outstandingFifo + - fromIntegral numIdsToAck + + fromIntegral numIdsToReq + > fromIntegral maxFifoLength + ) + $ throwIO (ProtocolErrorRequestedTooManyObjectIds numIdsToReq maxFifoLength) + + -- First we update our FIFO to remove the number of objectIds that the + -- inbound peer has acknowledged. + let !outstandingFifo' = Seq.drop (fromIntegral numIdsToAck) outstandingFifo + -- must specify the type here otherwise GHC complains about mismatch objectId types + st' :: OutboundSt objectId object ticketNo + !st' = st{outstandingFifo = outstandingFifo'} + + -- Grab info about any new objects after the last object ticketNo we've + -- seen, up to the number that the peer has requested. + case blocking of + ----------------------------------------------------------------------- + SingBlocking -> do + when (numIdsToReq == 0) $ + throwIO ProtocolErrorRequestedNothing + unless (Seq.null outstandingFifo') $ + throwIO ProtocolErrorRequestBlocking + + newContent <- atomically $ do + newObjectsWithTicketNos <- + oprObjectsAfter + lastTicketNo + (fromIntegral numIdsToReq) + check (not $ null newObjectsWithTicketNos) + pure newObjectsWithTicketNos + + newObjectsWithTicketNos <- forM newContent $ + \(ticketNo, _, getObject) -> do + object <- getObject + pure (object, ticketNo) + + let !newIds = oprObjectId . fst <$> newObjectsWithTicketNos + st'' = updateStNewObjects st' newObjectsWithTicketNos + + traceWith tracer (TraceObjectDiffusionOutboundSendMsgReplyObjectIds newIds) + + -- Assert objects is non-empty: we blocked until objects was + -- non-null, and we know numIdsToReq > 0, hence + -- `take numIdsToReq objects` is non-null. + assert (not $ null newObjectsWithTicketNos) $ + pure $ + SendMsgReplyObjectIds + (BlockingReply (NonEmpty.fromList $ newIds)) + (makeBundle st'') + + ----------------------------------------------------------------------- + SingNonBlocking -> do + when (numIdsToReq == 0 && numIdsToAck == 0) $ + throwIO ProtocolErrorRequestedNothing + when (Seq.null outstandingFifo') $ + throwIO ProtocolErrorRequestNonBlocking + + newContent <- + atomically $ + oprObjectsAfter lastTicketNo (fromIntegral numIdsToReq) + newObjectsWithTicketNos <- forM newContent $ + \(ticketNo, _, getObject) -> do + object <- getObject + pure (object, ticketNo) + + let !newIds = oprObjectId . fst <$> newObjectsWithTicketNos + st'' = updateStNewObjects st' newObjectsWithTicketNos + + traceWith tracer (TraceObjectDiffusionOutboundSendMsgReplyObjectIds newIds) + + pure (SendMsgReplyObjectIds (NonBlockingReply newIds) (makeBundle st'')) + + recvMsgRequestObjects :: + OutboundSt objectId object ticketNo -> + [objectId] -> + m (OutboundStObjects objectId object m ()) + recvMsgRequestObjects !st@OutboundSt{..} requestedIds = do + traceWith tracer (TraceObjectDiffusionOutboundRecvMsgRequestObjects requestedIds) + + -- All the objects correspond to advertised objectIds are already in the + -- outstandingFifo. So we don't need to read from the object pool here. + + -- I've optimized the search to do only one traversal of 'outstandingFifo'. + -- When the 'requestedIds' is exactly the whole 'outstandingFifo', then this + -- should take O(n * log n) time. + -- + -- TODO: We might need to revisit the underlying 'outstandingFifo' data + -- structure and the search if performance isn't sufficient when we'll use + -- ObjectDiffusion for votes diffusion (and not just cert diffusion). + + let requestedIdsSet = Set.fromList requestedIds + + when (Set.size requestedIdsSet /= length requestedIds) $ + throwIO ProtocolErrorRequestedDuplicateObject + + let requestedObjects = + foldr + ( \obj acc -> + if Set.member (oprObjectId obj) requestedIdsSet + then obj : acc + else acc + ) + [] + outstandingFifo + + when (Set.size requestedIdsSet /= length requestedObjects) $ + throwIO ProtocolErrorRequestedUnavailableObject + + traceWith tracer (TraceObjectDiffusionOutboundSendMsgReplyObjects requestedObjects) + + pure (SendMsgReplyObjects requestedObjects (makeBundle st)) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs new file mode 100644 index 0000000000..5c024618b0 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs @@ -0,0 +1,54 @@ +-- | This module defines type aliases for the ObjectDiffusion protocol applied +-- to PerasCert diffusion. +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert + ( TracePerasCertDiffusionInbound + , TracePerasCertDiffusionOutbound + , PerasCertPoolReader + , PerasCertPoolWriter + , PerasCertDiffusionInboundPipelined + , PerasCertDiffusionOutbound + , PerasCertDiffusion + , PerasCertDiffusionInboundState + , PerasCertDiffusionInboundHandle + , PerasCertDiffusionInboundHandleCollection + ) where + +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound +import Ouroboros.Consensus.Storage.PerasCertDB.API +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound (ObjectDiffusionInboundPipelined) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (ObjectDiffusionOutbound) +import Ouroboros.Network.Protocol.ObjectDiffusion.Type (ObjectDiffusion) + +type TracePerasCertDiffusionInbound blk = + TraceObjectDiffusionInbound PerasRoundNo (PerasCert blk) + +type TracePerasCertDiffusionOutbound blk = + TraceObjectDiffusionOutbound PerasRoundNo (PerasCert blk) + +type PerasCertPoolReader blk m = + ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m + +type PerasCertPoolWriter blk m = + ObjectPoolWriter PerasRoundNo (PerasCert blk) m + +type PerasCertDiffusionInboundPipelined blk m a = + ObjectDiffusionInboundPipelined PerasRoundNo (PerasCert blk) m a + +type PerasCertDiffusionOutbound blk m a = + ObjectDiffusionOutbound PerasRoundNo (PerasCert blk) m a + +type PerasCertDiffusion blk = + ObjectDiffusion PerasRoundNo (PerasCert blk) + +type PerasCertDiffusionInboundState blk = + ObjectDiffusionInboundState blk + +type PerasCertDiffusionInboundHandle m blk = + ObjectDiffusionInboundHandle m blk + +type PerasCertDiffusionInboundHandleCollection peer m blk = + ObjectDiffusionInboundHandleCollection peer m blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util.hs new file mode 100644 index 0000000000..58fa7d2161 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util.hs @@ -0,0 +1,5 @@ +module Ouroboros.Consensus.MiniProtocol.Util + ( module Ouroboros.Consensus.MiniProtocol.Util.Idling + ) where + +import Ouroboros.Consensus.MiniProtocol.Util.Idling diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util/Idling.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util/Idling.hs new file mode 100644 index 0000000000..3962d26dd6 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util/Idling.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Ouroboros.Consensus.MiniProtocol.Util.Idling + ( Idling (..) + , noIdling + ) where + +import GHC.Generics (Generic) +import Ouroboros.Consensus.Util.IOLike (IOLike, NoThunks) + +-- | Interface to manipulate the idling flag in the client state of a peer. +data Idling m = Idling + { idlingStart :: !(m ()) + -- ^ Mark the peer as being idle. + , idlingStop :: !(m ()) + -- ^ Mark the peer as not being idle. + } + deriving stock Generic + +deriving anyclass instance IOLike m => NoThunks (Idling m) + +-- | No-op implementation, for tests. +noIdling :: Applicative m => Idling m +noIdling = + Idling + { idlingStart = pure () + , idlingStop = pure () + } 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 6520aae47c..6a4fc87229 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs @@ -6,8 +6,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -- | Serialisation for sending things across the network. @@ -33,8 +36,8 @@ module Ouroboros.Consensus.Node.Serialisation , Some (..) ) where -import Codec.CBOR.Decoding (Decoder) -import Codec.CBOR.Encoding (Encoding) +import Codec.CBOR.Decoding (Decoder, decodeListLenOf) +import Codec.CBOR.Encoding (Encoding, encodeListLen) import Codec.Serialise (Serialise (decode, encode)) import Data.Kind import Data.SOP.BasicFunctors @@ -47,7 +50,15 @@ import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (Some (..)) -import Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR) +import Ouroboros.Network.Block + ( Tip + , decodePoint + , decodeTip + , encodePoint + , encodeTip + , unwrapCBORinCBOR + , wrapCBORinCBOR + ) {------------------------------------------------------------------------------- NodeToNode @@ -173,6 +184,29 @@ deriving newtype instance SerialiseNodeToNode blk (GenTxId blk) => SerialiseNodeToNode blk (WrapGenTxId blk) +instance ConvertRawHash blk => SerialiseNodeToNode blk (Point blk) where + encodeNodeToNode _ccfg _version = encodePoint $ encodeRawHash (Proxy @blk) + decodeNodeToNode _ccfg _version = decodePoint $ decodeRawHash (Proxy @blk) + +instance ConvertRawHash blk => SerialiseNodeToNode blk (Tip blk) where + encodeNodeToNode _ccfg _version = encodeTip $ encodeRawHash (Proxy @blk) + decodeNodeToNode _ccfg _version = decodeTip $ decodeRawHash (Proxy @blk) + +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 + deriving newtype instance SerialiseNodeToClient blk (GenTxId blk) => SerialiseNodeToClient blk (WrapGenTxId blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs new file mode 100644 index 0000000000..7895a38a93 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Ouroboros.Consensus.Peras.SelectView + ( -- * 'WeightedSelectView' + WeightedSelectView (..) + , wsvTotalWeight + , weightedSelectView + + -- * Utility: 'WithEmptyFragment' + , WithEmptyFragment (..) + , withEmptyFragmentFromMaybe + , withEmptyFragmentToMaybe + ) where + +import Data.Function (on) +import Data.Word (Word64) +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Peras.Weight +import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import qualified Ouroboros.Network.AnchoredFragment as AF + +{------------------------------------------------------------------------------- + Weighted select views +-------------------------------------------------------------------------------} + +-- | Information from a non-empty chain fragment for a weighted chain comparison +-- against other fragments with the same anchor. +data WeightedSelectView proto = WeightedSelectView + { wsvLength :: !Word64 + -- ^ The length of the fragment. + -- + -- If we ignore EBBs, then it would be equivalent to use the tip 'BlockNo' + -- here. However, with EBBs, the 'BlockNo' can result in misleading + -- comparisons if only one fragment contains EBBs. + , wsvWeightBoost :: !PerasWeight + -- ^ The weight boost of a fragment (w.r.t. a particular anchor). + , wsvTiebreaker :: TiebreakerView proto + -- ^ Lazy because it is only needed when 'wsvTotalWeight' is inconclusive. + } + +deriving stock instance Show (TiebreakerView proto) => Show (WeightedSelectView proto) +deriving stock instance Eq (TiebreakerView proto) => Eq (WeightedSelectView proto) + +-- TODO: More type safety to prevent people from accidentally comparing +-- 'WeightedSelectView's obtained from fragments with different anchors? +-- Something ST-trick like? + +-- | The total weight, ie the sum of 'wsvLength' and 'wsvBoostedWeight'. +wsvTotalWeight :: WeightedSelectView proto -> PerasWeight +-- could be cached, but then we need to be careful to maintain the invariant +wsvTotalWeight wsv = + PerasWeight (wsvLength wsv) <> wsvWeightBoost wsv + +instance Ord (TiebreakerView proto) => Ord (WeightedSelectView proto) where + compare = + mconcat + [ compare `on` wsvTotalWeight + , compare `on` wsvTiebreaker + ] + +instance ChainOrder (TiebreakerView proto) => ChainOrder (WeightedSelectView proto) where + type ChainOrderConfig (WeightedSelectView proto) = ChainOrderConfig (TiebreakerView proto) + + preferCandidate cfg ours cand = + case compare (wsvTotalWeight ours) (wsvTotalWeight cand) of + LT -> True + EQ -> preferCandidate cfg (wsvTiebreaker ours) (wsvTiebreaker cand) + GT -> False + +-- | Get the 'WeightedSelectView' for a fragment using the given +-- 'PerasWeightSnapshot'. Note that this is only meanigful for comparisons +-- against other fragments /with the same anchor/. +-- +-- Returns 'EmptyFragment' iff the input fragment is empty. +weightedSelectView :: + ( GetHeader1 h + , HasHeader (h blk) + , HeaderHash blk ~ HeaderHash (h blk) + , BlockSupportsProtocol blk + ) => + BlockConfig blk -> + PerasWeightSnapshot blk -> + AnchoredFragment (h blk) -> + WithEmptyFragment (WeightedSelectView (BlockProtocol blk)) +weightedSelectView bcfg weights = \case + AF.Empty{} -> EmptyFragment + frag@(_ AF.:> (getHeader1 -> hdr)) -> + NonEmptyFragment + WeightedSelectView + { wsvLength = fromIntegral @Int @Word64 $ AF.length frag + , wsvWeightBoost = weightBoostOfFragment weights frag + , wsvTiebreaker = tiebreakerView bcfg hdr + } + +{------------------------------------------------------------------------------- + WithEmptyFragment +-------------------------------------------------------------------------------} + +-- | Attach the possibility of an empty fragment to a type. +data WithEmptyFragment a = EmptyFragment | NonEmptyFragment !a + deriving stock (Show, Eq) + +withEmptyFragmentToMaybe :: WithEmptyFragment a -> Maybe a +withEmptyFragmentToMaybe = \case + EmptyFragment -> Nothing + NonEmptyFragment a -> Just a + +withEmptyFragmentFromMaybe :: Maybe a -> WithEmptyFragment a +withEmptyFragmentFromMaybe = \case + Nothing -> EmptyFragment + Just a -> NonEmptyFragment a + +-- | Prefer non-empty fragments to empty ones. +instance Ord a => Ord (WithEmptyFragment a) where + compare = \cases + EmptyFragment EmptyFragment -> EQ + EmptyFragment NonEmptyFragment{} -> LT + NonEmptyFragment{} EmptyFragment -> GT + (NonEmptyFragment a) (NonEmptyFragment b) -> compare a b + +-- | Prefer non-empty fragments to empty ones. This instance assumes that the +-- underlying fragments all have the same anchor. +instance ChainOrder a => ChainOrder (WithEmptyFragment a) where + type ChainOrderConfig (WithEmptyFragment a) = ChainOrderConfig a + + preferCandidate cfg = \cases + -- We prefer any non-empty fragment to the empty fragment. + EmptyFragment NonEmptyFragment{} -> True + -- We never prefer the empty fragment to our selection (even if it is also + -- empty). + _ EmptyFragment -> False + -- Otherwise, defer to @'ChainOrder' a@. + (NonEmptyFragment ours) (NonEmptyFragment cand) -> + preferCandidate cfg ours cand diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs new file mode 100644 index 0000000000..783c3b6a04 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +-- | Data structure for tracking the weight of blocks due to Peras boosts. +module Ouroboros.Consensus.Peras.Weight + ( -- * 'PerasWeightSnapshot' type + PerasWeightSnapshot + + -- * Construction + , emptyPerasWeightSnapshot + , mkPerasWeightSnapshot + + -- * Conversion + , perasWeightSnapshotToList + + -- * Insertion + , addToPerasWeightSnapshot + + -- * Pruning + , prunePerasWeightSnapshot + + -- * Query + , weightBoostOfPoint + , weightBoostOfFragment + , totalWeightOfFragment + , takeVolatileSuffix + ) where + +import Data.Foldable as Foldable (foldl') +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Word (Word64) +import GHC.Generics (Generic) +import NoThunks.Class +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Config.SecurityParam +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import qualified Ouroboros.Network.AnchoredFragment as AF + +-- | Data structure for tracking the weight of blocks due to Peras boosts. +newtype PerasWeightSnapshot blk = PerasWeightSnapshot + { getPerasWeightSnapshot :: Map (Point blk) PerasWeight + } + deriving stock Eq + deriving Generic + deriving newtype NoThunks + +instance StandardHash blk => Show (PerasWeightSnapshot blk) where + show = show . perasWeightSnapshotToList + +-- | An empty 'PerasWeightSnapshot' not containing any boosted blocks. +emptyPerasWeightSnapshot :: PerasWeightSnapshot blk +emptyPerasWeightSnapshot = PerasWeightSnapshot Map.empty + +-- | Create a weight snapshot from a list of boosted points with an associated +-- weight. In case of duplicate points, their weights are combined. +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- , (BlockPoint 3 "bar", PerasWeight 2) +-- , (BlockPoint 2 "foo", PerasWeight 2) +-- ] +-- :} +-- +-- >>> snap = mkPerasWeightSnapshot weights +-- >>> snap +-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 4),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)] +mkPerasWeightSnapshot :: + StandardHash blk => + [(Point blk, PerasWeight)] -> + PerasWeightSnapshot blk +mkPerasWeightSnapshot = + Foldable.foldl' + (\s (pt, weight) -> addToPerasWeightSnapshot pt weight s) + emptyPerasWeightSnapshot + +-- | Return the list of boosted points with their associated weight, sorted +-- based on their point. Does not contain duplicate points. +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- , (BlockPoint 3 "bar", PerasWeight 2) +-- , (BlockPoint 2 "foo", PerasWeight 2) +-- ] +-- :} +-- +-- >>> snap = mkPerasWeightSnapshot weights +-- >>> perasWeightSnapshotToList snap +-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 4),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)] +perasWeightSnapshotToList :: PerasWeightSnapshot blk -> [(Point blk, PerasWeight)] +perasWeightSnapshotToList = Map.toAscList . getPerasWeightSnapshot + +-- | Add weight for the given point to the 'PerasWeightSnapshot'. If the point +-- already has some weight, it is added on top. +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- ] +-- :} +-- +-- >>> snap0 = mkPerasWeightSnapshot weights +-- >>> snap0 +-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 2)] +-- +-- >>> snap1 = addToPerasWeightSnapshot (BlockPoint 3 "bar") (PerasWeight 2) snap0 +-- >>> snap1 +-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 2),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)] +-- +-- >>> snap2 = addToPerasWeightSnapshot (BlockPoint 2 "foo") (PerasWeight 2) snap1 +-- >>> snap2 +-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 4),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)] +addToPerasWeightSnapshot :: + StandardHash blk => + Point blk -> + PerasWeight -> + PerasWeightSnapshot blk -> + PerasWeightSnapshot blk +addToPerasWeightSnapshot pt weight = + PerasWeightSnapshot . Map.insertWith (<>) pt weight . getPerasWeightSnapshot + +-- | Prune the given 'PerasWeightSnapshot' by removing the weight of all blocks +-- strictly older than the given slot. +-- +-- This function is used to get garbage-collect boosted blocks blocks which are +-- older than our immutable tip as we will never adopt a chain containing them. +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- , (BlockPoint 3 "bar", PerasWeight 2) +-- , (BlockPoint 2 "foo", PerasWeight 2) +-- ] +-- :} +-- +-- >>> snap = mkPerasWeightSnapshot weights +-- +-- >>> prunePerasWeightSnapshot (SlotNo 2) snap +-- [(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 4),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)] +-- +-- >>> prunePerasWeightSnapshot (SlotNo 3) snap +-- [(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)] +prunePerasWeightSnapshot :: + SlotNo -> + PerasWeightSnapshot blk -> + PerasWeightSnapshot blk +prunePerasWeightSnapshot slot = + PerasWeightSnapshot . Map.dropWhileAntitone isTooOld . getPerasWeightSnapshot + where + isTooOld :: Point blk -> Bool + isTooOld pt = pointSlot pt < NotOrigin slot + +-- | Get the weight boost for a point, or @'mempty' :: 'PerasWeight'@ otherwise. +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- , (BlockPoint 3 "bar", PerasWeight 2) +-- , (BlockPoint 2 "foo", PerasWeight 2) +-- ] +-- :} +-- +-- >>> snap = mkPerasWeightSnapshot weights +-- +-- >>> weightBoostOfPoint snap (BlockPoint 2 "foo") +-- PerasWeight 4 +-- +-- >>> weightBoostOfPoint snap (BlockPoint 2 "baz") +-- PerasWeight 0 +weightBoostOfPoint :: + forall blk. + StandardHash blk => + PerasWeightSnapshot blk -> Point blk -> PerasWeight +weightBoostOfPoint (PerasWeightSnapshot weightByPoint) pt = + Map.findWithDefault mempty pt weightByPoint + +-- | Get the weight boost for a fragment, ie the sum of all +-- 'weightBoostOfPoint' for all points on the fragment (excluding the anchor). +-- +-- Note that this quantity is relative to the anchor of the fragment, so it +-- should only be compared against other fragments with the same anchor. +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- , (BlockPoint 3 "bar", PerasWeight 2) +-- , (BlockPoint 2 "foo", PerasWeight 2) +-- ] +-- :} +-- +-- >>> :{ +-- snap = mkPerasWeightSnapshot weights +-- foo = HeaderFields (SlotNo 2) (BlockNo 1) "foo" +-- bar = HeaderFields (SlotNo 3) (BlockNo 2) "bar" +-- frag0 :: AnchoredFragment (HeaderFields Blk) +-- frag0 = Empty AnchorGenesis :> foo :> bar +-- :} +-- +-- >>> weightBoostOfFragment snap frag0 +-- PerasWeight 6 +-- +-- Only keeping the last block from @frag0@: +-- +-- >>> frag1 = AF.anchorNewest 1 frag0 +-- >>> weightBoostOfFragment snap frag1 +-- PerasWeight 2 +-- +-- Dropping the head from @frag0@, and instead adding an unboosted point: +-- +-- >>> frag2 = AF.dropNewest 1 frag0 :> HeaderFields (SlotNo 4) (BlockNo 2) "baz" +-- >>> weightBoostOfFragment snap frag2 +-- PerasWeight 4 +weightBoostOfFragment :: + forall blk h. + (StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) => + PerasWeightSnapshot blk -> + AnchoredFragment h -> + PerasWeight +weightBoostOfFragment weightSnap frag = + -- TODO think about whether this could be done in sublinear complexity + foldMap + (weightBoostOfPoint weightSnap . castPoint . blockPoint) + (AF.toOldestFirst frag) + +-- | Get the total weight for a fragment, ie the length plus the weight boost +-- ('weightBoostOfFragment') of the fragment. +-- +-- Note that this quantity is relative to the anchor of the fragment, so it +-- should only be compared against other fragments with the same anchor. +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- , (BlockPoint 3 "bar", PerasWeight 2) +-- , (BlockPoint 2 "foo", PerasWeight 2) +-- ] +-- :} +-- +-- >>> :{ +-- snap = mkPerasWeightSnapshot weights +-- foo = HeaderFields (SlotNo 2) (BlockNo 1) "foo" +-- bar = HeaderFields (SlotNo 3) (BlockNo 2) "bar" +-- frag0 :: AnchoredFragment (HeaderFields Blk) +-- frag0 = Empty AnchorGenesis :> foo :> bar +-- :} +-- +-- >>> totalWeightOfFragment snap frag0 +-- PerasWeight 8 +-- +-- Only keeping the last block from @frag0@: +-- +-- >>> frag1 = AF.anchorNewest 1 frag0 +-- >>> totalWeightOfFragment snap frag1 +-- PerasWeight 3 +-- +-- Dropping the head from @frag0@, and instead adding an unboosted point: +-- +-- >>> frag2 = AF.dropNewest 1 frag0 :> HeaderFields (SlotNo 4) (BlockNo 2) "baz" +-- >>> totalWeightOfFragment snap frag2 +-- PerasWeight 6 +totalWeightOfFragment :: + forall blk h. + (StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) => + PerasWeightSnapshot blk -> + AnchoredFragment h -> + PerasWeight +totalWeightOfFragment weightSnap frag = + weightLength <> weightBoost + where + weightLength = PerasWeight $ fromIntegral $ AF.length frag + weightBoost = weightBoostOfFragment weightSnap frag + +-- | Take the longest suffix of the given fragment with total weight +-- ('totalWeightOfFragment') at most @k@. This is the volatile suffix of blocks +-- which are subject to rollback. +-- +-- If the total weight of the input fragment is at least @k@, then the anchor of +-- the output fragment is the most recent point on the input fragment that is +-- buried under at least weight @k@ (also counting the weight boost of that +-- point). +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- , (BlockPoint 3 "bar", PerasWeight 2) +-- , (BlockPoint 2 "foo", PerasWeight 2) +-- ] +-- snap = mkPerasWeightSnapshot weights +-- foo = HeaderFields (SlotNo 2) (BlockNo 1) "foo" +-- bar = HeaderFields (SlotNo 3) (BlockNo 2) "bar" +-- frag :: AnchoredFragment (HeaderFields Blk) +-- frag = Empty AnchorGenesis :> foo :> bar +-- :} +-- +-- >>> k1 = SecurityParam $ knownNonZeroBounded @1 +-- >>> k3 = SecurityParam $ knownNonZeroBounded @3 +-- >>> k6 = SecurityParam $ knownNonZeroBounded @6 +-- >>> k9 = SecurityParam $ knownNonZeroBounded @9 +-- +-- >>> AF.toOldestFirst $ takeVolatileSuffix snap k1 frag +-- [] +-- +-- >>> AF.toOldestFirst $ takeVolatileSuffix snap k3 frag +-- [HeaderFields {headerFieldSlot = SlotNo 3, headerFieldBlockNo = BlockNo 2, headerFieldHash = "bar"}] +-- +-- >>> AF.toOldestFirst $ takeVolatileSuffix snap k6 frag +-- [HeaderFields {headerFieldSlot = SlotNo 3, headerFieldBlockNo = BlockNo 2, headerFieldHash = "bar"}] +-- +-- >>> AF.toOldestFirst $ takeVolatileSuffix snap k9 frag +-- [HeaderFields {headerFieldSlot = SlotNo 2, headerFieldBlockNo = BlockNo 1, headerFieldHash = "foo"},HeaderFields {headerFieldSlot = SlotNo 3, headerFieldBlockNo = BlockNo 2, headerFieldHash = "bar"}] +takeVolatileSuffix :: + forall blk h. + (StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) => + PerasWeightSnapshot blk -> + -- | The security parameter @k@ is interpreted as a weight. + SecurityParam -> + AnchoredFragment h -> + AnchoredFragment h +takeVolatileSuffix snap secParam frag + | Map.null $ getPerasWeightSnapshot snap = + -- Optimize the case where Peras is disabled. + AF.anchorNewest (unPerasWeight k) frag + | hasAtMostWeightK frag = frag + | otherwise = go 0 lenFrag (AF.Empty $ AF.headAnchor frag) + where + k :: PerasWeight + k = maxRollbackWeight secParam + + hasAtMostWeightK :: AnchoredFragment h -> Bool + hasAtMostWeightK f = totalWeightOfFragment snap f <= k + + lenFrag = fromIntegral $ AF.length frag + + -- Binary search for the longest suffix of @frag@ which 'hasAtMostWeightK'. + go :: + Word64 -> -- lb. The length lb suffix satisfies 'hasAtMostWeightK'. + Word64 -> -- ub. The length ub suffix does not satisfy 'hasAtMostWeightK'. + AnchoredFragment h -> -- The length lb suffix. + AnchoredFragment h + go lb ub lbFrag + | lb + 1 == ub = lbFrag + | hasAtMostWeightK midFrag = go mid ub midFrag + | otherwise = go lb mid lbFrag + where + mid = (lb + ub) `div` 2 + midFrag = AF.anchorNewest mid frag + +-- $setup +-- >>> import Cardano.Ledger.BaseTypes +-- >>> import Ouroboros.Consensus.Block +-- >>> import Ouroboros.Consensus.Config.SecurityParam +-- >>> import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq(..), Anchor(..)) +-- >>> import qualified Ouroboros.Network.AnchoredFragment as AF +-- >>> :set -XDataKinds -XTypeApplications -XTypeFamilies +-- >>> data Blk = Blk +-- >>> type instance HeaderHash Blk = String +-- >>> instance StandardHash Blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs index 341a916495..676f01f023 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs @@ -9,9 +9,9 @@ module Ouroboros.Consensus.Protocol.MockChainSel import Data.List (sortOn) import Data.Maybe (listToMaybe, mapMaybe) import Data.Ord (Down (..)) +import Ouroboros.Consensus.Peras.SelectView (WeightedSelectView (..), WithEmptyFragment (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Network.Mock.Chain (Chain) -import qualified Ouroboros.Network.Mock.Chain as Chain {------------------------------------------------------------------------------- Chain selection @@ -33,8 +33,9 @@ selectChain :: forall proxy p hdr l. ConsensusProtocol p => proxy p -> - ChainOrderConfig (SelectView p) -> - (hdr -> SelectView p) -> + ChainOrderConfig (WeightedSelectView p) -> + -- | Compute the 'WeightedSelectView' of a chain. + (Chain hdr -> WithEmptyFragment (WeightedSelectView p)) -> -- | Our chain Chain hdr -> -- | Upstream chains @@ -51,24 +52,19 @@ selectChain _ cfg view ours = -- extract the 'SelectView' of the tip of the candidate. selectPreferredCandidate :: (Chain hdr, l) -> - Maybe (SelectView p, (Chain hdr, l)) - selectPreferredCandidate x@(cand, _) = - case (Chain.head ours, Chain.head cand) of - (Nothing, Just candTip) -> - Just (view candTip, x) - (Just ourTip, Just candTip) - | let candView = view candTip - , preferCandidate cfg (view ourTip) candView -> - Just (candView, x) - _otherwise -> - Nothing + Maybe (WithEmptyFragment (WeightedSelectView p), (Chain hdr, l)) + selectPreferredCandidate x@(cand, _) + | let candView = view cand + , preferCandidate cfg (view ours) candView = + Just (candView, x) + | otherwise = Nothing -- | Chain selection on unvalidated chains selectUnvalidatedChain :: ConsensusProtocol p => proxy p -> - ChainOrderConfig (SelectView p) -> - (hdr -> SelectView p) -> + ChainOrderConfig (WeightedSelectView p) -> + (Chain hdr -> WithEmptyFragment (WeightedSelectView p)) -> Chain hdr -> [Chain hdr] -> Maybe (Chain hdr) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 303fbcf78e..a7c5a61665 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -25,6 +25,10 @@ module Ouroboros.Consensus.Storage.ChainDB.API , addBlockWaitWrittenToDisk , addBlock_ + -- * Adding a Peras certificate + , AddPerasCertPromise (..) + , addPerasCertSync + -- * Trigger chain selection , ChainSelectionPromise (..) , triggerChainSelection @@ -77,12 +81,14 @@ import Control.ResourceRegistry import Data.Typeable (Typeable) import GHC.Generics (Generic) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.HeaderStateHistory ( HeaderStateHistory (..) ) import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Storage.LedgerDB @@ -90,6 +96,7 @@ import Ouroboros.Consensus.Storage.LedgerDB , ReadOnlyForker' , Statistics ) +import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertSnapshot) import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike @@ -386,6 +393,12 @@ data ChainDB m blk = ChainDB , getStatistics :: m (Maybe Statistics) -- ^ Get statistics from the LedgerDB, in particular the number of entries -- in the tables. + , addPerasCertAsync :: WithArrivalTime (ValidatedPerasCert blk) -> m (AddPerasCertPromise m) + -- ^ TODO docs + , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) + -- ^ TODO + , getPerasCertSnapshot :: STM m (PerasCertSnapshot blk) + -- ^ TODO , closeDB :: m () -- ^ Close the ChainDB -- @@ -505,6 +518,23 @@ triggerChainSelection :: IOLike m => ChainDB m blk -> m () triggerChainSelection chainDB = waitChainSelectionPromise =<< chainSelAsync chainDB +{------------------------------------------------------------------------------- + Adding a Peras certificate +-------------------------------------------------------------------------------} + +newtype AddPerasCertPromise m = AddPerasCertPromise + { waitPerasCertProcessed :: m () + -- ^ Wait until the Peras certificate has been processed (which potentially + -- includes switching to a different chain). If the PerasCertDB did already + -- contain a certificate for this round, the certificate is ignored (as the + -- two certificates must be identical because certificate equivocation is + -- impossible). + } + +addPerasCertSync :: IOLike m => ChainDB m blk -> WithArrivalTime (ValidatedPerasCert blk) -> m () +addPerasCertSync chainDB cert = + waitPerasCertProcessed =<< addPerasCertAsync chainDB cert + {------------------------------------------------------------------------------- Serialised block/header with its point -------------------------------------------------------------------------------} 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 e5f7b21014..a49173a15a 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 @@ -16,6 +16,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl -- * Trace types , SelectionChangedInfo (..) , TraceAddBlockEvent (..) + , TraceAddPerasCertEvent (..) , TraceChainSelStarvationEvent (..) , TraceCopyToImmutableDBEvent (..) , TraceEvent (..) @@ -79,6 +80,7 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import qualified Ouroboros.Consensus.Storage.ImmutableDB.Stream as ImmutableDB import Ouroboros.Consensus.Storage.LedgerDB (LedgerSupportsLedgerDB) import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util (newFuse, whenJust, withFuse) import Ouroboros.Consensus.Util.Args @@ -173,12 +175,15 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do ledgerDbGetVolatileSuffix traceWith tracer $ TraceOpenEvent OpenedLgrDB + perasCertDB <- PerasCertDB.openDB argsPerasCertDB + varInvalid <- newTVarIO (WithFingerprint Map.empty (Fingerprint 0)) let initChainSelTracer = TraceInitChainSelEvent >$< tracer traceWith initChainSelTracer StartedInitChainSelection initialLoE <- Args.cdbsLoE cdbSpecificArgs + initialWeights <- atomically $ PerasCertDB.getWeightSnapshot perasCertDB chain <- withRegistry $ \rr -> do chainAndLedger <- ChainSel.initialChainSelection @@ -190,6 +195,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do (Args.cdbsTopLevelConfig cdbSpecificArgs) varInvalid (void initialLoE) + (forgetFingerprint initialWeights) traceWith initChainSelTracer InitialChainSelected let chain = VF.validatedFragment chainAndLedger @@ -250,6 +256,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do , cdbChainSelQueue = chainSelQueue , cdbLoE = Args.cdbsLoE cdbSpecificArgs , cdbChainSelStarvation = varChainSelStarvation + , cdbPerasCertDB = perasCertDB } setGetCurrentChainForLedgerDB $ Query.getCurrentChain env @@ -280,6 +287,9 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do , getHeaderStateHistory = getEnvSTM h Query.getHeaderStateHistory , getReadOnlyForkerAtPoint = getEnv2 h Query.getReadOnlyForkerAtPoint , getStatistics = getEnv h Query.getStatistics + , addPerasCertAsync = getEnv1 h ChainSel.addPerasCertAsync + , getPerasWeightSnapshot = getEnvSTM h Query.getPerasWeightSnapshot + , getPerasCertSnapshot = getEnvSTM h Query.getPerasCertSnapshot } addBlockTestFuse <- newFuse "test chain selection" copyTestFuse <- newFuse "test copy to immutable db" @@ -310,7 +320,12 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do return ((chainDB, testing), env) where tracer = Args.cdbsTracer cdbSpecificArgs - Args.ChainDbArgs argsImmutableDb argsVolatileDb argsLgrDb cdbSpecificArgs = args + Args.ChainDbArgs + argsImmutableDb + argsVolatileDb + argsLgrDb + argsPerasCertDB + cdbSpecificArgs = args -- The LedgerDB requires a criterion ('LedgerDB.GetVolatileSuffix') -- determining which of its states are volatile/immutable. Once we have 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 db793c8f0d..cc285627a4 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 @@ -41,6 +41,7 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.LedgerDB (LedgerDbFlavorArgs) import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import Ouroboros.Consensus.Storage.LedgerDB.Snapshots +import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike @@ -54,6 +55,7 @@ data ChainDbArgs f m blk = ChainDbArgs { cdbImmDbArgs :: ImmutableDB.ImmutableDbArgs f m blk , cdbVolDbArgs :: VolatileDB.VolatileDbArgs f m blk , cdbLgrDbArgs :: LedgerDB.LedgerDbArgs f m blk + , cdbPerasCertDbArgs :: PerasCertDB.PerasCertDbArgs f m blk , cdbsArgs :: ChainDbSpecificArgs f m blk } @@ -138,6 +140,7 @@ defaultArgs = ImmutableDB.defaultArgs VolatileDB.defaultArgs LedgerDB.defaultArgs + PerasCertDB.defaultArgs defaultSpecificArgs ensureValidateAll :: @@ -209,6 +212,10 @@ completeChainDbArgs , LedgerDB.lgrFlavorArgs = flavorArgs , LedgerDB.lgrRegistry = registry } + , cdbPerasCertDbArgs = + PerasCertDB.PerasCertDbArgs + { PerasCertDB.pcdbaTracer = PerasCertDB.pcdbaTracer (cdbPerasCertDbArgs defArgs) + } , cdbsArgs = (cdbsArgs defArgs) { cdbsRegistry = registry @@ -226,6 +233,8 @@ updateTracer trcr args = { cdbImmDbArgs = (cdbImmDbArgs args){ImmutableDB.immTracer = TraceImmutableDBEvent >$< trcr} , cdbVolDbArgs = (cdbVolDbArgs args){VolatileDB.volTracer = TraceVolatileDBEvent >$< trcr} , cdbLgrDbArgs = (cdbLgrDbArgs args){LedgerDB.lgrTracer = TraceLedgerDBEvent >$< trcr} + , cdbPerasCertDbArgs = + (cdbPerasCertDbArgs args){PerasCertDB.pcdbaTracer = TracePerasCertDbEvent >$< trcr} , cdbsArgs = (cdbsArgs args){cdbsTracer = trcr} } 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 37cfd65e27..370e66114d 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 @@ -71,6 +71,7 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Query as Query import Ouroboros.Consensus.Storage.ChainDB.Impl.Types import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.Condense @@ -399,6 +400,7 @@ garbageCollectBlocks CDB{..} slotNo = do VolatileDB.garbageCollect cdbVolatileDB slotNo atomically $ do modifyTVar cdbInvalid $ fmap $ Map.filter ((>= slotNo) . invalidBlockSlotNo) + PerasCertDB.garbageCollect cdbPerasCertDB slotNo traceWith cdbTracer $ TraceGCEvent $ PerformedGC slotNo {------------------------------------------------------------------------------- @@ -632,6 +634,8 @@ addBlockRunner fuse cdb@CDB{..} = forever $ do varBlockProcessed (FailedToAddBlock "Failed to add block synchronously") pure () + ChainSelAddPerasCert _cert varProcessed -> + void $ tryPutTMVar varProcessed () closeChainSelQueue cdbChainSelQueue ) ( \message -> do @@ -640,6 +644,10 @@ addBlockRunner fuse cdb@CDB{..} = forever $ do trace PoppedReprocessLoEBlocksFromQueue ChainSelAddBlock BlockToAdd{blockToAdd} -> trace $ PoppedBlockFromQueue $ blockRealPoint blockToAdd + ChainSelAddPerasCert cert _varProcessed -> + traceWith cdbTracer $ + TraceAddPerasCertEvent $ + PoppedPerasCertFromQueue (getPerasCertRound cert) (getPerasCertBoostedBlock 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 a16e674b3d..9babf8a400 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 @@ -13,6 +13,7 @@ -- adding a block. module Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel ( addBlockAsync + , addPerasCertAsync , chainSelSync , chainSelectionForBlock , initialChainSelection @@ -37,13 +38,14 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, isJust) +import Data.Maybe (fromJust, fromMaybe, isJust) import Data.Maybe.Strict (StrictMaybe (..), strictMaybeToMaybe) import Data.Set (Set) import qualified Data.Set as Set import Data.Traversable (for) import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Config import Ouroboros.Consensus.Fragment.Diff (ChainDiff (..)) import qualified Ouroboros.Consensus.Fragment.Diff as Diff @@ -63,15 +65,19 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.SelectView +import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Storage.ChainDB.API ( AddBlockPromise (..) , AddBlockResult (..) + , AddPerasCertPromise , BlockComponent (..) , ChainType (..) , LoE (..) ) import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment ( InvalidBlockPunishment + , noPunishment ) import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment import Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache @@ -85,10 +91,12 @@ import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB) import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.AnchoredFragment +import Ouroboros.Consensus.Util.EarlyExit (exitEarly, withEarlyExit_) import Ouroboros.Consensus.Util.Enclose (encloseWith) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.STM (WithFingerprint (..)) @@ -118,6 +126,7 @@ initialChainSelection :: TopLevelConfig blk -> StrictTVar m (WithFingerprint (InvalidBlocks blk)) -> LoE () -> + PerasWeightSnapshot blk -> m (ChainAndLedger m blk) initialChainSelection immutableDB @@ -127,7 +136,8 @@ initialChainSelection tracer cfg varInvalid - loE = do + loE + weights = do -- TODO: Improve the user experience by trimming any potential -- blocks from the future from the VolatileDB. -- @@ -172,7 +182,7 @@ initialChainSelection let curChain = Empty (AF.castAnchor i) curChainAndLedger <- VF.newM curChain curForker - case NE.nonEmpty (filter (preferAnchoredCandidate bcfg curChain) chains) of + case NE.nonEmpty (filter (preferAnchoredCandidate bcfg weights curChain) chains) of -- If there are no candidates, no chain selection is needed Nothing -> return curChainAndLedger Just chains' -> @@ -254,7 +264,7 @@ initialChainSelection chainSelection' curChainAndLedger candidates = atomically (forkerCurrentPoint ledger) >>= \curpt -> assert (all ((curpt ==) . castPoint . AF.anchorPoint) candidates) $ - assert (all (preferAnchoredCandidate bcfg curChain) candidates) $ do + assert (all (preferAnchoredCandidate bcfg weights curChain) candidates) $ do cse <- chainSelEnv chainSelection cse rr (Diff.extend <$> candidates) where @@ -269,6 +279,7 @@ initialChainSelection , bcfg , varInvalid , blockCache = BlockCache.empty + , weights , curChain , validationTracer = InitChainSelValidation >$< tracer , -- initial chain selection is not concerned about pipelining @@ -314,6 +325,15 @@ addBlockAsync :: addBlockAsync CDB{cdbTracer, cdbChainSelQueue} = addBlockToAdd (TraceAddBlockEvent >$< cdbTracer) cdbChainSelQueue +addPerasCertAsync :: + forall m blk. + (IOLike m, HasHeader blk) => + ChainDbEnv m blk -> + WithArrivalTime (ValidatedPerasCert blk) -> + m (AddPerasCertPromise m) +addPerasCertAsync CDB{cdbTracer, cdbChainSelQueue} = + addPerasCertToQueue (TraceAddPerasCertEvent >$< cdbTracer) cdbChainSelQueue + -- | Schedule reprocessing of blocks postponed by the LoE. triggerChainSelectionAsync :: forall m blk. @@ -358,14 +378,15 @@ chainSelSync :: -- blocks that were originally postponed by the LoE, but can be adopted once we -- conclude that we are caught-up (and hence are longer bound by the LoE). chainSelSync cdb@CDB{..} (ChainSelReprocessLoEBlocks varProcessed) = lift $ do - (succsOf, lookupBlockInfo, curChain) <- atomically $ do + (succsOf, lookupBlockInfo, curChain, weights) <- atomically $ do invalid <- forgetFingerprint <$> readTVar cdbInvalid - (,,) + (,,,) <$> ( ignoreInvalidSuc cdbVolatileDB invalid <$> VolatileDB.filterByPredecessor cdbVolatileDB ) <*> VolatileDB.getBlockInfo cdbVolatileDB <*> Query.getCurrentChain cdb + <*> (forgetFingerprint <$> Query.getPerasWeightSnapshot cdb) let -- All immediate successor blocks of blocks on the current chain (including -- the anchor), excluding those on the current chain. @@ -380,10 +401,10 @@ chainSelSync cdb@CDB{..} (ChainSelReprocessLoEBlocks varProcessed) = lift $ do , not $ AF.pointOnFragment (realPointToPoint loePt) curChain ] - chainSelEnv = mkChainSelEnv cdb BlockCache.empty curChain Nothing + chainSelEnv = mkChainSelEnv cdb BlockCache.empty weights curChain Nothing chainDiffs :: [[ChainDiff (Header blk)]] <- - for loePoints $ constructPreferableCandidates cdb curChain Map.empty + for loePoints $ constructPreferableCandidates cdb weights curChain Map.empty -- Consider all candidates at once, to avoid transient chain switches. case NE.nonEmpty $ concat chainDiffs of @@ -392,7 +413,7 @@ chainSelSync cdb@CDB{..} (ChainSelReprocessLoEBlocks varProcessed) = lift $ do chainSelection chainSelEnv rr chainDiffs' >>= \case Just validatedChainDiff -> -- Switch to the new better chain. - switchTo cdb Nothing validatedChainDiff + switchTo cdb weights Nothing validatedChainDiff Nothing -> pure () Nothing -> pure () @@ -463,6 +484,65 @@ chainSelSync cdb@CDB{..} (ChainSelAddBlock BlockToAdd{blockToAdd = b, ..}) = do deliverProcessed tip = atomically $ putTMVar varBlockProcessed (SuccesfullyAddedBlock tip) +-- Process a Peras certificate by adding it to the PerasCertDB and potentially +-- performing chain selection if a candidate is now better than our selection. +chainSelSync cdb@CDB{..} (ChainSelAddPerasCert cert varProcessed) = do + curChain <- lift $ atomically $ Query.getCurrentChain cdb + let immTip = castPoint $ AF.anchorPoint curChain + + withEarlyExit_ $ do + -- Ignore the certificate if it boosts a block that is so old that it can't + -- influence our selection. + when (pointSlot boostedBlock < pointSlot immTip) $ do + lift $ lift $ traceWith tracer $ IgnorePerasCertTooOld certRound boostedBlock immTip + exitEarly + + -- Add the certificate to the PerasCertDB. + lift (lift $ PerasCertDB.addCert cdbPerasCertDB cert) >>= \case + PerasCertDB.AddedPerasCertToDB -> pure () + -- If it already is in the PerasCertDB, we are done. + PerasCertDB.PerasCertAlreadyInDB -> exitEarly + + -- If the certificate boosts a block on our current chain (including the + -- anchor), then it just makes our selection even stronger. + when (AF.withinFragmentBounds (castPoint boostedBlock) curChain) $ do + lift $ lift $ traceWith tracer $ PerasCertBoostsCurrentChain certRound boostedBlock + exitEarly + + boostedHash <- case pointHash boostedBlock of + -- If the certificate boosts the Genesis point, then it can not influence + -- chain selection as all chains contain it. + GenesisHash -> do + lift $ lift $ traceWith tracer $ PerasCertBoostsGenesis certRound + exitEarly + -- Otherwise, the certificate boosts a block potentially on a (future) + -- candidate. + BlockHash boostedHash -> pure boostedHash + boostedHdr <- + lift (lift $ VolatileDB.getBlockComponent cdbVolatileDB GetHeader boostedHash) >>= \case + -- If we have not (yet) received the boosted block, we don't need to do + -- anything further for now regarding chain selection. Once we receive + -- it, the additional weight of the certificate is taken into account. + Nothing -> do + lift $ lift $ traceWith tracer $ PerasCertBoostsBlockNotYetReceived certRound boostedBlock + exitEarly + Just boostedHdr -> pure boostedHdr + + -- Trigger chain selection for the boosted block. + lift $ lift $ traceWith tracer $ ChainSelectionForBoostedBlock certRound boostedBlock + lift $ chainSelectionForBlock cdb BlockCache.empty boostedHdr noPunishment + + -- Deliver promise indicating that we processed the cert. + lift $ atomically $ putTMVar varProcessed () + where + tracer :: Tracer m (TraceAddPerasCertEvent blk) + tracer = TraceAddPerasCertEvent >$< cdbTracer + + certRound :: PerasRoundNo + certRound = getPerasCertRound cert + + boostedBlock :: Point blk + boostedBlock = getPerasCertBoostedBlock cert -- | Return 'True' when the given header should be ignored when adding it -- because it is too old, i.e., we wouldn't be able to switch to a chain @@ -539,11 +619,12 @@ chainSelectionForBlock :: InvalidBlockPunishment m -> Electric m () chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegistry $ \rr -> do - (invalid, curChain) <- + (invalid, curChain, weights) <- atomically $ - (,) + (,,) <$> (forgetFingerprint <$> readTVar cdbInvalid) <*> Query.getCurrentChain cdb + <*> (forgetFingerprint <$> Query.getPerasWeightSnapshot cdb) -- The current chain we're working with here is not longer than @k@ blocks -- (see 'getCurrentChain' and 'cdbChain'), which is easier to reason about @@ -576,13 +657,14 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist chainDiffs <- constructPreferableCandidates cdb + weights curChain (Map.singleton (headerHash hdr) hdr) (headerRealPoint hdr) let noChange = traceWith addBlockTracer $ StoreButDontChange p - chainSelEnv = mkChainSelEnv cdb blockCache curChain (Just (p, punish)) + chainSelEnv = mkChainSelEnv cdb blockCache weights curChain (Just (p, punish)) case NE.nonEmpty chainDiffs of Just chainDiffs' -> do @@ -590,7 +672,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist chainSelection chainSelEnv rr chainDiffs' >>= \case Just validatedChainDiff -> -- Switch to the new better chain. - switchTo cdb (Just p) validatedChainDiff + switchTo cdb weights (Just p) validatedChainDiff -- No valid candidate better than our chain. Nothing -> noChange -- No candidate better than our chain. @@ -617,6 +699,7 @@ constructPreferableCandidates :: , BlockSupportsProtocol blk ) => ChainDbEnv m blk -> + PerasWeightSnapshot blk -> -- | The current chain. AnchoredFragment (Header blk) -> -- | Headers already in memory (to avoid loading them from disk). @@ -626,7 +709,7 @@ constructPreferableCandidates :: -- | All candidates involving @p@ (ie containing @p@ in 'getSuffix') which are -- preferable to the current chain. m [ChainDiff (Header blk)] -constructPreferableCandidates CDB{..} curChain hdrCache p = do +constructPreferableCandidates CDB{..} weights curChain hdrCache p = do (succsOf, lookupBlockInfo) <- atomically $ do invalid <- forgetFingerprint <$> readTVar cdbInvalid (,) @@ -666,10 +749,10 @@ constructPreferableCandidates CDB{..} curChain hdrCache p = do -- Translate the 'HeaderFields' to 'Header' by reading the headers -- from disk. mapM translateToHeaders - -- Filter out candidates that are shorter than the current chain. - -- We don't want to needlessly read the headers from disk for - -- those candidates. - . NE.filter (not . Diff.rollbackExceedsSuffix) + -- Filter out candidates that have less weight than the current + -- chain. We don't want to needlessly read the headers from disk + -- for those candidates. + . NE.filter (not . Diff.rollbackExceedsSuffix weights curChain) -- Extend the diff with candidates fitting on @p@ . Paths.extendWithSuccessors succsOf lookupBlockInfo $ diff @@ -677,7 +760,7 @@ constructPreferableCandidates CDB{..} curChain hdrCache p = do | otherwise -> pure [] pure -- Only keep candidates preferable to the current chain. - . filter (preferAnchoredCandidate bcfg curChain . Diff.getSuffix) + . filter (preferAnchoredCandidate bcfg weights curChain . Diff.getSuffix) -- Trim fragments so that they follow the LoE, that is, they extend the LoE -- by at most @k@ blocks or are extended by the LoE. . fmap (trimToLoE loeFrag) @@ -792,6 +875,7 @@ switchTo :: , HasCallStack ) => ChainDbEnv m blk -> + PerasWeightSnapshot blk -> -- | Which block we performed chain selection for (if any). This is 'Nothing' -- when reprocessing blocks that were postponed due to the Limit on Eagerness -- (cf 'ChainSelReprocessLoEBlocks'). @@ -799,7 +883,7 @@ switchTo :: -- | Chain and ledger to switch to ValidatedChainDiff (Header blk) (Forker' m blk) -> m () -switchTo CDB{..} triggerPt vChainDiff = do +switchTo CDB{..} weights triggerPt vChainDiff = do traceWith addBlockTracer $ ChangingSelection $ castPoint $ @@ -860,7 +944,11 @@ switchTo CDB{..} triggerPt vChainDiff = do let mkTraceEvent | getRollback (getChainDiff vChainDiff) == 0 = AddedToCurrentChain | otherwise = SwitchedToAFork - selChangedInfo = mkSelectionChangedInfo curChain newChain newLedger + selChangedInfo = + mkSelectionChangedInfo + curChain + (getChainDiff vChainDiff) + newLedger traceWith addBlockTracer $ mkTraceEvent events selChangedInfo curChain newChain whenJust (strictMaybeToMaybe prevTentativeHeader) $ @@ -875,28 +963,29 @@ switchTo CDB{..} triggerPt vChainDiff = do addBlockTracer = TraceAddBlockEvent >$< cdbTracer mkSelectionChangedInfo :: - AnchoredFragment (Header blk) -> - -- \^ old chain - AnchoredFragment (Header blk) -> - -- \^ new chain - ExtLedgerState blk EmptyMK -> - -- \^ new tip + AnchoredFragment (Header blk) -> -- old selection + ChainDiff (Header blk) -> -- diff we are adopting + ExtLedgerState blk EmptyMK -> -- new tip SelectionChangedInfo blk - mkSelectionChangedInfo oldChain newChain newTip = + mkSelectionChangedInfo oldChain diff newTip = SelectionChangedInfo { newTipPoint = castRealPoint tipPoint , newTipEpoch = tipEpoch , newTipSlotInEpoch = tipSlotInEpoch , newTipTrigger = triggerPt - , newTipSelectView - , oldTipSelectView = - selectView (configBlock cfg) - <$> eitherToMaybe (AF.head oldChain) + , newSuffixSelectView + , oldSuffixSelectView = + withEmptyFragmentToMaybe $ + weightedSelectView (configBlock cfg) weights oldSuffix } where cfg :: TopLevelConfig blk cfg = cdbTopLevelConfig + oldSuffix, newSuffix :: AnchoredFragment (Header blk) + oldSuffix = AF.anchorNewest (getRollback diff) oldChain + newSuffix = getSuffix diff + ledger :: LedgerState blk EmptyMK ledger = ledgerState newTip @@ -906,14 +995,13 @@ switchTo CDB{..} triggerPt vChainDiff = do (configLedger cfg) ledger - (tipPoint, (tipEpoch, tipSlotInEpoch), newTipSelectView) = - case AF.head newChain of - Left _anchor -> error "cannot have switched to an empty chain" - Right tipHdr -> + (tipPoint, (tipEpoch, tipSlotInEpoch), newSuffixSelectView) = + case (AF.head newSuffix, weightedSelectView (configBlock cfg) weights newSuffix) of + (Right tipHdr, NonEmptyFragment wsv) -> let query = History.slotToEpoch' (blockSlot tipHdr) tipEpochData = History.runQueryPure query summary - sv = selectView (configBlock cfg) tipHdr - in (blockRealPoint tipHdr, tipEpochData, sv) + in (blockRealPoint tipHdr, tipEpochData, wsv) + _ -> error "cannot have switched via a diff with an empty suffix" -- | Check whether the header for the hash is in the cache, if not, get -- the corresponding header from the VolatileDB and store it in the cache. @@ -943,6 +1031,7 @@ data ChainSelEnv m blk = ChainSelEnv , varTentativeHeader :: StrictTVar m (StrictMaybe (Header blk)) , getTentativeFollowers :: STM m [FollowerHandle m blk] , blockCache :: BlockCache blk + , weights :: PerasWeightSnapshot blk , curChain :: AnchoredFragment (Header blk) , punish :: Maybe (RealPoint blk, InvalidBlockPunishment m) -- ^ The block that this chain selection invocation is processing, and the @@ -968,12 +1057,14 @@ mkChainSelEnv :: ChainDbEnv m blk -> -- | See 'blockCache' BlockCache blk -> + -- | See 'weights' + PerasWeightSnapshot blk -> -- | See 'curChain' AnchoredFragment (Header blk) -> -- | See 'punish'. Maybe (RealPoint blk, InvalidBlockPunishment m) -> ChainSelEnv m blk -mkChainSelEnv CDB{..} blockCache curChain punish = +mkChainSelEnv CDB{..} blockCache weights curChain punish = ChainSelEnv { lgrDB = cdbLedgerDB , bcfg = configBlock cdbTopLevelConfig @@ -984,6 +1075,7 @@ mkChainSelEnv CDB{..} blockCache curChain punish = filter ((TentativeChain ==) . fhChainType) . Map.elems <$> readTVar cdbFollowers , blockCache + , weights , curChain , validationTracer = TraceAddBlockEvent . AddBlockValidation >$< cdbTracer @@ -1017,7 +1109,7 @@ chainSelection :: chainSelection chainSelEnv rr chainDiffs = assert ( all - (preferAnchoredCandidate bcfg curChain . Diff.getSuffix) + (preferAnchoredCandidate bcfg weights curChain . Diff.getSuffix) chainDiffs ) $ assert @@ -1030,8 +1122,7 @@ chainSelection chainSelEnv rr chainDiffs = ChainSelEnv{..} = chainSelEnv sortCandidates :: [ChainDiff (Header blk)] -> [ChainDiff (Header blk)] - sortCandidates = - sortBy (flip (compareAnchoredFragments bcfg) `on` Diff.getSuffix) + sortCandidates = sortBy (flip $ compareChainDiffs bcfg weights curChain) -- 1. Take the first candidate from the list of sorted candidates -- 2. Validate it @@ -1067,7 +1158,7 @@ chainSelection chainSelEnv rr chainDiffs = -- it will be dropped here, as it will not be preferred over the -- current chain. let candidates2 - | preferAnchoredCandidate bcfg curChain (Diff.getSuffix candidate') = + | preferAnchoredCandidate bcfg weights curChain (Diff.getSuffix candidate') = candidate' : candidates1 | otherwise = candidates1 @@ -1125,7 +1216,7 @@ chainSelection chainSelEnv rr chainDiffs = let isRejected hdr = Map.member (headerHash hdr) (forgetFingerprint invalid) return $ - filter (preferAnchoredCandidate bcfg curChain . Diff.getSuffix) $ + filter (preferAnchoredCandidate bcfg weights curChain . Diff.getSuffix) $ map (Diff.takeWhileOldest (not . isRejected)) cands -- [Ouroboros] @@ -1333,3 +1424,26 @@ ignoreInvalidSuc :: (ChainHash blk -> Set (HeaderHash blk)) ignoreInvalidSuc _ invalid succsOf = Set.filter (`Map.notMember` invalid) . succsOf + +-- | Compare two 'ChainDiff's w.r.t. the chain order. +-- +-- PRECONDITION: Both 'ChainDiff's fit onto the given current chain. +compareChainDiffs :: + forall blk. + BlockSupportsProtocol blk => + BlockConfig blk -> + PerasWeightSnapshot blk -> + -- | Current chain. + AnchoredFragment (Header blk) -> + ChainDiff (Header blk) -> + ChainDiff (Header blk) -> + Ordering +compareChainDiffs bcfg weights curChain = + -- The precondition of 'compareAnchoredFragment's is satisfied as the result + -- of @mkCand@ has the same anchor as @curChain@, and so any two fragments + -- returned by @mkCand@ do intersect. + compareAnchoredFragments bcfg weights `on` mkCand + where + mkCand = + fromMaybe (error "compareChainDiffs: precondition violated") + . Diff.apply curChain diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs index 821586f745..353bae1f65 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs @@ -3,6 +3,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} -- | Queries module Ouroboros.Consensus.Storage.ChainDB.Impl.Query @@ -18,6 +19,8 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query , getIsValid , getMaxSlotNo , getPastLedger + , getPerasWeightSnapshot + , getPerasCertSnapshot , getReadOnlyForkerAtPoint , getStatistics , getTipBlock @@ -31,7 +34,6 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query , getChainSelStarvation ) where -import Cardano.Ledger.BaseTypes (unNonZero) import Control.ResourceRegistry (ResourceRegistry) import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -43,6 +45,10 @@ import Ouroboros.Consensus.HeaderStateHistory import Ouroboros.Consensus.HeaderValidation (HeaderWithTime) import Ouroboros.Consensus.Ledger.Abstract (EmptyMK) import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Peras.Weight + ( PerasWeightSnapshot + , takeVolatileSuffix + ) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API ( BlockComponent (..) @@ -52,6 +58,8 @@ import Ouroboros.Consensus.Storage.ChainDB.Impl.Types import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB +import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertSnapshot) import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB) import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util (eitherToMaybe) @@ -83,29 +91,44 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Type getCurrentChain :: forall m blk. ( IOLike m + , StandardHash blk , HasHeader (Header blk) , ConsensusProtocol (BlockProtocol blk) ) => ChainDbEnv m blk -> STM m (AnchoredFragment (Header blk)) -getCurrentChain CDB{..} = - AF.anchorNewest (unNonZero k) . icWithoutTime <$> readTVar cdbChain - where - SecurityParam k = configSecurityParam cdbTopLevelConfig +getCurrentChain cdb@CDB{..} = + getCurrentChainLike cdb $ icWithoutTime <$> readTVar cdbChain -- | Same as 'getCurrentChain', /mutatis mutandi/. getCurrentChainWithTime :: forall m blk. ( IOLike m + , StandardHash blk , HasHeader (HeaderWithTime blk) , ConsensusProtocol (BlockProtocol blk) ) => ChainDbEnv m blk -> STM m (AnchoredFragment (HeaderWithTime blk)) -getCurrentChainWithTime CDB{..} = - AF.anchorNewest (unNonZero k) . icWithTime <$> readTVar cdbChain +getCurrentChainWithTime cdb@CDB{..} = + getCurrentChainLike cdb $ icWithTime <$> readTVar cdbChain + +getCurrentChainLike :: + forall m blk h. + ( IOLike m + , StandardHash blk + , HasHeader h + , HeaderHash blk ~ HeaderHash h + , ConsensusProtocol (BlockProtocol blk) + ) => + ChainDbEnv m blk -> + STM m (AnchoredFragment h) -> + STM m (AnchoredFragment h) +getCurrentChainLike cdb@CDB{..} getCurChain = do + weights <- forgetFingerprint <$> getPerasWeightSnapshot cdb + takeVolatileSuffix weights k <$> getCurChain where - SecurityParam k = configSecurityParam cdbTopLevelConfig + k = configSecurityParam cdbTopLevelConfig -- | Get a 'HeaderStateHistory' populated with the 'HeaderState's of the -- last @k@ blocks of the current chain. @@ -262,6 +285,14 @@ getReadOnlyForkerAtPoint CDB{..} = LedgerDB.getReadOnlyForker cdbLedgerDB getStatistics :: IOLike m => ChainDbEnv m blk -> m (Maybe LedgerDB.Statistics) getStatistics CDB{..} = LedgerDB.getTipStatistics cdbLedgerDB +getPerasWeightSnapshot :: + ChainDbEnv m blk -> STM m (WithFingerprint (PerasWeightSnapshot blk)) +getPerasWeightSnapshot CDB{..} = PerasCertDB.getWeightSnapshot cdbPerasCertDB + +getPerasCertSnapshot :: + ChainDbEnv m blk -> STM m (PerasCertSnapshot blk) +getPerasCertSnapshot CDB{..} = PerasCertDB.getCertSnapshot cdbPerasCertDB + {------------------------------------------------------------------------------- Unifying interface over the immutable DB and volatile DB, but independent of the ledger DB. These functions therefore do not require the entire 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 30193ba314..17a6e941cb 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 @@ -55,6 +55,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Types , ChainSelMessage (..) , ChainSelQueue -- opaque , addBlockToAdd + , addPerasCertToQueue , addReprocessLoEBlocks , closeChainSelQueue , getChainSelMessage @@ -66,6 +67,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Types -- * Trace types , SelectionChangedInfo (..) , TraceAddBlockEvent (..) + , TraceAddPerasCertEvent (..) , TraceChainSelStarvationEvent (..) , TraceCopyToImmutableDBEvent (..) , TraceEvent (..) @@ -83,7 +85,6 @@ import Control.ResourceRegistry import Control.Tracer import Data.Foldable (traverse_) import Data.Map.Strict (Map) -import Data.Maybe (mapMaybe) import Data.Maybe.Strict (StrictMaybe (..)) import Data.MultiSet (MultiSet) import qualified Data.MultiSet as MultiSet @@ -93,16 +94,19 @@ import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class (OnlyCheckWhnfNamed (..)) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Config import Ouroboros.Consensus.Fragment.Diff (ChainDiff) import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) import Ouroboros.Consensus.Ledger.Extended (ExtValidationError) import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.SelectView (WeightedSelectView) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API ( AddBlockPromise (..) , AddBlockResult (..) + , AddPerasCertPromise (..) , ChainDbError (..) , ChainSelectionPromise (..) , ChainType @@ -124,6 +128,8 @@ import Ouroboros.Consensus.Storage.LedgerDB , LedgerDbSerialiseConstraints ) import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import Ouroboros.Consensus.Storage.PerasCertDB (PerasCertDB) +import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Storage.VolatileDB ( VolatileDB @@ -349,6 +355,7 @@ data ChainDbEnv m blk = CDB , cdbChainSelStarvation :: !(StrictTVar m ChainSelStarvation) -- ^ Information on the last starvation of ChainSel, whether ongoing or -- ended recently. + , cdbPerasCertDB :: !(PerasCertDB m blk) } deriving Generic @@ -545,6 +552,11 @@ data BlockToAdd m blk = BlockToAdd data ChainSelMessage m blk = -- | Add a new block ChainSelAddBlock !(BlockToAdd m blk) + | -- | Add a Peras certificate + ChainSelAddPerasCert + !(WithArrivalTime (ValidatedPerasCert blk)) + -- | Used for 'AddPerasCertPromise'. + !(StrictTMVar m ()) | -- | Reprocess blocks that have been postponed by the LoE. ChainSelReprocessLoEBlocks -- | Used for 'ChainSelectionPromise'. @@ -593,6 +605,27 @@ addBlockToAdd tracer (ChainSelQueue{varChainSelQueue, varChainSelPoints}) punish , blockProcessed = readTMVar varBlockProcessed } +-- | Add a Peras certificate to the background queue. +addPerasCertToQueue :: + (IOLike m, StandardHash blk) => + Tracer m (TraceAddPerasCertEvent blk) -> + ChainSelQueue m blk -> + WithArrivalTime (ValidatedPerasCert blk) -> + m (AddPerasCertPromise m) +addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do + varProcessed <- newEmptyTMVarIO + traceWith tracer $ addedToQueue RisingEdge + queueSize <- atomically $ do + writeTBQueue varChainSelQueue $ ChainSelAddPerasCert cert varProcessed + lengthTBQueue varChainSelQueue + traceWith tracer $ addedToQueue $ FallingEdgeWith $ fromIntegral queueSize + pure + AddPerasCertPromise + { waitPerasCertProcessed = atomically $ takeTMVar varProcessed + } + where + addedToQueue = AddedPerasCertToQueue (getPerasCertRound cert) (getPerasCertBoostedBlock cert) + -- | Try to add blocks again that were postponed due to the LoE. addReprocessLoEBlocks :: IOLike m => @@ -647,23 +680,21 @@ getChainSelMessage starvationTracer starvationVar chainSelQueue = let pt = blockRealPoint block traceWith starvationTracer $ ChainSelStarvation (FallingEdgeWith pt) atomically . writeTVar starvationVar . ChainSelStarvationEndedAt =<< getMonotonicTime + ChainSelAddPerasCert{} -> pure () ChainSelReprocessLoEBlocks{} -> pure () -- | Flush the 'ChainSelQueue' queue and notify the waiting threads. closeChainSelQueue :: IOLike m => ChainSelQueue m blk -> STM m () closeChainSelQueue ChainSelQueue{varChainSelQueue = queue} = do - as <- mapMaybe blockAdd <$> flushTBQueue queue - traverse_ - ( \a -> - tryPutTMVar - (varBlockProcessed a) - (FailedToAddBlock "Queue flushed") - ) - as + traverse_ deliverPromise =<< flushTBQueue queue where - blockAdd = \case - ChainSelAddBlock ab -> Just ab - ChainSelReprocessLoEBlocks _ -> Nothing + deliverPromise = \case + ChainSelAddBlock ab -> + tryPutTMVar (varBlockProcessed ab) (FailedToAddBlock "Queue flushed") + ChainSelAddPerasCert _cert varProcessed -> + tryPutTMVar varProcessed () + ChainSelReprocessLoEBlocks varProcessed -> + tryPutTMVar varProcessed () -- | To invoke when the given 'ChainSelMessage' has been processed by ChainSel. -- This is used to remove the respective point from the multiset of points in @@ -676,6 +707,8 @@ processedChainSelMessage :: processedChainSelMessage ChainSelQueue{varChainSelPoints} = \case ChainSelAddBlock BlockToAdd{blockToAdd = blk} -> modifyTVar varChainSelPoints $ MultiSet.delete (blockRealPoint blk) + ChainSelAddPerasCert{} -> + pure () ChainSelReprocessLoEBlocks{} -> pure () @@ -717,8 +750,10 @@ data TraceEvent blk | TraceLedgerDBEvent (LedgerDB.TraceEvent blk) | TraceImmutableDBEvent (ImmutableDB.TraceEvent blk) | TraceVolatileDBEvent (VolatileDB.TraceEvent blk) + | TracePerasCertDbEvent (PerasCertDB.TraceEvent blk) | TraceLastShutdownUnclean | TraceChainSelStarvationEvent (TraceChainSelStarvationEvent blk) + | TraceAddPerasCertEvent (TraceAddPerasCertEvent blk) deriving Generic deriving instance @@ -797,21 +832,23 @@ data SelectionChangedInfo blk = SelectionChangedInfo -- Due to the Ouroboros Genesis (Limit on Eagerness), chain selection can also -- be triggered without any particular trigger block, in which case this is -- 'Nothing'. - , newTipSelectView :: SelectView (BlockProtocol blk) - -- ^ The 'SelectView' of the new tip. It is guaranteed that + , newSuffixSelectView :: WeightedSelectView (BlockProtocol blk) + -- ^ The 'WeightedSelectView' of the suffix of our new selection that was not + -- already present in the old selection. It is guaranteed that -- - -- > Just newTipSelectView > oldTipSelectView - -- True - , oldTipSelectView :: Maybe (SelectView (BlockProtocol blk)) - -- ^ The 'SelectView' of the old, previous tip. This can be 'Nothing' when - -- the previous chain/tip was Genesis. + -- > preferCandidate cfg + -- > (withEmptyFragmentFromMaybe oldSuffixSelectView) + -- > newSuffixSelectView + , oldSuffixSelectView :: Maybe (WeightedSelectView (BlockProtocol blk)) + -- ^ The 'WeightedSelectView' of the orphaned suffix of our old selection. + -- This is 'Nothing' when we extended our selection. } deriving Generic deriving stock instance - (Show (SelectView (BlockProtocol blk)), StandardHash blk) => Show (SelectionChangedInfo blk) + (Show (TiebreakerView (BlockProtocol blk)), StandardHash blk) => Show (SelectionChangedInfo blk) deriving stock instance - (Eq (SelectView (BlockProtocol blk)), StandardHash blk) => Eq (SelectionChangedInfo blk) + (Eq (TiebreakerView (BlockProtocol blk)), StandardHash blk) => Eq (SelectionChangedInfo blk) -- | Trace type for the various events that occur when adding a block. data TraceAddBlockEvent blk @@ -1027,3 +1064,26 @@ data TraceIteratorEvent blk newtype TraceChainSelStarvationEvent blk = ChainSelStarvation (Enclosing' (RealPoint blk)) deriving (Generic, Eq, Show) + +data TraceAddPerasCertEvent blk + = -- | The Peras certificate from the given round boosting the given block was + -- added to the queue. The size of the queue is included. + AddedPerasCertToQueue PerasRoundNo (Point blk) (Enclosing' Word) + | -- | The Peras certificate from the given round boosting the given block was + -- popped from the queue. + PoppedPerasCertFromQueue PerasRoundNo (Point blk) + | -- | The Peras certificate from the given round boosting the given block was + -- too old, ie its slot was older than the current immutable slot (the third + -- argument). + IgnorePerasCertTooOld PerasRoundNo (Point blk) (Point blk) + | -- | The Peras certificate from the given round boosts a block on the + -- current selection. + PerasCertBoostsCurrentChain PerasRoundNo (Point blk) + | -- | The Peras certificate from the given round boosts the Genesis point. + PerasCertBoostsGenesis PerasRoundNo + | -- | The Peras certificate from the given round boosts a block that we have + -- not (yet) received. + PerasCertBoostsBlockNotYetReceived PerasRoundNo (Point blk) + | -- | Perform chain selection for a block boosted by a Peras certificate. + ChainSelectionForBoostedBlock PerasRoundNo (Point blk) + deriving (Generic, Eq, Show) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB.hs new file mode 100644 index 0000000000..288039b30c --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB.hs @@ -0,0 +1,4 @@ +module Ouroboros.Consensus.Storage.PerasCertDB (module X) where + +import Ouroboros.Consensus.Storage.PerasCertDB.API as X +import Ouroboros.Consensus.Storage.PerasCertDB.Impl as X 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 new file mode 100644 index 0000000000..db9b51be67 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.Storage.PerasCertDB.API + ( PerasCertDB (..) + , AddPerasCertResult (..) + + -- * 'PerasCertSnapshot' + , PerasCertSnapshot (..) + , PerasCertTicketNo + , zeroPerasCertTicketNo + ) where + +import Data.Word (Word64) +import NoThunks.Class +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) +import Ouroboros.Consensus.Peras.Weight +import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Consensus.Util.STM (WithFingerprint (..)) + +data PerasCertDB m blk = PerasCertDB + { addCert :: WithArrivalTime (ValidatedPerasCert blk) -> m AddPerasCertResult + -- ^ TODO docs + , getWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) + -- ^ Return the Peras weights in order compare the current selection against + -- potential candidate chains, namely the weights for blocks not older than + -- the current immutable tip. It might contain weights for even older blocks + -- if they have not yet been garbage-collected. + -- + -- The 'Fingerprint' is updated every time a new certificate is added, but it + -- stays the same when certificates are garbage-collected. + , getCertSnapshot :: STM m (PerasCertSnapshot blk) + , garbageCollect :: SlotNo -> m () + -- ^ Garbage-collect state older than the given slot number. + , closeDB :: m () + } + deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDB" (PerasCertDB m blk) + +data AddPerasCertResult = AddedPerasCertToDB | PerasCertAlreadyInDB + deriving stock (Show, Eq) + +-- TODO: also move the weight snapshot in here? +data PerasCertSnapshot blk = PerasCertSnapshot + { containsCert :: PerasRoundNo -> Bool + -- ^ Do we have the certificate for this round? + , getCertsAfter :: + PerasCertTicketNo -> + [(WithArrivalTime (ValidatedPerasCert blk), PerasCertTicketNo)] + } + +-- TODO: Once we store historical certificates on disk, this should (also) track +-- round numbers, as we only have ticket numbers for in-memory certs. +newtype PerasCertTicketNo = PerasCertTicketNo Word64 + deriving stock Show + deriving newtype (Eq, Ord, Enum, NoThunks) + +zeroPerasCertTicketNo :: PerasCertTicketNo +zeroPerasCertTicketNo = PerasCertTicketNo 0 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 new file mode 100644 index 0000000000..3428ce5f64 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module Ouroboros.Consensus.Storage.PerasCertDB.Impl + ( -- * Opening + PerasCertDbArgs (..) + , defaultArgs + , openDB + + -- * Trace types + , TraceEvent (..) + + -- * Exceptions + , PerasCertDbError (..) + ) where + +import Control.Tracer (Tracer, nullTracer, traceWith) +import Data.Functor ((<&>)) +import Data.Kind (Type) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import GHC.Generics (Generic) +import NoThunks.Class +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) +import Ouroboros.Consensus.Peras.Weight +import Ouroboros.Consensus.Storage.PerasCertDB.API +import Ouroboros.Consensus.Util.Args +import Ouroboros.Consensus.Util.CallStack +import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Consensus.Util.STM + +{------------------------------------------------------------------------------ + Opening the database +------------------------------------------------------------------------------} + +type PerasCertDbArgs :: (Type -> Type) -> (Type -> Type) -> Type -> Type +data PerasCertDbArgs f m blk = PerasCertDbArgs + { pcdbaTracer :: Tracer m (TraceEvent blk) + } + +defaultArgs :: Applicative m => Incomplete PerasCertDbArgs m blk +defaultArgs = + PerasCertDbArgs + { pcdbaTracer = nullTracer + } + +openDB :: + forall m blk. + ( IOLike m + , StandardHash blk + ) => + Complete PerasCertDbArgs m blk -> + m (PerasCertDB m blk) +openDB args = do + pcdbVolatileState <- newTVarIO initialPerasVolatileCertState + let env = + PerasCertDbEnv + { pcdbTracer + , pcdbVolatileState + } + h <- PerasCertDbHandle <$> newTVarIO (PerasCertDbOpen env) + traceWith pcdbTracer OpenedPerasCertDB + pure + PerasCertDB + { addCert = getEnv1 h implAddCert + , getWeightSnapshot = getEnvSTM h implGetWeightSnapshot + , getCertSnapshot = getEnvSTM h implGetCertSnapshot + , garbageCollect = getEnv1 h implGarbageCollect + , closeDB = implCloseDB h + } + where + PerasCertDbArgs + { pcdbaTracer = pcdbTracer + } = args + +{------------------------------------------------------------------------------- + Database state +-------------------------------------------------------------------------------} + +newtype PerasCertDbHandle m blk = PerasCertDbHandle (StrictTVar m (PerasCertDbState m blk)) + +data PerasCertDbState m blk + = PerasCertDbOpen !(PerasCertDbEnv m blk) + | PerasCertDbClosed + deriving stock Generic + deriving anyclass NoThunks + +data PerasCertDbEnv m blk = PerasCertDbEnv + { pcdbTracer :: !(Tracer m (TraceEvent blk)) + , pcdbVolatileState :: !(StrictTVar m (WithFingerprint (PerasVolatileCertState blk))) + -- ^ The 'RoundNo's of all certificates currently in the db. + } + deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDbEnv" (PerasCertDbEnv m blk) + +getEnv :: + (IOLike m, HasCallStack) => + PerasCertDbHandle m blk -> + (PerasCertDbEnv m blk -> m r) -> + m r +getEnv (PerasCertDbHandle varState) f = + readTVarIO varState >>= \case + PerasCertDbOpen env -> f env + PerasCertDbClosed -> throwIO $ ClosedDBError prettyCallStack + +getEnv1 :: + (IOLike m, HasCallStack) => + PerasCertDbHandle m blk -> + (PerasCertDbEnv m blk -> a -> m r) -> + a -> + m r +getEnv1 h f a = getEnv h (\env -> f env a) + +getEnvSTM :: + (IOLike m, HasCallStack) => + PerasCertDbHandle m blk -> + (PerasCertDbEnv m blk -> STM m r) -> + STM m r +getEnvSTM (PerasCertDbHandle varState) f = + readTVar varState >>= \case + PerasCertDbOpen env -> f env + PerasCertDbClosed -> throwIO $ ClosedDBError prettyCallStack + +{------------------------------------------------------------------------------- + API implementation +-------------------------------------------------------------------------------} + +implCloseDB :: IOLike m => PerasCertDbHandle m blk -> m () +implCloseDB (PerasCertDbHandle varState) = + atomically (swapTVar varState PerasCertDbClosed) >>= \case + PerasCertDbOpen PerasCertDbEnv{pcdbTracer} -> do + traceWith pcdbTracer ClosedPerasCertDB + -- DB was already closed. + PerasCertDbClosed -> pure () + +-- TODO: validation +implAddCert :: + ( IOLike m + , StandardHash blk + ) => + PerasCertDbEnv m blk -> + WithArrivalTime (ValidatedPerasCert blk) -> + m AddPerasCertResult +implAddCert env cert = do + traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt + res <- atomically $ do + WithFingerprint + PerasVolatileCertState + { pvcsCerts + , pvcsWeightByPoint + , pvcsCertsByTicket + , pvcsLastTicketNo + } + fp <- + readTVar pcdbVolatileState + if Map.member roundNo pvcsCerts + then pure PerasCertAlreadyInDB + else do + let pvcsLastTicketNo' = succ pvcsLastTicketNo + writeTVar pcdbVolatileState $ + WithFingerprint + PerasVolatileCertState + { pvcsCerts = + Map.insert roundNo cert pvcsCerts + , -- Note that the same block might be boosted by multiple points. + pvcsWeightByPoint = + addToPerasWeightSnapshot boostedPt (getPerasCertBoost cert) pvcsWeightByPoint + , pvcsCertsByTicket = + Map.insert pvcsLastTicketNo' cert pvcsCertsByTicket + , pvcsLastTicketNo = pvcsLastTicketNo' + } + (succ fp) + pure AddedPerasCertToDB + traceWith pcdbTracer $ case res of + AddedPerasCertToDB -> AddedPerasCert roundNo boostedPt + PerasCertAlreadyInDB -> IgnoredCertAlreadyInDB roundNo boostedPt + pure res + where + PerasCertDbEnv + { pcdbTracer + , pcdbVolatileState + } = env + + boostedPt = getPerasCertBoostedBlock cert + roundNo = getPerasCertRound cert + +implGetWeightSnapshot :: + IOLike m => + PerasCertDbEnv m blk -> STM m (WithFingerprint (PerasWeightSnapshot blk)) +implGetWeightSnapshot PerasCertDbEnv{pcdbVolatileState} = + fmap pvcsWeightByPoint <$> readTVar pcdbVolatileState + +implGetCertSnapshot :: + IOLike m => + PerasCertDbEnv m blk -> STM m (PerasCertSnapshot blk) +implGetCertSnapshot PerasCertDbEnv{pcdbVolatileState} = + readTVar pcdbVolatileState + <&> forgetFingerprint + <&> \PerasVolatileCertState + { pvcsCerts + , pvcsCertsByTicket + } -> + PerasCertSnapshot + { containsCert = \r -> Map.member r pvcsCerts + , getCertsAfter = \ticketNo -> + let (_, certs) = Map.split ticketNo pvcsCertsByTicket + in [(cert, tno) | (tno, cert) <- Map.toAscList certs] + } + +implGarbageCollect :: + forall m blk. + (IOLike m, StandardHash blk) => + PerasCertDbEnv m blk -> SlotNo -> m () +implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = + -- No need to update the 'Fingerprint' as we only remove certificates that do + -- not matter for comparing interesting chains. + atomically $ modifyTVar pcdbVolatileState (fmap gc) + where + gc :: PerasVolatileCertState blk -> PerasVolatileCertState blk + gc + PerasVolatileCertState + { pvcsCerts + , pvcsWeightByPoint + , pvcsLastTicketNo + , pvcsCertsByTicket + } = + PerasVolatileCertState + { pvcsCerts = Map.filter keepCert pvcsCerts + , pvcsWeightByPoint = prunePerasWeightSnapshot slot pvcsWeightByPoint + , pvcsCertsByTicket = Map.filter keepCert pvcsCertsByTicket + , pvcsLastTicketNo = pvcsLastTicketNo + } + where + keepCert cert = + pointSlot (getPerasCertBoostedBlock cert) >= NotOrigin slot + +{------------------------------------------------------------------------------- + Implementation-internal types +-------------------------------------------------------------------------------} + +-- | Volatile Peras certificate state, i.e. certificates that could influence +-- chain selection by boosting a volatile block. +data PerasVolatileCertState blk = PerasVolatileCertState + { pvcsCerts :: !(Map PerasRoundNo (WithArrivalTime (ValidatedPerasCert blk))) + -- ^ The boosted blocks by 'RoundNo' of all certificates currently in the db. + , pvcsWeightByPoint :: !(PerasWeightSnapshot blk) + -- ^ The weight of boosted blocks w.r.t. the certificates currently in the db. + -- + -- INVARIANT: In sync with 'pvcsCerts'. + , pvcsCertsByTicket :: !(Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))) + -- ^ The certificates by 'PerasCertTicketNo'. + -- + -- INVARIANT: In sync with 'pvcsCerts'. + , pvcsLastTicketNo :: !PerasCertTicketNo + -- ^ The most recent 'PerasCertTicketNo' (or 'zeroPerasCertTicketNo' + -- otherwise). + } + deriving stock (Show, Generic) + deriving anyclass NoThunks + +initialPerasVolatileCertState :: WithFingerprint (PerasVolatileCertState blk) +initialPerasVolatileCertState = + WithFingerprint + PerasVolatileCertState + { pvcsCerts = Map.empty + , pvcsWeightByPoint = emptyPerasWeightSnapshot + , pvcsCertsByTicket = Map.empty + , pvcsLastTicketNo = zeroPerasCertTicketNo + } + (Fingerprint 0) + +{------------------------------------------------------------------------------- + Trace types +-------------------------------------------------------------------------------} + +data TraceEvent blk + = OpenedPerasCertDB + | ClosedPerasCertDB + | AddingPerasCert PerasRoundNo (Point blk) + | AddedPerasCert PerasRoundNo (Point blk) + | IgnoredCertAlreadyInDB PerasRoundNo (Point blk) + deriving stock (Show, Eq, Generic) + +{------------------------------------------------------------------------------- + Exceptions +-------------------------------------------------------------------------------} + +data PerasCertDbError + = ClosedDBError PrettyCallStack + deriving stock Show + deriving anyclass Exception diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs index cfcb5c3050..0eca5b8e03 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs @@ -10,26 +10,21 @@ module Ouroboros.Consensus.Util.AnchoredFragment ( compareAnchoredFragments , compareHeadBlockNo , cross - , forksAtMostKBlocks + , forksAtMostKWeight , preferAnchoredCandidate , stripCommonPrefix ) where -import Control.Monad.Except (throwError) import Data.Foldable (toList) import qualified Data.Foldable1 as F1 import Data.Function (on) import qualified Data.List.NonEmpty as NE -import Data.Maybe (isJust) -import Data.Word (Word64) import GHC.Stack import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Peras.SelectView +import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Protocol.Abstract -import Ouroboros.Consensus.Util.Assert -import Ouroboros.Network.AnchoredFragment - ( AnchoredFragment - , AnchoredSeq (Empty, (:>)) - ) +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF {------------------------------------------------------------------------------- @@ -59,76 +54,67 @@ compareHeadBlockNo :: Ordering compareHeadBlockNo = compare `on` AF.headBlockNo -forksAtMostKBlocks :: - HasHeader b => - -- | How many blocks can it fork? - Word64 -> - -- | Our chain. +-- | Check that we can switch from @ours@ to @theirs@ by rolling back our chain +-- by at most @k@ weight. +-- +-- If @ours@ and @cand@ do not intersect, this returns 'False'. If they do +-- intersect, then we check that the suffix of @ours@ after the intersection has +-- total weight at most @k@. +forksAtMostKWeight :: + ( StandardHash blk + , HasHeader b + , HeaderHash blk ~ HeaderHash b + ) => + PerasWeightSnapshot blk -> + -- | By how much weight can we roll back our chain at most? + PerasWeight -> + -- | Our chain @ours@. AnchoredFragment b -> - -- | Their chain + -- | Their chain @theirs@. AnchoredFragment b -> - -- | Indicates whether their chain forks at most the - -- specified number of blocks. + -- | Indicates whether their chain forks at most the given the amount of + -- weight. Returns 'False' if the two fragments do not intersect. Bool -forksAtMostKBlocks k ours theirs = case ours `AF.intersect` theirs of - Nothing -> False - Just (_, _, ourSuffix, _) -> fromIntegral (AF.length ourSuffix) <= k +forksAtMostKWeight weights maxWeight ours theirs = + case ours `AF.intersect` theirs of + Nothing -> False + Just (_, _, ourSuffix, _) -> + totalWeightOfFragment weights ourSuffix <= maxWeight -- | Compare two (potentially empty!) 'AnchoredFragment's. -- --- PRECONDITION: Either both fragments are non-empty or they intersect. --- --- For a detailed discussion of this precondition, and a justification for the --- definition of this function, please refer to the Consensus Report. +-- PRECONDITION: The fragments must intersect. -- -- Usage note: the primary user of this function is the chain database when -- sorting fragments that are preferred over our selection. It establishes the -- precondition in the following way: It will only compare candidate fragments --- that it has previously verified are preferable to our current chain. --- Therefore, they are non-empty, as an empty fragment anchored in our chain can --- never be preferable to our chain. +-- that it has previously verified are preferable to our current chain. Since +-- these fragments intersect with our current chain, we can enlarge them to all +-- be anchored in the immutable tip. Therefore, they intersect pairwise. compareAnchoredFragments :: forall blk h. ( BlockSupportsProtocol blk , HasCallStack , GetHeader1 h , HasHeader (h blk) + , HeaderHash (h blk) ~ HeaderHash blk ) => BlockConfig blk -> + PerasWeightSnapshot blk -> AnchoredFragment (h blk) -> AnchoredFragment (h blk) -> Ordering -compareAnchoredFragments cfg frag1 frag2 = - assertWithMsg (precondition frag1 frag2) $ - case (frag1, frag2) of - (Empty _, Empty _) -> - -- The fragments intersect but are equal: their anchors must be equal, - -- and hence the fragments represent the same chain. They are therefore - -- equally preferable. - EQ - (Empty anchor, _ :> tip') -> - -- Since the fragments intersect, but the first one is empty, its anchor - -- must lie somewhere along the the second. If it is the tip, the two - -- fragments represent the same chain and are equally preferable. If - -- not, the second chain is a strict extension of the first and is - -- therefore strictly preferable. - if blockPoint tip' == AF.castPoint (AF.anchorToPoint anchor) - then EQ - else LT - (_ :> tip, Empty anchor') -> - -- This case is symmetric to the previous - if blockPoint tip == AF.castPoint (AF.anchorToPoint anchor') - then EQ - else GT - (_ :> tip, _ :> tip') -> - -- Case 4 - compare - (selectView cfg (getHeader1 tip)) - (selectView cfg (getHeader1 tip')) +compareAnchoredFragments cfg weights frag1 frag2 = + case AF.intersect frag1 frag2 of + Nothing -> error "precondition violated: fragments must intersect" + Just (_oursPrefix, _candPrefix, oursSuffix, candSuffix) -> + compare + (weightedSelectView cfg weights oursSuffix) + (weightedSelectView cfg weights candSuffix) -- | Lift 'preferCandidate' to 'AnchoredFragment' -- --- PRECONDITION: Either both fragments are non-empty or they intersect. +-- PRECONDITION: The fragments must intersect. -- -- Usage note: the primary user of this function is the chain database. It -- establishes the precondition when comparing a candidate fragment to our @@ -142,47 +128,27 @@ preferAnchoredCandidate :: , HasCallStack , GetHeader1 h , GetHeader1 h' + , HeaderHash (h blk) ~ HeaderHash blk , HeaderHash (h blk) ~ HeaderHash (h' blk) , HasHeader (h blk) , HasHeader (h' blk) ) => BlockConfig blk -> + -- | Peras weights used to judge this chain. + PerasWeightSnapshot blk -> -- | Our chain AnchoredFragment (h blk) -> -- | Candidate AnchoredFragment (h' blk) -> Bool -preferAnchoredCandidate cfg ours cand = - assertWithMsg (precondition ours cand) $ - case (ours, cand) of - (_, Empty _) -> False - (Empty ourAnchor, _ :> theirTip) -> - blockPoint theirTip /= castPoint (AF.anchorToPoint ourAnchor) - (_ :> ourTip, _ :> theirTip) -> - preferCandidate - (projectChainOrderConfig cfg) - (selectView cfg (getHeader1 ourTip)) - (selectView cfg (getHeader1 theirTip)) - --- For 'compareAnchoredFragment' and 'preferAnchoredCandidate'. -precondition :: - ( HeaderHash (h blk) ~ HeaderHash (h' blk) - , HasHeader (h blk) - , HasHeader (h' blk) - ) => - AnchoredFragment (h blk) -> - AnchoredFragment (h' blk) -> - Either String () -precondition frag1 frag2 - | not (AF.null frag1) - , not (AF.null frag2) = - return () - | isJust (AF.intersectionPoint frag1 frag2) = - return () - | otherwise = - throwError - "precondition violated: fragments should both be non-empty or they \ - \should intersect" +preferAnchoredCandidate cfg weights ours cand = + case AF.intersect ours cand of + Nothing -> error "precondition violated: fragments must intersect" + Just (_oursPrefix, _candPrefix, oursSuffix, candSuffix) -> + preferCandidate + (projectChainOrderConfig cfg) + (weightedSelectView cfg weights oursSuffix) + (weightedSelectView cfg weights candSuffix) -- | If the two fragments `c1` and `c2` intersect, return the intersection -- point and join the prefix of `c1` before the intersection with the suffix 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 a623d0b9a9..71bc19a5f8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -31,6 +31,7 @@ import NoThunks.Class , OnlyCheckWhnfNamed (..) , allNoThunks ) +import Ouroboros.Consensus.Node.NetworkProtocolVersion (NodeToNodeVersion) import Ouroboros.Network.Util.ShowProxy import System.FS.API (SomeHasFS) import System.FS.API.Types (FsPath, Handle) @@ -85,6 +86,9 @@ instance NoThunks a => NoThunks (MultiSet a) where showTypeOf _ = "MultiSet" wNoThunks ctxt = wNoThunks ctxt . MultiSet.toMap +-- NOTE: fixed in https://github.com/IntersectMBO/ouroboros-network/pull/5214 +instance NoThunks NodeToNodeVersion + {------------------------------------------------------------------------------- fs-api -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs index 9130e3bee1..86687227c7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs @@ -1,9 +1,5 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -36,10 +32,12 @@ import Control.Monad (void) import Control.Monad.State (StateT (..)) import Control.ResourceRegistry import Data.Void -import Data.Word (Word64) -import GHC.Generics (Generic) import GHC.Stack import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Network.BlockFetch.ConsensusInterface + ( Fingerprint (..) + , WithFingerprint (..) + ) {------------------------------------------------------------------------------- Misc @@ -83,20 +81,6 @@ blockUntilJust getMaybeA = do blockUntilAllJust :: MonadSTM m => [STM m (Maybe a)] -> STM m [a] blockUntilAllJust = mapM blockUntilJust --- | Simple type that can be used to indicate something in a @TVar@ is --- changed. -newtype Fingerprint = Fingerprint Word64 - deriving stock (Show, Eq, Generic) - deriving newtype Enum - deriving anyclass NoThunks - --- | Store a value together with its fingerprint. -data WithFingerprint a = WithFingerprint - { forgetFingerprint :: !a - , getFingerprint :: !Fingerprint - } - deriving (Show, Eq, Functor, Generic, NoThunks) - {------------------------------------------------------------------------------- Simulate monad stacks -------------------------------------------------------------------------------} 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 08ef2fa6f9..47b4ab762a 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 @@ -750,6 +750,7 @@ mkTestConfig k ChunkSize{chunkCanContainEBB, numRegularBlocks} = , eraSlotLength = slotLength , eraSafeZone = HardFork.StandardSafeZone (unNonZero (maxRollbacks k) * 2) , eraGenesisWin = GenesisWindow (unNonZero (maxRollbacks k) * 2) + , eraPerasRoundLength = HardFork.PerasEnabled defaultPerasRoundLength } instance ImmutableEraParams TestBlock where 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 d32ee6522b..75110df40e 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -32,6 +32,7 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB import Ouroboros.Consensus.Storage.LedgerDB.V2.Args +import Ouroboros.Consensus.Storage.PerasCertDB (PerasCertDbArgs (..)) import Ouroboros.Consensus.Storage.VolatileDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.Args @@ -135,6 +136,10 @@ fromMinimalChainDbArgs MinimalChainDbArgs{..} = , lgrQueryBatchSize = DefaultQueryBatchSize , lgrStartSnapshot = Nothing } + , cdbPerasCertDbArgs = + PerasCertDbArgs + { pcdbaTracer = nullTracer + } , cdbsArgs = ChainDbSpecificArgs { cdbsBlocksToAddSize = 1 diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs index 27b96abf4e..544f25db2a 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs @@ -310,7 +310,17 @@ instance -------------------------------------------------------------------------------} instance Arbitrary EraParams where - arbitrary = EraParams <$> arbitrary <*> arbitrary <*> arbitrary <*> (GenesisWindow <$> arbitrary) + arbitrary = + EraParams + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> (GenesisWindow <$> arbitrary) + <*> mPerasRoundLength + where + mPerasRoundLength :: Gen (PerasEnabled PerasRoundLength) + mPerasRoundLength = do + (\x -> if x == 0 then NoPerasEnabled else PerasEnabled . PerasRoundLength $ x) <$> arbitrary instance Arbitrary SafeZone where arbitrary = @@ -332,6 +342,15 @@ instance Arbitrary Bound where <$> (RelativeTime <$> arbitrary) <*> (SlotNo <$> arbitrary) <*> (EpochNo <$> arbitrary) + <*> mPerasRoundNo + where + mPerasRoundNo :: Gen (PerasEnabled PerasRoundNo) + mPerasRoundNo = do + n <- arbitrary + pure $ + if n == 0 + then NoPerasEnabled + else PerasEnabled (PerasRoundNo n) instance Arbitrary (K Past blk) where arbitrary = K <$> (Past <$> arbitrary <*> arbitrary) 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 6830141290..d00f14ec1b 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 @@ -17,6 +17,7 @@ import qualified Control.Monad.Class.MonadTime.SI as SI import Data.TreeDiff import GHC.Generics (Generic) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime, WithArrivalTime) import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended @@ -112,6 +113,8 @@ instance , toExpr j ] +instance ToExpr RelativeTime where + toExpr = defaultExprViaShow instance ToExpr ChunkInfo where toExpr = defaultExprViaShow instance ToExpr FsError where @@ -119,6 +122,16 @@ instance ToExpr FsError where deriving instance ToExpr a => ToExpr (LoE a) +deriving anyclass instance ToExpr PerasRoundNo + +deriving anyclass instance ToExpr PerasWeight + +deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (PerasCert blk) + +deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (ValidatedPerasCert blk) + +deriving anyclass instance ToExpr a => ToExpr (WithArrivalTime a) + {------------------------------------------------------------------------------- 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 f1f397011b..27a8d0c641 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -139,6 +139,8 @@ import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Peras.SelectView (weightedSelectView) +import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.BFT import Ouroboros.Consensus.Protocol.MockChainSel @@ -859,15 +861,21 @@ treeToBlocks = Tree.flatten . blockTree treeToChains :: BlockTree -> [Chain TestBlock] treeToChains = map Chain.fromOldestFirst . allPaths . blockTree -treePreferredChain :: BlockTree -> Chain TestBlock -treePreferredChain = +treePreferredChain :: + PerasWeightSnapshot TestBlock -> + BlockTree -> + Chain TestBlock +treePreferredChain weights = fromMaybe Genesis . selectUnvalidatedChain (Proxy @(BlockProtocol TestBlock)) (() :: ChainOrderConfig (SelectView (BlockProtocol TestBlock))) - (\hdr -> SelectView (blockNo hdr) NoTiebreaker) + (weightedSelectView bcfg weights . Chain.toAnchoredFragment . fmap getHeader) Genesis . treeToChains + where + -- inconsequential for this function + bcfg = TestBlockConfig (NumCoreNodes 0) instance Show BlockTree where show (BlockTree t) = Tree.drawTree (fmap show t) diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index 88681b82fa..79d681213a 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -16,6 +16,9 @@ import qualified Test.Consensus.MiniProtocol.BlockFetch.Client (tests) import qualified Test.Consensus.MiniProtocol.ChainSync.CSJ (tests) import qualified Test.Consensus.MiniProtocol.ChainSync.Client (tests) import qualified Test.Consensus.MiniProtocol.LocalStateQuery.Server (tests) +import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke (tests) +import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke (tests) +import qualified Test.Consensus.Peras.WeightSnapshot (tests) import qualified Test.Consensus.Util.MonadSTM.NormalForm (tests) import qualified Test.Consensus.Util.Versioned (tests) import Test.Tasty @@ -36,6 +39,8 @@ tests = , Test.Consensus.MiniProtocol.BlockFetch.Client.tests , Test.Consensus.MiniProtocol.ChainSync.CSJ.tests , Test.Consensus.MiniProtocol.ChainSync.Client.tests + , Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke.tests + , Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke.tests , Test.Consensus.MiniProtocol.LocalStateQuery.Server.tests , testGroup "Mempool" @@ -43,6 +48,7 @@ tests = , Test.Consensus.Mempool.Fairness.tests , Test.Consensus.Mempool.StateMachine.tests ] + , Test.Consensus.Peras.WeightSnapshot.tests , Test.Consensus.Util.MonadSTM.NormalForm.tests , Test.Consensus.Util.Versioned.tests , testGroup diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/History.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/History.hs index 95491738d3..a2ad4d3bc8 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/History.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/History.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -65,11 +66,11 @@ import Test.Util.QuickCheck -- General approach: -- -- * Generate a chain of events --- * Each event records its own 'RelativeTime', 'SlotNo', and 'EpochNo' +-- * Each event records its own 'RelativeTime', 'SlotNo', 'EpochNo', and 'PerasRoundNo' -- * We then construct a 'HF.Summary' from a /prefix/ of this chain -- * We then pick an arbitrary event from the (full) chain: -- a. If that event is on the prefix of the chain, or within the safe zone, we --- expect to be able to do any slot/epoch or slot/time conversion, and we +-- expect to be able to do any slot/epoch, slot/time or Peras round/slot conversion, and we -- can easily verify the result by comparing it to the values the 'Event' -- itself reports. -- b. If the event is outside of safe zone, we expect the conversion to throw @@ -96,6 +97,7 @@ tests = , testProperty "eventWallclockToSlot" eventWallclockToSlot , testProperty "epochInfoSlotToEpoch" epochInfoSlotToEpoch , testProperty "epochInfoEpochToSlot" epochInfoEpochToSlot + , testProperty "eventPerasRounNoToSlot" eventPerasRoundNoToSlot , testProperty "query vs expr" queryVsExprConsistency ] ] @@ -208,6 +210,20 @@ eventWallclockToSlot chain@ArbitraryChain{..} = diff :: NominalDiffTime diff = arbitraryDiffTime arbitraryParams +eventPerasRoundNoToSlot :: ArbitraryChain -> Property +eventPerasRoundNoToSlot chain@ArbitraryChain{..} = + testSkeleton chain (HF.perasRoundNoToSlot eventTimePerasRoundNo) $ + \case + HF.NoPerasEnabled -> property True + HF.PerasEnabled (startOfPerasRound, roundLength) -> + conjoin + [ eventTimeSlot + === (HF.addSlots eventTimeSlotInPerasRound startOfPerasRound) + , eventTimeSlotInPerasRound `lt` (unPerasRoundLength roundLength) + ] + where + EventTime{..} = eventTime arbitraryEvent + -- | Composing queries should be equivalent to composing expressions. -- -- This is a regression test. Each expression in a query should be evaluated in @@ -503,7 +519,13 @@ data EventTime = EventTime { eventTimeSlot :: SlotNo , eventTimeEpochNo :: EpochNo , eventTimeEpochSlot :: Word64 + -- ^ Relative slot withing the current epoch round, + -- needed to be able to advance the epoch number , eventTimeRelative :: RelativeTime + , eventTimePerasRoundNo :: PerasRoundNo + , eventTimeSlotInPerasRound :: Word64 + -- ^ Relative slot withing the current Peras round, + -- needed to be able to advance the round number } deriving Show @@ -514,6 +536,8 @@ initEventTime = , eventTimeEpochNo = EpochNo 0 , eventTimeEpochSlot = 0 , eventTimeRelative = RelativeTime 0 + , eventTimePerasRoundNo = PerasRoundNo 0 + , eventTimeSlotInPerasRound = 0 } -- | Next time slot @@ -526,6 +550,8 @@ stepEventTime HF.EraParams{..} EventTime{..} = , eventTimeRelative = addRelTime (getSlotLength eraSlotLength) $ eventTimeRelative + , eventTimePerasRoundNo = perasRoundNo' + , eventTimeSlotInPerasRound = slotInPerasRound' } where epoch' :: EpochNo @@ -535,6 +561,16 @@ stepEventTime HF.EraParams{..} EventTime{..} = then (succ eventTimeEpochNo, 0) else (eventTimeEpochNo, succ eventTimeEpochSlot) + perasRoundNo' :: PerasRoundNo + slotInPerasRound' :: Word64 + args@(perasRoundNo', slotInPerasRound') = + case eraPerasRoundLength of + HF.NoPerasEnabled -> args + HF.PerasEnabled (PerasRoundLength perasRoundLength) -> + if succ eventTimeSlotInPerasRound == perasRoundLength + then (succ eventTimePerasRoundNo, 0) + else (eventTimePerasRoundNo, succ eventTimeSlotInPerasRound) + {------------------------------------------------------------------------------- Chain model -----------------------------------------------------------------------------} diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Infra.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Infra.hs index 150ccda30e..4cecb8c968 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Infra.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Infra.hs @@ -35,7 +35,9 @@ import Data.SOP.Strict import Data.Word import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime +import Ouroboros.Consensus.HardFork.History (Bound (..)) import qualified Ouroboros.Consensus.HardFork.History as HF +import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (..)) import Test.QuickCheck {------------------------------------------------------------------------------- @@ -121,6 +123,11 @@ genEraParams = do eraSlotLength <- slotLengthFromSec <$> choose (1, 5) eraSafeZone <- genSafeZone eraGenesisWin <- GenesisWindow <$> choose (1, 10) + -- we restrict Peras round length to divide the epoch size. + -- for testing purposes, we include Peras round length in every era. + eraPerasRoundLength <- + HF.PerasEnabled . PerasRoundLength + <$> choose (1, 10) `suchThat` (\x -> (unEpochSize eraEpochSize) `mod` x == 0) return HF.EraParams{..} where genSafeZone :: Gen HF.SafeZone @@ -154,8 +161,13 @@ genShape eras = HF.Shape <$> erasMapStateM genParams eras (EpochNo 0) genSummary :: Eras xs -> Gen (HF.Summary xs) genSummary is = - HF.Summary <$> erasUnfoldAtMost genEraSummary is HF.initBound + HF.Summary <$> erasUnfoldAtMost genEraSummary is initBoundWithPeras where + -- TODO(geo2a): revisit this hard-coding of enabling Peras when + -- we're further into the integration process + -- see https://github.com/tweag/cardano-peras/issues/112 + initBoundWithPeras = HF.initBound{boundPerasRound = HF.PerasEnabled . PerasRoundNo $ 0} + genEraSummary :: Era -> HF.Bound -> Gen (HF.EraSummary, HF.EraEnd) genEraSummary _era lo = do params <- genEraParams diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Summary.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Summary.hs index c1bc38c9f6..361e5d0966 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Summary.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Summary.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RankNTypes #-} @@ -19,6 +20,7 @@ -- * Converting slot to an epoch and then back to a slot should be an identity -- (modulo the time spent in that epoch). -- * Converting an epoch to a slot and then back should be an identity. +-- * Converting a Peras round number to a slot and then back should be an identity. module Test.Consensus.HardFork.Summary (tests) where import Data.Time @@ -50,6 +52,7 @@ tests = , testProperty "roundtripSlotWallclock" roundtripSlotWallclock , testProperty "roundtripSlotEpoch" roundtripSlotEpoch , testProperty "roundtripEpochSlot" roundtripEpochSlot + , testProperty "roundtripPerasRoundSlot" roundtripPerasRoundSlot , testProperty "reportsPastHorizon" reportsPastHorizon ] ] @@ -131,6 +134,28 @@ roundtripEpochSlot s@ArbitrarySummary{beforeHorizonEpoch = epoch} = , inEpoch + slotsLeft === unEpochSize epochSize ] +-- | Test that conversion between Peras rounds and slots roundtips. +-- Additionally, test that the relative slot in round and remaining +-- slots in round are withing the round length. +roundtripPerasRoundSlot :: ArbitrarySummary -> Property +roundtripPerasRoundSlot s@ArbitrarySummary{beforeHorizonPerasRoundNo} = + case beforeHorizonPerasRoundNo of + HF.NoPerasEnabled -> property True + HF.PerasEnabled perasRoundNo -> + noPastHorizonException s $ + HF.perasRoundNoToSlot perasRoundNo >>= \case + HF.NoPerasEnabled -> pure $ property True + HF.PerasEnabled (slot, PerasRoundLength perasRoundLength) -> do + HF.slotToPerasRoundNo slot >>= \case + HF.NoPerasEnabled -> pure $ property True + HF.PerasEnabled (perasRoundNo', slotInRound, remainingSlotsInRound) -> + pure $ + conjoin + [ perasRoundNo' === perasRoundNo + , slotInRound `lt` perasRoundLength + , remainingSlotsInRound `le` perasRoundLength + ] + reportsPastHorizon :: ArbitrarySummary -> Property reportsPastHorizon s@ArbitrarySummary{..} = conjoin @@ -146,6 +171,9 @@ reportsPastHorizon s@ArbitrarySummary{..} = , case mPastHorizonEpoch of Just x -> isPastHorizonException s $ HF.epochToSlot x Nothing -> property True + , case mPastHorizonPerasRoundNo of + Just (HF.PerasEnabled x) -> isPastHorizonException s $ HF.perasRoundNoToSlot x + _ -> property True ] {------------------------------------------------------------------------------- @@ -160,9 +188,13 @@ data ArbitrarySummary = forall xs. ArbitrarySummary , beforeHorizonTime :: RelativeTime , beforeHorizonSlot :: SlotNo , beforeHorizonEpoch :: EpochNo + , beforeHorizonPerasRoundNo :: HF.PerasEnabled PerasRoundNo + -- ^ 'PerasRoundNo' is not optional here, + -- i.e. we do not model non-Peras eras in the time conversion tests , mPastHorizonTime :: Maybe RelativeTime , mPastHorizonSlot :: Maybe SlotNo , mPastHorizonEpoch :: Maybe EpochNo + , mPastHorizonPerasRoundNo :: Maybe (HF.PerasEnabled PerasRoundNo) } deriving instance Show ArbitrarySummary @@ -181,10 +213,12 @@ instance Arbitrary ArbitrarySummary where beforeHorizonSlots <- choose (0, 100_000_000) beforeHorizonEpochs <- choose (0, 1_000_000) beforeHorizonSeconds <- choose (0, 1_000_000_000) + beforeHorizonPerasRounds <- HF.PerasEnabled <$> choose (0, 1_000) let beforeHorizonSlot :: SlotNo beforeHorizonEpoch :: EpochNo beforeHorizonTime :: RelativeTime + beforeHorizonPerasRoundNo :: HF.PerasEnabled PerasRoundNo beforeHorizonSlot = HF.addSlots @@ -198,19 +232,25 @@ instance Arbitrary ArbitrarySummary where addRelTime (realToFrac (beforeHorizonSeconds :: Double)) (HF.boundTime summaryStart) - + beforeHorizonPerasRoundNo = + HF.addPerasRounds + <$> beforeHorizonPerasRounds + <*> HF.boundPerasRound summaryStart return ArbitrarySummary { arbitrarySummary = summary , beforeHorizonTime , beforeHorizonSlot , beforeHorizonEpoch + , beforeHorizonPerasRoundNo , mPastHorizonTime = Nothing , mPastHorizonSlot = Nothing , mPastHorizonEpoch = Nothing + , mPastHorizonPerasRoundNo = Nothing } HF.EraEnd summaryEnd -> do let summarySlots, summaryEpochs :: Word64 + summaryPerasRounds :: HF.PerasEnabled Word64 summarySlots = HF.countSlots (HF.boundSlot summaryEnd) @@ -219,7 +259,10 @@ instance Arbitrary ArbitrarySummary where HF.countEpochs (HF.boundEpoch summaryEnd) (HF.boundEpoch summaryStart) - + summaryPerasRounds = + HF.countPerasRounds + <$> HF.boundPerasRound summaryEnd + <*> HF.boundPerasRound summaryStart summaryTimeSpan :: NominalDiffTime summaryTimeSpan = diffRelTime @@ -236,7 +279,9 @@ instance Arbitrary ArbitrarySummary where beforeHorizonSeconds <- choose (0, summaryTimeSpanSeconds) `suchThat` \x -> x /= summaryTimeSpanSeconds - + beforeHorizonPerasRounds <- case summaryPerasRounds of + HF.NoPerasEnabled -> pure HF.NoPerasEnabled + HF.PerasEnabled rounds -> HF.PerasEnabled <$> choose (0, rounds - 1) let beforeHorizonSlot :: SlotNo beforeHorizonEpoch :: EpochNo beforeHorizonTime :: RelativeTime @@ -253,16 +298,22 @@ instance Arbitrary ArbitrarySummary where addRelTime (realToFrac beforeHorizonSeconds) (HF.boundTime summaryStart) + beforeHorizonPerasRoundNo = + HF.addPerasRounds + <$> beforeHorizonPerasRounds + <*> HF.boundPerasRound summaryStart -- Pick arbitrary values past the horizon pastHorizonSlots :: Word64 <- choose (0, 10) pastHorizonEpochs :: Word64 <- choose (0, 10) pastHorizonSeconds :: Double <- choose (0, 10) + pastHorizonPerasRounds :: HF.PerasEnabled Word64 <- HF.PerasEnabled <$> choose (0, 10) let pastHorizonSlot :: SlotNo pastHorizonEpoch :: EpochNo pastHorizonTime :: RelativeTime + pastHorizonPerasRoundNo :: HF.PerasEnabled PerasRoundNo pastHorizonSlot = HF.addSlots @@ -276,16 +327,21 @@ instance Arbitrary ArbitrarySummary where addRelTime (realToFrac pastHorizonSeconds) (HF.boundTime summaryEnd) - + pastHorizonPerasRoundNo = + HF.addPerasRounds + <$> pastHorizonPerasRounds + <*> HF.boundPerasRound summaryEnd return ArbitrarySummary { arbitrarySummary = summary , beforeHorizonTime , beforeHorizonSlot , beforeHorizonEpoch + , beforeHorizonPerasRoundNo , mPastHorizonTime = Just pastHorizonTime , mPastHorizonSlot = Just pastHorizonSlot , mPastHorizonEpoch = Just pastHorizonEpoch + , mPastHorizonPerasRoundNo = Just pastHorizonPerasRoundNo } shrink summary@ArbitrarySummary{..} = diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs index e45c89ab65..1a440370e7 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs @@ -306,6 +306,7 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do getMaxSlotNo = ChainDB.getMaxSlotNo chainDB addBlockAsync = ChainDB.addBlockAsync chainDB getChainSelStarvation = ChainDB.getChainSelStarvation chainDB + getPerasWeightSnapshot = ChainDB.getPerasWeightSnapshot chainDB pure BlockFetchClientInterface.ChainDbView{..} where cdbTracer = Tracer \case diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs index efafdc18aa..d0c8b4adbc 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs @@ -37,6 +37,7 @@ import Ouroboros.Consensus.Ledger.Query (Query (..)) import Ouroboros.Consensus.MiniProtocol.LocalStateQuery.Server import Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..)) import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Peras.Weight (emptyPerasWeightSnapshot) import Ouroboros.Consensus.Protocol.BFT import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache as BlockCache import Ouroboros.Consensus.Storage.ImmutableDB.Stream hiding @@ -100,7 +101,7 @@ prop_localStateQueryServer :: prop_localStateQueryServer k bt p (Positive (Small n)) = checkOutcome k chain actualOutcome where chain :: Chain TestBlock - chain = treePreferredChain bt + chain = treePreferredChain emptyPerasWeightSnapshot bt points :: [Target (Point TestBlock)] points = 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 new file mode 100644 index 0000000000..c0db35ff1a --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -0,0 +1,157 @@ +{-# 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 (tests) where + +import Control.Tracer (contramap, nullTracer) +import Data.Functor.Identity (Identity (..)) +import qualified Data.List.NonEmpty as NE +import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer) +import Ouroboros.Consensus.Block.SupportsPeras +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime (..) + , SystemTime (..) + , addArrivalTime + , systemTimeCurrent + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert +import Ouroboros.Consensus.Storage.PerasCertDB.API + ( AddPerasCertResult (..) + , PerasCertDB + , PerasCertTicketNo + ) +import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB +import qualified Ouroboros.Consensus.Storage.PerasCertDB.Impl as PerasCertDB +import Ouroboros.Consensus.Util.IOLike (IOLike, atomically, newTVarIO, stateTVar, throwIO) +import Ouroboros.Network.Block (Point (..), SlotNo (SlotNo), StandardHash) +import Ouroboros.Network.Point (Block (Block), WithOrigin (..)) +import Ouroboros.Network.Protocol.ObjectDiffusion.Codec +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound + ( objectDiffusionInboundPeerPipelined + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundPeer) +import Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke + ( ListWithUniqueIds (..) + , ProtocolConstants + , WithId + , getId + , prop_smoke_object_diffusion + ) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) +import Test.Util.TestBlock + +tests :: TestTree +tests = + testGroup + "ObjectDiffusion.PerasCert.Smoke" + [ testProperty "PerasCertDiffusion smoke test" prop_smoke + ] + +perasTestCfg :: PerasCfg TestBlock +perasTestCfg = makePerasCfg Nothing + +instance Arbitrary (Point TestBlock) where + arbitrary = + -- Sometimes pick the genesis point + frequency + [ (1, pure $ Point Origin) + , + ( 4 + , do + slotNo <- SlotNo <$> arbitrary + hash <- TestHash . NE.fromList . getNonEmpty <$> arbitrary + pure $ Point (At (Block slotNo hash)) + ) + ] + +instance Arbitrary (Point blk) => Arbitrary (PerasCert blk) where + arbitrary = do + pcCertRound <- PerasRoundNo <$> arbitrary + pcCertBoostedBlock <- arbitrary + pure $ PerasCert{pcCertRound, pcCertBoostedBlock} + +instance WithId (PerasCert blk) PerasRoundNo where + getId = pcCertRound + +mockSystemTime :: IOLike m => m (SystemTime m) +mockSystemTime = do + varTime <- newTVarIO 0 + return $ + SystemTime + { systemTimeCurrent = + RelativeTime <$> atomically (stateTVar varTime (\t -> (t, t + 1))) + , systemTimeWait = + pure () + } + +newCertDB :: + (IOLike m, StandardHash blk) => + PerasCfg blk -> + SystemTime m -> + [PerasCert blk] -> + m (PerasCertDB m blk) +newCertDB perasCfg systemTime certs = do + db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer) + mapM_ + ( \cert -> do + let validatedCert = + ValidatedPerasCert + { vpcCert = cert + , vpcCertBoost = perasCfgWeightBoost perasCfg + } + result <- PerasCertDB.addCert db =<< addArrivalTime systemTime validatedCert + case result of + AddedPerasCertToDB -> pure () + PerasCertAlreadyInDB -> throwIO (userError "Expected AddedPerasCertToDB, but cert was already in DB") + ) + certs + pure db + +prop_smoke :: ProtocolConstants -> ListWithUniqueIds (PerasCert TestBlock) PerasRoundNo -> Property +prop_smoke protocolConstants (ListWithUniqueIds certs) = + prop_smoke_object_diffusion protocolConstants certs runOutboundPeer runInboundPeer mkPoolInterfaces + where + runOutboundPeer outbound outboundChannel tracer = + runPeer + ((\x -> "Outbound (Client): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + outboundChannel + (objectDiffusionOutboundPeer outbound) + >> pure () + runInboundPeer inbound inboundChannel tracer = + runPipelinedPeer + ((\x -> "Inbound (Server): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + inboundChannel + (objectDiffusionInboundPeerPipelined inbound) + >> pure () + mkPoolInterfaces :: + forall m. + IOLike m => + m + ( ObjectPoolReader PerasRoundNo (PerasCert TestBlock) PerasCertTicketNo m + , ObjectPoolWriter PerasRoundNo (PerasCert TestBlock) m + , m [PerasCert TestBlock] + ) + mkPoolInterfaces = do + systemTime <- mockSystemTime + outboundPool <- newCertDB perasTestCfg systemTime certs + inboundPool <- newCertDB perasTestCfg systemTime [] + + let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool + inboundPoolWriter = makePerasCertPoolWriterFromCertDB systemTime inboundPool + getAllInboundPoolContent = do + snap <- atomically $ PerasCertDB.getCertSnapshot inboundPool + let rawContent = PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo) + pure $ getPerasCert . fst <$> rawContent + + return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs new file mode 100644 index 0000000000..8e12f01d6d --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Smoke tests for the object diffusion protocol. This uses a trivial object +-- pool and checks that a few objects can indeed be transferred from the +-- outbound to the inbound peer. +module Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke + ( tests + , WithId (..) + , ListWithUniqueIds (..) + , ProtocolConstants + , prop_smoke_object_diffusion + ) where + +import Control.Monad.IOSim (runSimStrictShutdown) +import Control.ResourceRegistry (forkLinkedThread, waitAnyThread, withRegistry) +import Control.Tracer (Tracer, nullTracer, traceWith) +import Data.Containers.ListUtils (nubOrdOn) +import Data.Functor.Contravariant (contramap) +import Network.TypedProtocol.Channel (Channel, createConnectedChannels) +import Network.TypedProtocol.Codec (AnyMessage) +import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound + ( objectDiffusionInbound + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State + ( ObjectDiffusionInboundStateView (..) + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API + ( ObjectPoolReader (..) + , ObjectPoolWriter (..) + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound (objectDiffusionOutbound) +import qualified Ouroboros.Consensus.MiniProtocol.Util.Idling as Idling +import Ouroboros.Consensus.Util.IOLike + ( IOLike + , MonadDelay (..) + , MonadSTM (..) + , StrictTVar + , modifyTVar + , readTVar + , uncheckedNewTVarM + , writeTVar + ) +import Ouroboros.Network.ControlMessage (ControlMessage (..)) +import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion (..)) +import Ouroboros.Network.Protocol.ObjectDiffusion.Codec (codecObjectDiffusionId) +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound + ( ObjectDiffusionInboundPipelined + , objectDiffusionInboundPeerPipelined + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound + ( ObjectDiffusionOutbound + , objectDiffusionOutboundPeer + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Type + ( NumObjectIdsReq (..) + , NumObjectsOutstanding (..) + , NumObjectsReq (..) + , ObjectDiffusion + ) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Util.Orphans.Arbitrary () +import Test.Util.Orphans.IOLike () + +tests :: TestTree +tests = + testGroup + "ObjectDiffusion.Smoke" + [ testProperty + "ObjectDiffusion smoke test with mock objects" + prop_smoke + ] + +{------------------------------------------------------------------------------- + Provides a way to generate lists composed of objects with no duplicate ids, + with an Arbitrary instance +-------------------------------------------------------------------------------} + +class WithId a idTy | a -> idTy where + getId :: a -> idTy + +newtype ListWithUniqueIds a idTy = ListWithUniqueIds [a] + deriving (Eq, Show, Ord) + +instance (Ord idTy, WithId a idTy, Arbitrary a) => Arbitrary (ListWithUniqueIds a idTy) where + arbitrary = ListWithUniqueIds . nubOrdOn getId <$> arbitrary + +instance WithId SmokeObject SmokeObjectId where getId = getSmokeObjectId + +{------------------------------------------------------------------------------- + Mock objectPools +-------------------------------------------------------------------------------} + +newtype SmokeObjectId = SmokeObjectId Int + deriving (Eq, Ord, Show, NoThunks, Arbitrary) + +newtype SmokeObject = SmokeObject {getSmokeObjectId :: SmokeObjectId} + deriving (Eq, Ord, Show, NoThunks, Arbitrary) + +newtype SmokeObjectPool m = SmokeObjectPool (StrictTVar m [SmokeObject]) + +newObjectPool :: MonadSTM m => [SmokeObject] -> m (SmokeObjectPool m) +newObjectPool initialPoolContent = SmokeObjectPool <$> uncheckedNewTVarM initialPoolContent + +makeObjectPoolReader :: + MonadSTM m => SmokeObjectPool m -> ObjectPoolReader SmokeObjectId SmokeObject Int m +makeObjectPoolReader (SmokeObjectPool poolContentTvar) = + ObjectPoolReader + { oprObjectId = getSmokeObjectId + , oprObjectsAfter = \minTicketNo limit -> do + poolContent <- readTVar poolContentTvar + pure $ + take (fromIntegral limit) $ + drop (minTicketNo + 1) $ + ( (\(ticketNo, smokeObject) -> (ticketNo, getSmokeObjectId smokeObject, pure smokeObject)) + <$> zip [(0 :: Int) ..] poolContent + ) + , oprZeroTicketNo = -1 -- objectPoolObjectIdsAfter uses strict comparison, and first ticketNo is 0. + } + +makeObjectPoolWriter :: + MonadSTM m => SmokeObjectPool m -> ObjectPoolWriter SmokeObjectId SmokeObject m +makeObjectPoolWriter (SmokeObjectPool poolContentTvar) = + ObjectPoolWriter + { opwObjectId = getSmokeObjectId + , opwAddObjects = \objects -> do + atomically $ modifyTVar poolContentTvar (++ objects) + return () + , opwHasObject = do + poolContent <- readTVar poolContentTvar + pure $ \objectId -> any (\obj -> getSmokeObjectId obj == objectId) poolContent + } + +mkMockPoolInterfaces :: + MonadSTM m => + [SmokeObject] -> + m + ( ObjectPoolReader SmokeObjectId SmokeObject Int m + , ObjectPoolWriter SmokeObjectId SmokeObject m + , m [SmokeObject] + ) +mkMockPoolInterfaces objects = do + outboundPool <- newObjectPool objects + inboundPool@(SmokeObjectPool tvar) <- newObjectPool [] + + let outboundPoolReader = makeObjectPoolReader outboundPool + inboundPoolWriter = makeObjectPoolWriter inboundPool + + return (outboundPoolReader, inboundPoolWriter, atomically $ readTVar tvar) + +{------------------------------------------------------------------------------- + Main properties +-------------------------------------------------------------------------------} + +-- Protocol constants + +newtype ProtocolConstants + = ProtocolConstants (NumObjectsOutstanding, NumObjectIdsReq, NumObjectsReq) + deriving Show + +instance Arbitrary ProtocolConstants where + arbitrary = do + maxFifoSize <- choose (5, 20) + maxIdsToReq <- choose (3, maxFifoSize) + maxObjectsToReq <- choose (2, maxIdsToReq) + pure $ + ProtocolConstants + ( NumObjectsOutstanding maxFifoSize + , NumObjectIdsReq maxIdsToReq + , NumObjectsReq maxObjectsToReq + ) + +nodeToNodeVersion :: NodeToNodeVersion +nodeToNodeVersion = NodeToNodeV_14 + +prop_smoke :: ProtocolConstants -> ListWithUniqueIds SmokeObject idTy -> Property +prop_smoke protocolConstants (ListWithUniqueIds objects) = + prop_smoke_object_diffusion + protocolConstants + objects + runOutboundPeer + runInboundPeer + (mkMockPoolInterfaces objects) + where + runOutboundPeer outbound outboundChannel tracer = + runPeer + ((\x -> "Outbound (Server): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + outboundChannel + (objectDiffusionOutboundPeer outbound) + >> pure () + + runInboundPeer inbound inboundChannel tracer = + runPipelinedPeer + ((\x -> "Inbound (Client): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + inboundChannel + (objectDiffusionInboundPeerPipelined inbound) + >> pure () + +--- The core logic of the smoke test is shared between the generic smoke tests for ObjectDiffusion, and the ones specialised to PerasCert/PerasVote diffusion +prop_smoke_object_diffusion :: + ( Eq object + , Show object + , Ord objectId + , NoThunks objectId + , Show objectId + , NoThunks object + , Ord ticketNo + ) => + ProtocolConstants -> + [object] -> + ( forall m. + IOLike m => + ObjectDiffusionOutbound objectId object m () -> + Channel m (AnyMessage (ObjectDiffusion objectId object)) -> + (Tracer m String) -> + m () + ) -> + ( forall m. + IOLike m => + ObjectDiffusionInboundPipelined objectId object m () -> + (Channel m (AnyMessage (ObjectDiffusion objectId object))) -> + (Tracer m String) -> + m () + ) -> + ( forall m. + IOLike m => + m + ( ObjectPoolReader objectId object ticketNo m + , ObjectPoolWriter objectId object m + , m [object] + ) + ) -> + Property +prop_smoke_object_diffusion + (ProtocolConstants (maxFifoSize, maxIdsToReq, maxObjectsToReq)) + objects + runOutboundPeer + runInboundPeer + mkPoolInterfaces = + let + simulationResult = runSimStrictShutdown $ do + let tracer = nullTracer + + traceWith tracer "========== [ Starting ObjectDiffusion smoke test ] ==========" + traceWith tracer (show objects) + + (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) <- mkPoolInterfaces + controlMessage <- uncheckedNewTVarM Continue + + let + inboundState = + ObjectDiffusionInboundStateView + { odisvIdling = Idling.noIdling + } + + inbound = + objectDiffusionInbound + tracer + ( maxFifoSize + , maxIdsToReq + , maxObjectsToReq + ) + inboundPoolWriter + nodeToNodeVersion + (readTVar controlMessage) + inboundState + + outbound = + objectDiffusionOutbound + tracer + maxFifoSize + outboundPoolReader + nodeToNodeVersion + + withRegistry $ \reg -> do + (outboundChannel, inboundChannel) <- createConnectedChannels + outboundThread <- + forkLinkedThread reg "ObjectDiffusion Outbound peer thread" $ + runOutboundPeer outbound outboundChannel tracer + inboundThread <- + forkLinkedThread reg "ObjectDiffusion Inbound peer thread" $ + runInboundPeer inbound inboundChannel tracer + controlMessageThread <- forkLinkedThread reg "ObjectDiffusion Control thread" $ do + threadDelay 1000 -- give a head start to the other threads + atomically $ writeTVar controlMessage Terminate + threadDelay 1000 -- wait for the other threads to finish + waitAnyThread [outboundThread, inboundThread, controlMessageThread] + + traceWith tracer "========== [ ObjectDiffusion smoke test finished ] ==========" + poolContent <- getAllInboundPoolContent + + traceWith tracer "inboundPoolContent:" + traceWith tracer (show poolContent) + traceWith tracer "========== ======================================= ==========" + pure poolContent + in + case simulationResult of + Right inboundPoolContent -> inboundPoolContent === objects + Left msg -> counterexample (show msg) $ property False diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs new file mode 100644 index 0000000000..59fd52d636 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +#if __GLASGOW_HASKELL__ >= 910 +{-# OPTIONS_GHC -Wno-x-partial #-} +#endif + +-- | Test that 'PerasWeightSnapshot' can correctly compute the weight of points +-- and fragments. +module Test.Consensus.Peras.WeightSnapshot (tests) where + +import Cardano.Ledger.BaseTypes (unNonZero) +import Data.Containers.ListUtils (nubOrd) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) +import Data.Traversable (for) +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Config.SecurityParam +import Ouroboros.Consensus.Peras.Weight +import Ouroboros.Consensus.Util.Condense +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import qualified Ouroboros.Network.AnchoredFragment as AF +import qualified Ouroboros.Network.Mock.Chain as Chain +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Util.Orphans.Arbitrary () +import Test.Util.QuickCheck +import Test.Util.TestBlock + +tests :: TestTree +tests = + testGroup + "PerasWeightSnapshot" + [ testProperty "correctness" prop_perasWeightSnapshot + ] + +prop_perasWeightSnapshot :: TestSetup -> Property +prop_perasWeightSnapshot testSetup = + tabulate "logâ‚‚ # of points" [show $ round @Double @Int $ logBase 2 (fromIntegral (length tsPoints))] + . counterexample ("PerasWeightSnapshot: " <> show snap) + $ conjoin + [ conjoin + [ counterexample ("Incorrect weight for " <> condense pt) $ + weightBoostOfPointReference pt =:= weightBoostOfPoint snap pt + | pt <- tsPoints + ] + , conjoin + [ counterexample ("Incorrect weight for " <> condense frag) $ + weightBoostOfFragmentReference frag =:= weightBoostOfFragment snap frag + | frag <- tsFragments + ] + , conjoin + [ conjoin + [ counterexample ("Incorrect volatile suffix for " <> condense frag) $ + takeVolatileSuffixReference frag =:= volSuffix + , counterexample ("Volatile suffix must be a suffix of" <> condense frag) $ + AF.headPoint frag =:= AF.headPoint volSuffix + .&&. AF.withinFragmentBounds (AF.anchorPoint volSuffix) frag + , counterexample ("Volatile suffix of " <> condense frag <> " must contain at most k blocks") $ + AF.length volSuffix `le` fromIntegral (unNonZero (maxRollbacks tsSecParam)) + ] + | frag <- tsFragments + , let volSuffix = takeVolatileSuffix snap tsSecParam frag + ] + ] + where + TestSetup + { tsWeights + , tsPoints + , tsFragments + , tsSecParam + } = testSetup + + snap = mkPerasWeightSnapshot $ Map.toList tsWeights + + weightBoostOfPointReference :: Point TestBlock -> PerasWeight + weightBoostOfPointReference pt = Map.findWithDefault mempty pt tsWeights + + weightBoostOfFragmentReference :: AnchoredFragment TestBlock -> PerasWeight + weightBoostOfFragmentReference frag = + foldMap + (weightBoostOfPointReference . blockPoint) + (AF.toOldestFirst frag) + + takeVolatileSuffixReference :: + AnchoredFragment TestBlock -> AnchoredFragment TestBlock + takeVolatileSuffixReference frag = + head + [ suffix + | len <- reverse [0 .. AF.length frag] + , -- Consider suffixes of @frag@, longest first + let suffix = AF.anchorNewest (fromIntegral len) frag + weightBoost = weightBoostOfFragmentReference suffix + lengthWeight = PerasWeight (fromIntegral (AF.length suffix)) + totalWeight = lengthWeight <> weightBoost + , totalWeight <= maxRollbackWeight tsSecParam + ] + +data TestSetup = TestSetup + { tsWeights :: Map (Point TestBlock) PerasWeight + , tsPoints :: [Point TestBlock] + -- ^ Check the weight of these points. + , tsFragments :: [AnchoredFragment TestBlock] + -- ^ Check the weight of these fragments. + , tsSecParam :: SecurityParam + } + deriving stock Show + +instance Arbitrary TestSetup where + arbitrary = do + tree :: BlockTree <- arbitrary + let tsPoints = nubOrd $ GenesisPoint : (blockPoint <$> treeToBlocks tree) + treeChains = treeToChains tree + tsWeights <- do + boostedChain <- elements treeChains + let boostablePts = + GenesisPoint : (blockPoint <$> Chain.toOldestFirst boostedChain) + Map.fromList . catMaybes <$> for boostablePts \pt -> do + weight <- + frequency + [ (3, pure Nothing) + , (1, Just . PerasWeight <$> choose (1, 10)) + ] + pure $ (pt,) <$> weight + tsFragments <- for treeChains \chain -> do + let lenChain = Chain.length chain + fullFrag = Chain.toAnchoredFragment chain + nTakeNewest <- choose (0, lenChain) + nDropNewest <- choose (0, nTakeNewest) + pure $ + AF.dropNewest nDropNewest $ + AF.anchorNewest (fromIntegral nTakeNewest) fullFrag + tsSecParam <- arbitrary + pure + TestSetup + { tsWeights + , tsPoints + , tsFragments + , tsSecParam + } + + shrink ts = + concat + [ [ ts{tsWeights = Map.fromList tsWeights'} + | tsWeights' <- + shrinkList + -- Shrink boosted points to have weight 1. + (\(pt, w) -> [(pt, w1) | w1 /= w]) + $ Map.toList tsWeights + ] + , [ ts{tsPoints = tsPoints'} + | tsPoints' <- shrinkList (\_pt -> []) tsPoints + ] + , [ ts{tsFragments = tsFragments'} + | tsFragments' <- shrinkList (\_frag -> []) tsFragments + ] + , [ ts{tsSecParam = tsSecParam'} + | tsSecParam' <- shrink tsSecParam + ] + ] + where + w1 = PerasWeight 1 + + TestSetup + { tsWeights + , tsPoints + , tsFragments + , tsSecParam + } = ts diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs index 419d8872a7..1153457c70 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs @@ -5,6 +5,7 @@ module Test.Ouroboros.Storage (tests) where import qualified Test.Ouroboros.Storage.ChainDB as ChainDB import qualified Test.Ouroboros.Storage.ImmutableDB as ImmutableDB import qualified Test.Ouroboros.Storage.LedgerDB as LedgerDB +import qualified Test.Ouroboros.Storage.PerasCertDB as PerasCertDB import qualified Test.Ouroboros.Storage.VolatileDB as VolatileDB import Test.Tasty (TestTree, testGroup) @@ -20,4 +21,5 @@ tests = , VolatileDB.tests , LedgerDB.tests , ChainDB.tests + , PerasCertDB.tests ] 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 d8cbf1acb0..1d04c09b4e 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 @@ -25,6 +25,7 @@ module Test.Ouroboros.Storage.ChainDB.Model , addBlock , addBlockPromise , addBlocks + , addPerasCert , empty -- * Queries @@ -44,7 +45,7 @@ module Test.Ouroboros.Storage.ChainDB.Model , invalid , isOpen , isValid - , lastK + , maxPerasRoundNo , tipBlock , tipPoint , volatileChain @@ -90,6 +91,7 @@ import Control.Monad.Except (runExcept) import Data.Bifunctor (first) import qualified Data.ByteString.Lazy as Lazy import Data.Containers.ListUtils (nubOrdOn) +import Data.Foldable (foldMap') import Data.Function (on, (&)) import Data.Functor (($>), (<&>)) import Data.List (isInfixOf, isPrefixOf, sortBy) @@ -100,14 +102,16 @@ import Data.Proxy import Data.Set (Set) import qualified Data.Set as Set import Data.TreeDiff -import Data.Word (Word64) import GHC.Generics (Generic) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Config import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.SelectView +import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.MockChainSel import Ouroboros.Consensus.Storage.ChainDB.API @@ -145,6 +149,7 @@ data Model blk = Model -- ^ The VolatileDB , immutableDbChain :: Chain blk -- ^ The ImmutableDB + , perasCerts :: Map PerasRoundNo (WithArrivalTime (ValidatedPerasCert blk)) , cps :: CPS.ChainProducerState blk , currentLedger :: ExtLedgerState blk EmptyMK , initLedger :: ExtLedgerState blk EmptyMK @@ -231,72 +236,78 @@ tipPoint = maybe GenesisPoint blockPoint . tipBlock getMaxSlotNo :: HasHeader blk => Model blk -> MaxSlotNo getMaxSlotNo = foldMap (MaxSlotNo . blockSlot) . blocks -lastK :: - HasHeader a => - SecurityParam -> - -- | Provided since `AnchoredFragment` is not a functor - (blk -> a) -> - Model blk -> - AnchoredFragment a -lastK (SecurityParam k) f = - Fragment.anchorNewest (unNonZero k) - . Chain.toAnchoredFragment - . fmap f - . currentChain - --- | Actual number of blocks that can be rolled back. Equal to @k@, except --- when: +-- | Actual amount of weight that can be rolled back. This can non-trivially +-- smaller than @k@ in the following cases: -- --- * Near genesis, the chain might not be @k@ blocks long yet. --- * After VolatileDB corruption, the whole chain might be >= @k@ blocks, but --- the tip of the ImmutableDB might be closer than @k@ blocks away from the --- current chain's tip. -maxActualRollback :: HasHeader blk => SecurityParam -> Model blk -> Word64 +-- * Near genesis, the chain might not have grown sufficiently yet. +-- * 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 k m = - fromIntegral - . length + foldMap' (weightBoostOfPoint weights) . takeWhile (/= immutableTipPoint) . map blockPoint . Chain.toNewestFirst . currentChain $ m where + weights = perasWeights m + immutableTipPoint = Chain.headPoint (immutableChain k m) -- | Return the immutable prefix of the current chain. -- -- This is the longest of the given two chains: -- --- 1. The current chain with the last @k@ blocks dropped. +-- 1. The current chain with the longest suffix of weight at most @k@ dropped. -- 2. The chain formed by the blocks in 'immutableDbChain', i.e., the -- \"ImmutableDB\". We need to take this case in consideration because the -- VolatileDB might have been wiped. -- --- We need this because we do not allow rolling back more than @k@ blocks, but +-- We need this because we do not allow rolling back more than weight @k@, but -- the background thread copying blocks from the VolatileDB to the ImmutableDB -- might not have caught up yet. This means we cannot use the tip of the -- ImmutableDB to know the most recent \"immutable\" block. immutableChain :: + forall blk. + HasHeader blk => SecurityParam -> Model blk -> Chain blk -immutableChain (SecurityParam k) m = +immutableChain k m = maxBy + -- As one of the two chains is a prefix of the other, Peras weight doesn't + -- matter here. Chain.length - (Chain.drop (fromIntegral $ unNonZero k) (currentChain m)) + (dropAtMostWeight (maxRollbackWeight k) (currentChain m)) (immutableDbChain m) where maxBy f a b | f a >= f b = a | otherwise = b + weights = perasWeights m + + -- Drop the longest suffix with at most the given weight. + dropAtMostWeight :: PerasWeight -> Chain blk -> Chain blk + dropAtMostWeight budget = go mempty + where + go w = \case + Genesis -> Genesis + c@(c' :> b) + | w' <= budget -> go w' c' + | otherwise -> c + where + w' = w <> PerasWeight 1 <> weightBoostOfPoint weights (blockPoint b) + -- | Return the volatile suffix of the current chain. -- -- The opposite of 'immutableChain'. -- -- This is the shortest of the given two chain fragments: -- --- 1. The last @k@ blocks of the current chain. +-- 1. The longest suffix of the current chain with weight at most @k@. -- 2. The suffix of the current chain not part of the 'immutableDbChain', i.e., -- the \"ImmutableDB\". volatileChain :: @@ -368,6 +379,16 @@ isValid = flip getIsValid getLoEFragment :: Model blk -> LoE (AnchoredFragment blk) getLoEFragment = loeFragment +perasWeights :: StandardHash blk => Model blk -> PerasWeightSnapshot blk +perasWeights = + mkPerasWeightSnapshot + . fmap (\cert -> (getPerasCertBoostedBlock cert, getPerasCertBoost cert)) + . Map.elems + . perasCerts + +maxPerasRoundNo :: Model blk -> Maybe PerasRoundNo +maxPerasRoundNo m = fst <$> Map.lookupMax (perasCerts m) + {------------------------------------------------------------------------------- Construction -------------------------------------------------------------------------------} @@ -381,6 +402,7 @@ empty loe initLedger = Model { volatileDbBlocks = Map.empty , immutableDbChain = Chain.Genesis + , perasCerts = Map.empty , cps = CPS.initChainProducerState Chain.Genesis , currentLedger = initLedger , initLedger = initLedger @@ -420,6 +442,23 @@ addBlock cfg blk m -- If it's an invalid block we've seen before, ignore it. Map.member (blockHash blk) (invalid m) +addPerasCert :: + forall blk. + (LedgerSupportsProtocol blk, LedgerTablesAreTrivial (ExtLedgerState blk)) => + TopLevelConfig blk -> + WithArrivalTime (ValidatedPerasCert blk) -> + Model blk -> + Model blk +addPerasCert cfg cert m + -- Do not alter the model when a certificate for that round already exists. + | Map.member certRound (perasCerts m) = m + | otherwise = + chainSelection + cfg + m{perasCerts = Map.insert certRound cert (perasCerts m)} + where + certRound = getPerasCertRound cert + chainSelection :: forall blk. ( LedgerTablesAreTrivial (ExtLedgerState blk) @@ -432,6 +471,7 @@ chainSelection cfg m = Model { volatileDbBlocks = volatileDbBlocks m , immutableDbChain = immutableDbChain m + , perasCerts = perasCerts m , cps = CPS.switchFork newChain (cps m) , currentLedger = newLedger , initLedger = initLedger m @@ -531,7 +571,10 @@ chainSelection cfg m = . selectChain (Proxy @(BlockProtocol blk)) (projectChainOrderConfig (configBlock cfg)) - (selectView (configBlock cfg) . getHeader) + ( weightedSelectView (configBlock cfg) (perasWeights m) + . Chain.toAnchoredFragment + . fmap getHeader + ) (currentChain m) $ consideredCandidates @@ -863,7 +906,7 @@ validChains cfg m bs = sortChains = sortBy $ flip - ( Fragment.compareAnchoredFragments (configBlock cfg) + ( Fragment.compareAnchoredFragments (configBlock cfg) (perasWeights m) `on` (Chain.toAnchoredFragment . fmap getHeader) ) @@ -899,7 +942,11 @@ between k from to m = do fork <- errFork -- See #871. if partOfCurrentChain fork - || Fragment.forksAtMostKBlocks (maxActualRollback k m) currentFrag fork + || Fragment.forksAtMostKWeight + (perasWeights m) + (maxActualRollback k m) + currentFrag + fork then return $ Fragment.toOldestFirst fork -- We cannot stream from an old fork else Left $ ForkTooOld from @@ -1039,6 +1086,7 @@ garbageCollect :: garbageCollect secParam m@Model{..} = m { volatileDbBlocks = Map.filter (not . collectable) volatileDbBlocks + -- TODO garbage collection Peras certs? } where -- TODO what about iterators that will stream garbage collected blocks? @@ -1090,6 +1138,14 @@ wipeVolatileDB cfg m = m' = (closeDB m) { volatileDbBlocks = Map.empty + , -- TODO: Currently, the SUT has no persistence of Peras certs across + -- restarts, but this will change. There are at least two options: + -- + -- * Change this command to mean "wipe volatile state" (including + -- volatile certificates) + -- + -- * Add a separate "Wipe volatile certs". + perasCerts = Map.empty , cps = CPS.switchFork newChain (cps m) , currentLedger = newLedger , invalid = Map.empty @@ -1108,7 +1164,11 @@ wipeVolatileDB cfg m = $ selectChain (Proxy @(BlockProtocol blk)) (projectChainOrderConfig (configBlock cfg)) - (selectView (configBlock cfg) . getHeader) + -- Weight is inconsequential as there is only a single candidate. + ( weightedSelectView (configBlock cfg) emptyPerasWeightSnapshot + . Chain.toAnchoredFragment + . fmap getHeader + ) Chain.genesis $ snd $ validChains cfg m (immutableDbBlocks m) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs index 6293e11968..0b2410f68f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs @@ -22,11 +22,11 @@ -- chain DB, we always pick the most preferred chain. module Test.Ouroboros.Storage.ChainDB.Model.Test (tests) where -import Cardano.Ledger.BaseTypes (unNonZero) import GHC.Stack import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Tables +import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Storage.ChainDB.API ( LoE (..) , StreamFrom (..) @@ -96,16 +96,20 @@ prop_alwaysPickPreferredChain bt p = curFragment = Chain.toAnchoredFragment (getHeader <$> current) - SecurityParam k = configSecurityParam singleNodeTestConfig + k = configSecurityParam singleNodeTestConfig bcfg = configBlock singleNodeTestConfig preferCandidate' candidate = - AF.preferAnchoredCandidate bcfg curFragment candFragment - && AF.forksAtMostKBlocks (unNonZero k) curFragment candFragment + AF.preferAnchoredCandidate bcfg weights curFragment candFragment + && AF.forksAtMostKWeight weights (maxRollbackWeight k) curFragment candFragment where candFragment = Chain.toAnchoredFragment (getHeader <$> candidate) + -- TODO test with non-trivial weights + weights :: PerasWeightSnapshot TestBlock + weights = emptyPerasWeightSnapshot + -- TODO add properties about forks too prop_between_currentChain :: LoE () -> BlockTree -> Property prop_between_currentChain loe bt = 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 4e97810d90..c66b781c87 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 @@ -73,7 +73,7 @@ module Test.Ouroboros.Storage.ChainDB.StateMachine , tests ) where -import Cardano.Ledger.BaseTypes (knownNonZeroBounded) +import Cardano.Ledger.BaseTypes (unNonZero, unsafeNonZero) import Codec.Serialise (Serialise) import Control.Monad (replicateM, void) import Control.ResourceRegistry @@ -89,6 +89,7 @@ import Data.Functor.Classes (Eq1, Show1) import Data.Functor.Identity (Identity) import Data.List (sortOn) import qualified Data.List.NonEmpty as NE +import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Ord (Down (..)) @@ -96,11 +97,17 @@ import Data.Proxy import Data.TreeDiff import Data.Typeable import Data.Void (Void) -import Data.Word (Word16) +import Data.Word (Word16, Word64) import GHC.Generics (Generic) import qualified Generics.SOP as SOP import NoThunks.Class (AllowThunk (..)) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime (..) + , SystemTime (..) + , WithArrivalTime + , addArrivalTime + ) import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.HardFork.Combinator.Abstract @@ -127,6 +134,7 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal import Ouroboros.Consensus.Storage.LedgerDB (LedgerSupportsLedgerDB) import qualified Ouroboros.Consensus.Storage.LedgerDB.TraceEvent as LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog as DbChangelog +import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util (split) import Ouroboros.Consensus.Util.CallStack @@ -149,6 +157,7 @@ import qualified Test.Ouroboros.Storage.ChainDB.Model as Model import Test.Ouroboros.Storage.Orphans () import Test.Ouroboros.Storage.TestBlock import Test.QuickCheck hiding (forAll) +import qualified Test.QuickCheck as QC import qualified Test.QuickCheck.Monadic as QC import Test.StateMachine import qualified Test.StateMachine.Labelling as C @@ -175,9 +184,18 @@ import Test.Util.WithEq Abstract model -------------------------------------------------------------------------------} +-- | A randomly generated value that gets persisted between steps, so that we +-- can carry generator state forward between commands. See 'GenState' below for +-- more details. +newtype Persistent a = Persistent {unPersistent :: a} + deriving (Eq, Show, Functor) + -- | Commands data Cmd blk it flr - = AddBlock blk + = -- | Add a block, with (possibly) some gap blocks before it being created. + AddBlock blk (Persistent [blk]) + | -- | Add a Peras cert for a block, with (possibly) some gap blocks before it being created. + AddPerasCert (WithArrivalTime (ValidatedPerasCert blk)) (Persistent [blk]) | GetCurrentChain | GetTipBlock | GetTipHeader @@ -402,8 +420,9 @@ run :: Cmd blk (TestIterator m blk) (TestFollower m blk) -> m (Success blk (TestIterator m blk) (TestFollower m blk)) run cfg env@ChainDBEnv{varDB, ..} cmd = - readTVarIO varDB >>= \st@ChainDBState{chainDB = ChainDB{..}, internal} -> case cmd of - AddBlock blk -> Point <$> advanceAndAdd st blk + readTVarIO varDB >>= \st@ChainDBState{chainDB = chainDB@ChainDB{..}, internal} -> case cmd of + AddBlock blk _ -> Point <$> advanceAndAdd st blk + AddPerasCert cert _ -> Unit <$> addPerasCertSync chainDB cert GetCurrentChain -> Chain <$> atomically getCurrentChain GetTipBlock -> MbBlock <$> getTipBlock GetTipHeader -> MbHeader <$> getTipHeader @@ -608,7 +627,7 @@ instance Eq IsValidResult where (Just _, Nothing) -> False {------------------------------------------------------------------------------- - Instantiating the semantics + Responses -------------------------------------------------------------------------------} -- | Responses are either successful termination or an error. @@ -625,6 +644,26 @@ instance (TestConstraints blk, Eq it, Eq flr) => Eq (Resp blk it flr) where Resp (Right a) == Resp (Right a') = a == a' _ == _ = False +{------------------------------------------------------------------------------- + Bitraversable instances +-------------------------------------------------------------------------------} + +TH.deriveBifunctor ''Cmd +TH.deriveBifoldable ''Cmd +TH.deriveBitraversable ''Cmd + +TH.deriveBifunctor ''Success +TH.deriveBifoldable ''Success +TH.deriveBitraversable ''Success + +TH.deriveBifunctor ''Resp +TH.deriveBifoldable ''Resp +TH.deriveBitraversable ''Resp + +{------------------------------------------------------------------------------- + Instantiating the semantics +-------------------------------------------------------------------------------} + type DBModel blk = Model.Model blk -- We can't reuse 'run' because the 'ChainDB' API uses 'STM'. Instead, we call @@ -637,7 +676,8 @@ runPure :: DBModel blk -> (Resp blk IteratorId FollowerId, DBModel blk) runPure cfg = \case - AddBlock blk -> ok Point $ update (add blk) + AddBlock blk _ -> ok Point $ update (add blk) + AddPerasCert cert _ -> ok Unit $ ((),) . update (Model.addPerasCert cfg cert) GetCurrentChain -> ok Chain $ query (Model.volatileChain k getHeader) GetTipBlock -> ok MbBlock $ query Model.tipBlock GetTipHeader -> ok MbHeader $ query (fmap getHeader . Model.tipBlock) @@ -724,22 +764,6 @@ iters = bifoldMap (: []) (const []) flrs :: Bitraversable t => t it flr -> [flr] flrs = bifoldMap (const []) (: []) -{------------------------------------------------------------------------------- - Bitraversable instances --------------------------------------------------------------------------------} - -TH.deriveBifunctor ''Cmd -TH.deriveBifoldable ''Cmd -TH.deriveBitraversable ''Cmd - -TH.deriveBifunctor ''Success -TH.deriveBifoldable ''Success -TH.deriveBitraversable ''Success - -TH.deriveBifunctor ''Resp -TH.deriveBifoldable ''Resp -TH.deriveBitraversable ''Resp - {------------------------------------------------------------------------------- Model -------------------------------------------------------------------------------} @@ -756,12 +780,69 @@ type FollowerRef blk m r = Reference (Opaque (TestFollower m blk)) r -- | Mapping between iterator references and mocked followers type KnownFollowers blk m r = RefEnv (Opaque (TestFollower m blk)) FollowerId r +-- | Generator state to be carried forward between commands +-- +-- NOTE: some of our generators benefit from carrying state between commands. +-- However, 'quickcheck-state-machine' does not provide much support for this, +-- so we manually carry it around as part of the evolving SUT's model--even if +-- it's technically not part of the actual model we are trying to test against. +-- +-- TODO: Explore if this can be improved by tweaking the API of +-- 'quickcheck-state-machine' to allow for the same functionality to exist +-- under the hood. +data GenState blk + = GenState + { seenBlocks :: Map (HeaderHash blk) blk + -- ^ Blocks that have been generated but not yet added to the ChainDB, e.g., + -- gap blocks generated by 'genBlockAfterGap', or boosted blocks generated by + -- 'genAddPerasCert'. We don't want to discard these because they can be used + -- to fill gaps between existing blocks added via 'AddBlock', simulating + -- blocks and certificates arriving out of order. + } + deriving Generic + +deriving instance + ( ToExpr blk + , ToExpr (HeaderHash blk) + ) => + ToExpr (GenState blk) + +deriving instance (Show blk, Show (HeaderHash blk)) => Show (GenState blk) + +emptyGenState :: GenState blk +emptyGenState = + GenState + { seenBlocks = Map.empty + } + +-- | Use the extra state stored in a generated command to update a model's +-- 'GenState' accordingly. +updateGenState :: + HasHeader blk => + At Cmd blk m r -> + GenState blk -> + GenState blk +updateGenState cmd gs = + case unAt cmd of + AddBlock _ (Persistent blks) -> saveSeenBlocks blks gs + AddPerasCert _ (Persistent blks) -> saveSeenBlocks blks gs + _ -> gs + where + saveSeenBlocks blks gs' = + gs' + { seenBlocks = + Map.union + (Map.fromList [(blockHash blk, blk) | blk <- blks]) + (seenBlocks gs') + } + -- | Execution model data Model blk m r = Model { dbModel :: DBModel blk , knownIters :: KnownIters blk m r , knownFollowers :: KnownFollowers blk m r , modelConfig :: Opaque (TopLevelConfig blk) + , genState :: GenState blk } deriving Generic @@ -780,6 +861,7 @@ initModel loe cfg initLedger = , knownIters = RE.empty , knownFollowers = RE.empty , modelConfig = QSM.Opaque cfg + , genState = emptyGenState } -- | Key property of the model is that we can go from real to mock responses @@ -867,6 +949,7 @@ lockstep model@Model{..} cmd (At resp) = } where (mockResp, dbModel') = step model cmd + genState' = updateGenState cmd genState newIters = RE.fromList $ zip (iters resp) (iters mockResp) newFollowers = RE.fromList $ zip (flrs resp) (flrs mockResp) model' = case unAt cmd of @@ -875,18 +958,21 @@ lockstep model@Model{..} cmd (At resp) = Close -> model { dbModel = dbModel' + , genState = genState' , knownIters = RE.empty , knownFollowers = RE.empty } WipeVolatileDB -> model { dbModel = dbModel' + , genState = genState' , knownIters = RE.empty , knownFollowers = RE.empty } _ -> model { dbModel = dbModel' + , genState = genState' , knownIters = knownIters `RE.union` newIters , knownFollowers = knownFollowers `RE.union` newFollowers } @@ -895,20 +981,23 @@ lockstep model@Model{..} cmd (At resp) = Generator -------------------------------------------------------------------------------} -type BlockGen blk m = Model blk m Symbolic -> Gen blk - -- | Generate a 'Cmd' generator :: forall blk m. TestConstraints blk => LoE () -> - BlockGen blk m -> + (Model blk m Symbolic -> Gen (blk, Persistent [blk])) -> Model blk m Symbolic -> Gen (At Cmd blk m Symbolic) generator loe genBlock m@Model{..} = At <$> frequency - [ (30, genAddBlock) + [ (100, genAddBlock) + , let freq = case loe of + LoEDisabled -> 100 + -- The LoE does not yet support Peras. + LoEEnabled () -> 0 + in (freq, genAddPerasCert) , (if empty then 1 else 10, return GetCurrentChain) , -- , (if empty then 1 else 10, return GetLedgerDB) (if empty then 1 else 10, return GetTipBlock) @@ -964,7 +1053,7 @@ generator loe genBlock m@Model{..} = followers = RE.keys knownFollowers genRandomPoint :: Gen (RealPoint blk) - genRandomPoint = blockRealPoint <$> genBlock m + genRandomPoint = blockRealPoint . fst <$> genBlock m blocksInDB :: Map.Map (HeaderHash blk) blk blocksInDB = Model.blocks dbModel @@ -985,7 +1074,7 @@ generator loe genBlock m@Model{..} = anchor <- elements $ AF.AnchorGenesis : fmap AF.anchorFromBlock immutableBlocks - blk <- genBlock m + (blk, _) <- genBlock m tip <- frequency [ (1, pure $ Chain.headHash immutableChain) @@ -1007,6 +1096,11 @@ generator loe genBlock m@Model{..} = empty :: Bool empty = null pointsInDB + genSystemTime :: Gen (SystemTime Gen) + genSystemTime = do + current <- RelativeTime . fromIntegral <$> arbitrary @Word64 + pure $ SystemTime{systemTimeCurrent = return current, systemTimeWait = pure ()} + genRealPoint :: Gen (RealPoint blk) genRealPoint = frequency @@ -1024,6 +1118,7 @@ generator loe genBlock m@Model{..} = genGetIsValid :: Gen (Cmd blk it flr) genGetIsValid = GetIsValid <$> genRealPoint + genGetBlockComponent :: Gen (Cmd blk it flr) genGetBlockComponent = do pt <- genRealPoint @@ -1032,7 +1127,43 @@ generator loe genBlock m@Model{..} = then GetGCedBlockComponent pt else GetBlockComponent pt - genAddBlock = AddBlock <$> genBlock m + genAddBlock :: Gen (Cmd blk it flr) + genAddBlock = do + (blk, gapBlks) <- genBlock m + pure $ AddBlock blk gapBlks + + genAddPerasCert :: Gen (Cmd blk it flr) + genAddPerasCert = do + -- TODO chain condition? + (blk, gapBlks) <- genBlock m + let roundNo = case Model.maxPerasRoundNo dbModel of + Nothing -> PerasRoundNo 0 + Just (PerasRoundNo r) -> PerasRoundNo (r + 1) + -- Generate an almost-always-valid boost, i.e., below the maximum rollback + let k = unPerasWeight (maxRollbackWeight secParam) + boost <- + PerasWeight + <$> frequency + [ (10, choose (1, k - 1)) + , (1, choose (k, k + 1)) + ] + -- Put together the certificate and attach a random arrival time + systemTime <- genSystemTime + validatedCert <- + addArrivalTime systemTime $ + ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = blockPoint blk + } + , vpcCertBoost = boost + } + + -- Include the boosted block itself in the persisted seenBlocks + let seenBlks = fmap (blk :) gapBlks + + pure $ AddPerasCert validatedCert seenBlks genBounds :: Gen (StreamFrom blk, StreamTo blk) genBounds = @@ -1232,16 +1363,33 @@ invariant cfg Model{..} = postcondition :: TestConstraints blk => + TopLevelConfig blk -> Model blk m Concrete -> At Cmd blk m Concrete -> At Resp blk m Concrete -> Logic -postcondition model cmd resp = +postcondition cfg model cmd resp = (toMock (eventAfter ev) resp .== eventMockResp ev) .// "real response didn't match model response" + .&& immutableTipMonotonicity where ev = lockstep model cmd resp + immutableTipMonotonicity = case unAt cmd of + -- When we wipe the VolatileDB (and haven't persisted all immutable blocks), + -- the immutable tip can recede. + WipeVolatileDB -> Top + _ -> + Annotate ("Immutable tip non-monotonicity: " <> show before <> " > " <> show after) $ + Boolean (before <= after) + where + before = immTipBlockNo $ eventBefore ev + after = immTipBlockNo $ eventAfter ev + immTipBlockNo = + Chain.headBlockNo + . Model.immutableChain (configSecurityParam cfg) + . dbModel + semantics :: forall blk. TestConstraints blk => @@ -1258,7 +1406,7 @@ sm :: TestConstraints blk => LoE () -> ChainDBEnv IO blk -> - BlockGen blk IO -> + (Model blk IO Symbolic -> Gen (blk, Persistent [blk])) -> TopLevelConfig blk -> ExtLedgerState blk EmptyMK -> StateMachine @@ -1271,7 +1419,7 @@ sm loe env genBlock cfg initLedger = { initModel = initModel loe cfg initLedger , transition = transition , precondition = precondition - , postcondition = postcondition + , postcondition = postcondition cfg , generator = Just . generator loe genBlock , shrinker = shrinker , semantics = semantics cfg env @@ -1329,14 +1477,19 @@ deriving instance SOP.Generic (ImmutableDB.TraceEvent blk) deriving instance SOP.HasDatatypeInfo (ImmutableDB.TraceEvent blk) deriving instance SOP.Generic (VolatileDB.TraceEvent blk) deriving instance SOP.HasDatatypeInfo (VolatileDB.TraceEvent blk) +deriving instance SOP.Generic (PerasCertDB.TraceEvent blk) +deriving instance SOP.HasDatatypeInfo (PerasCertDB.TraceEvent blk) deriving anyclass instance SOP.Generic (TraceChainSelStarvationEvent blk) deriving anyclass instance SOP.HasDatatypeInfo (TraceChainSelStarvationEvent blk) +deriving anyclass instance SOP.Generic (TraceAddPerasCertEvent blk) +deriving anyclass instance SOP.HasDatatypeInfo (TraceAddPerasCertEvent blk) data Tag = TagGetIsValidJust | TagGetIsValidNothing | TagChainSelReprocessChangedSelection | TagChainSelReprocessKeptSelection + | TagSwitchedToShorterChain deriving (Show, Eq) -- | Predicate on events @@ -1363,6 +1516,7 @@ tag = , tagGetIsValidNothing , tagChainSelReprocess TagChainSelReprocessChangedSelection (/=) , tagChainSelReprocess TagChainSelReprocessKeptSelection (==) + , tagSwitchedToShorterChain ] where tagGetIsValidJust :: EventPred m @@ -1387,6 +1541,21 @@ tag = Left t _ -> Right $ tagChainSelReprocess t test + -- Tag this test case if we ever switch from a longer to a shorter chain in a + -- non-degenerate case. + tagSwitchedToShorterChain :: EventPred m + tagSwitchedToShorterChain = C.predicate $ \case + ev + | case unAt $ eventCmd ev of + -- Wiping the VolatileDB is not interesting here. + WipeVolatileDB{} -> False + _ -> True + , ((>) `on` curChainLength) (eventBefore ev) (eventAfter ev) -> + Left TagSwitchedToShorterChain + | otherwise -> Right tagSwitchedToShorterChain + where + curChainLength = Chain.length . Model.currentChain . dbModel + -- | Step the model using a 'QSM.Command' (i.e., a command associated with -- an explicit set of variables) execCmd :: @@ -1421,21 +1590,25 @@ type Blk = TestBlock -- ChainDB, blocks are added /out of order/, while in the ImmutableDB, they -- must be added /in order/. This generator can thus not be reused for the -- ImmutableDB. -genBlk :: ImmutableDB.ChunkInfo -> BlockGen Blk m +genBlk :: ImmutableDB.ChunkInfo -> Model Blk m r -> Gen (TestBlock, Persistent [TestBlock]) genBlk chunkInfo Model{..} = frequency - [ (if empty then 0 else 1, genAlreadyInChain) - , (5, genAppendToCurrentChain) - , (5, genFitsOnSomewhere) - , (3, genGap) + [ (if noBlocksInChainDB then 0 else 1, withoutGapBlocks genAlreadyInChain) + , (if noSavedGapBlocks then 0 else 20, withoutGapBlocks genGapBlock) + , (5, withoutGapBlocks genAppendToCurrentChain) + , (5, withoutGapBlocks genFitsOnSomewhere) + , (3, genBlockAfterGap) ] where blocksInChainDB = Model.blocks dbModel + noBlocksInChainDB = Map.null blocksInChainDB + + savedGapBlocks = seenBlocks genState + noSavedGapBlocks = Map.null savedGapBlocks + withoutGapBlocks = fmap (,Persistent []) + modelSupportsEBBs = ImmutableDB.chunkInfoSupportsEBBs chunkInfo canContainEBB = const modelSupportsEBBs -- TODO: we could be more precise - empty :: Bool - empty = Map.null blocksInChainDB - genBody :: Gen TestBody genBody = do isValid <- @@ -1468,20 +1641,28 @@ genBlk chunkInfo Model{..} = Nothing -> genFirstBlock Just _ -> genAlreadyInChain >>= genFitsOn - -- A block that doesn't fit onto a block in the ChainDB, but it creates a - -- gap of a couple of blocks between genesis or an existing block in the - -- ChainDB. We generate it by generating a few intermediary blocks first, - -- which we don't add. But the chance exists that we will generate them - -- again later on. - genGap :: Gen TestBlock - genGap = do + -- A block that doesn't fit onto a block in the ChainDB, but it creates a gap + -- of a couple of blocks between genesis or an existing block in the ChainDB. + -- We generate it by generating a few intermediary blocks first, which we + -- don't add just yet. These are in turn returned and stored as seen blocks + -- in the generator state of the model. We can sample from these later on to + -- (hopefully) fill the gaps. + genBlockAfterGap :: Gen (TestBlock, Persistent [TestBlock]) + genBlockAfterGap = do gapSize <- choose (1, 3) start <- genFitsOnSomewhere - go gapSize start + go gapSize start [] where - go :: Int -> TestBlock -> Gen TestBlock - go 0 b = return b - go n b = genFitsOn b >>= go (n - 1) + go :: Int -> TestBlock -> [TestBlock] -> Gen (TestBlock, Persistent [TestBlock]) + go 0 tip gapBlks = return (tip, Persistent gapBlks) + go n tip gapBlks = do + tip' <- genFitsOn tip + go (n - 1) tip' (tip : gapBlks) + + -- An intermediate gap block that was generated by 'genGap' but stored for + -- later in the model's generator state. + genGapBlock :: Gen TestBlock + genGapBlock = elements (Map.elems savedGapBlocks) -- Generate a block or EBB fitting on genesis genFirstBlock :: Gen TestBlock @@ -1542,40 +1723,59 @@ genBlk chunkInfo Model{..} = ) ] +genSecurityParam :: Gen SecurityParam +genSecurityParam = + SecurityParam + . unsafeNonZero + . fromIntegral + . (+ 2) -- shift to the right to avoid degenerate cases + <$> geometric 0.5 -- range in [0, +inf); mean = 1/p = 2 + where + geometric :: Double -> Gen Int + geometric p + | p <= 0 || p > 1 = error "p must be in (0,1]" + | otherwise = do + u <- choose (0.0, 1.0) + let k = floor (log u / log (1 - p)) + return k + {------------------------------------------------------------------------------- Top-level tests -------------------------------------------------------------------------------} -mkTestCfg :: ImmutableDB.ChunkInfo -> TopLevelConfig TestBlock -mkTestCfg (ImmutableDB.UniformChunkSize chunkSize) = - mkTestConfig (SecurityParam $ knownNonZeroBounded @2) chunkSize +mkTestCfg :: SecurityParam -> ImmutableDB.ChunkInfo -> TopLevelConfig TestBlock +mkTestCfg k (ImmutableDB.UniformChunkSize chunkSize) = + mkTestConfig k chunkSize envUnused :: ChainDBEnv m blk envUnused = error "ChainDBEnv used during command generation" smUnused :: LoE () -> + SecurityParam -> ImmutableDB.ChunkInfo -> StateMachine (Model Blk IO) (At Cmd Blk IO) IO (At Resp Blk IO) -smUnused loe chunkInfo = +smUnused loe k chunkInfo = sm loe envUnused (genBlk chunkInfo) - (mkTestCfg chunkInfo) + (mkTestCfg k chunkInfo) testInitExtLedger prop_sequential :: LoE () -> SmallChunkInfo -> Property prop_sequential loe smallChunkInfo@(SmallChunkInfo chunkInfo) = - forAllCommands (smUnused loe chunkInfo) Nothing $ - runCmdsLockstep loe smallChunkInfo + QC.forAll genSecurityParam $ \k -> + forAllCommands (smUnused loe k chunkInfo) Nothing $ + runCmdsLockstep loe k smallChunkInfo runCmdsLockstep :: LoE () -> + SecurityParam -> SmallChunkInfo -> QSM.Commands (At Cmd Blk IO) (At Resp Blk IO) -> Property -runCmdsLockstep loe (SmallChunkInfo chunkInfo) cmds = +runCmdsLockstep loe k (SmallChunkInfo chunkInfo) cmds = QC.monadicIO $ do let -- Current test case command names. @@ -1583,15 +1783,15 @@ runCmdsLockstep loe (SmallChunkInfo chunkInfo) cmds = ctcCmdNames = fmap (show . cmdName . QSM.getCommand) $ QSM.unCommands cmds (hist, prop) <- QC.run $ test cmds - prettyCommands (smUnused loe chunkInfo) hist + prettyCommands (smUnused loe k chunkInfo) hist $ tabulate "Tags" - (map show $ tag (execCmds (QSM.initModel (smUnused loe chunkInfo)) cmds)) + (map show $ tag (execCmds (QSM.initModel (smUnused loe k chunkInfo)) cmds)) $ tabulate "Command sequence length" [show $ length ctcCmdNames] $ tabulate "Commands" ctcCmdNames $ prop where - testCfg = mkTestCfg chunkInfo + testCfg = mkTestCfg k chunkInfo test :: QSM.Commands (At Cmd Blk IO) (At Resp Blk IO) -> @@ -1654,26 +1854,30 @@ runCmdsLockstep loe (SmallChunkInfo chunkInfo) cmds = fses <- atomically $ traverse readTMVar nodeDBs let modelChain = Model.currentChain $ dbModel model + secParam = unNonZero (maxRollbacks (configSecurityParam testCfg)) prop = counterexample (show (configSecurityParam testCfg)) $ counterexample ("Model chain: " <> condense modelChain) $ counterexample ("TraceEvents: " <> unlines (map show trace)) $ tabulate "Chain length" [show (Chain.length modelChain)] $ - tabulate "TraceEvents" (map traceEventName trace) $ - res === Ok - .&&. prop_trace testCfg (dbModel model) trace - .&&. counterexample - "ImmutableDB is leaking file handles" - (Mock.numOpenHandles (nodeDBsImm fses) === 0) - .&&. counterexample - "VolatileDB is leaking file handles" - (Mock.numOpenHandles (nodeDBsVol fses) === 0) - .&&. counterexample - "LedgerDB is leaking file handles" - (Mock.numOpenHandles (nodeDBsLgr fses) === 0) - .&&. counterexample - "There were registered clean-up actions" - (remainingCleanups === 0) + tabulate "Security Parameter (k)" [show secParam] $ + tabulate "Chain length >= k" [show (Chain.length modelChain >= fromIntegral secParam)] $ + tabulate "TraceEvents" (map traceEventName trace) $ + res + === Ok + .&&. prop_trace testCfg (dbModel model) trace + .&&. counterexample + "ImmutableDB is leaking file handles" + (Mock.numOpenHandles (nodeDBsImm fses) === 0) + .&&. counterexample + "VolatileDB is leaking file handles" + (Mock.numOpenHandles (nodeDBsVol fses) === 0) + .&&. counterexample + "LedgerDB is leaking file handles" + (Mock.numOpenHandles (nodeDBsLgr fses) === 0) + .&&. counterexample + "There were registered clean-up actions" + (remainingCleanups === 0) return (hist, prop) prop_trace :: TopLevelConfig Blk -> DBModel Blk -> [TraceEvent Blk] -> Property @@ -1755,8 +1959,10 @@ traceEventName = \case TraceLedgerDBEvent ev -> "Ledger." <> constrName ev TraceImmutableDBEvent ev -> "ImmutableDB." <> constrName ev TraceVolatileDBEvent ev -> "VolatileDB." <> constrName ev + TracePerasCertDbEvent ev -> "PerasCertDB." <> constrName ev TraceLastShutdownUnclean -> "LastShutdownUnclean" TraceChainSelStarvationEvent ev -> "ChainSelStarvation." <> constrName ev + TraceAddPerasCertEvent ev -> "AddPerasCert." <> constrName ev mkArgs :: IOLike m => diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs index 96055b09ee..369f3974cd 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs @@ -87,6 +87,7 @@ import Ouroboros.Consensus.Block , EpochNo (EpochNo) , SlotNo (SlotNo) ) +import Ouroboros.Consensus.Config (SecurityParam) import Ouroboros.Consensus.Storage.ChainDB ( ChainType (TentativeChain) , LoE @@ -142,8 +143,9 @@ pattern Command cmd rsp xs = quickCheckCmdsLockStep :: LoE () -> + SecurityParam -> SmallChunkInfo -> Commands (StateMachine.At Cmd TestBlock IO) (StateMachine.At Resp TestBlock IO) -> IO () -quickCheckCmdsLockStep loe chunkInfo cmds = - quickCheck $ runCmdsLockstep loe chunkInfo cmds +quickCheckCmdsLockStep loe k chunkInfo cmds = + quickCheck $ runCmdsLockstep loe k chunkInfo cmds diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs index 6811e7c427..4bf1a91c21 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -7,12 +8,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Test.Ouroboros.Storage.ChainDB.Unit (tests) where +import Cardano.Ledger.BaseTypes (knownNonZeroBounded) import Cardano.Slotting.Slot (WithOrigin (..)) import Control.Monad (replicateM, unless, void) import Control.Monad.Except @@ -35,6 +38,7 @@ import Ouroboros.Consensus.Config ( TopLevelConfig , configSecurityParam ) +import Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..)) import Ouroboros.Consensus.Ledger.Basics import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) import Ouroboros.Consensus.Ledger.SupportsProtocol @@ -243,8 +247,9 @@ runModelIO :: API.LoE () -> ModelM TestBlock a -> IO () runModelIO loe expr = toAssertion (runModel newModel topLevelConfig expr) where chunkInfo = ImmutableDB.simpleChunkInfo 100 + k = SecurityParam (knownNonZeroBounded @2) newModel = Model.empty loe testInitExtLedger - topLevelConfig = mkTestCfg chunkInfo + topLevelConfig = mkTestCfg k chunkInfo -- | Helper function to run the test against the actual chain database and -- translate to something that HUnit likes. @@ -252,7 +257,8 @@ runSystemIO :: SystemM TestBlock IO a -> IO () runSystemIO expr = runSystem withChainDbEnv expr >>= toAssertion where chunkInfo = ImmutableDB.simpleChunkInfo 100 - topLevelConfig = mkTestCfg chunkInfo + k = SecurityParam (knownNonZeroBounded @2) + topLevelConfig = mkTestCfg k chunkInfo withChainDbEnv = withTestChainDbEnv topLevelConfig chunkInfo $ convertMapKind testInitExtLedger newtype TestFailure = TestFailure String deriving Show diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs index d81a0a7940..cadeff1857 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs @@ -4,6 +4,7 @@ module Test.Ouroboros.Storage.Orphans () where import Data.Maybe (isJust) +import Data.Time.Clock (NominalDiffTime) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Storage.ChainDB.API ( ChainDbError @@ -16,6 +17,8 @@ import Ouroboros.Consensus.Storage.VolatileDB.API (VolatileDBError) import qualified Ouroboros.Consensus.Storage.VolatileDB.API as VolatileDB import Ouroboros.Consensus.Util.CallStack import System.FS.API.Types (FsError, sameFsError) +import Test.QuickCheck.StateModel (HasVariables) +import Test.QuickCheck.StateModel.Variables (HasVariables (..)) {------------------------------------------------------------------------------- PrettyCallStack @@ -66,3 +69,10 @@ deriving instance StandardHash blk => Eq (ImmutableDB.UnexpectedFailure blk) deriving instance StandardHash blk => Eq (ChainDbFailure blk) deriving instance StandardHash blk => Eq (ChainDbError blk) + +{------------------------------------------------------------------------------- + Time +-------------------------------------------------------------------------------} + +instance HasVariables NominalDiffTime where + getAllVariables _ = mempty diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB.hs new file mode 100644 index 0000000000..6a3f06bf90 --- /dev/null +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE CPP #-} + +module Test.Ouroboros.Storage.PerasCertDB (tests) where + +import qualified Test.Ouroboros.Storage.PerasCertDB.StateMachine as StateMachine +import Test.Tasty (TestTree, testGroup) + +-- +-- The list of all PerasCertDB tests +-- + +tests :: TestTree +tests = + testGroup + "PerasCertDB" + [ StateMachine.tests + ] 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 new file mode 100644 index 0000000000..812e031c78 --- /dev/null +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.Ouroboros.Storage.PerasCertDB.Model + ( Model (..) + , initModel + , openDB + , closeDB + , addCert + , getWeightSnapshot + , garbageCollect + ) where + +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Generics (Generic) +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) +import Ouroboros.Consensus.Peras.Weight + ( PerasWeightSnapshot + , mkPerasWeightSnapshot + ) + +data Model blk = Model + { certs :: Set (WithArrivalTime (ValidatedPerasCert blk)) + , open :: Bool + } + deriving Generic + +deriving instance StandardHash blk => Show (Model blk) + +initModel :: Model blk +initModel = Model{open = False, certs = Set.empty} + +openDB :: Model blk -> Model blk +openDB model = model{open = True} + +closeDB :: Model blk -> Model blk +closeDB _ = Model{open = False, certs = Set.empty} + +addCert :: + StandardHash blk => + Model blk -> WithArrivalTime (ValidatedPerasCert blk) -> Model blk +addCert model@Model{certs} cert = + model{certs = Set.insert cert certs} + +getWeightSnapshot :: + StandardHash blk => + Model blk -> PerasWeightSnapshot blk +getWeightSnapshot Model{certs} = + mkPerasWeightSnapshot + [ (getPerasCertBoostedBlock cert, getPerasCertBoost cert) + | cert <- Set.toList certs + ] + +garbageCollect :: StandardHash blk => SlotNo -> Model blk -> Model blk +garbageCollect slot model@Model{certs} = + model{certs = Set.filter keepCert certs} + where + keepCert cert = pointSlot (getPerasCertBoostedBlock cert) >= NotOrigin slot 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 new file mode 100644 index 0000000000..c301937031 --- /dev/null +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.Ouroboros.Storage.PerasCertDB.StateMachine (tests) where + +import Control.Monad.State +import Control.Tracer (nullTracer) +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set +import Data.Word (Word64) +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime (..) + , SystemTime (..) + , WithArrivalTime + , addArrivalTime + ) +import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) +import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB +import Ouroboros.Consensus.Storage.PerasCertDB.API (AddPerasCertResult (..), PerasCertDB) +import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Consensus.Util.Orphans () +import Ouroboros.Consensus.Util.STM +import Test.Ouroboros.Storage.Orphans () +import qualified Test.Ouroboros.Storage.PerasCertDB.Model as Model +import Test.QuickCheck hiding (Some (..)) +import qualified Test.QuickCheck.Monadic as QC +import Test.QuickCheck.StateModel +import Test.Tasty +import Test.Tasty.QuickCheck hiding (Some (..)) +import Test.Util.TestBlock (TestBlock, TestHash (..)) +import Test.Util.TestEnv (adjustQuickCheckTests) + +tests :: TestTree +tests = + testGroup + "PerasCertDB" + [ adjustQuickCheckTests (* 100) $ testProperty "q-d" $ prop_qd + ] + +perasTestCfg :: PerasCfg TestBlock +perasTestCfg = makePerasCfg Nothing + +prop_qd :: Actions Model -> Property +prop_qd actions = QC.monadic f $ property () <$ runActions actions + where + f :: StateT (PerasCertDB IO TestBlock) IO Property -> Property + f = ioProperty . flip evalStateT (error "unreachable") + +newtype Model = Model (Model.Model TestBlock) deriving (Show, Generic) + +instance StateModel Model where + data Action Model a where + OpenDB :: Action Model () + CloseDB :: Action Model () + AddCert :: WithArrivalTime (ValidatedPerasCert TestBlock) -> Action Model AddPerasCertResult + GetWeightSnapshot :: Action Model (PerasWeightSnapshot TestBlock) + GarbageCollect :: SlotNo -> Action Model () + + arbitraryAction _ (Model model) + | model.open = + frequency + [ (1, pure $ Some CloseDB) + , (20, Some <$> genAddCert) + , (20, pure $ Some GetWeightSnapshot) + , (5, Some . GarbageCollect . SlotNo <$> arbitrary) + ] + | otherwise = pure $ Some OpenDB + where + genSystemTime :: Gen (SystemTime Gen) + genSystemTime = do + current <- RelativeTime . fromIntegral <$> arbitrary @Word64 + pure $ SystemTime{systemTimeCurrent = return current, systemTimeWait = pure ()} + + genAddCert = do + roundNo <- PerasRoundNo <$> arbitrary + boostedBlock <- genPoint + systemTime <- genSystemTime + let validatedCert = + ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = boostedBlock + } + , vpcCertBoost = perasCfgWeightBoost perasTestCfg + } + AddCert <$> addArrivalTime systemTime validatedCert + + genPoint :: Gen (Point TestBlock) + genPoint = + oneof + [ return GenesisPoint + , BlockPoint <$> (SlotNo <$> arbitrary) <*> genHash + ] + where + genHash = TestHash . NE.fromList . getNonEmpty <$> arbitrary + + initialState = Model Model.initModel + + nextState (Model model) action _ = Model $ case action of + OpenDB -> Model.openDB model + CloseDB -> Model.closeDB model + AddCert cert -> Model.addCert model cert + GetWeightSnapshot -> model + GarbageCollect slot -> Model.garbageCollect slot model + + precondition (Model model) = \case + OpenDB -> not model.open + action -> + model.open && case action of + CloseDB -> True + -- Do not add equivocating certificates. + AddCert cert -> all p model.certs + where + p cert' = getPerasCertRound cert /= getPerasCertRound cert' || cert == cert' + GetWeightSnapshot -> True + GarbageCollect _slot -> True + +deriving stock instance Show (Action Model a) +deriving stock instance Eq (Action Model a) + +instance HasVariables (Action Model a) where + getAllVariables _ = mempty + +instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where + perform _ action _ = case action of + OpenDB -> do + perasCertDB <- lift $ PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs nullTracer) + put perasCertDB + CloseDB -> do + perasCertDB <- get + lift $ PerasCertDB.closeDB perasCertDB + AddCert cert -> do + perasCertDB <- get + lift $ PerasCertDB.addCert perasCertDB cert + GetWeightSnapshot -> do + perasCertDB <- get + lift $ atomically $ forgetFingerprint <$> PerasCertDB.getWeightSnapshot perasCertDB + GarbageCollect slot -> do + perasCertDB <- get + lift $ PerasCertDB.garbageCollect perasCertDB slot + + postcondition (Model model, _) (AddCert cert) _ actual = do + let expected + | cert `Set.member` model.certs = PerasCertAlreadyInDB + | otherwise = AddedPerasCertToDB + counterexamplePost $ show expected <> " /= " <> show actual + pure $ expected == actual + postcondition (Model model, _) GetWeightSnapshot _ actual = do + let expected = Model.getWeightSnapshot model + counterexamplePost $ "Model: " <> show expected + counterexamplePost $ "SUT: " <> show actual + pure $ expected == actual + postcondition _ _ _ _ = pure True